ffi.k (10274B)
1 ;; 2 ;; Basic FFI examples. 3 ;; 4 ;; usage: 5 ;; .../src$ make posix USE_LIBFFI=1 6 ;; .../src$ ./klisp examples/ffi-sdl.k 7 ;; 8 9 10 ;; (ffi-load-library DLLNAME) ... loads the C library DLLNAME 11 ;; and returns opaque handle. 12 ;; 13 ;; (ffi-load-library) ... returns a handle, which can be used 14 ;; to access the functions linked statically to the interpreter 15 ;; 16 ;; Unloading not supported. ffi-load-library is actually 17 ;; a wrapper around dlopen() 18 ;; 19 ($define! libc (ffi-load-library "libc.so.6")) 20 ($define! self (ffi-load-library)) 21 22 ;; (ffi-make-call-interface ABI RETURN-TYPE ARGUMENT-TYPES) returns 23 ;; libffi call interface object. It is actually a wrapper around 24 ;; ffi_prep_cif(). 25 ;; 26 ;; The parameter ABI determines the C call convention. Only 27 ;; "FFI_DEFAULT_ABI" is supported. 28 ;; 29 ;; RETURN-TYPE determines the return type and ARGUMENT-TYPES 30 ;; is a list which determines the arguments. The types 31 ;; are specified as strings: 32 ;; 33 ;; type C type klisp type note 34 ;; ---------------------------------------------------- 35 ;; "void" void inert (only return) 36 ;; "sint" signed int fixint 37 ;; "string" (char *) string 38 ;; "uint8" uint8_t fixint 39 ;; "uint16" uint16_t fixint 40 ;; "uint32" uint32_t fixint, bigint 41 ;; "uint64" uint64_t fixint, bigint 42 ;; "float" float double 43 ;; "double" double double 44 ;; "pointer" (void *) bytevector (only for arguments) 45 ;; string (only for arguments) 46 ;; nil 47 ;; pointer (TAG_USER) 48 ;; 49 ;; Other data types not supported yet. Varargs function 50 ;; not supported by libffi. 51 ;; 52 53 ($define! abi "FFI_DEFAULT_ABI") 54 ($define! cif-int-void (ffi-make-call-interface abi "sint" ())) 55 ($define! cif-string-string (ffi-make-call-interface abi "string" (list "string"))) 56 ($define! cif-int-string (ffi-make-call-interface abi "sint" (list "string"))) 57 ($define! cif-double-double (ffi-make-call-interface abi "double" (list "double"))) 58 59 ;; (ffi-make-applicative LIB-HANDLE FUNCTION-NAME CALL-INTERFACE) 60 ;; 61 ;; Looks up the function FUNCTION-NAME in the library referenced 62 ;; by LIB-HANDLE. Creates an applicative which calls the function 63 ;; using the interface CALL-INTERFACE. Conversion from/to klisp 64 ;; types is handled automatically. 65 ;; 66 ;; It is a wrapper around dlsym(). The types should match the 67 ;; actual C function prototype, the interpreter might crash 68 ;; otherwise. 69 ;; 70 71 ($define! getpid (ffi-make-applicative self "getpid" cif-int-void)) 72 ($define! getppid (ffi-make-applicative self "getppid" cif-int-void)) 73 ($define! system (ffi-make-applicative self "system" cif-int-string)) 74 ($define! getenv (ffi-make-applicative self "getenv" cif-string-string)) 75 ($define! lgamma (ffi-make-applicative self "lgamma" cif-double-double)) 76 77 (display "Testing getpid(), getppid() ...") 78 (write (list (getpid) (getppid))) 79 (newline) 80 81 (display "Testing getenv(\"HOME\")...") 82 (write (getenv "HOME")) 83 (newline) 84 85 (display "Testing system(\"ls /\")...") 86 (newline) 87 (write (system "ls /")) 88 (newline) 89 90 (display "Testing lgamma(9.87)...") 91 (write (lgamma 9.87)) 92 (newline) 93 94 ($define! unix-write-string 95 ($let* 96 ( (unix-write (ffi-make-applicative libc "write" 97 (ffi-make-call-interface abi 98 "sint" (list "sint" "pointer" "sint"))))) 99 ($lambda (s) (unix-write 0 s (string-length s))))) 100 101 (display "Testing unix write()...") 102 (unix-write-string "ABCDEFGH") 103 (newline) 104 105 ($define! strtoull 106 (ffi-make-applicative libc "strtoull" 107 (ffi-make-call-interface abi 108 "uint64" (list "string" "pointer" "sint")))) 109 110 (display "Testing strtoull(\"0x123456789ABCDEF\", NULL, 0)...") 111 (write (strtoull "0x123456789ABCDEF" () 0)) 112 (display "...") 113 (write #x123456789ABCDEF) 114 (display "= #x123456789ABCDEF") 115 (newline) 116 117 ;; (ffi-type-suite TYPE) returns a four-element list 118 ;; (SIZE ALIGNMENT REF SET!). SIZE is the size of 119 ;; the data type in bytes. ALIGNMENT is preferred 120 ;; alignment. REF and SET! are applicatives. 121 ;; 122 ;; (REF MEMORY-LOCATION) 123 ;; (SET! MEMORY-LOCATION VALUE) 124 ;; 125 ;; MEMORY-LOCATION is either bytevector, string, pointer, 126 ;; or a two-element list (MEMORY-LOCATION OFFSET). 127 ;; The offset specification can not be nested, i.e. 128 ;; ((blob 1) 2) is not valid memory location. 129 ;; 130 ($define! 131 (sint-size sint-alignment sint-ref sint-set!) 132 (ffi-type-suite "sint")) 133 134 (display "\"sint\" data type size and alignment: ") 135 (write (list sint-size sint-alignment)) 136 (newline) 137 138 ;; Using ffi-type-suite, one can define means to convert 139 ;; C structs (stored in bytevectors or arbitrary memory locations) 140 ;; to lists. 141 ;; 142 ($define! align 143 ($lambda (offset alignment) 144 (+ offset (mod (- alignment offset) alignment)))) 145 146 ($define! regularize-location 147 ($lambda (location) 148 ($if (pair? location) 149 location 150 (list location 0)))) 151 152 ($define! decode-struct 153 ($lambda type-strings 154 ($letrec* 155 ( (suites (map ffi-type-suite type-strings)) 156 (decode ($lambda (base offset tail) 157 ($if (null? tail) 158 () 159 ($let (((size alignment ref set!) (car tail))) 160 (cons 161 (ref (list base (align offset alignment))) 162 (decode 163 base 164 (+ size (align offset alignment)) 165 (cdr tail)))))))) 166 ($lambda (location) 167 ($let (((base offset) (regularize-location location))) 168 (decode base offset suites)))))) 169 170 ;; For example, 171 ;; 172 ;; struct timeval { 173 ;; time_t tv_sec; /* seconds */ 174 ;; suseconds_t tv_usec; /* microseconds */ 175 ;; }; 176 ;; 177 ($define! struct-timeval-ref 178 (decode-struct "sint" "sint")) 179 180 ($define! gettimeofday 181 ($let 182 ( (unix-gettimeofday 183 (ffi-make-applicative libc "gettimeofday" 184 (ffi-make-call-interface abi 185 "sint" (list "pointer" "pointer"))))) 186 ($lambda () 187 ($let* ((buffer (make-bytevector (* 2 sint-size)))) 188 (unix-gettimeofday buffer ()) 189 ($let (((tv_sec tv_usec) (struct-timeval-ref buffer))) 190 (list tv_sec (/ tv_usec 1000000))))))) 191 192 (display "Testing gettimeofday(), assuming 32-bit arch...") 193 (write (gettimeofday)) 194 (newline) 195 196 ($define! localtime 197 ($let 198 ( (localtime-r 199 (ffi-make-applicative libc "localtime_r" 200 (ffi-make-call-interface abi 201 "pointer" (list "pointer" "pointer")))) 202 (decoder 203 (decode-struct "sint" "sint" "sint" "sint" "sint" "sint" "sint" "sint"))) 204 ($lambda (t) 205 ($let* 206 ( (t-buf (make-bytevector sint-size)) 207 (tm-buf (make-bytevector 128)) ) 208 (sint-set! t-buf t) 209 (localtime-r t-buf tm-buf) 210 ($let 211 (((tm_sec tm_min tm_hour tm_mday tm_mon tm_year . rest) 212 (decoder tm-buf))) 213 (list 214 (list (+ 1900 tm_year) (+ 1 tm_mon) tm_mday) 215 (list tm_hour tm_min tm_sec))))))) 216 217 (display "Testing localtime()...") 218 (write 219 ($let (((tm_sec tm_usec) (gettimeofday))) 220 (localtime tm_sec))) 221 (newline) 222 223 ;; Some C structs are more complex: 224 ;; 225 ;; struct hostent { 226 ;; char *h_name; /* official name of host */ 227 ;; char **h_aliases; /* alias list */ 228 ;; int h_addrtype; /* host address type */ 229 ;; int h_length; /* length of address */ 230 ;; char **h_addr_list; /* list of addresses */ 231 ;; } 232 ;; 233 ;; Network address is just byte array. IPv4 address 234 ;; contains 4 bytes, IPv6 address contains 16 bytes. 235 ;; 236 ;; (ffi-memmove DESTINATION SOURCE SIZE) copies 237 ;; SIZE bytes from SOURCE to DESTINATION. Both SOURCE 238 ;; and DESTINATION are memory locations as described above. 239 ;; ffi-memmove can copy data between bytevectors and arbitrary 240 ;; memory locations. 241 ;; 242 ($define! copy-location 243 ($lambda (location size) 244 ($let ((blob (make-bytevector size))) 245 (ffi-memmove blob location size) 246 blob))) 247 248 ($define! bytevector->list 249 ($letrec 250 ((aux ($lambda (blob index) 251 ($if (<? index (bytevector-length blob)) 252 (cons 253 (bytevector-u8-ref blob index) 254 (aux blob (+ 1 index))) 255 ())))) 256 ($lambda (blob) 257 (aux blob 0)))) 258 259 ($define! parse-address 260 ($lambda (location size) 261 (bytevector->list (copy-location location size)))) 262 263 ($define! 264 (voidptr-size voidptr-alignment voidptr-ref voidptr-set!) 265 (ffi-type-suite "pointer")) 266 267 ($define! null-terminated-array->list 268 ($letrec 269 ( (aux 270 ($lambda (base offset) 271 ($if (null? (voidptr-ref (list base offset))) 272 () 273 (cons 274 (list base offset) 275 (aux base (+ offset voidptr-size))))))) 276 ($lambda (location) 277 (apply aux (regularize-location location))))) 278 279 ($define! 280 (charptr-size charptr-alignment charptr-ref charptr-set!) 281 (ffi-type-suite "string")) 282 283 ($define! parse-hostent 284 ($letrec* 285 ( (decode-1 286 (decode-struct "string" "pointer" "sint" "sint" "pointer"))) 287 ($lambda (pointer) 288 ($let 289 ( ((h_name h_aliases h_addrtype h_length h_addr_list) (decode-1 pointer))) 290 (list 291 h_name 292 (map 293 charptr-ref 294 (null-terminated-array->list h_aliases)) 295 (map 296 ($lambda (a) (parse-address (voidptr-ref a) h_length)) 297 (null-terminated-array->list h_addr_list))))))) 298 299 ($define! gethostbyname 300 ($let 301 ((unix-gethostbyname 302 (ffi-make-applicative libc "gethostbyname" 303 (ffi-make-call-interface abi "pointer" (list "string"))))) 304 ($lambda (hostname) 305 (parse-hostent (unix-gethostbyname hostname))))) 306 307 (display "Testing gehostbyname(\"localhost\")...") 308 (write (gethostbyname "localhost")) 309 (newline) 310 311 (display "Testing gehostbyname(\"www.google.com\")...") 312 (write (gethostbyname "www.google.com")) 313 (newline) 314 315 ;; 316 ;; Detecting machine endianess. 317 ;; 318 319 ($define! 320 (uint32-size uint32-alignment uint32-ref uint32-set!) 321 (ffi-type-suite "uint32")) 322 323 ($define! endianess 324 ($let 325 ((buffer (make-bytevector 4))) 326 (uint32-set! buffer #x01020304) 327 ($let 328 ((bytes (bytevector->list buffer))) 329 ($cond 330 ((equal? bytes (list 1 2 3 4)) "big-endian") 331 ((equal? bytes (list 4 3 2 1)) "little-endian") 332 (#t "unknown"))))) 333 334 (display "Guessing endianess...") 335 (write endianess) 336 (newline)