commit 9ff76bef82f9fb4dd120f3e74697e9a87af12f52
parent 0cad9cd9407592834a01d4a7f43479382d96e2e4
Author: Oto Havle <havleoto@gmail.com>
Date: Sat, 5 Nov 2011 19:59:18 +0100
Added FFI for win32
Diffstat:
3 files changed, 161 insertions(+), 8 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -18,6 +18,8 @@ LIBS= -lm $(MYLIBS)
# Set USE_LIBFFI=1 (or other nonempty string) to enable libffi-dependent
# code.
USE_LIBFFI=
+MINGW_LIBFFI_CFLAGS = -I/usr/local/lib/libffi-3.0.10/include
+MINGW_LIBFFI_LDFLAGS = -L/usr/local/lib/
MYCFLAGS=
MYLDFLAGS=
@@ -60,7 +62,7 @@ o: $(ALL_O)
a: $(ALL_A)
$(KRN_A): $(CORE_O) $(LIB_O)
- $(AR) $@ $?
+ $(AR) $@ $? $(MINGW_LDFLAGS)
$(RANLIB) $@
$(KRN_T): $(KRN_O) $(KRN_A)
@@ -94,8 +96,12 @@ generic:
mingw:
$(MAKE) "KRN_A=klisp01.dll" "KRN_T=klisp.exe" \
- "AR=$(CC) -shared -o" "RANLIB=strip --strip-unneeded" \
- "MYCFLAGS=-DKLISP_BUILD_AS_DLL" "MYLIBS=" "MYLDFLAGS=-s" klisp.exe
+ "AR=$(CC) -shared -o" \
+ "RANLIB=strip --strip-unneeded" \
+ "MYCFLAGS=-DKLISP_BUILD_AS_DLL $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 $(MINGW_LIBFFI_CFLAGS))" \
+ "MYLIBS=$(if $(USE_LIBFFI), $(MINGW_LIBFFI_LDFLAGS) -lffi.dll)" \
+ "MINGW_LDFLAGS=$(if $(USE_LIBFFI), $(MINGW_LIBFFI_LDFLAGS) -lffi.dll)" \
+ "MYLDFLAGS=-s" klisp.exe
#lisp_use_posix isn't used right now...
# TEMP: rename read() and write() here to avoid name conflicts with foreign code
posix:
diff --git a/src/examples/ffi-win32.k b/src/examples/ffi-win32.k
@@ -0,0 +1,81 @@
+;;
+;; Windows API FFI example
+;; See ffi.k for general info.
+;;
+;; usage:
+;; 1) compile and install libffi 3.0.10
+;; 2) set PATH correctly so libffi-5.dll can be found
+;; 3) compile klisp: make mingw USE_LIBFFI=1
+;; 4) run test script: ....\src> klisp examples/ffi-win32.k
+;;
+
+($define! kernel32 (ffi-load-library "kernel32"))
+($define! abi "FFI_STDCALL")
+
+($define! DWORD "uint32")
+($define! BOOL "sint")
+
+($define! dword-void (ffi-make-call-interface abi DWORD ()))
+($define! u64-void (ffi-make-call-interface abi "uint64" ()))
+
+($define! GetLastError (ffi-make-applicative kernel32 "GetLastError" dword-void))
+($define! GetTickCount (ffi-make-applicative kernel32 "GetTickCount" dword-void))
+($define! GetTickCount64 (ffi-make-applicative kernel32 "GetTickCount64" u64-void))
+
+(display "Testing GetTickCount(), GetTickCount64() ... ")
+(write (list (GetTickCount) (GetTickCount64)))
+(newline)
+
+($define! (DWORD-size DWORD-alignment DWORD-ref DWORD-set!)
+ (ffi-type-suite DWORD))
+
+($define! (charptr-size charptr-alignment charptr-ref charptr-set!)
+ (ffi-type-suite "string"))
+
+($define! blob->list
+ ($lambda (blob index len)
+ ($if (>? len 0)
+ (cons
+ (blob-u8-ref blob index)
+ (blob->list blob (+ 1 index) (- len 1)))
+ ())))
+
+($define! blob->string
+ ($lambda (blob offset len)
+ (list->string (map integer->char (blob->list blob offset len)))))
+
+($define! advapi32 (ffi-load-library "advapi32"))
+
+($define! GetUserName
+ ($let
+ ( (win32-GetUserName (ffi-make-applicative advapi32 "GetUserNameA"
+ (ffi-make-call-interface abi BOOL (list "pointer" "pointer"))))
+ ((DWORD-size DWORD-alignment DWORD-ref DWORD-set!)
+ (ffi-type-suite DWORD)))
+ ($lambda ()
+ ($let ((buffer (make-blob 256)) (lenbuf (make-blob 4)))
+ (DWORD-set! lenbuf (blob-length buffer))
+ (win32-GetUserName buffer lenbuf)
+ (blob->string buffer 0 (- (DWORD-ref lenbuf) 1))))))
+
+(display "Testing GetUserName()...")
+(write (GetUserName))
+(newline)
+
+($define! user32 (ffi-load-library "user32"))
+
+($define! HWND "pointer")
+($define! UINT "uint32")
+($define! MB_OK 0)
+
+($define! MessageBox
+ ($let
+ ( (win32-MessageBox (ffi-make-applicative user32 "MessageBoxA"
+ (ffi-make-call-interface abi "sint" (list HWND "string" "string" UINT)))))
+ ($lambda (text caption)
+ (win32-MessageBox () text caption MB_OK))))
+
+(display "Testing MessageBox()...")
+(MessageBox "FFI test" "klisp")
+(display "done.")
+(newline)
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -4,13 +4,30 @@
** See Copyright Notice in klisp.h
*/
+/*
+ * Detect dynamic linking facilities.
+ *
+ */
+#if !defined(KLISP_USE_POSIX) && defined(_WIN32)
+# define KGFFI_WIN32 true
+#else
+# define KGFFI_DLFCN true
+#endif
+
#include <assert.h>
#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>
#include <string.h>
-#include <dlfcn.h>
+#if KGFFI_DLFCN
+# include <dlfcn.h>
+#elif KGFFI_WIN32
+# include <windows.h>
+#else
+# error
+#endif
+
#include <ffi.h>
#include "imath.h"
@@ -341,6 +358,24 @@ static ffi_codec_t ffi_codecs[] = {
#undef SIMPLE_TYPE
};
+#ifdef KGFFI_WIN32
+static TValue ffi_win32_error_message(klisp_State *K, DWORD dwMessageId)
+{
+ LPTSTR s;
+ if (0 == FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+ NULL,
+ dwMessageId,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ &s, 0, NULL)) {
+ return kstring_new_b_imm(K, "Unknown error");
+ } else {
+ TValue v = kstring_new_b_imm(K, s);
+ LocalFree(s);
+ return v;
+ }
+}
+#endif
+
void ffi_load_library(klisp_State *K, TValue *xparams,
TValue ptree, TValue denv)
{
@@ -354,6 +389,7 @@ void ffi_load_library(klisp_State *K, TValue *xparams,
get_opt_tpar(K, "ffi-load-library", K_TSTRING, &filename)
? kstring_buf(filename) : NULL;
+#if KGFFI_DLFCN
void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL);
if (handle == NULL) {
krooted_tvs_push(K, filename);
@@ -363,7 +399,19 @@ void ffi_load_library(klisp_State *K, TValue *xparams,
2, filename, err);
return;
}
-
+#elif KGFFI_WIN32
+ /* TODO: unicode and wide character issues ??? */
+ HMODULE handle = LoadLibrary(filename_c);
+ if (handle == NULL) {
+ krooted_tvs_push(K, filename);
+ TValue err = ffi_win32_error_message(K, GetLastError());
+ klispE_throw_simple_with_irritants(K, "couldn't load dynamic library",
+ 2, filename, err);
+ return;
+ }
+#else
+# error
+#endif
TValue key = xparams[0];
krooted_tvs_push(K, key);
@@ -384,6 +432,12 @@ static ffi_abi tv2ffi_abi(klisp_State *K, TValue v)
{
if (!strcmp("FFI_DEFAULT_ABI", kstring_buf(v))) {
return FFI_DEFAULT_ABI;
+ } else if (!strcmp("FFI_SYSV", kstring_buf(v))) {
+ return FFI_SYSV;
+#if KGFFI_WIN32
+ } else if (!strcmp("FFI_STDCALL", kstring_buf(v))) {
+ return FFI_STDCALL;
+#endif
} else {
klispE_throw_simple_with_irritants(K, "unsupported FFI ABI", 1, v);
return 0;
@@ -516,7 +570,7 @@ void do_ffi_call(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
assert(offset == p->buffer_size);
if (!ttisnil(tail)) {
- klispE_throw_simple(K, "too much arguments");
+ klispE_throw_simple(K, "too many arguments");
return;
}
@@ -548,14 +602,14 @@ void ffi_make_applicative(klisp_State *K, TValue *xparams,
return;
}
- void *handle = pvalue(kcar(kget_enc_val(lib_tv)));
TValue lib_name = kcdr(kget_enc_val(lib_tv));
assert(ttisstring(lib_name));
+#if KGFFI_DLFCN
+ void *handle = pvalue(kcar(kget_enc_val(lib_tv)));
(void) dlerror();
void *funptr = dlsym(handle, kstring_buf(name_tv));
const char *err_c = dlerror();
-
if (err_c) {
krooted_tvs_push(K, name_tv);
krooted_tvs_push(K, lib_name);
@@ -568,6 +622,18 @@ void ffi_make_applicative(klisp_State *K, TValue *xparams,
klispE_throw_simple_with_irritants(K, "symbol is NULL", 2,
lib_name, name_tv);
}
+#elif KGFFI_WIN32
+ HMODULE handle = pvalue(kcar(kget_enc_val(lib_tv)));
+ void *funptr = GetProcAddress(handle, kstring_buf(name_tv));
+ if (NULL == funptr) {
+ TValue err = ffi_win32_error_message(K, GetLastError());
+ klispE_throw_simple_with_irritants(K, "couldn't find symbol",
+ 3, lib_name, name_tv, err);
+ return;
+ }
+#else
+# error
+#endif
TValue app = kmake_applicative(K, do_ffi_call, 2, p2tv(funptr), cif_tv);
