diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-09-03 15:12:54 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-09-03 15:26:37 +0200 |
commit | 33186356668fe7697a8f2692660aaff69178d720 (patch) | |
tree | ec54e0b939ee5abccd30b9e1a1c76970e921dbf4 /libguile/foreign.c | |
parent | a148c752ba7adf0d2005cc7bc5928a2dde467609 (diff) | |
download | guile-33186356668fe7697a8f2692660aaff69178d720.tar.gz |
Add `procedure->pointer' to the FFI.
* libguile/foreign.c (make_cif): New procedure, with code formerly in
`scm_make_foreign_function'.
(scm_make_foreign_function): Use it.
(invoke_closure, scm_procedure_to_pointer)[FFI_CLOSURES]: New
functions.
* libguile/foreign.h (scm_procedure_to_pointer): New declaration.
* module/system/foreign.scm: Export `procedure->pointer' when available.
* test-suite/standalone/test-ffi (f-callback-1, f-callback-2): New
procedures and related tests.
* test-suite/standalone/test-ffi-lib.c (test_ffi_callback_1,
test_ffi_callback_2): New functions.
* test-suite/tests/foreign.test ("procedure->pointer"): New test prefix.
* doc/ref/api-foreign.texi (Dynamic FFI): Document `procedure->pointer'.
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r-- | libguile/foreign.c | 140 |
1 files changed, 114 insertions, 26 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 33af17285..c36972b54 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -563,19 +563,14 @@ fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs, ftype->elements[i] = NULL; } } - -SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0, - (SCM return_type, SCM func_ptr, SCM arg_types), - "Make a foreign function.\n\n" - "Given the foreign void pointer @var{func_ptr}, its argument and\n" - "return types @var{arg_types} and @var{return_type}, return a\n" - "procedure that will pass arguments to the foreign function\n" - "and return appropriate values.\n\n" - "@var{arg_types} should be a list of foreign types.\n" - "@code{return_type} should be a foreign type.") -#define FUNC_NAME s_scm_make_foreign_function + +/* Return a "cif" (call interface) for the given RETURN_TYPE and + ARG_TYPES. */ +static ffi_cif * +make_cif (SCM return_type, SCM arg_types, const char *caller) +#define FUNC_NAME caller { - SCM walk, scm_cif; + SCM walk; long i, nargs, n_structs, n_struct_elts; size_t cif_len; char *mem; @@ -583,8 +578,6 @@ SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0, ffi_type **type_ptrs; ffi_type *types; - SCM_VALIDATE_POINTER (2, func_ptr); - nargs = scm_ilength (arg_types); SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME); /* fixme: assert nargs < 1<<32 */ @@ -598,32 +591,31 @@ SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0, for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk)) if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts)) scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk)); - + /* the memory: with space for the cif itself */ cif_len = sizeof (ffi_cif); /* then ffi_type pointers: one for each arg, one for each struct element, and one for each struct (for null-termination) */ cif_len = (ROUND_UP (cif_len, alignof(void*)) - + (nargs + n_structs + n_struct_elts)*sizeof(void*)); - + + (nargs + n_structs + n_struct_elts)*sizeof(void*)); + /* then the ffi_type structs themselves, one per arg and struct element, and one for the return val */ cif_len = (ROUND_UP (cif_len, alignof(ffi_type)) - + (nargs + n_struct_elts + 1)*sizeof(ffi_type)); + + (nargs + n_struct_elts + 1)*sizeof(ffi_type)); mem = scm_gc_malloc_pointerless (cif_len, "foreign"); - scm_cif = scm_from_pointer (mem, NULL); cif = (ffi_cif *) mem; /* reuse cif_len to walk through the mem */ cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*)); type_ptrs = (ffi_type**)(mem + cif_len); cif_len = ROUND_UP (cif_len - + (nargs + n_structs + n_struct_elts)*sizeof(void*), - alignof(ffi_type)); + + (nargs + n_structs + n_struct_elts)*sizeof(void*), + alignof(ffi_type)); types = (ffi_type*)(mem + cif_len); - + /* whew. now knit the pointers together. */ cif->rtype = types++; fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types); @@ -640,12 +632,33 @@ SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0, cif->nargs = nargs; cif->bytes = 0; cif->flags = 0; - + if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype, - cif->arg_types)) - scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL); + cif->arg_types)) + SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL); + + return cif; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0, + (SCM return_type, SCM func_ptr, SCM arg_types), + "Make a foreign function.\n\n" + "Given the foreign void pointer @var{func_ptr}, its argument and\n" + "return types @var{arg_types} and @var{return_type}, return a\n" + "procedure that will pass arguments to the foreign function\n" + "and return appropriate values.\n\n" + "@var{arg_types} should be a list of foreign types.\n" + "@code{return_type} should be a foreign type.") +#define FUNC_NAME s_scm_make_foreign_function +{ + ffi_cif *cif; + + SCM_VALIDATE_POINTER (2, func_ptr); - return cif_to_procedure (scm_cif, func_ptr); + cif = make_cif (return_type, arg_types, FUNC_NAME); + + return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr); } #undef FUNC_NAME @@ -932,6 +945,81 @@ scm_i_foreign_call (SCM foreign, const SCM *argv) } +/* Function pointers aka. "callbacks" or "closures". */ + +#ifdef FFI_CLOSURES + +/* Trampoline to invoke a libffi closure that wraps a Scheme + procedure. */ +static void +invoke_closure (ffi_cif *cif, void *ret, void **args, void *data) +{ + size_t i; + SCM proc, *argv, result; + + proc = PTR2SCM (data); + + argv = alloca (cif->nargs * sizeof (*argv)); + + /* Pack ARGS to SCM values, setting ARGV pointers. */ + for (i = 0; i < cif->nargs; i++) + argv[i] = pack (cif->arg_types[i], args[i]); + + result = scm_call_n (proc, argv, cif->nargs); + + unpack (cif->rtype, ret, result); +} + +SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0, + (SCM return_type, SCM proc, SCM arg_types), + "Return a pointer to a C function of type @var{return-type}\n" + "taking arguments of types @var{arg-types} (a list) and\n" + "behaving as a proxy to procedure @var{proc}. Thus\n" + "@var{proc}'s arity, supported argument types, and return\n" + "type should match @var{return-type} and @var{arg-types}.\n") +#define FUNC_NAME s_scm_procedure_to_pointer +{ + SCM pointer; + ffi_cif *cif; + ffi_status err; + void *closure, *executable; + + cif = make_cif (return_type, arg_types, FUNC_NAME); + + closure = ffi_closure_alloc (sizeof (ffi_closure), &executable); + err = ffi_prep_closure_loc ((ffi_closure *) closure, cif, + invoke_closure, SCM2PTR (proc), + executable); + if (err != FFI_OK) + { + ffi_closure_free (closure); + SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL); + } + + if (closure == executable) + pointer = scm_from_pointer (executable, ffi_closure_free); + else + { + /* CLOSURE needs to be freed eventually. However, since + `GC_all_interior_pointers' is disabled, we can't just register + a finalizer for CLOSURE. Instead, we create a pointer object + for CLOSURE, with a finalizer, and register it as a weak + reference of POINTER. */ + SCM friend; + + pointer = scm_from_pointer (executable, NULL); + friend = scm_from_pointer (closure, ffi_closure_free); + + register_weak_reference (pointer, friend); + } + + return pointer; +} +#undef FUNC_NAME + +#endif /* FFI_CLOSURES */ + + static void scm_init_foreign (void) |