diff options
| -rw-r--r-- | ffi.c | 80 | ||||
| -rw-r--r-- | ffi.h | 2 | ||||
| -rw-r--r-- | share/txr/stdlib/ffi.tl | 26 | ||||
| -rw-r--r-- | txr.1 | 58 |
4 files changed, 147 insertions, 19 deletions
@@ -85,6 +85,8 @@ val ffi_type_s, ffi_call_desc_s, ffi_closure_s; static val ffi_typedef_hash; +static uw_frame_t *s_exit_point; + struct txr_ffi_type { ffi_type *ft; val lt; @@ -1945,6 +1947,12 @@ val ffi_call_wrap(val ffi_call_desc, val fptr, val args_in) } } + if (s_exit_point) { + uw_frame_t *ep = s_exit_point; + s_exit_point = 0; + uw_continue(ep); + } + return ret; } @@ -1990,13 +1998,75 @@ static void ffi_closure_dispatch(ffi_cif *cif, void *cret, rtft->put(rtft, retval, convert(mem_t *, cret), self); } -val ffi_make_closure(val fun, val call_desc) +static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret, + void *cargs[], void *clo) +{ + val self = lit("ffi-closure-dispatch-safe"); + val closure = coerce(val, clo); + struct txr_ffi_closure *tfcl = ffi_closure_struct(closure); + cnum i, nargs = tfcl->nparam; + struct txr_ffi_call_desc *tfcd = tfcl->tfcd; + val types = tfcd->argtypes; + val rtype = tfcd->rettype; + struct txr_ffi_type *volatile rtft = 0; + val retval = nil; + int out_pass_needed = 0; + uw_frame_t cont_guard; + + uw_push_guard(&cont_guard, 0); + + uw_simple_catch_begin; + + args_decl(args, tfcl->nparam); + args_decl(args_cp, tfcl->nparam); + rtft = ffi_type_struct(rtype); + + for (i = 0; i < nargs; i++) { + val type = pop(&types); + struct txr_ffi_type *mtft = ffi_type_struct(type); + val arg = mtft->get(mtft, convert(mem_t *, cargs[i]), self); + args_add(args, arg); + if (mtft->out != 0) + out_pass_needed = 1; + } + + args_copy(args_cp, args); + + retval = generic_funcall(tfcl->fun, args); + + if (out_pass_needed) { + for (types = tfcd->argtypes, i = 0; i < nargs; i++) { + val type = pop(&types); + val arg = args_at(args_cp, i); + struct txr_ffi_type *mtft = ffi_type_struct(type); + if (mtft->out != 0) + mtft->out(mtft, 0, arg, convert(mem_t *, cargs[i]), self); + } + } + + rtft->put(rtft, retval, convert(mem_t *, cret), self); + + uw_unwind { + s_exit_point = uw_curr_exit_point; + if (s_exit_point && rtft != 0) + memset(cret, 0, rtft->size); + uw_curr_exit_point = 0; /* stops unwinding */ + } + + uw_catch_end; + + uw_pop_frame(&cont_guard); +} + + +val ffi_make_closure(val fun, val call_desc, val safe_p_in) { val self = lit("ffi-make-closure"); struct txr_ffi_closure *tfcl = coerce(struct txr_ffi_closure *, chk_calloc(1, sizeof *tfcl)); struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(call_desc); val obj = cobj(coerce(mem_t *, tfcl), ffi_closure_s, &ffi_closure_ops); + val safe_p = default_arg(safe_p_in, t); ffi_status ffis = FFI_OK; tfcl->clo = convert(ffi_closure *, @@ -2007,7 +2077,11 @@ val ffi_make_closure(val fun, val call_desc) uw_throwf(error_s, lit("~a: failed to allocate special closure memory"), self, nao); - if ((ffis = ffi_prep_closure_loc(tfcl->clo, &tfcd->cif, ffi_closure_dispatch, obj, + if ((ffis = ffi_prep_closure_loc(tfcl->clo, &tfcd->cif, + if3(safe_p, + ffi_closure_dispatch_safe, + ffi_closure_dispatch), + obj, coerce(void *, tfcl->fptr))) != FFI_OK) uw_throwf(error_s, lit("~a: ffi_prep_closure_loc failed: ~s"), self, num(ffis), nao); @@ -2146,7 +2220,7 @@ void ffi_init(void) reg_fun(intern(lit("ffi-type-compile"), user_package), func_n1(ffi_type_compile)); reg_fun(intern(lit("ffi-make-call-desc"), user_package), func_n4(ffi_make_call_desc)); reg_fun(intern(lit("ffi-call"), user_package), func_n3(ffi_call_wrap)); - reg_fun(intern(lit("ffi-make-closure"), user_package), func_n2(ffi_make_closure)); + reg_fun(intern(lit("ffi-make-closure"), user_package), func_n3o(ffi_make_closure, 2)); reg_fun(intern(lit("ffi-typedef"), user_package), func_n2(ffi_typedef)); reg_fun(intern(lit("ffi-size"), user_package), func_n1(ffi_size)); reg_fun(intern(lit("ffi-put-into"), user_package), func_n3(ffi_put_into)); @@ -53,7 +53,7 @@ extern val ffi_type_s, ffi_call_desc_s, ffi_closure_s; val ffi_type_compile(val syntax); val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes); -val ffi_make_closure(val fun, val call_desc); +val ffi_make_closure(val fun, val call_desc, val safe_p_in); mem_t *ffi_closure_get_fptr(val closure); val ffi_call_wrap(val ffi_call_desc, val fptr, val args); val ffi_typedef(val name, val type); diff --git a/share/txr/stdlib/ffi.tl b/share/txr/stdlib/ffi.tl index 2d61e640..739023fd 100644 --- a/share/txr/stdlib/ffi.tl +++ b/share/txr/stdlib/ffi.tl @@ -72,20 +72,26 @@ (defmacro deffi-type (name type-expr) ^(ffi-typedef ',name (ffi-type-compile ',type-expr))) -(defmacro deffi-cb (:form f name rettype argtypes) +(defun sys:deffi-cb-expander (f name rettype argtypes safe-p) (let ((ret-type-sym (gensym "ret-type-")) (arg-types-sym (gensym "arg-types-")) (call-desc-sym (gensym "call-desc-")) (fun-sym (gensym "fun-"))) - (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) - ^(progn - (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) - (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) - (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic - ,ret-type-sym - ,arg-types-sym)) - (defun ,name (,fun-sym) - [ffi-make-closure ,fun-sym ,call-desc-sym]))))) + (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) + ^(progn + (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) + (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) + (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic + ,ret-type-sym + ,arg-types-sym)) + (defun ,name (,fun-sym) + [ffi-make-closure ,fun-sym ,call-desc-sym ,safe-p]))))) + +(defmacro deffi-cb (:form f name rettype argtypes) + (sys:deffi-cb-expander f name rettype argtypes t)) + +(defmacro deffi-cb-unsafe (:form f name rettype argtypes) + (sys:deffi-cb-expander f name rettype argtypes nil)) (defmacro sizeof (type) (ffi-size (ffi-type-compile type))) @@ -54048,7 +54048,7 @@ argument types match. .coNP Function @ ffi-make-closure .synb -.mets (ffi-make-closure < lisp-fun << call-desc ) +.mets (ffi-make-closure < lisp-fun < call-desc <> [ safe-p ]) .syne .desc The @@ -54071,6 +54071,41 @@ and may be called as such. When it is called by foreign code, it triggers a call to .meta lisp-fun. +The optional +.meta safe-p +parameter controls whether the closure dispatch is "safe", the meaning of +which is described shortly. The default value is +.code t +so that unsafe closure dispatch must be explicitly requested with a +.code nil +argument for this parameter. + +A a callback closure which is is safely dispatched, firstly, does not permit +the capture of delimited continuations across foreign code. Delimited +continuations can be captured inside a closure dispatched that way, but the +delimiting prompt must be within the callback's local stack frame, without +traversing across the foreign stack frames. Secondly, a callback closure which +is safely dispatched doesn't permit direct non-local control transfers across +foreign code, such as exception handling. Such transfers, however, appear to +work anyway (with caveats): this is because they are specially handled. The +closure dispatch mechanism intercepts all dynamic control transfers, converts +them to an ordinary return from the callback to the foreign code, and resumes +the control transfer when the foreign code itself finishes and returns. +If the callback returns a value (its return type is other than +.codn void ) +then in this situation, the callback returns an all-zero-bits return +value to the foreign caller. + +An unsafely dispatched closure permits the capture of continuations from +the callback across the foreign code and direct dynamic control transfers which +abandon the foreign stack frames. + +Unsafe closure dispatch is only compatible with foreign code which is +designed with that usage in mind. For instance foreign code which holds +dynamic resources in stack variables will leak those resources if abandoned +this way. There are also issues with capturing continuations across foreign +code. + Note: the C function pointer is called a "closure" because it carries environment information. For instance, if .code lisp-fun @@ -54351,9 +54386,10 @@ macro yields the compiled version of .meta type-syntax as its value. -.coNP Macro @ deffi-cb +.coNP Macros @ deffi-cb and @ deffi-cb-unsafe .synb .mets (deffi-cb < name < rettype << argtypes ) +.mets (deffi-cb-unsafe < name < rettype << argtypes ) .syne .desc The @@ -54374,12 +54410,12 @@ The and .meta argtypes arguments are processed exactly as in the corresponding arguments in the -.meta deffi +.code deffi macro. The -.meta deffi-cb -arranges for +.code deffi-cb +macro arranges for .meta rettype and .meta argtypes @@ -54390,6 +54426,18 @@ then serves as a combinator which takes a Lisp function as its argument, and binds it to the FFI call descriptor to produce a FFI closure. That closure may then be passed to foreign functions as a callback. +The +.code deffi-cb-unsafe +macro is a variant of +.code deffi-cb +with exactly the same conventions. The difference is that it arranges for +.code ffi-make-closure +to be invoked with +.code nil +for the +.meta safe-p +parameter. + .TP* Example: .cblk |