add #:callback-exns? to _fun and _cprocedure
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
parent
5ed105ef8a
commit
bf8741e727
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
;; In the Racket source repo, this version should change only when
|
||||
;; "racket_version.h" changes:
|
||||
(define version "8.0.0.7")
|
||||
(define version "8.0.0.8")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -523,6 +523,7 @@ the later case, the result is the @racket[ctype]).}
|
|||
[#:lock-name lock-name (or/c string? #f) #f]
|
||||
[#:in-original-place? in-original-place? 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]
|
||||
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
|
||||
#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
|
||||
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
|
||||
underlying callout, and not the replacement produced by a
|
||||
@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
|
||||
deadlock. In addition, the Racket code must not perform any
|
||||
potentially blocking operation (such as I/O), it must not raise
|
||||
an uncaught exception, it must not perform any escaping
|
||||
continuation jumps, and its non-tail recursion must be minimal
|
||||
to avoid C-level stack overflow; otherwise, the process may
|
||||
crash or misbehave.
|
||||
an uncaught exception unless called through a @tech{callout}
|
||||
that supports exception (with @racket[#:callback-exns? #t]), it
|
||||
must not perform any escaping continuation jumps, and (at
|
||||
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,
|
||||
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.}
|
||||
#: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 (->> :: :)
|
||||
(_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 #:in-original-place? in-original-place?-expr)
|
||||
(code:line #:blocking? blocking?-expr)
|
||||
(code:line #:callback-exns? callback-exns?-expr)
|
||||
(code:line #:retry (retry-id [arg-id init-expr]))]
|
||||
[maybe-args code:blank
|
||||
(code:line formals ::)]
|
||||
|
|
@ -821,8 +843,8 @@ and returns an integer.
|
|||
See @racket[_cprocedure] for information about the @racket[#:abi],
|
||||
@racket[#:varargs-after],
|
||||
@racket[#:save-errno], @racket[#:keep], @racket[#:atomic?],
|
||||
@racket[#:async-apply], @racket[#:in-original-place?], and
|
||||
@racket[#:blocking] options.
|
||||
@racket[#:async-apply], @racket[#:in-original-place?],
|
||||
@racket[#:blocking], and @racket[#:callback-exns?] options.
|
||||
|
||||
In its full form, the @racket[_fun] syntax provides an IDL-like
|
||||
language that creates a wrapper function around the
|
||||
|
|
@ -916,7 +938,8 @@ specifications:
|
|||
@history[#:changed "6.2" @elem{Added the @racket[#:retry] option.}
|
||||
#:changed "6.3" @elem{Added the @racket[#:lock-name] 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?)]
|
||||
[fun-type ctype?])
|
||||
|
|
|
|||
|
|
@ -402,3 +402,8 @@ X long varargs_check(int init, int n, ...) {
|
|||
|
||||
return accum;
|
||||
}
|
||||
|
||||
X int callback_hungry(int (*f)(void*)) {
|
||||
char use_stack_space[10000];
|
||||
return f(use_stack_space);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -908,6 +908,26 @@
|
|||
(check (lambda (f) (f)) add1)
|
||||
(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
|
||||
(let ()
|
||||
(define _t (_array _int 6))
|
||||
|
|
|
|||
|
|
@ -509,10 +509,13 @@
|
|||
#:atomic? [atomic? #f]
|
||||
#:in-original-place? [orig-place? #f]
|
||||
#:blocking? [blocking? #f]
|
||||
#:callback-exns? [callback-exns? #f]
|
||||
#:lock-name [lock-name #f]
|
||||
#:async-apply [async-apply #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
|
||||
;; it's ok (but unlikely) to evaluate `expr` more than once and keep
|
||||
|
|
@ -533,9 +536,12 @@
|
|||
|
||||
;; for internal use
|
||||
(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-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)
|
||||
(make-ctype _fpointer
|
||||
(lambda (x)
|
||||
|
|
@ -572,7 +578,7 @@
|
|||
(provide _fun)
|
||||
(define-for-syntax _fun-keywords
|
||||
`([#: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]
|
||||
[#:retry #f]))
|
||||
(define-syntax (_fun stx)
|
||||
|
|
@ -737,6 +743,7 @@
|
|||
#,(kwd-ref '#:atomic?)
|
||||
#,(kwd-ref '#:in-original-place?)
|
||||
#,(kwd-ref '#:blocking?)
|
||||
#,(kwd-ref '#:callback-exns?)
|
||||
#,(kwd-ref '#:async-apply)
|
||||
#,(kwd-ref '#:save-errno)
|
||||
#,(kwd-ref '#:lock-name)))])
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
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)
|
||||
/* 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]));
|
||||
int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
|
||||
Scheme_Object *lock = SCHEME_VEC_ELS(data)[7];
|
||||
int callback_exns = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
|
||||
#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
|
||||
int nargs /* = cif->nargs, after checking cif */;
|
||||
/* 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);
|
||||
else
|
||||
#endif
|
||||
{
|
||||
if (callback_exns)
|
||||
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))
|
||||
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;
|
||||
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
||||
GC_CAN_IGNORE ffi_cif *cif;
|
||||
int i, nargs, save_errno;
|
||||
int i, nargs, save_errno, callback_exns;
|
||||
Scheme_Object *lock = scheme_false;
|
||||
Scheme_Performance_State perf_state;
|
||||
# ifdef MZ_USE_PLACES
|
||||
int orig_place = MZ_USE_FFIPOLL_COND;
|
||||
# define FFI_CALL_VEC_SIZE 9
|
||||
# define FFI_CALL_VEC_SIZE 10
|
||||
# else /* MZ_USE_PLACES undefined */
|
||||
# define FFI_CALL_VEC_SIZE 8
|
||||
# define FFI_CALL_VEC_SIZE 9
|
||||
# endif /* MZ_USE_PLACES */
|
||||
scheme_performance_record_start(&perf_state);
|
||||
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);
|
||||
} else
|
||||
varargs_after = -1;
|
||||
if (argc > ARGPOS(9))
|
||||
callback_exns = SCHEME_TRUEP(argv[ARGPOS(9)]);
|
||||
else
|
||||
callback_exns = 0;
|
||||
|
||||
if (cp && SCHEME_FFIOBJP(cp))
|
||||
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)[6] = scheme_make_integer(save_errno);
|
||||
SCHEME_VEC_ELS(data)[7] = lock;
|
||||
SCHEME_VEC_ELS(data)[8] = (callback_exns ? scheme_true : scheme_false);
|
||||
# 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 */
|
||||
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
|
||||
a[0] = data;
|
||||
|
|
@ -3993,7 +4030,7 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
|
|||
#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 */
|
||||
#define MYNAME "ffi-call"
|
||||
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
|
||||
|
||||
/* (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` */
|
||||
#define MYNAME "ffi-call-maker"
|
||||
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_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env);
|
||||
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_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_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env);
|
||||
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_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env);
|
||||
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_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_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env);
|
||||
scheme_addto_primitive_instance("ffi-callback-maker",
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
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)
|
||||
/* 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]));
|
||||
int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
|
||||
Scheme_Object *lock = SCHEME_VEC_ELS(data)[7];
|
||||
int callback_exns = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
|
||||
#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
|
||||
int nargs /* = cif->nargs, after checking cif */;
|
||||
/* When the foreign function is called, we need an array (ivals) of nargs
|
||||
|
|
@ -2929,9 +2954,16 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
|
|||
offsets, p);
|
||||
else
|
||||
#endif
|
||||
{
|
||||
if (callback_exns)
|
||||
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))
|
||||
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;
|
||||
GC_CAN_IGNORE ffi_type *rtype, **atypes;
|
||||
GC_CAN_IGNORE ffi_cif *cif;
|
||||
int i, nargs, save_errno;
|
||||
int i, nargs, save_errno, callback_exns;
|
||||
Scheme_Object *lock = scheme_false;
|
||||
Scheme_Performance_State perf_state;
|
||||
@@@IFDEF{MZ_USE_PLACES}{
|
||||
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);
|
||||
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);
|
||||
} else
|
||||
varargs_after = -1;
|
||||
if (argc > ARGPOS(9))
|
||||
callback_exns = SCHEME_TRUEP(argv[ARGPOS(9)]);
|
||||
else
|
||||
callback_exns = 0;
|
||||
|
||||
if (cp && SCHEME_FFIOBJP(cp))
|
||||
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)[6] = scheme_make_integer(save_errno);
|
||||
SCHEME_VEC_ELS(data)[7] = lock;
|
||||
SCHEME_VEC_ELS(data)[8] = (callback_exns ? scheme_true : scheme_false);
|
||||
@@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);
|
||||
a[0] = data;
|
||||
|
|
@ -3160,15 +3197,15 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
|
|||
#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 */
|
||||
@cdefine[ffi-call 3 9]{
|
||||
@cdefine[ffi-call 3 10]{
|
||||
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` */
|
||||
@cdefine[ffi-call-maker 2 8]{
|
||||
@cdefine[ffi-call-maker 2 9]{
|
||||
return ffi_call_or_curry(MYNAME, 1, argc, argv);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1532,39 +1532,48 @@
|
|||
(define/who ffi-call
|
||||
(case-lambda
|
||||
[(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)
|
||||
(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)
|
||||
(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?)
|
||||
(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)
|
||||
(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?)
|
||||
(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)
|
||||
(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-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
|
||||
(case-lambda
|
||||
[(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)
|
||||
(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)
|
||||
(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?)
|
||||
(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)
|
||||
(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?)
|
||||
(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)
|
||||
(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)
|
||||
(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)
|
||||
(check-ffi who in-types out-type abi varargs-after)
|
||||
|
|
@ -1586,7 +1595,9 @@
|
|||
|
||||
(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
|
||||
[(stdcall) '(__stdcall)]
|
||||
[(sysv) '(__cdecl)]
|
||||
|
|
@ -1686,6 +1697,7 @@
|
|||
[(and (not ret-id)
|
||||
(not blocking?)
|
||||
(not orig-place?)
|
||||
(not exns?)
|
||||
(not save-errno)
|
||||
(#%andmap (lambda (in-type)
|
||||
(case (ctype-host-rep in-type)
|
||||
|
|
@ -1787,8 +1799,7 @@
|
|||
(when blocking? (currently-blocking? #t))
|
||||
(retain
|
||||
orig-args
|
||||
(let ([r (#%apply (gen-proc (cpointer-address proc-p))
|
||||
(append
|
||||
(let ([r (let ([args (append
|
||||
(if ret-ptr
|
||||
(begin
|
||||
(lock-cpointer ret-ptr)
|
||||
|
|
@ -1802,7 +1813,17 @@
|
|||
[(struct union)
|
||||
(maker (cpointer-address 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 blocking? (currently-blocking? #f))
|
||||
(case save-errno
|
||||
|
|
@ -1843,7 +1864,7 @@
|
|||
[arg (c->s type
|
||||
(case (ctype-host-rep type)
|
||||
[(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)
|
||||
#;
|
||||
(let* ([size (compound-ctype-size type)]
|
||||
|
|
@ -1918,6 +1939,9 @@
|
|||
(scheduler-start-atomic)
|
||||
;; Now that the schedule is in atomic mode, reenable interrupts (for GC)
|
||||
(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)])
|
||||
(disable-interrupts)
|
||||
(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?)
|
||||
(fields code))
|
||||
|
||||
|
|
@ -1982,7 +2046,9 @@
|
|||
(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)
|
||||
(check 'make-ffi-callback procedure? proc)
|
||||
(create-callback (make-code proc)))))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 8
|
||||
#define MZSCHEME_VERSION_Y 0
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 7
|
||||
#define MZSCHEME_VERSION_W 8
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user