suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add #:callback-exns? to _fun and _cprocedure

Browse Source 
In Racket BC, callbacks don't have to be atomic, and it's ok for the
callback to raise an exception (as long as the foreign library is ok
with a longjmp escape). Using `#:callback-exns? #t` on a foreign
callout in both CS and BC allows an atomic callback (invoked during
the foreign call) to raise an exception. Terms and conditions apply.
This commit is contained in:
Matthew Flatt 2021-02-17 08:31:31 -07:00
parent 5ed105ef8a
commit bf8741e727
9 changed files with 269 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when ;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes: ;; "racket_version.h" changes:
(define version "8.0.0.7") (define version "8.0.0.8")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

39
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -523,6 +523,7 @@ the later case, the result is the @racket[ctype]).}
[#:lock-name lock-name (or/c string? #f) #f] [#:lock-name lock-name (or/c string? #f) #f]
[#:in-original-place? in-original-place? any/c #f] [#:in-original-place? in-original-place? any/c #f]
[#:blocking? blocking? any/c #f] [#:blocking? blocking? any/c #f]
[#:callback-exns? callback-exns? any/c #f]
[#:save-errno save-errno (or/c #f 'posix 'windows) #f] [#:save-errno save-errno (or/c #f 'posix 'windows) #f]
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
#f] #f]
@ -624,6 +625,23 @@ For @tech{callouts} to foreign functions with the generated type:
value of @racket[async-apply], even if they are always applied value of @racket[async-apply], even if they are always applied
in the OS thread used to run Racket.} in the OS thread used to run Racket.}
@item{If @racket[callback-exns?] is true, then a foreign
@tech{callout} allows an atomic @tech{callback} during the
foreign call to raise an exception that escapes from the
foreign call. From the foreign library's perspective, the
exception escapes via @tt{longjmp}. Exception escapes are
implemented through an exception handler that catches and
reraises the exception.
A callback that raises an exception must be an atomic callback
in the @BC[] implementation of Racket (and callbacks are always
atomic in the @CS[] implementation). Raising an exception is
not allowed in a callback that has an @racket[async-apply],
since the callback will run in an unspecified context. Raising
an exception is also not allowed if the callout (that led to
the callback) was created with @racket[in-original-place?] as
true and called in a non-original place.}
@item{Values that are provided to a @tech{callout} (i.e., the @item{Values that are provided to a @tech{callout} (i.e., the
underlying callout, and not the replacement produced by a underlying callout, and not the replacement produced by a
@racket[wrapper], if any) are always considered reachable by the @racket[wrapper], if any) are always considered reachable by the
@ -716,10 +734,12 @@ For @tech{callbacks} to Racket functions with the generated type:
synchronization with other threads, or else it may lead to synchronization with other threads, or else it may lead to
deadlock. In addition, the Racket code must not perform any deadlock. In addition, the Racket code must not perform any
potentially blocking operation (such as I/O), it must not raise potentially blocking operation (such as I/O), it must not raise
an uncaught exception, it must not perform any escaping an uncaught exception unless called through a @tech{callout}
continuation jumps, and its non-tail recursion must be minimal that supports exception (with @racket[#:callback-exns? #t]), it
to avoid C-level stack overflow; otherwise, the process may must not perform any escaping continuation jumps, and (at
crash or misbehave. least for the @BC[] implementation) its
non-tail recursion must be minimal to avoid C-level stack
overflow; otherwise, the process may crash or misbehave.
Callbacks are always atomic in the @CS[] implementation of Racket, Callbacks are always atomic in the @CS[] implementation of Racket,
because Racket threads do not capture C-stack context. Even on because Racket threads do not capture C-stack context. Even on
@ -779,7 +799,8 @@ For @tech{callbacks} to Racket functions with the generated type:
@history[#:changed "6.3" @elem{Added the @racket[#:lock-name] argument.} @history[#:changed "6.3" @elem{Added the @racket[#:lock-name] argument.}
#:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] argument.} #:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] argument.}
#:changed "7.9.0.16" @elem{Added the @racket[#:varargs-after] argument.}]} #:changed "7.9.0.16" @elem{Added the @racket[#:varargs-after] argument.}
#:changed "8.0.0.8" @elem{Added the @racket[#:callback-exns?] argument.}]}
@defform/subs[#:literals (->> :: :) @defform/subs[#:literals (->> :: :)
(_fun fun-option ... maybe-args type-spec ... ->> type-spec (_fun fun-option ... maybe-args type-spec ... ->> type-spec
@ -793,6 +814,7 @@ For @tech{callbacks} to Racket functions with the generated type:
(code:line #:lock-name lock-name-expr) (code:line #:lock-name lock-name-expr)
(code:line #:in-original-place? in-original-place?-expr) (code:line #:in-original-place? in-original-place?-expr)
(code:line #:blocking? blocking?-expr) (code:line #:blocking? blocking?-expr)
(code:line #:callback-exns? callback-exns?-expr)
(code:line #:retry (retry-id [arg-id init-expr]))] (code:line #:retry (retry-id [arg-id init-expr]))]
[maybe-args code:blank [maybe-args code:blank
(code:line formals ::)] (code:line formals ::)]
@ -821,8 +843,8 @@ and returns an integer.
See @racket[_cprocedure] for information about the @racket[#:abi], See @racket[_cprocedure] for information about the @racket[#:abi],
@racket[#:varargs-after], @racket[#:varargs-after],
@racket[#:save-errno], @racket[#:keep], @racket[#:atomic?], @racket[#:save-errno], @racket[#:keep], @racket[#:atomic?],
@racket[#:async-apply], @racket[#:in-original-place?], and @racket[#:async-apply], @racket[#:in-original-place?],
@racket[#:blocking] options. @racket[#:blocking], and @racket[#:callback-exns?] options.
In its full form, the @racket[_fun] syntax provides an IDL-like In its full form, the @racket[_fun] syntax provides an IDL-like
language that creates a wrapper function around the language that creates a wrapper function around the
@ -916,7 +938,8 @@ specifications:
@history[#:changed "6.2" @elem{Added the @racket[#:retry] option.} @history[#:changed "6.2" @elem{Added the @racket[#:retry] option.}
#:changed "6.3" @elem{Added the @racket[#:lock-name] option.} #:changed "6.3" @elem{Added the @racket[#:lock-name] option.}
#:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] option.} #:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] option.}
#:changed "7.9.0.16" @elem{Added the @racket[#:varargs-after] option.}]} #:changed "7.9.0.16" @elem{Added the @racket[#:varargs-after] option.}
#:changed "8.0.0.8" @elem{Added the @racket[#:callback-exns?] option.}]}
@defproc[(function-ptr [ptr-or-proc (or cpointer? procedure?)] @defproc[(function-ptr [ptr-or-proc (or cpointer? procedure?)]
[fun-type ctype?]) [fun-type ctype?])

5
pkgs/racket-test-core/tests/racket/foreign-test.c
View File

@ -402,3 +402,8 @@ X long varargs_check(int init, int n, ...) {
return accum; return accum;
} }
X int callback_hungry(int (*f)(void*)) {
char use_stack_space[10000];
return f(use_stack_space);
}

20
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -908,6 +908,26 @@
(check (lambda (f) (f)) add1) (check (lambda (f) (f)) add1)
(check (box 20) (lambda (x) 20))) (check (box 20) (lambda (x) 20)))
;; check `#:callback-exns?`
(let ([callback_hungry (get-ffi-obj 'callback_hungry test-lib
(_fun #:callback-exns? #t
(_fun #:atomic? #t -> _int) -> _int))])
(test 17 callback_hungry (lambda () 17))
(for ([i 1000])
(with-handlers ([(lambda (x) (eq? x 'out)) void])
(callback_hungry (lambda () (raise 'out))))
(sync (system-idle-evt))))
;; Same thing, with a lock
(let ([callback_hungry (get-ffi-obj 'callback_hungry test-lib
(_fun #:callback-exns? #t
#:lock-name "hungry"
(_fun #:atomic? #t -> _int) -> _int))])
(test 170 callback_hungry (lambda () 170))
(for ([i 1000])
(with-handlers ([(lambda (x) (eq? x 'out)) void])
(callback_hungry (lambda () (raise 'out))))
(sync (system-idle-evt))))
;; check in-array ;; check in-array
(let () (let ()
(define _t (_array _int 6)) (define _t (_array _int 6))

15
racket/collects/ffi/unsafe.rkt
View File

@ -509,10 +509,13 @@
#:atomic? [atomic? #f] #:atomic? [atomic? #f]
#:in-original-place? [orig-place? #f] #:in-original-place? [orig-place? #f]
#:blocking? [blocking? #f] #:blocking? [blocking? #f]
#:callback-exns? [callback-exns? #f]
#:lock-name [lock-name #f] #:lock-name [lock-name #f]
#:async-apply [async-apply #f] #:async-apply [async-apply #f]
#:save-errno [errno #f]) #:save-errno [errno #f])
(_cprocedure* itypes otype abi varargs-after wrapper keep atomic? orig-place? blocking? async-apply errno lock-name)) (_cprocedure* itypes otype abi varargs-after wrapper keep
atomic? orig-place? blocking? callback-exns?
async-apply errno lock-name))
;; A lightwegith delay meachnism for a single-argument function when ;; A lightwegith delay meachnism for a single-argument function when
;; it's ok (but unlikely) to evaluate `expr` more than once and keep ;; it's ok (but unlikely) to evaluate `expr` more than once and keep
@ -533,9 +536,12 @@
;; for internal use ;; for internal use
(define held-callbacks (make-weak-hasheq)) (define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi varargs-after wrapper keep atomic? orig-place? blocking? async-apply errno lock-name) (define (_cprocedure* itypes otype abi varargs-after wrapper keep
atomic? orig-place? blocking? callback-exns?
async-apply errno lock-name)
(define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply varargs-after))) (define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply varargs-after)))
(define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno orig-place? lock-name blocking? varargs-after))) (define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno
orig-place? lock-name blocking? varargs-after callback-exns?)))
(define-syntax-rule (make-it wrap) (define-syntax-rule (make-it wrap)
(make-ctype _fpointer (make-ctype _fpointer
(lambda (x) (lambda (x)
@ -572,7 +578,7 @@
(provide _fun) (provide _fun)
(define-for-syntax _fun-keywords (define-for-syntax _fun-keywords
`([#:abi ,#'#f] [#:varargs-after ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] `([#:abi ,#'#f] [#:varargs-after ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f]
[#:in-original-place? ,#'#f] [#:blocking? ,#'#f] [#:lock-name ,#'#f] [#:in-original-place? ,#'#f] [#:blocking? ,#'#f] [#:callback-exns? ,#'#f] [#:lock-name ,#'#f]
[#:async-apply ,#'#f] [#:save-errno ,#'#f] [#:async-apply ,#'#f] [#:save-errno ,#'#f]
[#:retry #f])) [#:retry #f]))
(define-syntax (_fun stx) (define-syntax (_fun stx)
@ -737,6 +743,7 @@
#,(kwd-ref '#:atomic?) #,(kwd-ref '#:atomic?)
#,(kwd-ref '#:in-original-place?) #,(kwd-ref '#:in-original-place?)
#,(kwd-ref '#:blocking?) #,(kwd-ref '#:blocking?)
#,(kwd-ref '#:callback-exns?)
#,(kwd-ref '#:async-apply) #,(kwd-ref '#:async-apply)
#,(kwd-ref '#:save-errno) #,(kwd-ref '#:save-errno)
#,(kwd-ref '#:lock-name)))]) #,(kwd-ref '#:lock-name)))])

65
racket/src/bc/foreign/foreign.c
View File

@ -3656,6 +3656,30 @@ static void finish_ffi_call(ffi_cif *cif, void *c_func, intptr_t cfoff,
ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
} }
static void finish_ffi_call_handle_exn(ffi_cif *cif, void *c_func, intptr_t cfoff,
int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
intptr_t *offsets, void *p,
Scheme_Object *lock)
{
mz_jmp_buf * volatile save, fresh;
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &fresh;
if (scheme_setjmp(scheme_error_buf)) {
if (SCHEME_TRUEP(lock))
release_ffi_lock(lock);
scheme_end_in_scheduler();
scheme_longjmp(*save, 1);
} else {
finish_ffi_call(cif, c_func, cfoff,
nargs, ivals, avalues,
offsets, p);
}
scheme_current_thread->error_buf = save;
}
static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object *self) static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object *self)
/* data := {name, c-function, itypes, otype, cif} */ /* data := {name, c-function, itypes, otype, cif} */
{ {
@ -3674,8 +3698,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
: SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5])); : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]));
int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
Scheme_Object *lock = SCHEME_VEC_ELS(data)[7]; Scheme_Object *lock = SCHEME_VEC_ELS(data)[7];
int callback_exns = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]); int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[9]);
#endif #endif
int nargs /* = cif->nargs, after checking cif */; int nargs /* = cif->nargs, after checking cif */;
/* When the foreign function is called, we need an array (ivals) of nargs /* When the foreign function is called, we need an array (ivals) of nargs
@ -3762,9 +3787,16 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
offsets, p); offsets, p);
else else
#endif #endif
finish_ffi_call(cif, c_func, cfoff, {
nargs, ivals, avalues, if (callback_exns)
offsets, p); finish_ffi_call_handle_exn(cif, c_func, cfoff,
nargs, ivals, avalues,
offsets, p, lock);
else
finish_ffi_call(cif, c_func, cfoff,
nargs, ivals, avalues,
offsets, p);
}
if (SCHEME_TRUEP(lock)) if (SCHEME_TRUEP(lock))
release_ffi_lock(lock); release_ffi_lock(lock);
@ -3879,14 +3911,14 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
intptr_t ooff; intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif; GC_CAN_IGNORE ffi_cif *cif;
int i, nargs, save_errno; int i, nargs, save_errno, callback_exns;
Scheme_Object *lock = scheme_false; Scheme_Object *lock = scheme_false;
Scheme_Performance_State perf_state; Scheme_Performance_State perf_state;
# ifdef MZ_USE_PLACES # ifdef MZ_USE_PLACES
int orig_place = MZ_USE_FFIPOLL_COND; int orig_place = MZ_USE_FFIPOLL_COND;
# define FFI_CALL_VEC_SIZE 9 # define FFI_CALL_VEC_SIZE 10
# else /* MZ_USE_PLACES undefined */ # else /* MZ_USE_PLACES undefined */
# define FFI_CALL_VEC_SIZE 8 # define FFI_CALL_VEC_SIZE 9
# endif /* MZ_USE_PLACES */ # endif /* MZ_USE_PLACES */
scheme_performance_record_start(&perf_state); scheme_performance_record_start(&perf_state);
if (!curry) { if (!curry) {
@ -3941,6 +3973,10 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs); varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs);
} else } else
varargs_after = -1; varargs_after = -1;
if (argc > ARGPOS(9))
callback_exns = SCHEME_TRUEP(argv[ARGPOS(9)]);
else
callback_exns = 0;
if (cp && SCHEME_FFIOBJP(cp)) if (cp && SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
@ -3971,8 +4007,9 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff); SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno); SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno);
SCHEME_VEC_ELS(data)[7] = lock; SCHEME_VEC_ELS(data)[7] = lock;
SCHEME_VEC_ELS(data)[8] = (callback_exns ? scheme_true : scheme_false);
# ifdef MZ_USE_PLACES # ifdef MZ_USE_PLACES
SCHEME_VEC_ELS(data)[8] = (orig_place ? scheme_true : scheme_false); SCHEME_VEC_ELS(data)[9] = (orig_place ? scheme_true : scheme_false);
# endif /* MZ_USE_PLACES */ # endif /* MZ_USE_PLACES */
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL); scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
a[0] = data; a[0] = data;
@ -3993,7 +4030,7 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
#undef ARGPOS #undef ARGPOS
} }
/* (ffi-call ffi-obj in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (in-types -> out-value) */ /* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */ /* the real work is done by ffi_do_call above */
#define MYNAME "ffi-call" #define MYNAME "ffi-call"
static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
@ -4002,7 +4039,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
} }
#undef MYNAME #undef MYNAME
/* (ffi-call-maker in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */ /* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (ffi->obj -> (in-types -> out-value)) */
/* Curried version of `ffi-call` */ /* Curried version of `ffi-call` */
#define MYNAME "ffi-call-maker" #define MYNAME "ffi-call-maker"
static Scheme_Object *foreign_ffi_call_maker(int argc, Scheme_Object *argv[]) static Scheme_Object *foreign_ffi_call_maker(int argc, Scheme_Object *argv[])
@ -5172,9 +5209,9 @@ void scheme_init_foreign(Scheme_Startup_Env *env)
scheme_addto_prim_instance("make-sized-byte-string", scheme_addto_prim_instance("make-sized-byte-string",
scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env); scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env);
scheme_addto_prim_instance("ffi-call", scheme_addto_prim_instance("ffi-call",
scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 9), env); scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 10), env);
scheme_addto_prim_instance("ffi-call-maker", scheme_addto_prim_instance("ffi-call-maker",
scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 8), env); scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 9), env);
scheme_addto_prim_instance("ffi-callback", scheme_addto_prim_instance("ffi-callback",
scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env); scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env);
scheme_addto_prim_instance("ffi-callback-maker", scheme_addto_prim_instance("ffi-callback-maker",
@ -5539,9 +5576,9 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_addto_primitive_instance("make-sized-byte-string", scheme_addto_primitive_instance("make-sized-byte-string",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env);
scheme_addto_primitive_instance("ffi-call", scheme_addto_primitive_instance("ffi-call",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 9), env); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 10), env);
scheme_addto_primitive_instance("ffi-call-maker", scheme_addto_primitive_instance("ffi-call-maker",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 8), env); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 9), env);
scheme_addto_primitive_instance("ffi-callback", scheme_addto_primitive_instance("ffi-callback",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env);
scheme_addto_primitive_instance("ffi-callback-maker", scheme_addto_primitive_instance("ffi-callback-maker",

63
racket/src/bc/foreign/foreign.rktc
View File

@ -2823,6 +2823,30 @@ static void finish_ffi_call(ffi_cif *cif, void *c_func, intptr_t cfoff,
ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
} }
static void finish_ffi_call_handle_exn(ffi_cif *cif, void *c_func, intptr_t cfoff,
int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
intptr_t *offsets, void *p,
Scheme_Object *lock)
{
mz_jmp_buf * volatile save, fresh;
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &fresh;
if (scheme_setjmp(scheme_error_buf)) {
if (SCHEME_TRUEP(lock))
release_ffi_lock(lock);
scheme_end_in_scheduler();
scheme_longjmp(*save, 1);
} else {
finish_ffi_call(cif, c_func, cfoff,
nargs, ivals, avalues,
offsets, p);
}
scheme_current_thread->error_buf = save;
}
static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object *self) static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object *self)
/* data := {name, c-function, itypes, otype, cif} */ /* data := {name, c-function, itypes, otype, cif} */
{ {
@ -2841,8 +2865,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
: SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5])); : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]));
int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
Scheme_Object *lock = SCHEME_VEC_ELS(data)[7]; Scheme_Object *lock = SCHEME_VEC_ELS(data)[7];
int callback_exns = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]); int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[9]);
#endif #endif
int nargs /* = cif->nargs, after checking cif */; int nargs /* = cif->nargs, after checking cif */;
/* When the foreign function is called, we need an array (ivals) of nargs /* When the foreign function is called, we need an array (ivals) of nargs
@ -2929,10 +2954,17 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
offsets, p); offsets, p);
else else
#endif #endif
finish_ffi_call(cif, c_func, cfoff, {
nargs, ivals, avalues, if (callback_exns)
offsets, p); finish_ffi_call_handle_exn(cif, c_func, cfoff,
nargs, ivals, avalues,
offsets, p, lock);
else
finish_ffi_call(cif, c_func, cfoff,
nargs, ivals, avalues,
offsets, p);
}
if (SCHEME_TRUEP(lock)) if (SCHEME_TRUEP(lock))
release_ffi_lock(lock); release_ffi_lock(lock);
@ -3046,14 +3078,14 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
intptr_t ooff; intptr_t ooff;
GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_type *rtype, **atypes;
GC_CAN_IGNORE ffi_cif *cif; GC_CAN_IGNORE ffi_cif *cif;
int i, nargs, save_errno; int i, nargs, save_errno, callback_exns;
Scheme_Object *lock = scheme_false; Scheme_Object *lock = scheme_false;
Scheme_Performance_State perf_state; Scheme_Performance_State perf_state;
@@@IFDEF{MZ_USE_PLACES}{ @@@IFDEF{MZ_USE_PLACES}{
int orig_place = MZ_USE_FFIPOLL_COND; int orig_place = MZ_USE_FFIPOLL_COND;
@DEFINE{FFI_CALL_VEC_SIZE 9} @DEFINE{FFI_CALL_VEC_SIZE 10}
}{ }{
@DEFINE{FFI_CALL_VEC_SIZE 8} @DEFINE{FFI_CALL_VEC_SIZE 9}
} }
scheme_performance_record_start(&perf_state); scheme_performance_record_start(&perf_state);
if (!curry) { if (!curry) {
@ -3108,6 +3140,10 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs); varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs);
} else } else
varargs_after = -1; varargs_after = -1;
if (argc > ARGPOS(9))
callback_exns = SCHEME_TRUEP(argv[ARGPOS(9)]);
else
callback_exns = 0;
if (cp && SCHEME_FFIOBJP(cp)) if (cp && SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
@ -3138,8 +3174,9 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff); SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno); SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno);
SCHEME_VEC_ELS(data)[7] = lock; SCHEME_VEC_ELS(data)[7] = lock;
SCHEME_VEC_ELS(data)[8] = (callback_exns ? scheme_true : scheme_false);
@@IFDEF{MZ_USE_PLACES}{ @@IFDEF{MZ_USE_PLACES}{
SCHEME_VEC_ELS(data)[8] = (orig_place ? scheme_true : scheme_false); SCHEME_VEC_ELS(data)[9] = (orig_place ? scheme_true : scheme_false);
} }
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL); scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
a[0] = data; a[0] = data;
@ -3160,15 +3197,15 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
#undef ARGPOS #undef ARGPOS
} }
/* (ffi-call ffi-obj in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (in-types -> out-value) */ /* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */ /* the real work is done by ffi_do_call above */
@cdefine[ffi-call 3 9]{ @cdefine[ffi-call 3 10]{
return ffi_call_or_curry(MYNAME, 0, argc, argv); return ffi_call_or_curry(MYNAME, 0, argc, argv);
} }
/* (ffi-call-maker in-types out-type [abi varargs-after save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */ /* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (ffi->obj -> (in-types -> out-value)) */
/* Curried version of `ffi-call` */ /* Curried version of `ffi-call` */
@cdefine[ffi-call-maker 2 8]{ @cdefine[ffi-call-maker 2 9]{
return ffi_call_or_curry(MYNAME, 1, argc, argv); return ffi_call_or_curry(MYNAME, 1, argc, argv);
} }

132
racket/src/cs/rumble/foreign.ss
View File

@ -1532,39 +1532,48 @@
(define/who ffi-call (define/who ffi-call
(case-lambda (case-lambda
[(p in-types out-type) [(p in-types out-type)
(ffi-call p in-types out-type #f #f #f)] (ffi-call p in-types out-type #f #f #f #f)]
[(p in-types out-type abi) [(p in-types out-type abi)
(ffi-call p in-types out-type abi #f #f #f)] (ffi-call p in-types out-type abi #f #f #f #f)]
[(p in-types out-type abi save-errno) [(p in-types out-type abi save-errno)
(ffi-call p in-types out-type abi save-errno #f #f)] (ffi-call p in-types out-type abi save-errno #f #f #f)]
[(p in-types out-type abi save-errno orig-place?) [(p in-types out-type abi save-errno orig-place?)
(ffi-call p in-types out-type abi save-errno orig-place? #f #f)] (ffi-call p in-types out-type abi save-errno orig-place? #f #f #f)]
[(p in-types out-type abi save-errno orig-place? lock-name) [(p in-types out-type abi save-errno orig-place? lock-name)
(ffi-call p in-types out-type abi save-errno orig-place? lock-name #f #f)] (ffi-call p in-types out-type abi save-errno orig-place? lock-name #f #f #f)]
[(p in-types out-type abi save-errno orig-place? lock-name blocking?) [(p in-types out-type abi save-errno orig-place? lock-name blocking?)
(ffi-call p in-types out-type abi save-errno orig-place? lock-name blocking? #f)] (ffi-call p in-types out-type abi save-errno orig-place? lock-name blocking? #f #f)]
[(p in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after) [(p in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after)
(ffi-call p in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after #f)]
[(p in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after exns?)
(check who cpointer? p) (check who cpointer? p)
(check-ffi-call who in-types out-type abi varargs-after save-errno lock-name) (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name)
((ffi-call/callable #t in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? #f #f) p)])) ((ffi-call/callable #t in-types out-type abi varargs-after
save-errno lock-name (and blocking? #t) (and orig-place? #t) #f (and exns? #t)
#f)
p)]))
(define/who ffi-call-maker (define/who ffi-call-maker
(case-lambda (case-lambda
[(in-types out-type) [(in-types out-type)
(ffi-call-maker in-types out-type #f #f #f #f)] (ffi-call-maker in-types out-type #f #f #f #f #f)]
[(in-types out-type abi) [(in-types out-type abi)
(ffi-call-maker in-types out-type abi #f #f #f)] (ffi-call-maker in-types out-type abi #f #f #f #f)]
[(in-types out-type abi save-errno) [(in-types out-type abi save-errno)
(ffi-call-maker in-types out-type abi save-errno #f #f)] (ffi-call-maker in-types out-type abi save-errno #f #f #f)]
[(in-types out-type abi save-errno orig-place?) [(in-types out-type abi save-errno orig-place?)
(ffi-call-maker in-types out-type abi save-errno orig-place? #f #f)] (ffi-call-maker in-types out-type abi save-errno orig-place? #f #f #f)]
[(in-types out-type abi save-errno orig-place? lock-name) [(in-types out-type abi save-errno orig-place? lock-name)
(ffi-call-maker in-types out-type abi save-errno orig-place? lock-name #f #f)] (ffi-call-maker in-types out-type abi save-errno orig-place? lock-name #f #f #f)]
[(in-types out-type abi save-errno orig-place? lock-name blocking?) [(in-types out-type abi save-errno orig-place? lock-name blocking?)
(ffi-call-maker in-types out-type abi save-errno orig-place? lock-name blocking? #f)] (ffi-call-maker in-types out-type abi save-errno orig-place? lock-name blocking? #f #f)]
[(in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after) [(in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after)
(ffi-call-maker in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after #f)]
[(in-types out-type abi save-errno orig-place? lock-name blocking? varargs-after exns?)
(check-ffi-call who in-types out-type abi varargs-after save-errno lock-name) (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name)
(ffi-call/callable #t in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? #f #f)])) (ffi-call/callable #t in-types out-type abi varargs-after
save-errno lock-name (and blocking? #t) (and orig-place? #t) #f (and exns? #t)
#f)]))
(define (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name) (define (check-ffi-call who in-types out-type abi varargs-after save-errno lock-name)
(check-ffi who in-types out-type abi varargs-after) (check-ffi who in-types out-type abi varargs-after)
@ -1586,7 +1595,9 @@
(define call-locks (make-eq-hashtable)) (define call-locks (make-eq-hashtable))
(define (ffi-call/callable call? in-types out-type abi varargs-after save-errno lock-name blocking? orig-place? atomic? async-apply) (define (ffi-call/callable call? in-types out-type abi varargs-after
save-errno lock-name blocking? orig-place? atomic? exns?
async-apply)
(let* ([conv* (let ([conv* (case abi (let* ([conv* (let ([conv* (case abi
[(stdcall) '(__stdcall)] [(stdcall) '(__stdcall)]
[(sysv) '(__cdecl)] [(sysv) '(__cdecl)]
@ -1686,6 +1697,7 @@
[(and (not ret-id) [(and (not ret-id)
(not blocking?) (not blocking?)
(not orig-place?) (not orig-place?)
(not exns?)
(not save-errno) (not save-errno)
(#%andmap (lambda (in-type) (#%andmap (lambda (in-type)
(case (ctype-host-rep in-type) (case (ctype-host-rep in-type)
@ -1787,22 +1799,31 @@
(when blocking? (currently-blocking? #t)) (when blocking? (currently-blocking? #t))
(retain (retain
orig-args orig-args
(let ([r (#%apply (gen-proc (cpointer-address proc-p)) (let ([r (let ([args (append
(append (if ret-ptr
(if ret-ptr (begin
(begin (lock-cpointer ret-ptr)
(lock-cpointer ret-ptr) (list (ret-maker (cpointer-address ret-ptr))))
(list (ret-maker (cpointer-address ret-ptr)))) '())
'()) (map (lambda (arg in-type maker)
(map (lambda (arg in-type maker) (let ([host-rep (array-rep-to-pointer-rep
(let ([host-rep (array-rep-to-pointer-rep (ctype-host-rep in-type))])
(ctype-host-rep in-type))]) (case host-rep
(case host-rep [(void*) (cpointer-address arg)]
[(void*) (cpointer-address arg)] [(struct union)
[(struct union) (maker (cpointer-address arg))]
(maker (cpointer-address arg))] [else arg])))
[else arg]))) args in-types arg-makers))]
args in-types arg-makers)))]) [proc (gen-proc (cpointer-address proc-p))])
(cond
[(not exns?)
(#%apply proc args)]
[else
(call-guarding-foreign-escape
(lambda () (#%apply proc args))
(lambda ()
(when lock (mutex-release lock))
(when blocking? (currently-blocking? #f))))]))])
(when lock (mutex-release lock)) (when lock (mutex-release lock))
(when blocking? (currently-blocking? #f)) (when blocking? (currently-blocking? #f))
(case save-errno (case save-errno
@ -1843,7 +1864,7 @@
[arg (c->s type [arg (c->s type
(case (ctype-host-rep type) (case (ctype-host-rep type)
[(struct union) [(struct union)
;; Like old Racket, refer to argument on stack: ;; Like Racket BC, refer to argument on stack:
(make-cpointer (ftype-pointer-address arg) #f) (make-cpointer (ftype-pointer-address arg) #f)
#; #;
(let* ([size (compound-ctype-size type)] (let* ([size (compound-ctype-size type)]
@ -1918,6 +1939,9 @@
(scheduler-start-atomic) (scheduler-start-atomic)
;; Now that the schedule is in atomic mode, reenable interrupts (for GC) ;; Now that the schedule is in atomic mode, reenable interrupts (for GC)
(enable-interrupts) (enable-interrupts)
;; See also `call-guarding-foreign-escape`, which will need to take
;; appropriate steps if `(thunk)` escapes, which currently means ending
;; the scheduler's atomic mode
(let ([v (thunk)]) (let ([v (thunk)])
(disable-interrupts) (disable-interrupts)
(scheduler-end-atomic) (scheduler-end-atomic)
@ -1949,6 +1973,46 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Call `thunk` to enter a foreign call while wrapping it with a way
;; to escape with an exception from a foreign callback during the
;; call:
(define (call-guarding-foreign-escape thunk clean-up)
((call-with-c-return
(lambda ()
(call-with-current-continuation
(lambda (esc)
(call-with-exception-handler
(lambda (x)
;; Deliver an exception re-raise after returning back
;; from `call-with-c-return`:
(|#%app| esc (lambda ()
(scheduler-end-atomic) ; error in callback means during atomic mode
(clean-up)
(raise x))))
(lambda ()
(call-with-values thunk
;; Deliver successful values after returning back from
;; `call-with-c-return`:
(case-lambda
[(v) (lambda () v)]
[args (lambda () (#%apply values args))]))))))))))
;; `call-with-c-return` looks like a foreign function, due to a "cast"
;; to and from a callback, so returning from `call-with-c-return` will
;; pop and C frame stacks (via longjmp internally) that were pushed
;; since `call-with-c-return` was called.
(define call-with-c-return
(let ([call (lambda (thunk) (thunk))])
(define-ftype ptr->ptr (function (ptr) ptr))
(let ([fptr (make-ftype-pointer ptr->ptr call)])
(let ([v (ftype-ref ptr->ptr () fptr)])
(unlock-object
(foreign-callable-code-object
(ftype-pointer-address fptr)))
v))))
;; ----------------------------------------
(define-record-type (callback create-callback ffi-callback?) (define-record-type (callback create-callback ffi-callback?)
(fields code)) (fields code))
@ -1982,7 +2046,9 @@
(ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply)])) (ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply)]))
(define (ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply) (define (ffi-callback-maker* in-types out-type abi varargs-after atomic? async-apply)
(let ([make-code (ffi-call/callable #f in-types out-type abi varargs-after #f #f #f #f (and atomic? #t) async-apply)]) (let ([make-code (ffi-call/callable #f in-types out-type abi varargs-after
#f #f #f #f (and atomic? #t) #f
async-apply)])
(lambda (proc) (lambda (proc)
(check 'make-ffi-callback procedure? proc) (check 'make-ffi-callback procedure? proc)
(create-callback (make-code proc))))) (create-callback (make-code proc)))))

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 8 #define MZSCHEME_VERSION_X 8
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 7 #define MZSCHEME_VERSION_W 8
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x