kgffi.c (35769B)
1 /* 2 ** kgffi.c 3 ** Foreign function interface 4 ** See Copyright Notice in klisp.h 5 */ 6 7 /* 8 * Detect dynamic linking facilities. 9 * 10 */ 11 #if !defined(KLISP_USE_POSIX) && defined(_WIN32) 12 # define KGFFI_WIN32 true 13 #else 14 # define KGFFI_DLFCN true 15 #endif 16 17 #include <assert.h> 18 #include <stdlib.h> 19 #include <stdbool.h> 20 #include <stdint.h> 21 #include <string.h> 22 23 #if KGFFI_DLFCN 24 # include <dlfcn.h> 25 #elif KGFFI_WIN32 26 # include <windows.h> 27 #else 28 # error 29 #endif 30 31 #include <ffi.h> 32 33 #include "imath.h" 34 #include "kstate.h" 35 #include "kobject.h" 36 #include "kinteger.h" 37 #include "kpair.h" 38 #include "kerror.h" 39 #include "kbytevector.h" 40 #include "kencapsulation.h" 41 #include "ktable.h" 42 43 #include "kghelpers.h" 44 #include "kgffi.h" 45 46 /* Set to 0 to ignore aligment errors during direct 47 * memory read/writes. */ 48 49 #define KGFFI_CHECK_ALIGNMENT 1 50 51 typedef struct ffi_codec_s ffi_codec_t; 52 struct ffi_codec_s { 53 const char *name; 54 ffi_type *libffi_type; 55 TValue (*decode)(ffi_codec_t *self, klisp_State *K, const void *buf); 56 void (*encode)(ffi_codec_t *self, klisp_State *K, TValue v, void *buf); 57 }; 58 59 typedef struct { 60 ffi_cif cif; 61 size_t buffer_size; 62 ffi_codec_t *rcodec; 63 size_t nargs; 64 ffi_type **argtypes; 65 ffi_codec_t **acodecs; 66 } ffi_call_interface_t; 67 68 typedef struct { 69 ffi_closure libffi_closure; 70 klisp_State *K; 71 Table *table; 72 size_t index; 73 } ffi_callback_t; 74 75 #define CB_INDEX_N 0 76 #define CB_INDEX_STACK 1 77 #define CB_INDEX_FIRST_CALLBACK 2 78 79 /* Continuations */ 80 void do_ffi_callback_encode_result(klisp_State *K); 81 void do_ffi_callback_return(klisp_State *K); 82 83 static TValue ffi_decode_void(ffi_codec_t *self, klisp_State *K, const void *buf) 84 { 85 UNUSED(self); 86 UNUSED(K); 87 UNUSED(buf); 88 return KINERT; 89 } 90 91 static void ffi_encode_void(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 92 { 93 /* useful only with callbacks */ 94 UNUSED(self); 95 UNUSED(K); 96 UNUSED(buf); 97 if (!ttisinert(v)) 98 klispE_throw_simple_with_irritants(K, "only inert can be cast to C void", 1, v); 99 } 100 101 static TValue ffi_decode_sint(ffi_codec_t *self, klisp_State *K, const void *buf) 102 { 103 UNUSED(self); 104 UNUSED(K); 105 return i2tv(* (int *) buf); 106 } 107 108 static void ffi_encode_sint(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 109 { 110 if (!ttisfixint(v)) { 111 klispE_throw_simple_with_irritants(K, "unable to convert to C int", 1, v); 112 return; 113 } 114 /* TODO: bigint, ... */ 115 * (int *) buf = ivalue(v); 116 } 117 118 static TValue ffi_decode_pointer(ffi_codec_t *self, klisp_State *K, const void *buf) 119 { 120 UNUSED(self); 121 void *p = *(void **)buf; 122 return (p) ? p2tv(p) : KNIL; 123 } 124 125 static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 126 { 127 if (ttisbytevector(v)) { 128 *(void **)buf = tv2bytevector(v)->b; 129 } else if (ttisstring(v)) { 130 *(void **)buf = kstring_buf(v); 131 } else if (ttisnil(v)) { 132 *(void **)buf = NULL; 133 } else if (tbasetype_(v) == K_TAG_USER) { 134 /* TODO: do not use internal macro tbasetype_ */ 135 *(void **)buf = pvalue(v); 136 } else { 137 klispE_throw_simple_with_irritants(K, "neither bytevector, string, pointer or nil", 1, v); 138 } 139 } 140 141 static TValue ffi_decode_string(ffi_codec_t *self, klisp_State *K, const void *buf) 142 { 143 UNUSED(self); 144 char *s = *(char **) buf; 145 return (s) ? kstring_new_b_imm(K, s) : KNIL; 146 } 147 148 static void ffi_encode_string(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 149 { 150 if (ttisstring(v)) { 151 *(void **)buf = kstring_buf(v); 152 } else { 153 klispE_throw_simple_with_irritants(K, "not a string", 1, v); 154 } 155 } 156 157 static TValue ffi_decode_uint8(ffi_codec_t *self, klisp_State *K, const void *buf) 158 { 159 UNUSED(self); 160 UNUSED(K); 161 return i2tv(*(uint8_t *)buf); 162 } 163 164 static void ffi_encode_uint8(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 165 { 166 UNUSED(self); 167 if (ttisfixint(v) && 0 <= ivalue(v) && ivalue(v) <= UINT8_MAX) { 168 *(uint8_t *) buf = ivalue(v); 169 } else { 170 klispE_throw_simple_with_irritants(K, "unable to convert to C uint8_t", 1, v); 171 return; 172 } 173 } 174 175 static TValue ffi_decode_sint8(ffi_codec_t *self, klisp_State *K, const void *buf) 176 { 177 UNUSED(self); 178 UNUSED(K); 179 return i2tv(*(int8_t *)buf); 180 } 181 182 static void ffi_encode_sint8(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 183 { 184 UNUSED(self); 185 if (ttisfixint(v) && INT8_MIN <= ivalue(v) && ivalue(v) <= INT8_MAX) { 186 *(int8_t *) buf = ivalue(v); 187 } else { 188 klispE_throw_simple_with_irritants(K, "unable to convert to C int8_t", 1, v); 189 return; 190 } 191 } 192 193 static TValue ffi_decode_uint16(ffi_codec_t *self, klisp_State *K, const void *buf) 194 { 195 UNUSED(self); 196 return i2tv(*(uint16_t *)buf); 197 } 198 199 static void ffi_encode_uint16(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 200 { 201 UNUSED(self); 202 if (ttisfixint(v) && 0 <= ivalue(v) && ivalue(v) <= UINT16_MAX) { 203 *(uint16_t *) buf = ivalue(v); 204 } else { 205 klispE_throw_simple_with_irritants(K, "unable to convert to C uint16_t", 1, v); 206 return; 207 } 208 } 209 210 static TValue ffi_decode_sint16(ffi_codec_t *self, klisp_State *K, const void *buf) 211 { 212 UNUSED(self); 213 return i2tv(*(int16_t *)buf); 214 } 215 216 static void ffi_encode_sint16(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 217 { 218 UNUSED(self); 219 if (ttisfixint(v) && INT16_MIN <= ivalue(v) && ivalue(v) <= INT16_MAX) { 220 *(int16_t *) buf = ivalue(v); 221 } else { 222 klispE_throw_simple_with_irritants(K, "unable to convert to C int16_t", 1, v); 223 return; 224 } 225 } 226 227 static TValue ffi_decode_uint32(ffi_codec_t *self, klisp_State *K, const void *buf) 228 { 229 UNUSED(self); 230 uint32_t x = *(uint32_t *)buf; 231 if (x <= INT32_MAX) { 232 return i2tv((int32_t) x); 233 } else { 234 TValue res = kbigint_make_simple(K); 235 krooted_tvs_push(K, res); 236 237 uint8_t d[4]; 238 for (int i = 3; i >= 0; i--) { 239 d[i] = (x & 0xFF); 240 x >>= 8; 241 } 242 mp_int_read_unsigned(K, tv2bigint(res), d, 4); 243 244 krooted_tvs_pop(K); 245 return res; 246 } 247 } 248 249 static void ffi_encode_uint32(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 250 { 251 UNUSED(self); 252 uint32_t tmp; 253 254 if (ttisfixint(v) && 0 <= ivalue(v)) { 255 *(uint32_t *) buf = ivalue(v); 256 } else if (ttisbigint(v) && mp_int_to_uint(tv2bigint(v), &tmp) == MP_OK) { 257 *(uint32_t *) buf = tmp; 258 } else { 259 klispE_throw_simple_with_irritants(K, "unable to convert to C uint32_t", 1, v); 260 return; 261 } 262 } 263 264 static TValue ffi_decode_sint32(ffi_codec_t *self, klisp_State *K, const void *buf) 265 { 266 UNUSED(self); 267 return i2tv(*(int32_t *)buf); 268 } 269 270 static void ffi_encode_sint32(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 271 { 272 UNUSED(self); 273 if (ttisfixint(v)) { 274 *(int32_t *) buf = ivalue(v); 275 } else { 276 klispE_throw_simple_with_irritants(K, "unable to convert to C int32_t", 1, v); 277 return; 278 } 279 } 280 281 static TValue ffi_decode_uint64(ffi_codec_t *self, klisp_State *K, const void *buf) 282 { 283 UNUSED(self); 284 return kinteger_new_uint64(K, *(uint64_t *)buf); 285 } 286 287 static void ffi_encode_uint64(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 288 { 289 /* TODO */ 290 UNUSED(self); 291 292 if (ttisfixint(v) && 0 <= ivalue(v)) { 293 *(uint64_t *) buf = ivalue(v); 294 } else if (ttisbigint(v) 295 && mp_int_compare_zero(tv2bigint(v)) >= 0 296 && mp_int_unsigned_len(tv2bigint(v)) <= 8) { 297 uint8_t d[8]; 298 299 mp_int_to_unsigned(K, tv2bigint(v), d, 8); 300 uint64_t tmp = d[0]; 301 for (int i = 1; i < 8; i++) 302 tmp = (tmp << 8) | d[i]; 303 *(uint64_t *) buf = tmp; 304 } else { 305 klispE_throw_simple_with_irritants(K, "unable to convert to C uint64_t", 1, v); 306 return; 307 } 308 } 309 310 static TValue ffi_decode_double(ffi_codec_t *self, klisp_State *K, const void *buf) 311 { 312 UNUSED(self); 313 return d2tv(*(double *)buf); 314 } 315 316 static void ffi_encode_double(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 317 { 318 UNUSED(self); 319 if (ttisdouble(v)) { 320 *(double *) buf = dvalue(v); 321 } else { 322 klispE_throw_simple_with_irritants(K, "unable to cast to C double", 1, v); 323 return; 324 } 325 } 326 327 static TValue ffi_decode_float(ffi_codec_t *self, klisp_State *K, const void *buf) 328 { 329 UNUSED(self); 330 return d2tv((double) *(float *)buf); 331 } 332 333 static void ffi_encode_float(ffi_codec_t *self, klisp_State *K, TValue v, void *buf) 334 { 335 UNUSED(self); 336 if (ttisdouble(v)) { 337 /* TODO: avoid double rounding for rationals/bigints ?*/ 338 *(float *) buf = dvalue(v); 339 } else { 340 klispE_throw_simple_with_irritants(K, "unable to cast to C float", 1, v); 341 return; 342 } 343 } 344 345 static ffi_codec_t ffi_codecs[] = { 346 { "string", &ffi_type_pointer, ffi_decode_string, ffi_encode_string }, 347 #define SIMPLE_TYPE(t) { #t, &ffi_type_ ## t, ffi_decode_ ## t, ffi_encode_ ## t } 348 SIMPLE_TYPE(void), 349 SIMPLE_TYPE(sint), 350 SIMPLE_TYPE(pointer), 351 SIMPLE_TYPE(uint8), 352 SIMPLE_TYPE(sint8), 353 SIMPLE_TYPE(uint16), 354 SIMPLE_TYPE(sint16), 355 SIMPLE_TYPE(uint32), 356 SIMPLE_TYPE(sint32), 357 SIMPLE_TYPE(uint64), 358 SIMPLE_TYPE(float), 359 SIMPLE_TYPE(double) 360 #undef SIMPLE_TYPE 361 }; 362 363 #ifdef KGFFI_WIN32 364 static TValue ffi_win32_error_message(klisp_State *K, DWORD dwMessageId) 365 { 366 LPTSTR s; 367 if (0 == FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, 368 NULL, 369 dwMessageId, 370 MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), 371 (LPTSTR)&s, 0, NULL)) { 372 return kstring_new_b_imm(K, "Unknown error"); 373 } else { 374 TValue v = kstring_new_b_imm(K, s); 375 LocalFree(s); 376 return v; 377 } 378 } 379 #endif 380 381 void ffi_load_library(klisp_State *K) 382 { 383 TValue *xparams = K->next_xparams; 384 TValue ptree = K->next_value; 385 TValue denv = K->next_env; 386 klisp_assert(ttisenvironment(K->next_env)); 387 UNUSED(denv); 388 /* 389 ** xparams[0]: encapsulation key denoting loaded library 390 */ 391 392 TValue filename = ptree; 393 const char *filename_c = 394 get_opt_tpar(K, filename, "string", ttisstring) 395 ? kstring_buf(filename) : NULL; 396 397 #if KGFFI_DLFCN 398 void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL); 399 if (handle == NULL) { 400 krooted_tvs_push(K, filename); 401 const char *err_c = dlerror(); 402 TValue err = (err_c == NULL) ? KNIL : kstring_new_b_imm(K, err_c); 403 klispE_throw_simple_with_irritants(K, "couldn't load dynamic library", 404 2, filename, err); 405 return; 406 } 407 #elif KGFFI_WIN32 408 /* TODO: unicode and wide character issues ??? */ 409 HMODULE handle = LoadLibrary(filename_c); 410 if (handle == NULL) { 411 krooted_tvs_push(K, filename); 412 TValue err = ffi_win32_error_message(K, GetLastError()); 413 klispE_throw_simple_with_irritants(K, "couldn't load dynamic library", 414 2, filename, err); 415 return; 416 } 417 #else 418 # error 419 #endif 420 TValue key = xparams[0]; 421 krooted_tvs_push(K, key); 422 423 TValue safe_filename = (filename_c) ? filename : kstring_new_b_imm(K, "interpreter binary or statically linked library"); 424 krooted_tvs_push(K, safe_filename); 425 426 TValue lib_tv = kcons(K, p2tv(handle), safe_filename); 427 krooted_tvs_push(K, lib_tv); 428 429 TValue enc = kmake_encapsulation(K, key, lib_tv); 430 krooted_tvs_pop(K); 431 krooted_tvs_pop(K); 432 krooted_tvs_pop(K); 433 kapply_cc(K, enc); 434 } 435 436 static ffi_abi tv2ffi_abi(klisp_State *K, TValue v) 437 { 438 if (!strcmp("FFI_DEFAULT_ABI", kstring_buf(v))) { 439 return FFI_DEFAULT_ABI; 440 } else if (!strcmp("FFI_SYSV", kstring_buf(v))) { 441 return FFI_SYSV; 442 #if KGFFI_WIN32 443 } else if (!strcmp("FFI_STDCALL", kstring_buf(v))) { 444 return FFI_STDCALL; 445 #endif 446 } else { 447 klispE_throw_simple_with_irritants(K, "unsupported FFI ABI", 1, v); 448 return 0; 449 } 450 } 451 452 static ffi_codec_t *tv2ffi_codec(klisp_State *K, TValue v) 453 { 454 for (size_t i = 0; i < sizeof(ffi_codecs)/sizeof(ffi_codecs[0]); i++) { 455 if (!strcmp(ffi_codecs[i].name, kstring_buf(v))) 456 return &ffi_codecs[i]; 457 } 458 klispE_throw_simple_with_irritants(K, "unsupported FFI type", 1, v); 459 return NULL; 460 } 461 462 static inline size_t align(size_t offset, size_t alignment) 463 { 464 assert(alignment > 0); 465 return offset + (alignment - offset % alignment) % alignment; 466 } 467 468 void ffi_make_call_interface(klisp_State *K) 469 { 470 TValue *xparams = K->next_xparams; 471 TValue ptree = K->next_value; 472 TValue denv = K->next_env; 473 klisp_assert(ttisenvironment(K->next_env)); 474 UNUSED(denv); 475 /* 476 ** xparams[0]: encapsulation key denoting call interface 477 */ 478 479 #define ttislist(v) (ttispair(v) || ttisnil(v)) 480 bind_3tp(K, ptree, 481 "abi string", ttisstring, abi_tv, 482 "rtype string", ttisstring, rtype_tv, 483 "argtypes string list", ttislist, argtypes_tv); 484 #undef ttislist 485 486 size_t nargs; 487 check_typed_list(K, kstringp, false, argtypes_tv, (int32_t *) &nargs, 488 NULL); 489 490 /* Allocate C structure ffi_call_interface_t inside 491 a mutable bytevector. The structure contains C pointers 492 into itself. It must never be reallocated or copied. 493 The bytevector will be encapsulated later to protect 494 it from lisp code. */ 495 496 size_t bytevector_size = sizeof(ffi_call_interface_t) + (sizeof(ffi_codec_t *) + sizeof(ffi_type)) * nargs; 497 TValue bytevector = kbytevector_new_sf(K, bytevector_size, 0); 498 krooted_tvs_push(K, bytevector); 499 500 ffi_call_interface_t *p = (ffi_call_interface_t *) tv2bytevector(bytevector)->b; 501 p->acodecs = (ffi_codec_t **) ((char *) p + sizeof(ffi_call_interface_t)); 502 p->argtypes = (ffi_type **) ((char *) p + sizeof(ffi_call_interface_t) + nargs * sizeof(ffi_codec_t *)); 503 p->nargs = nargs; 504 p->rcodec = tv2ffi_codec(K, rtype_tv); 505 if (p->rcodec->decode == NULL) { 506 klispE_throw_simple_with_irritants(K, "this type is not allowed as a return type", 1, rtype_tv); 507 return; 508 } 509 510 p->buffer_size = p->rcodec->libffi_type->size; 511 TValue tail = argtypes_tv; 512 for (int i = 0; i < nargs; i++) { 513 p->acodecs[i] = tv2ffi_codec(K, kcar(tail)); 514 if (p->acodecs[i]->encode == NULL) { 515 klispE_throw_simple_with_irritants(K, "this type is not allowed in argument list", 1, kcar(tail)); 516 return; 517 } 518 ffi_type *t = p->acodecs[i]->libffi_type; 519 p->argtypes[i] = t; 520 p->buffer_size = align(p->buffer_size, t->alignment) + t->size; 521 tail = kcdr(tail); 522 } 523 ffi_abi abi = tv2ffi_abi(K, abi_tv); 524 525 ffi_status status = ffi_prep_cif(&p->cif, abi, nargs, p->rcodec->libffi_type, p->argtypes); 526 switch (status) { 527 case FFI_OK: 528 break; 529 case FFI_BAD_ABI: 530 klispE_throw_simple(K, "FFI_BAD_ABI"); 531 return; 532 case FFI_BAD_TYPEDEF: 533 klispE_throw_simple(K, "FFI_BAD_TYPEDEF"); 534 return; 535 default: 536 klispE_throw_simple(K, "unknown error in ffi_prep_cif"); 537 return; 538 } 539 540 TValue key = xparams[0]; 541 TValue enc = kmake_encapsulation(K, key, bytevector); 542 krooted_tvs_pop(K); 543 kapply_cc(K, enc); 544 } 545 546 void do_ffi_call(klisp_State *K) 547 { 548 TValue *xparams = K->next_xparams; 549 TValue ptree = K->next_value; 550 TValue denv = K->next_env; 551 klisp_assert(ttisenvironment(K->next_env)); 552 UNUSED(denv); 553 /* 554 ** xparams[0]: function pointer 555 ** xparams[1]: call interface (encapsulated bytevector) 556 */ 557 558 void *funptr = pvalue(xparams[0]); 559 ffi_call_interface_t *p = (ffi_call_interface_t *) tv2bytevector(kget_enc_val(xparams[1]))->b; 560 561 562 int64_t buffer[(p->buffer_size + sizeof(int64_t) - 1) / sizeof(int64_t)]; 563 void *aptrs[p->nargs]; 564 565 size_t offset = 0; 566 void *rptr = (unsigned char *) buffer + offset; 567 offset += p->rcodec->libffi_type->size; 568 569 TValue tail = ptree; 570 for (int i = 0; i < p->nargs; i++) { 571 if (!ttispair(tail)) { 572 klispE_throw_simple(K, "too few arguments"); 573 return; 574 } 575 ffi_type *t = p->acodecs[i]->libffi_type; 576 offset = align(offset, t->alignment); 577 aptrs[i] = (unsigned char *) buffer + offset; 578 p->acodecs[i]->encode(p->acodecs[i], K, kcar(tail), aptrs[i]); 579 offset += t->size; 580 tail = kcdr(tail); 581 } 582 assert(offset == p->buffer_size); 583 if (!ttisnil(tail)) { 584 klispE_throw_simple(K, "too many arguments"); 585 return; 586 } 587 588 ffi_call(&p->cif, funptr, rptr, aptrs); 589 590 TValue result = p->rcodec->decode(p->rcodec, K, rptr); 591 kapply_cc(K, result); 592 } 593 594 void ffi_make_applicative(klisp_State *K) 595 { 596 TValue *xparams = K->next_xparams; 597 TValue ptree = K->next_value; 598 TValue denv = K->next_env; 599 klisp_assert(ttisenvironment(K->next_env)); 600 UNUSED(denv); 601 /* 602 ** xparams[0]: encapsulation key denoting dynamically loaded library 603 ** xparams[1]: encapsulation key denoting call interface 604 */ 605 606 bind_3tp(K, ptree, 607 "dynamic library", ttisencapsulation, lib_tv, 608 "function name string", ttisstring, name_tv, 609 "call interface", ttisencapsulation, cif_tv); 610 if (!kis_encapsulation_type(lib_tv, xparams[0])) { 611 klispE_throw_simple(K, "first argument shall be dynamic library"); 612 return; 613 } 614 if (!kis_encapsulation_type(cif_tv, xparams[1])) { 615 klispE_throw_simple(K, "third argument shall be call interface"); 616 return; 617 } 618 619 TValue lib_name = kcdr(kget_enc_val(lib_tv)); 620 assert(ttisstring(lib_name)); 621 622 #if KGFFI_DLFCN 623 void *handle = pvalue(kcar(kget_enc_val(lib_tv))); 624 (void) dlerror(); 625 void *funptr = dlsym(handle, kstring_buf(name_tv)); 626 const char *err_c = dlerror(); 627 if (err_c) { 628 krooted_tvs_push(K, name_tv); 629 krooted_tvs_push(K, lib_name); 630 TValue err = kstring_new_b_imm(K, err_c); 631 klispE_throw_simple_with_irritants(K, "couldn't find symbol", 632 3, lib_name, name_tv, err); 633 return; 634 } 635 if (!funptr) { 636 klispE_throw_simple_with_irritants(K, "symbol is NULL", 2, 637 lib_name, name_tv); 638 } 639 #elif KGFFI_WIN32 640 HMODULE handle = pvalue(kcar(kget_enc_val(lib_tv))); 641 void *funptr = GetProcAddress(handle, kstring_buf(name_tv)); 642 if (NULL == funptr) { 643 TValue err = ffi_win32_error_message(K, GetLastError()); 644 klispE_throw_simple_with_irritants(K, "couldn't find symbol", 645 3, lib_name, name_tv, err); 646 return; 647 } 648 #else 649 # error 650 #endif 651 652 TValue app = kmake_applicative(K, do_ffi_call, 2, p2tv(funptr), cif_tv); 653 654 #if KTRACK_SI 655 krooted_tvs_push(K, app); 656 krooted_tvs_push(K, lib_name); 657 TValue tail = kcons(K, i2tv((int) funptr), i2tv(0)); 658 krooted_tvs_push(K, tail); 659 TValue si = kcons(K, lib_name, tail); 660 krooted_tvs_push(K, si); 661 kset_source_info(K, kunwrap(app), si); 662 krooted_tvs_pop(K); 663 krooted_tvs_pop(K); 664 krooted_tvs_pop(K); 665 krooted_tvs_pop(K); 666 #endif 667 668 kapply_cc(K, app); 669 } 670 671 static void ffi_callback_push(ffi_callback_t *cb, TValue v) 672 { 673 /* assume v is rooted */ 674 TValue *s = klispH_setfixint(cb->K, cb->table, CB_INDEX_STACK); 675 *s = kimm_cons(cb->K, v, *s); 676 } 677 678 static TValue ffi_callback_pop(ffi_callback_t *cb) 679 { 680 TValue *s = klispH_setfixint(cb->K, cb->table, CB_INDEX_STACK); 681 TValue v = kcar(*s); 682 krooted_tvs_push(cb->K, v); 683 *s = kcdr(*s); 684 krooted_tvs_pop(cb->K); 685 return v; 686 } 687 688 static TValue ffi_callback_guard(ffi_callback_t *cb, klisp_CFunction fn) 689 { 690 TValue app = kmake_applicative(cb->K, fn, 1, p2tv(cb)); 691 krooted_tvs_push(cb->K, app); 692 TValue ls1 = kimm_list(cb->K, 2, G(cb->K)->root_cont, app); 693 krooted_tvs_push(cb->K, ls1); 694 TValue ls2 = kimm_list(cb->K, 1, ls1); 695 krooted_tvs_pop(cb->K); 696 krooted_tvs_pop(cb->K); 697 return ls2; 698 } 699 700 void do_ffi_callback_encode_result(klisp_State *K) 701 { 702 TValue *xparams = K->next_xparams; 703 TValue obj = K->next_value; 704 klisp_assert(ttisnil(K->next_env)); 705 /* 706 ** xparams[0]: cif 707 ** xparams[1]: p2tv(libffi return buffer) 708 */ 709 ffi_call_interface_t *p = (ffi_call_interface_t *) kbytevector_buf(kget_enc_val(xparams[0])); 710 void *ret = pvalue(xparams[1]); 711 p->rcodec->encode(p->rcodec, K, obj, ret); 712 kapply_cc(K, KINERT); 713 } 714 715 void do_ffi_callback_decode_arguments(klisp_State *K) 716 { 717 TValue *xparams = K->next_xparams; 718 TValue ptree = K->next_value; 719 TValue denv = K->next_env; 720 klisp_assert(ttisenvironment(K->next_env)); 721 /* 722 ** xparams[0]: p2tv(ffi_callback_t) 723 ** xparams[1]: p2tv(libffi return buffer) 724 ** xparams[2]: p2tv(libffi argument array) 725 */ 726 727 ffi_callback_t *cb = pvalue(xparams[0]); 728 void *ret = pvalue(xparams[1]); 729 void **args = pvalue(xparams[2]); 730 731 /* get the lisp applicative and the call interface 732 * from the auxilliary table. */ 733 734 const TValue *slot = klispH_setfixint(K, cb->table, cb->index); 735 TValue app_tv = kcar(*slot); 736 TValue cif_tv = kcdr(*slot); 737 assert(ttisapplicative(app_tv)); 738 assert(ttisencapsulation(cif_tv)); 739 krooted_tvs_push(K, app_tv); 740 krooted_tvs_push(K, cif_tv); 741 ffi_call_interface_t *p = (ffi_call_interface_t *) kbytevector_buf(kget_enc_val(cif_tv)); 742 743 /* Decode arguments. */ 744 745 TValue tail = KNIL; 746 for (int i = p->nargs - 1; i >= 0; i--) { 747 krooted_tvs_push(K, ptree); 748 TValue arg = p->acodecs[i]->decode(p->acodecs[i], K, args[i]); 749 krooted_tvs_pop(K); 750 tail = kimm_cons(K, arg, tail); 751 } 752 krooted_tvs_push(K, tail); 753 754 /* Setup continuation for encoding return value. */ 755 756 TValue encoding_cont = kmake_continuation(K, kget_cc(K), do_ffi_callback_encode_result, 2, cif_tv, p2tv(ret)); 757 kset_cc(K, encoding_cont); 758 759 /* apply the callback applicative */ 760 761 krooted_tvs_pop(K); 762 krooted_tvs_pop(K); 763 krooted_tvs_pop(K); 764 765 while(ttisapplicative(app_tv)) 766 app_tv = tv2app(app_tv)->underlying; 767 ktail_call(K, app_tv, tail, denv); 768 } 769 770 void do_ffi_callback_return(klisp_State *K) 771 { 772 TValue *xparams = K->next_xparams; 773 TValue obj = K->next_value; 774 klisp_assert(ttisnil(K->next_env)); 775 UNUSED(obj); 776 /* 777 ** xparams[0]: p2tv(ffi_callback_t) 778 ** 779 ** Signal normal return and force the "inner" trampoline 780 ** loop to exit. 781 */ 782 ffi_callback_t *cb = pvalue(xparams[0]); 783 ffi_callback_push(cb, i2tv(1)); 784 K->next_func = NULL; 785 } 786 787 void do_ffi_callback_entry_guard(klisp_State *K) 788 { 789 TValue *xparams = K->next_xparams; 790 TValue ptree = K->next_value; 791 TValue denv = K->next_env; 792 klisp_assert(ttisenvironment(K->next_env)); 793 UNUSED(xparams); 794 UNUSED(ptree); 795 UNUSED(denv); 796 /* The entry guard is invoked only if the user captured 797 * the continuation under foreign callback and applied 798 * it later after the foreign callback terminated. 799 * 800 * The auxilliary stack (stored in the callback hash table) 801 * now does not correspond to the actual state of callback 802 * nesting. 803 */ 804 klispE_throw_simple(K, "tried to re-enter continuation under FFI callback"); 805 } 806 807 void do_ffi_callback_exit_guard(klisp_State *K) 808 { 809 TValue *xparams = K->next_xparams; 810 TValue ptree = K->next_value; 811 TValue denv = K->next_env; 812 klisp_assert(ttisenvironment(K->next_env)); 813 UNUSED(ptree); 814 UNUSED(denv); 815 /* 816 ** xparams[0]: p2tv(ffi_callback_t) 817 ** 818 ** Signal abnormal return and force the "inner" trampoline 819 ** loop to exit to ffi_callback_entry(). The parameter tree 820 ** will be processed there. 821 */ 822 ffi_callback_t *cb = pvalue(xparams[0]); 823 ffi_callback_push(cb, i2tv(0)); 824 K->next_func = NULL; 825 } 826 827 static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_data) 828 { 829 ffi_callback_t *cb = (ffi_callback_t *) user_data; 830 klisp_State *K = cb->K; 831 832 /* save state of the interpreter */ 833 834 volatile jmp_buf saved_error_jb; 835 memcpy(&saved_error_jb, &K->error_jb, sizeof(K->error_jb)); 836 ffi_callback_push(cb, K->curr_cont); 837 838 /* Set up continuation for normal return path. */ 839 840 TValue return_cont = kmake_continuation(K, K->curr_cont, do_ffi_callback_return, 1, p2tv(cb)); 841 krooted_tvs_push(K, return_cont); 842 kset_cc(K, return_cont); 843 844 /* Do not decode arguments yet. The decoding may fail 845 * and raise errors. Let klisp core handle all errors 846 * inside guarded continuation. */ 847 848 TValue app = kmake_applicative(K, do_ffi_callback_decode_arguments, 3, p2tv(cb), p2tv(ret), p2tv(args)); 849 krooted_tvs_push(K, app); 850 851 TValue entry_guard = ffi_callback_guard(cb, do_ffi_callback_entry_guard); 852 krooted_tvs_push(K, entry_guard); 853 TValue exit_guard = ffi_callback_guard(cb, do_ffi_callback_exit_guard); 854 krooted_tvs_push(K, exit_guard); 855 856 /* Construct fresh dynamic environment for the callback applicative. */ 857 TValue denv = kmake_empty_environment(K); 858 krooted_tvs_push(K, denv); 859 860 TValue ptree = kimm_list(K, 3, entry_guard, app, exit_guard); 861 krooted_tvs_pop(K); 862 krooted_tvs_pop(K); 863 krooted_tvs_pop(K); 864 krooted_tvs_pop(K); 865 krooted_tvs_pop(K); 866 867 K->next_xparams = NULL; 868 K->next_value = ptree; 869 K->next_env = denv; 870 871 guard_dynamic_extent(K); 872 873 /* Enter new "inner" trampoline loop. */ 874 875 klispT_run(K); 876 877 /* restore longjump buffer of the outer trampoline loop */ 878 879 memcpy(&K->error_jb, &saved_error_jb, sizeof(K->error_jb)); 880 881 /* Now, the "inner" trampoline loop exited. The exit 882 was forced by return_cont or exit_guard. */ 883 884 if (ivalue(ffi_callback_pop(cb))) { 885 /* Normal return - reinstall old continuation. It will be 886 * used after the foreign call which originally called 887 * this callback eventually returns. */ 888 kset_cc(K, ffi_callback_pop(cb)); 889 } else { 890 /* Abnormal return - throw away the old continuation 891 ** and longjump back in the "outer" trampoline loop. 892 ** Longjump unwinds the stack space used by the foreign 893 ** call which originally called this callback. After 894 ** that the interpreter state will look like normal 895 ** normal return from the exit guard. 896 */ 897 (void) ffi_callback_pop(cb); 898 klispT_apply_cc(K, kcar(K->next_value)); 899 longjmp(K->error_jb, 1); 900 } 901 } 902 903 904 void ffi_make_callback(klisp_State *K) 905 { 906 TValue *xparams = K->next_xparams; 907 TValue ptree = K->next_value; 908 TValue denv = K->next_env; 909 klisp_assert(ttisenvironment(K->next_env)); 910 UNUSED(denv); 911 /* 912 ** xparams[0]: encapsulation key denoting call interface 913 ** xparams[1]: callback data table 914 */ 915 916 bind_2tp(K, ptree, 917 "applicative", ttisapplicative, app_tv, 918 "call interface", ttisencapsulation, cif_tv); 919 if (!kis_encapsulation_type(cif_tv, xparams[0])) { 920 klispE_throw_simple(K, "second argument shall be call interface"); 921 return; 922 } 923 ffi_call_interface_t *p = (ffi_call_interface_t *) kbytevector_buf(kget_enc_val(cif_tv)); 924 TValue cb_tab = xparams[1]; 925 926 /* Allocate memory for libffi closure. */ 927 928 void *code; 929 ffi_callback_t *cb = ffi_closure_alloc(sizeof(ffi_callback_t), &code); 930 931 /* Get the index of this callback in the callback table. */ 932 933 TValue *n_tv = klispH_setfixint(K, tv2table(cb_tab), 0); 934 assert(n_tv != &kfree); 935 int32_t new_index = ivalue(*n_tv); 936 *n_tv = i2tv(new_index + 1); 937 938 /* Prepare the C part of callback data */ 939 940 cb->K = K; 941 cb->table = tv2table(xparams[1]); 942 cb->index = new_index; 943 944 /* TODO: The closure leaks. Should be finalized. */ 945 946 /* Prepare the lisp part of callback data */ 947 948 krooted_tvs_push(K, cb_tab); 949 krooted_tvs_push(K, app_tv); 950 krooted_tvs_push(K, cif_tv); 951 952 TValue item_tv = kimm_cons(K, app_tv, cif_tv); 953 krooted_tvs_push(K, item_tv); 954 955 TValue *slot = klispH_setfixint(K, tv2table(cb_tab), new_index); 956 *slot = item_tv; 957 958 krooted_tvs_pop(K); 959 krooted_tvs_pop(K); 960 krooted_tvs_pop(K); 961 krooted_tvs_pop(K); 962 963 /* Initialize callback. */ 964 965 ffi_status status = ffi_prep_closure_loc(&cb->libffi_closure, &p->cif, ffi_callback_entry, cb, code); 966 if (status != FFI_OK) { 967 ffi_closure_free(cb); 968 klispE_throw_simple(K, "unknown error in ffi_prep_closure_loc"); 969 return; 970 } 971 972 /* return the libffi closure entry point */ 973 974 TValue funptr_tv = p2tv(code); 975 kapply_cc(K, funptr_tv); 976 } 977 978 static uint8_t * ffi_memory_location(klisp_State *K, bool allow_nesting, 979 TValue v, bool mutable, size_t size) 980 { 981 if (ttisbytevector(v)) { 982 if (mutable && kbytevector_immutablep(v)) { 983 klispE_throw_simple_with_irritants(K, "bytevector not mutable", 1, v); 984 return NULL; 985 } else if (size > kbytevector_size(v)) { 986 klispE_throw_simple_with_irritants(K, "bytevector too small", 1, v); 987 return NULL; 988 } else { 989 return kbytevector_buf(v); 990 } 991 } else if (ttisstring(v)) { 992 if (mutable && kstring_immutablep(v)) { 993 klispE_throw_simple_with_irritants(K, "string not mutable", 1, v); 994 return NULL; 995 } else if (size > kstring_size(v)) { 996 klispE_throw_simple_with_irritants(K, "string too small", 1, v); 997 return NULL; 998 } else { 999 return (uint8_t *) kstring_buf(v); 1000 } 1001 } else if (tbasetype_(v) == K_TAG_USER) { 1002 /* TODO: do not use internal macro tbasetype_ */ 1003 return (pvalue(v)); 1004 } else if (ttispair(v) && ttispair(kcdr(v)) && ttisnil(kcddr(v))) { 1005 if (!allow_nesting) { 1006 klispE_throw_simple_with_irritants(K, "offset specifications cannot be nested", 1, v); 1007 return NULL; 1008 } 1009 TValue base_tv = kcar(v); 1010 TValue offset_tv = kcadr(v); 1011 if (!ttisfixint(offset_tv) || ivalue(offset_tv) < 0) { 1012 klispE_throw_simple_with_irritants(K, "offset should be nonnegative fixint", 1, v); 1013 return NULL; 1014 } else { 1015 size_t offset = ivalue(offset_tv); 1016 uint8_t * p = ffi_memory_location(K, false, base_tv, mutable, size + offset); 1017 return (p + offset); 1018 } 1019 } else { 1020 klispE_throw_simple_with_irritants(K, "not a memory location", 1, v); 1021 return NULL; 1022 } 1023 } 1024 1025 void ffi_memmove(klisp_State *K) 1026 { 1027 TValue *xparams = K->next_xparams; 1028 TValue ptree = K->next_value; 1029 TValue denv = K->next_env; 1030 klisp_assert(ttisenvironment(K->next_env)); 1031 UNUSED(xparams); 1032 UNUSED(denv); 1033 1034 bind_3tp(K, ptree, 1035 "any", anytype, dst_tv, 1036 "any", anytype, src_tv, 1037 "integer", ttisfixint, sz_tv); 1038 1039 if (ivalue(sz_tv) < 0) 1040 klispE_throw_simple(K, "size should be nonnegative fixint"); 1041 1042 size_t sz = (size_t) ivalue(sz_tv); 1043 uint8_t * dst = ffi_memory_location(K, true, dst_tv, true, sz); 1044 const uint8_t * src = ffi_memory_location(K, true, src_tv, false, sz); 1045 memmove(dst, src, sz); 1046 1047 kapply_cc(K, KINERT); 1048 } 1049 1050 static void ffi_type_ref(klisp_State *K) 1051 { 1052 TValue *xparams = K->next_xparams; 1053 TValue ptree = K->next_value; 1054 TValue denv = K->next_env; 1055 klisp_assert(ttisenvironment(K->next_env)); 1056 UNUSED(denv); 1057 1058 /* 1059 ** xparams[0]: pointer to ffi_codec_t 1060 */ 1061 1062 bind_1tp(K, ptree, "any", anytype, location_tv); 1063 ffi_codec_t *codec = pvalue(xparams[0]); 1064 const uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size); 1065 #if KGFFI_CHECK_ALIGNMENT 1066 if ((size_t) ptr % codec->libffi_type->alignment != 0) 1067 klispE_throw_simple(K, "unaligned memory read through FFI"); 1068 #endif 1069 1070 TValue result = codec->decode(codec, K, ptr); 1071 kapply_cc(K, result); 1072 } 1073 1074 static void ffi_type_set(klisp_State *K) 1075 { 1076 TValue *xparams = K->next_xparams; 1077 TValue ptree = K->next_value; 1078 TValue denv = K->next_env; 1079 klisp_assert(ttisenvironment(K->next_env)); 1080 UNUSED(denv); 1081 1082 /* 1083 ** xparams[0]: pointer to ffi_codec_t 1084 */ 1085 1086 bind_2tp(K, ptree, 1087 "any", anytype, location_tv, 1088 "any", anytype, value_tv); 1089 ffi_codec_t *codec = pvalue(xparams[0]); 1090 uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size); 1091 #if KGFFI_CHECK_ALIGNMENT 1092 if ((size_t) ptr % codec->libffi_type->alignment != 0) 1093 klispE_throw_simple(K, "unaligned memory write through FFI"); 1094 #endif 1095 1096 codec->encode(codec, K, value_tv, ptr); 1097 kapply_cc(K, KINERT); 1098 } 1099 1100 void ffi_type_suite(klisp_State *K) 1101 { 1102 TValue *xparams = K->next_xparams; 1103 TValue ptree = K->next_value; 1104 TValue denv = K->next_env; 1105 klisp_assert(ttisenvironment(K->next_env)); 1106 1107 UNUSED(xparams); 1108 UNUSED(denv); 1109 1110 bind_1tp(K, ptree, "string", ttisstring, type_tv); 1111 ffi_codec_t *codec = tv2ffi_codec(K, type_tv); 1112 1113 TValue size_tv = i2tv(codec->libffi_type->size); 1114 krooted_tvs_push(K, size_tv); 1115 1116 TValue alignment_tv = i2tv(codec->libffi_type->alignment); 1117 krooted_tvs_push(K, alignment_tv); 1118 1119 TValue getter_tv = 1120 (codec->decode) 1121 ? kmake_applicative(K, ffi_type_ref, 1, p2tv(codec)) 1122 : KINERT; 1123 krooted_tvs_push(K, getter_tv); 1124 1125 TValue setter_tv = 1126 (codec->encode) 1127 ? kmake_applicative(K, ffi_type_set, 1, p2tv(codec)) 1128 : KINERT; 1129 krooted_tvs_push(K, setter_tv); 1130 1131 TValue suite_tv = kimm_list(K, 4, size_tv, alignment_tv, getter_tv, setter_tv); 1132 1133 krooted_tvs_pop(K); 1134 krooted_tvs_pop(K); 1135 krooted_tvs_pop(K); 1136 krooted_tvs_pop(K); 1137 1138 kapply_cc(K, suite_tv); 1139 } 1140 1141 void ffi_klisp_state(klisp_State *K) 1142 { 1143 TValue *xparams = K->next_xparams; 1144 TValue ptree = K->next_value; 1145 TValue denv = K->next_env; 1146 klisp_assert(ttisenvironment(K->next_env)); 1147 UNUSED(xparams); 1148 UNUSED(denv); 1149 check_0p(K, ptree); 1150 kapply_cc(K, p2tv(K)); 1151 } 1152 1153 /* init ground */ 1154 void kinit_ffi_ground_env(klisp_State *K) 1155 { 1156 TValue ground_env = G(K)->ground_env; 1157 TValue symbol, value; 1158 1159 /* create encapsulation keys */ 1160 1161 TValue dll_key = kmake_encapsulation_key(K); 1162 TValue cif_key = kmake_encapsulation_key(K); 1163 1164 /* TODO: should be rooted */ 1165 1166 /* create table for callback data */ 1167 TValue cb_tab = klispH_new(K, 0, 64, K_FLAG_WEAK_NOTHING); 1168 1169 TValue *v; 1170 v = klispH_setfixint(K, tv2table(cb_tab), CB_INDEX_N); 1171 *v = i2tv(CB_INDEX_FIRST_CALLBACK); 1172 v = klispH_setfixint(K, tv2table(cb_tab), CB_INDEX_STACK); 1173 *v = KNIL; 1174 1175 add_applicative(K, ground_env, "ffi-load-library", ffi_load_library, 1, dll_key); 1176 add_applicative(K, ground_env, "ffi-make-call-interface", ffi_make_call_interface, 1, cif_key); 1177 add_applicative(K, ground_env, "ffi-make-applicative", ffi_make_applicative, 2, dll_key, cif_key); 1178 add_applicative(K, ground_env, "ffi-make-callback", ffi_make_callback, 2, cif_key, cb_tab); 1179 add_applicative(K, ground_env, "ffi-memmove", ffi_memmove, 0); 1180 add_applicative(K, ground_env, "ffi-type-suite", ffi_type_suite, 0); 1181 add_applicative(K, ground_env, "ffi-klisp-state", ffi_klisp_state, 0); 1182 add_applicative(K, ground_env, "ffi-library?", enc_typep, 1, dll_key); 1183 add_applicative(K, ground_env, "ffi-call-interface?", enc_typep, 1, cif_key); 1184 } 1185 1186 /* XXX lock? */ 1187 /* init continuation names */ 1188 void kinit_ffi_cont_names(klisp_State *K) 1189 { 1190 Table *t = tv2table(G(K)->cont_name_table); 1191 1192 add_cont_name(K, t, do_ffi_callback_encode_result, 1193 "ffi-callback-encode-result"); 1194 add_cont_name(K, t, do_ffi_callback_return, 1195 "ffi-callback-ret"); 1196 }