commit a0d8828c721590fb129df4b5dccc982f3b0b8749
parent 1e036d3d1b4535d7bb7eb93839acaaab72b78b12
Author: Oto Havle <havleoto@gmail.com>
Date: Wed, 26 Oct 2011 11:30:17 +0200
Improved FFI - conditional compilation, new functions ffi-memmove and ffi-type-suite, more examples.
Diffstat:
6 files changed, 851 insertions(+), 46 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -15,6 +15,10 @@ RANLIB= ranlib
RM= rm -f
LIBS= -lm $(MYLIBS)
+# Set USE_LIBFFI=1 (or other nonempty string) to enable libffi-dependent
+# code.
+USE_LIBFFI=
+
MYCFLAGS=
MYLDFLAGS=
MYLIBS=
@@ -34,7 +38,9 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o kgnumbers.o \
- kgstrings.o kgblobs.o kgsystem.o kgffi.o
+ kgstrings.o kgblobs.o kgsystem.o \
+ $(if $(USE_LIBFFI),kgffi.o)
+
# TEMP: in klisp there is no distinction between core & lib
LIB_O=
@@ -91,8 +97,11 @@ mingw:
"AR=$(CC) -shared -o" "RANLIB=strip --strip-unneeded" \
"MYCFLAGS=-DKLISP_BUILD_AS_DLL" "MYLIBS=" "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:
- $(MAKE) all MYCFLAGS=-DKLISP_USE_POSIX MYLIBS="-ldl -lffi"
+ $(MAKE) all \
+ "MYCFLAGS=-DKLISP_USE_POSIX $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 -Dread=klisp_read -Dwrite=klisp_write)" \
+ "MYLIBS=$(if $(USE_LIBFFI), -ldl -lffi)"
# list targets that do not create files (but not all makes understand .PHONY)
.PHONY: all default o clean
diff --git a/src/examples/ffi-sdl.k b/src/examples/ffi-sdl.k
@@ -0,0 +1,205 @@
+;;
+;; Dynamic FFI example.
+;; Interfacing Simple DirectMedia Layer Library.
+;;
+;; Tested with SDL 1.2 on Debian Squeeze, x86.
+;; It is quite likely that this program will not work
+;; with other versions and other operating systems.
+;;
+;; Dynamic FFI is inherently unsafe. The user is responsible
+;; for specifying correct argument types, data structure
+;; layout, alignment, etc. even though it is platform dependent.
+;;
+;; usage:
+;; .../src$ make posix USE_LIBFFI=1
+;; .../src$ ./klisp examples/ffi-sdl.k
+;;
+;; The program shall create a window and responding
+;; to mouse click.
+;;
+
+($define! sdl-import
+ ($let
+ ( (libsdl (ffi-load-library "libSDL.so"))
+ (abi "FFI_DEFAULT_ABI"))
+ ($lambda (rtype name . args)
+ (ffi-make-applicative libsdl name
+ (ffi-make-call-interface abi rtype args)))))
+
+($define! SDL_INIT_TIMER #x00000001)
+($define! SDL_INIT_AUDIO #x00000010)
+($define! SDL_INIT_VIDEO #x00000020)
+($define! SDL_INIT_NOPARACHUTE #x01000000)
+
+($define! sdl-init (sdl-import "sint" "SDL_Init" "uint32"))
+($define! sdl-quit (sdl-import "void" "SDL_Quit"))
+
+($define! SDL_SWSURFACE #x00000000)
+($define! SDL_HWSURFACE #x00000001)
+
+($define! sdl-set-video-mode (sdl-import "pointer" "SDL_SetVideoMode" "sint" "sint" "sint" "uint32"))
+($define! sdl-wm-set-caption (sdl-import "void" "SDL_WM_SetCaption" "string" "pointer"))
+
+($define! sdl-wait-event
+ ($let
+ ((SDL_WaitEvent (sdl-import "sint" "SDL_WaitEvent" "pointer")))
+ ($lambda ()
+ ($let*
+ ( (buffer (make-blob 512))
+ (ok (SDL_WaitEvent buffer)))
+ ($if (zero? ok)
+ (apply-continuation error-continuation "SDL_WaitEvent signalled error")
+ buffer)))))
+
+($define! align
+ ($lambda (offset alignment)
+ (+ offset (mod (- alignment (mod offset alignment)) alignment))))
+
+($define! $quote
+ ($vau (x) denv x))
+
+($define! $define-struct-projectors!
+ ($letrec*
+ ( (aux
+ ($lambda (fields offset denv)
+ ($if (null? fields)
+ ()
+ ($let*
+ ( (((projector-name type-string) . tail) fields)
+ ((size alignment ref set!) (ffi-type-suite type-string))
+ (aligned-offset (align offset alignment))
+ (projector-function ($lambda (blob) (ref (list blob aligned-offset)))))
+ (write (list projector-name size alignment aligned-offset))
+ (newline)
+ (eval
+ (list
+ ($quote $define!)
+ projector-name
+ (list ($quote $quote) projector-function))
+ denv)
+ (aux tail (+ size aligned-offset) denv))))))
+ ($vau fields denv
+ (aux fields 0 denv))))
+
+($define! SDL_QUIT 12)
+($define! SDL_MOUSEMOTION 4)
+($define! SDL_MOUSEBUTTONDOWN 5)
+($define! SDL_MOUSEBUTTONUP 6)
+
+($define-struct-projectors!
+ (event-type "uint8"))
+
+($define-struct-projectors!
+ (MouseMotionEvent.type "uint8")
+ (MouseMotionEvent.state "uint8")
+ (MouseMotionEvent.which "uint8")
+ (MouseMotionEvent.x "uint16")
+ (MouseMotionEvent.y "uint16")
+ (MouseMotionEvent.xrel "sint16")
+ (MouseMotionEvent.yrel "sint16"))
+
+($define-struct-projectors!
+ (MouseButtonEvent.type "uint8")
+ (MouseButtonEvent.which "uint8")
+ (MouseButtonEvent.button "uint8")
+ (MouseButtonEvent.state "uint8")
+ (MouseButtonEvent.x "uint16")
+ (MouseButtonEvent.y "uint16"))
+
+($define! with-sdl
+ ($lambda (window-title worker)
+ (display "Initializing SDL...")
+ ($let ((status (sdl-init SDL_INIT_VIDEO)))
+ (write status)
+ (newline)
+ ($if (<? status 0)
+ (apply error-continuation "error initializing SDL")
+ ($sequence
+ (guard-dynamic-extent
+ ()
+ ($lambda ()
+ ($let* ((screen (sdl-set-video-mode 640 480 32 SDL_HWSURFACE)))
+ ($if (null? screen)
+ (apply-continuation error-contination "unable to set video mode")
+ ($sequence
+ (sdl-wm-set-caption window-title ())
+ (worker screen)))))
+ (list
+ (list
+ error-continuation
+ ($lambda (v divert)
+ (display "Error. Deinitializing SDL...")
+ (sdl-quit)
+ (display "done.")
+ (newline)
+ v))))
+ (display "Finished. Deinitializing SDL...")
+ (sdl-quit)
+ (display "done.")
+ (newline))))))
+
+($define-struct-projectors!
+ (SDL_Surface.flags "uint32")
+ (SDL_Surface.format "pointer")
+ (SDL_Surface.w "sint")
+ (SDL_Surface.h "sint")
+ (SDL_Surface.pitch "uint16")
+ (SDL_Surface.pixels "pointer")
+ (SDL_Surface.offset "sint"))
+
+($define! draw-pixel
+ ($let
+ ( ((pixel-size pixel-alignment pixel-ref pixel-set!) (ffi-type-suite "uint32"))
+ (SDL_MapRGB (sdl-import "uint32" "SDL_MapRGB" "pointer" "uint8" "uint8" "uint8"))
+ (SDL_LockSurface (sdl-import "sint" "SDL_LockSurface" "pointer"))
+ (SDL_UnlockSurface (sdl-import "void" "SDL_UnlockSurface" "pointer"))
+ (SDL_Flip (sdl-import "sint" "SDL_Flip" "pointer")))
+ ($lambda (screen (x y) (r g b))
+ ($if (<? (SDL_LockSurface screen) 0)
+ (apply error-continuation "SDL_LockSurface failed")
+ ())
+ ($let
+ ( (pixels (SDL_Surface.pixels screen))
+ (pitch (SDL_Surface.pitch screen))
+ (color (SDL_MapRGB (SDL_Surface.format screen) r g b)))
+ ;(display (list color x y pixel-size pitch (SDL_Surface.flags screen)))
+ (pixel-set!
+ (list pixels (+ (* x pixel-size) (* y pitch)))
+ color))
+ (SDL_UnlockSurface screen)
+ (SDL_Flip screen))))
+
+($define! event-loop
+ ($lambda (screen drawing)
+ ($let*
+ ( (ev (sdl-wait-event))
+ (t (event-type ev)))
+ ($cond
+ ( (equal? t SDL_QUIT)
+ ())
+ ( (and? drawing (equal? t SDL_MOUSEMOTION))
+ (draw-pixel
+ screen
+ (list (MouseMotionEvent.x ev) (MouseMotionEvent.y ev))
+ (list 0 255 0))
+ (event-loop screen #t))
+ ( (equal? t SDL_MOUSEBUTTONDOWN)
+ (draw-pixel
+ screen
+ (list (MouseButtonEvent.x ev) (MouseButtonEvent.y ev))
+ (list 255 0 0))
+ (event-loop screen #t))
+ ( (equal? t SDL_MOUSEBUTTONUP)
+ (draw-pixel
+ screen
+ (list (MouseButtonEvent.x ev) (MouseButtonEvent.y ev))
+ (list 0 0 255))
+ (event-loop screen #f))
+ (#t
+ (event-loop screen drawing))))))
+
+($define! main
+ ($lambda (argv)
+ (with-sdl "klisp ffi demo"
+ ($lambda (screen) (event-loop screen #f)))))
+
diff --git a/src/examples/ffi.k b/src/examples/ffi.k
@@ -1,4 +1,12 @@
;;
+;; Basic FFI examples.
+;;
+;; usage:
+;; .../src$ make posix USE_LIBFFI=1
+;; .../src$ ./klisp examples/ffi-sdl.k
+;;
+
+
;; (ffi-load-library DLLNAME) ... loads the C library DLLNAME
;; and returns opaque handle.
;;
@@ -27,16 +35,26 @@
;; "void" void inert (only return)
;; "sint" signed int fixint
;; "string" (char *) string
-;; "pointer" (void *) blob, string, nil (only arguments)
+;; "uint8" uint8_t fixint
+;; "uint16" uint16_t fixint
+;; "uint32" uint32_t fixint, bigint
+;; "uint64" uint64_t fixint, bigint
+;; "float" float double
+;; "double" double double
+;; "pointer" (void *) blob (only for arguments)
+;; string (only for arguments)
+;; nil
+;; pointer (TAG_USER)
;;
;; Other data types not supported yet. Varargs function
;; not supported by libffi.
;;
($define! abi "FFI_DEFAULT_ABI")
-($define! cif1 (ffi-make-call-interface abi "sint" ()))
-($define! cif2 (ffi-make-call-interface abi "sint" (list "string")))
-($define! cif3 (ffi-make-call-interface abi "string" (list "string")))
+($define! cif-int-void (ffi-make-call-interface abi "sint" ()))
+($define! cif-string-string (ffi-make-call-interface abi "string" (list "string")))
+($define! cif-int-string (ffi-make-call-interface abi "sint" (list "string")))
+($define! cif-double-double (ffi-make-call-interface abi "double" (list "double")))
;; (ffi-make-applicative LIB-HANDLE FUNCTION-NAME CALL-INTERFACE)
;;
@@ -50,34 +68,28 @@
;; otherwise.
;;
-($define! getpid (ffi-make-applicative self "getpid" cif1))
-($define! getppid (ffi-make-applicative self "getppid" cif1))
-($define! system (ffi-make-applicative self "system" cif2))
-($define! getenv (ffi-make-applicative self "getenv" cif3))
+($define! getpid (ffi-make-applicative self "getpid" cif-int-void))
+($define! getppid (ffi-make-applicative self "getppid" cif-int-void))
+($define! system (ffi-make-applicative self "system" cif-int-string))
+($define! getenv (ffi-make-applicative self "getenv" cif-string-string))
+($define! lgamma (ffi-make-applicative self "lgamma" cif-double-double))
-($define! horner
- ($lambda (polynomial x acc)
- ($if (null? polynomial)
- acc
- (horner (cdr polynomial) x (+ (car polynomial) (* x acc))))))
+(display "Testing getpid(), getppid() ...")
+(write (list (getpid) (getppid)))
+(newline)
-($define! u32-of-u8-list
- ($lambda (list)
- (horner list 256 0)))
+(display "Testing getenv(\"HOME\")...")
+(write (getenv "HOME"))
+(newline)
-;; warning: 32-bit little endian only
-($define! gettimeofday
- ($let
- ( (unix-gettimeofday (ffi-make-applicative libc "gettimeofday"
- (ffi-make-call-interface abi
- "sint" (list "pointer" "pointer")))))
- ($lambda ()
- ($let* ( (buffer (make-blob 8))
- (b ($lambda (i) (blob-u8-ref buffer i))))
- (unix-gettimeofday buffer ())
- (list
- (u32-of-u8-list (map b (list 3 2 1 0)))
- (/ (u32-of-u8-list (map b (list 7 6 5 4))) 1000000))))))
+(display "Testing system(\"ls /\")...")
+(newline)
+(write (system "ls /"))
+(newline)
+
+(display "Testing lgamma(9.87)...")
+(write (lgamma 9.87))
+(newline)
($define! unix-write-string
($let*
@@ -90,25 +102,235 @@
(unix-write-string "ABCDEFGH")
(newline)
-(display "Testing getpid()...")
-(write (getpid))
-(newline)
+($define! strtoull
+ (ffi-make-applicative libc "strtoull"
+ (ffi-make-call-interface abi
+ "uint64" (list "string" "pointer" "sint"))))
-(display "Testing getppid()...")
-(write (getppid))
+(display "Testing strtoull(\"0x123456789ABCDEF\", NULL, 0)...")
+(write (strtoull "0x123456789ABCDEF" () 0))
+(display "...")
+(write #x123456789ABCDEF)
+(display "= #x123456789ABCDEF")
(newline)
-(display "Testing getenv(\"HOME\")...")
-(write (getenv "HOME"))
+;; (ffi-type-suite TYPE) returns a four-element list
+;; (SIZE ALIGNMENT REF SET!). SIZE is the size of
+;; the data type in bytes. ALIGNMENT is preferred
+;; alignment. REF and SET! are applicatives.
+;;
+;; (REF MEMORY-LOCATION)
+;; (SET! MEMORY-LOCATION VALUE)
+;;
+;; MEMORY-LOCATION is either blob, string, pointer,
+;; or a two-element list (MEMORY-LOCATION OFFSET).
+;; The offset specification can not be nested, i.e.
+;; ((blob 1) 2) is not valid memory location.
+;;
+($define!
+ (sint-size sint-alignment sint-ref sint-set!)
+ (ffi-type-suite "sint"))
+
+(display "\"sint\" data type size and alignment: ")
+(write (list sint-size sint-alignment))
(newline)
-(display "Testing gettimeofday(), assuming 32-bit intel arch...")
+;; Using ffi-type-suite, one can define means to convert
+;; C structs (stored in blobs or arbitrary memory locations)
+;; to lists.
+;;
+($define! align
+ ($lambda (offset alignment)
+ (+ offset (mod (- alignment offset) alignment))))
+
+($define! regularize-location
+ ($lambda (location)
+ ($if (pair? location)
+ location
+ (list location 0))))
+
+($define! decode-struct
+ ($lambda type-strings
+ ($letrec*
+ ( (suites (map ffi-type-suite type-strings))
+ (decode ($lambda (base offset tail)
+ ($if (null? tail)
+ ()
+ ($let (((size alignment ref set!) (car tail)))
+ (cons
+ (ref (list base (align offset alignment)))
+ (decode
+ base
+ (+ size (align offset alignment))
+ (cdr tail))))))))
+ ($lambda (location)
+ ($let (((base offset) (regularize-location location)))
+ (decode base offset suites))))))
+
+;; For example,
+;;
+;; struct timeval {
+;; time_t tv_sec; /* seconds */
+;; suseconds_t tv_usec; /* microseconds */
+;; };
+;;
+($define! struct-timeval-ref
+ (decode-struct "sint" "sint"))
+
+($define! gettimeofday
+ ($let
+ ( (unix-gettimeofday
+ (ffi-make-applicative libc "gettimeofday"
+ (ffi-make-call-interface abi
+ "sint" (list "pointer" "pointer")))))
+ ($lambda ()
+ ($let* ((buffer (make-blob (* 2 sint-size))))
+ (unix-gettimeofday buffer ())
+ ($let (((tv_sec tv_usec) (struct-timeval-ref buffer)))
+ (list tv_sec (/ tv_usec 1000000)))))))
+
+(display "Testing gettimeofday(), assuming 32-bit arch...")
(write (gettimeofday))
(newline)
-(display "Testing system(\"ls /\")...")
+($define! localtime
+ ($let
+ ( (localtime-r
+ (ffi-make-applicative libc "localtime_r"
+ (ffi-make-call-interface abi
+ "pointer" (list "pointer" "pointer"))))
+ (decoder
+ (decode-struct "sint" "sint" "sint" "sint" "sint" "sint" "sint" "sint")))
+ ($lambda (t)
+ ($let*
+ ( (t-buf (make-blob sint-size))
+ (tm-buf (make-blob 128)) )
+ (sint-set! t-buf t)
+ (localtime-r t-buf tm-buf)
+ ($let
+ (((tm_sec tm_min tm_hour tm_mday tm_mon tm_year . rest)
+ (decoder tm-buf)))
+ (list
+ (list (+ 1900 tm_year) (+ 1 tm_mon) tm_mday)
+ (list tm_hour tm_min tm_sec)))))))
+
+(display "Testing localtime()...")
+(write
+ ($let (((tm_sec tm_usec) (gettimeofday)))
+ (localtime tm_sec)))
(newline)
-(write (system "ls /"))
+
+;; Some C structs are more complex:
+;;
+;; struct hostent {
+;; char *h_name; /* official name of host */
+;; char **h_aliases; /* alias list */
+;; int h_addrtype; /* host address type */
+;; int h_length; /* length of address */
+;; char **h_addr_list; /* list of addresses */
+;; }
+;;
+;; Network address is just byte array. IPv4 address
+;; contains 4 bytes, IPv6 address contains 16 bytes.
+;;
+;; (ffi-memmove DESTINATION SOURCE SIZE) copies
+;; SIZE bytes from SOURCE to DESTINATION. Both SOURCE
+;; and DESTINATION are memory locations as described above.
+;; ffi-memmove can copy data between blobs and arbitrary
+;; memory locations.
+;;
+($define! copy-location
+ ($lambda (location size)
+ ($let ((blob (make-blob size)))
+ (ffi-memmove blob location size)
+ blob)))
+
+($define! blob->list
+ ($letrec
+ ((aux ($lambda (blob index)
+ ($if (<? index (blob-length blob))
+ (cons
+ (blob-u8-ref blob index)
+ (aux blob (+ 1 index)))
+ ()))))
+ ($lambda (blob)
+ (aux blob 0))))
+
+($define! parse-address
+ ($lambda (location size)
+ (blob->list (copy-location location size))))
+
+($define!
+ (voidptr-size voidptr-alignment voidptr-ref voidptr-set!)
+ (ffi-type-suite "pointer"))
+
+($define! null-terminated-array->list
+ ($letrec
+ ( (aux
+ ($lambda (base offset)
+ ($if (null? (voidptr-ref (list base offset)))
+ ()
+ (cons
+ (list base offset)
+ (aux base (+ offset voidptr-size)))))))
+ ($lambda (location)
+ (apply aux (regularize-location location)))))
+
+($define!
+ (charptr-size charptr-alignment charptr-ref charptr-set!)
+ (ffi-type-suite "string"))
+
+($define! parse-hostent
+ ($letrec*
+ ( (decode-1
+ (decode-struct "string" "pointer" "sint" "sint" "pointer")))
+ ($lambda (pointer)
+ ($let
+ ( ((h_name h_aliases h_addrtype h_length h_addr_list) (decode-1 pointer)))
+ (list
+ h_name
+ (map
+ charptr-ref
+ (null-terminated-array->list h_aliases))
+ (map
+ ($lambda (a) (parse-address (voidptr-ref a) h_length))
+ (null-terminated-array->list h_addr_list)))))))
+
+($define! gethostbyname
+ ($let
+ ((unix-gethostbyname
+ (ffi-make-applicative libc "gethostbyname"
+ (ffi-make-call-interface abi "pointer" (list "string")))))
+ ($lambda (hostname)
+ (parse-hostent (unix-gethostbyname hostname)))))
+
+(display "Testing gehostbyname(\"localhost\")...")
+(write (gethostbyname "localhost"))
(newline)
+(display "Testing gehostbyname(\"www.google.com\")...")
+(write (gethostbyname "www.google.com"))
+(newline)
+
+;;
+;; Detecting machine endianess.
+;;
+($define!
+ (uint32-size uint32-alignment uint32-ref uint32-set!)
+ (ffi-type-suite "uint32"))
+
+($define! endianess
+ ($let
+ ((buffer (make-blob 4)))
+ (uint32-set! buffer #x01020304)
+ ($let
+ ((bytes (blob->list buffer)))
+ ($cond
+ ((equal? bytes (list 1 2 3 4)) "big-endian")
+ ((equal? bytes (list 4 3 2 1)) "little-endian")
+ (#t "unknown")))))
+
+(display "Guessing endianess...")
+(write endianess)
+(newline)
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -13,8 +13,10 @@
#include <dlfcn.h>
#include <ffi.h>
+#include "imath.h"
#include "kstate.h"
#include "kobject.h"
+#include "kinteger.h"
#include "kpair.h"
#include "kerror.h"
#include "kblob.h"
@@ -24,6 +26,11 @@
#include "kgencapsulations.h"
#include "kgffi.h"
+/* Set to 0 to ignore aligment errors during direct
+ * memory read/writes. */
+
+#define KGFFI_CHECK_ALIGNMENT 1
+
typedef struct ffi_codec_s ffi_codec_t;
struct ffi_codec_s {
const char *name;
@@ -66,6 +73,13 @@ static void ffi_encode_sint(ffi_codec_t *self, klisp_State *K, TValue v, void *b
* (int *) buf = ivalue(v);
}
+static TValue ffi_decode_pointer(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ void *p = *(void **)buf;
+ return (p) ? p2tv(p) : KNIL;
+}
+
static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
{
if (ttisblob(v)) {
@@ -74,15 +88,19 @@ static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void
*(void **)buf = kstring_buf(v);
} else if (ttisnil(v)) {
*(void **)buf = NULL;
+ } else if (tbasetype_(v) == K_TAG_USER) {
+ /* TODO: do not use internal macro tbasetype_ */
+ *(void **)buf = pvalue(v);
} else {
- klispE_throw_simple_with_irritants(K, "neither blob, string or nil", 1, v);
+ klispE_throw_simple_with_irritants(K, "neither blob, string, pointer or nil", 1, v);
}
}
static TValue ffi_decode_string(ffi_codec_t *self, klisp_State *K, const void *buf)
{
UNUSED(self);
- return kstring_new_b_imm(K, *(char **)buf);
+ char *s = *(char **) buf;
+ return (s) ? kstring_new_b_imm(K, s) : KNIL;
}
static void ffi_encode_string(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
@@ -94,12 +112,208 @@ static void ffi_encode_string(ffi_codec_t *self, klisp_State *K, TValue v, void
}
}
+static TValue ffi_decode_uint8(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ UNUSED(K);
+ return i2tv(*(uint8_t *)buf);
+}
+
+static void ffi_encode_uint8(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && 0 <= ivalue(v) && ivalue(v) <= UINT8_MAX) {
+ *(uint8_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint8_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_sint8(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ UNUSED(K);
+ return i2tv(*(int8_t *)buf);
+}
+
+static void ffi_encode_sint8(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && INT8_MIN <= ivalue(v) && ivalue(v) <= INT8_MAX) {
+ *(int8_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int8_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_uint16(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return i2tv(*(uint16_t *)buf);
+}
+
+static void ffi_encode_uint16(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && 0 <= ivalue(v) && ivalue(v) <= UINT16_MAX) {
+ *(uint16_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint16_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_sint16(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return i2tv(*(int16_t *)buf);
+}
+
+static void ffi_encode_sint16(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && INT16_MIN <= ivalue(v) && ivalue(v) <= INT16_MAX) {
+ *(int16_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int16_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_uint32(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ uint32_t x = *(uint32_t *)buf;
+ if (x <= INT32_MAX) {
+ return i2tv((int32_t) x);
+ } else {
+ TValue res = kbigint_make_simple(K);
+ krooted_tvs_push(K, res);
+
+ uint8_t d[4];
+ for (int i = 3; i >= 0; i--) {
+ d[i] = (x & 0xFF);
+ x >>= 8;
+ }
+ mp_int_read_unsigned(K, tv2bigint(res), d, 4);
+
+ krooted_tvs_pop(K);
+ return res;
+ }
+}
+
+static void ffi_encode_uint32(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ uint32_t tmp;
+
+ if (ttisfixint(v) && 0 <= ivalue(v)) {
+ *(uint32_t *) buf = ivalue(v);
+ } else if (ttisbigint(v) && mp_int_to_uint(tv2bigint(v), &tmp) == MP_OK) {
+ *(uint32_t *) buf = tmp;
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint32_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_uint64(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ /* TODO */
+ UNUSED(self);
+ uint64_t x = *(uint64_t *)buf;
+ if (x <= INT32_MAX) {
+ return i2tv((int32_t) x);
+ } else {
+ TValue res = kbigint_make_simple(K);
+ krooted_tvs_push(K, res);
+
+ uint8_t d[8];
+ for (int i = 7; i >= 0; i--) {
+ d[i] = (x & 0xFF);
+ x >>= 8;
+ }
+
+ mp_int_read_unsigned(K, tv2bigint(res), d, 8);
+ krooted_tvs_pop(K);
+ return res;
+ }
+}
+
+static void ffi_encode_uint64(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ /* TODO */
+ UNUSED(self);
+
+ if (ttisfixint(v) && 0 <= ivalue(v)) {
+ *(uint64_t *) buf = ivalue(v);
+ } else if (ttisbigint(v)
+ && mp_int_compare_zero(tv2bigint(v)) >= 0
+ && mp_int_unsigned_len(tv2bigint(v)) <= 8) {
+ uint8_t d[8];
+
+ mp_int_to_unsigned(K, tv2bigint(v), d, 8);
+ uint64_t tmp = d[0];
+ for (int i = 1; i < 8; i++)
+ tmp = (tmp << 8) | d[i];
+ *(uint64_t *) buf = tmp;
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint64_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_double(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return d2tv(*(double *)buf);
+}
+
+static void ffi_encode_double(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisdouble(v)) {
+ *(double *) buf = dvalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to cast to C double", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_float(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return d2tv((double) *(float *)buf);
+}
+
+static void ffi_encode_float(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisdouble(v)) {
+ /* TODO: avoid double rounding for rationals/bigints ?*/
+ *(float *) buf = dvalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to cast to C float", 1, v);
+ return;
+ }
+}
+
static ffi_codec_t ffi_codecs[] = {
{ "void", &ffi_type_void, ffi_decode_void, NULL },
- { "pointer", &ffi_type_pointer, NULL, ffi_encode_pointer },
{ "string", &ffi_type_pointer, ffi_decode_string, ffi_encode_string },
#define SIMPLE_TYPE(t) { #t, &ffi_type_ ## t, ffi_decode_ ## t, ffi_encode_ ## t }
- SIMPLE_TYPE(sint)
+ SIMPLE_TYPE(sint),
+ SIMPLE_TYPE(pointer),
+ SIMPLE_TYPE(uint8),
+ SIMPLE_TYPE(sint8),
+ SIMPLE_TYPE(uint16),
+ SIMPLE_TYPE(sint16),
+ SIMPLE_TYPE(uint32),
+ SIMPLE_TYPE(uint64),
+ SIMPLE_TYPE(float),
+ SIMPLE_TYPE(double)
#undef SIMPLE_TYPE
};
@@ -350,6 +564,151 @@ void ffi_make_applicative(klisp_State *K, TValue *xparams,
kapply_cc(K, app);
}
+static uint8_t * ffi_memory_location(klisp_State *K, bool allow_nesting,
+ TValue v, bool mutable, size_t size)
+{
+ if (ttisblob(v)) {
+ if (mutable && kblob_immutablep(v)) {
+ klispE_throw_simple_with_irritants(K, "blob not mutable", 1, v);
+ return NULL;
+ } else if (size > kblob_size(v)) {
+ klispE_throw_simple_with_irritants(K, "blob too small", 1, v);
+ return NULL;
+ } else {
+ return kblob_buf(v);
+ }
+ } else if (ttisstring(v)) {
+ if (mutable && kstring_immutablep(v)) {
+ klispE_throw_simple_with_irritants(K, "string not mutable", 1, v);
+ return NULL;
+ } else if (size > kstring_size(v)) {
+ klispE_throw_simple_with_irritants(K, "string too small", 1, v);
+ return NULL;
+ } else {
+ return (uint8_t *) kstring_buf(v);
+ }
+ } else if (tbasetype_(v) == K_TAG_USER) {
+ /* TODO: do not use internal macro tbasetype_ */
+ return (pvalue(v));
+ } else if (ttispair(v) && ttispair(kcdr(v)) && ttisnil(kcddr(v))) {
+ if (!allow_nesting) {
+ klispE_throw_simple_with_irritants(K, "offset specifications cannot be nested", 1, v);
+ return NULL;
+ }
+ TValue base_tv = kcar(v);
+ TValue offset_tv = kcadr(v);
+ if (!ttisfixint(offset_tv) || ivalue(offset_tv) < 0) {
+ klispE_throw_simple_with_irritants(K, "offset should be nonnegative fixint", 1, v);
+ return NULL;
+ } else {
+ size_t offset = ivalue(offset_tv);
+ uint8_t * p = ffi_memory_location(K, false, base_tv, mutable, size + offset);
+ return (p + offset);
+ }
+ } else {
+ klispE_throw_simple_with_irritants(K, "not a memory location", 1, v);
+ return NULL;
+ }
+}
+
+void ffi_memmove(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_3tp(K, ptree,
+ "any", anytype, dst_tv,
+ "any", anytype, src_tv,
+ "integer", ttisfixint, sz_tv);
+
+ if (ivalue(sz_tv) < 0)
+ klispE_throw_simple(K, "size should be nonnegative fixint");
+
+ size_t sz = (size_t) ivalue(sz_tv);
+ uint8_t * dst = ffi_memory_location(K, true, dst_tv, true, sz);
+ const uint8_t * src = ffi_memory_location(K, true, src_tv, false, sz);
+ memmove(dst, src, sz);
+
+ kapply_cc(K, KINERT);
+}
+
+static void ffi_type_ref(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: pointer to ffi_codec_t
+ */
+
+ bind_1tp(K, ptree, "any", anytype, location_tv);
+ ffi_codec_t *codec = pvalue(xparams[0]);
+ const uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size);
+#if KGFFI_CHECK_ALIGNMENT
+ if ((size_t) ptr % codec->libffi_type->alignment != 0)
+ klispE_throw_simple(K, "unaligned memory read through FFI");
+#endif
+
+ TValue result = codec->decode(codec, K, ptr);
+ kapply_cc(K, result);
+}
+
+static void ffi_type_set(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: pointer to ffi_codec_t
+ */
+
+ bind_2tp(K, ptree,
+ "any", anytype, location_tv,
+ "any", anytype, value_tv);
+ ffi_codec_t *codec = pvalue(xparams[0]);
+ uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size);
+#if KGFFI_CHECK_ALIGNMENT
+ if ((size_t) ptr % codec->libffi_type->alignment != 0)
+ klispE_throw_simple(K, "unaligned memory write through FFI");
+#endif
+
+ codec->encode(codec, K, value_tv, ptr);
+ kapply_cc(K, KINERT);
+}
+
+void ffi_type_suite(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ bind_1tp(K, ptree, "string", ttisstring, type_tv);
+ ffi_codec_t *codec = tv2ffi_codec(K, type_tv);
+
+ TValue size_tv = i2tv(codec->libffi_type->size);
+ krooted_tvs_push(K, size_tv);
+
+ TValue alignment_tv = i2tv(codec->libffi_type->alignment);
+ krooted_tvs_push(K, alignment_tv);
+
+ TValue getter_tv =
+ (codec->decode)
+ ? kmake_applicative(K, ffi_type_ref, 1, p2tv(codec))
+ : KINERT;
+ krooted_tvs_push(K, getter_tv);
+
+ TValue setter_tv =
+ (codec->encode)
+ ? kmake_applicative(K, ffi_type_set, 1, p2tv(codec))
+ : KINERT;
+ krooted_tvs_push(K, setter_tv);
+
+ TValue suite_tv = kimm_list(K, 4, size_tv, alignment_tv, getter_tv, setter_tv);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ kapply_cc(K, suite_tv);
+}
+
/* init ground */
void kinit_ffi_ground_env(klisp_State *K)
{
@@ -364,6 +723,8 @@ void kinit_ffi_ground_env(klisp_State *K)
add_applicative(K, ground_env, "ffi-load-library", ffi_load_library, 1, dll_key);
add_applicative(K, ground_env, "ffi-make-call-interface", ffi_make_call_interface, 1, cif_key);
add_applicative(K, ground_env, "ffi-make-applicative", ffi_make_applicative, 2, dll_key, cif_key);
+ add_applicative(K, ground_env, "ffi-memmove", ffi_memmove, 0);
+ add_applicative(K, ground_env, "ffi-type-suite", ffi_type_suite, 0);
add_applicative(K, ground_env, "ffi-library?", enc_typep, 1, dll_key);
add_applicative(K, ground_env, "ffi-call-interface?", enc_typep, 1, cif_key);
}
diff --git a/src/kgffi.h b/src/kgffi.h
@@ -7,6 +7,9 @@
#ifndef kgffi_h
#define kgffi_h
+#if (KUSE_LIBFFI != 1)
+# error "Compiling FFI code, but KUSE_LIBFFI != 1."
+#endif
#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
diff --git a/src/kground.c b/src/kground.c
@@ -37,7 +37,10 @@
#include "kgports.h"
#include "kgblobs.h"
#include "kgsystem.h"
-#include "kgffi.h"
+
+#if KUSE_LIBFFI
+# include "kgffi.h"
+#endif
/* for initing cont names */
#include "ktable.h"
@@ -140,7 +143,9 @@ void kinit_ground_env(klisp_State *K)
kinit_ports_ground_env(K);
kinit_blobs_ground_env(K);
kinit_system_ground_env(K);
+#if KUSE_LIBFFI
kinit_ffi_ground_env(K);
+#endif
/*
** Initialize the names of the continuation used in
