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

ffi/unsafe: add #:lock-name option to _fun and _cprocedure

Browse Source 
While `#:in-original-place? #t` provides one way to serialize
foreign calls, it acts as a single lock and requires expensive
context switches. Using an explicit lock can be more efficient
for serializing calls across different places.

For example, running "plot.scrbl" takes 70 seconds on my machine
in the original place and using `#:lock-name` in any place,
while it took 162 seconds in a non-main place with Cairo+Pango
serialization via `#:in-original-place? #t`.

Internally, the named lock combines compare-and-swap with a
place channel. That strategy gives good performance in the case
of no contention, and it cooperates properly with the Racket
scheduler where there is contention.
This commit is contained in:
Matthew Flatt 2015-06-24 16:36:56 +08:00
parent 9931d5ef1c
commit 290020c597
9 changed files with 357 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.2.0.4") (define version "6.2.0.5")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

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

@ -474,6 +474,7 @@ the later case, the result is the @racket[ctype]).}
[#:abi abi (or/c #f 'default 'stdcall 'sysv) #f] [#:abi abi (or/c #f 'default 'stdcall 'sysv) #f]
[#:atomic? atomic? any/c #f] [#:atomic? atomic? any/c #f]
[#:async-apply async-apply (or/c #f ((-> any/c) . -> . any/c) box?) #f] [#:async-apply async-apply (or/c #f ((-> any/c) . -> . any/c) box?) #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]
[#: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?))
@ -536,6 +537,12 @@ For @tech{callouts} to foreign functions with the generated type:
(for example, grabbing a value stored in an ``output'' pointer (for example, grabbing a value stored in an ``output'' pointer
and returning multiple values).} and returning multiple values).}
@item{If @racket[lock-name] is not @racket[#f], then a process-wide
lock with the given name is held during the foreign call. In a
build that supports parallel places, @racket[lock-name] is
registered via @cpp{scheme_register_process_global}, so choose
names that are suitably distinct.}
@item{If @racket[in-original-place?] is true, then when a foreign @item{If @racket[in-original-place?] is true, then when a foreign
@tech{callout} procedure with the generated type is called in @tech{callout} procedure with the generated type is called in
any Racket @tech-place[], the procedure any Racket @tech-place[], the procedure
@ -692,7 +699,8 @@ For @tech{callbacks} to Racket functions with the generated type:
is not used.} is not used.}
] ]
}
@history[#:changed "6.2.0.5" @elem{Added the @racket[#:lock-name] 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
@ -702,6 +710,7 @@ For @tech{callbacks} to Racket functions with the generated type:
(code:line #:keep keep-expr) (code:line #:keep keep-expr)
(code:line #:atomic? atomic?-expr) (code:line #:atomic? atomic?-expr)
(code:line #:async-apply async-apply-expr) (code:line #:async-apply async-apply-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 #:retry (retry-id [arg-id init-expr]))] (code:line #:retry (retry-id [arg-id init-expr]))]
[maybe-args code:blank [maybe-args code:blank
@ -821,7 +830,8 @@ specifications:
] ]
@history[#:changed "6.2" @elem{Added the @racket[#:retry] option.}]} @history[#:changed "6.2" @elem{Added the @racket[#:retry] option.}
#:changed "6.2.0.5" @elem{Added the @racket[#:lock-name] 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?])

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

@ -452,13 +452,14 @@
#:keep [keep #t] #:keep [keep #t]
#:atomic? [atomic? #f] #:atomic? [atomic? #f]
#:in-original-place? [orig-place? #f] #:in-original-place? [orig-place? #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 wrapper keep atomic? orig-place? async-apply errno)) (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno lock-name))
;; for internal use ;; for internal use
(define held-callbacks (make-weak-hasheq)) (define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno) (define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno lock-name)
(define-syntax-rule (make-it wrap) (define-syntax-rule (make-it wrap)
(make-ctype _fpointer (make-ctype _fpointer
(lambda (x) (lambda (x)
@ -471,7 +472,7 @@
(if (or (null? x) (pair? x)) (cons cb x) cb)))] (if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? keep) (keep cb)]) [(procedure? keep) (keep cb)])
cb))) cb)))
(lambda (x) (and x (wrap (ffi-call x itypes otype abi errno orig-place?)))))) (lambda (x) (and x (wrap (ffi-call x itypes otype abi errno orig-place? lock-name))))))
(if wrapper (make-it wrapper) (make-it begin))) (if wrapper (make-it wrapper) (make-it begin)))
;; Syntax for the special _fun type: ;; Syntax for the special _fun type:
@ -494,7 +495,8 @@
(provide _fun) (provide _fun)
(define-for-syntax _fun-keywords (define-for-syntax _fun-keywords
`([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] [#:in-original-place? ,#'#f] `([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f]
[#:in-original-place? ,#'#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)
@ -658,7 +660,8 @@
#,(kwd-ref '#:atomic?) #,(kwd-ref '#:atomic?)
#,(kwd-ref '#:in-original-place?) #,(kwd-ref '#:in-original-place?)
#,(kwd-ref '#:async-apply) #,(kwd-ref '#:async-apply)
#,(kwd-ref '#:save-errno)))]) #,(kwd-ref '#:save-errno)
#,(kwd-ref '#:lock-name)))])
(if (or (caddr output) input-names (ormap caddr inputs) (if (or (caddr output) input-names (ormap caddr inputs)
(ormap (lambda (x) (not (car x))) inputs) (ormap (lambda (x) (not (car x))) inputs)
(pair? bind) (pair? pre) (pair? post)) (pair? bind) (pair? pre) (pair? post))

154
racket/src/foreign/foreign.c
View File

@ -3207,6 +3207,132 @@ void do_ptr_finalizer(void *p, void *finalizer)
ptr = NULL; ptr = NULL;
} }
/*****************************************************************************/
/* FFI named locks */
THREAD_LOCAL_DECL(static Scheme_Hash_Table *ffi_lock_ht);
#ifdef MZ_PRECISE_GC
static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
Scheme_Object *vec;
void *original_gc;
original_gc = GC_switch_to_master_gc();
vec = scheme_make_vector(count, val);
GC_switch_back_from_master(original_gc);
return vec;
}
#endif
static void *name_to_ffi_lock(Scheme_Object *bstr)
{
Scheme_Object *lock;
if (!ffi_lock_ht) {
REGISTER_SO(ffi_lock_ht);
ffi_lock_ht = scheme_make_hash_table_equal();
}
lock = scheme_hash_get(ffi_lock_ht, bstr);
if (!lock) {
# ifdef MZ_USE_PLACES
/* implement the lock with a compare-and-swap with fallback (on
contention) to a place channel; this strategy has minimal
overhead when there's no contention, which is good for avoiding
a penalty in the common case of a single place (but it's probably
not the best strategy for a contended lock) */
void *lock_box, *old_lock_box;
lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), NULL);
if (!lock_box) {
lock = scheme_place_make_async_channel();
lock = make_vector_in_master(2, lock);
SCHEME_VEC_ELS(lock)[1] = scheme_make_integer(-1);
lock_box = scheme_malloc_immobile_box(lock);
old_lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), lock_box);
if (old_lock_box) {
scheme_free_immobile_box(lock_box);
lock_box = old_lock_box;
}
}
lock = *(Scheme_Object **)lock_box;
# else /* MZ_USE_PLACES undefined */
lock = scheme_make_sema(1);
# endif /* MZ_USE_PLACES */
scheme_hash_set(ffi_lock_ht, bstr, lock);
}
return lock;
}
static void wait_ffi_lock(Scheme_Object *lock)
{
# ifdef MZ_USE_PLACES
while (1) {
if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)scheme_make_integer(-1),
(uintptr_t)scheme_make_integer(scheme_current_place_id))) {
/* obtained lock the fast way */
break;
} else {
Scheme_Object *owner, *new_val;
owner = SCHEME_VEC_ELS(lock)[1];
if (SCHEME_INT_VAL(owner) != -1) {
if (SCHEME_INT_VAL(owner) < -1) {
/* other processes waiting, and now there's one more: */
new_val = scheme_make_integer(SCHEME_INT_VAL(owner)-1);
} else {
/* notify owner that another process is now waiting: */
new_val = scheme_make_integer(-2);
}
if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)owner,
(uintptr_t)new_val)) {
/* wait for lock the slow way - without blocking other Racket threads */
(void)scheme_place_async_channel_receive(SCHEME_VEC_ELS(lock)[0]);
/* not waiting anymore: */
while (1) {
owner = SCHEME_VEC_ELS(lock)[1];
if (SCHEME_INT_VAL(owner) == -2) {
/* no other processes waiting */
new_val = scheme_make_integer(scheme_current_place_id);
} else {
/* one less process waiting */
new_val = scheme_make_integer(SCHEME_INT_VAL(owner)+1);
}
if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)owner,
(uintptr_t)new_val)) {
break;
}
}
break;
}
}
}
}
# else /* MZ_USE_PLACES undefined */
scheme_wait_sema(lock, 0);
# endif /* MZ_USE_PLACES */
}
static void release_ffi_lock(void *lock)
{
# ifdef MZ_USE_PLACES
if (mzrt_cas((uintptr_t *)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)scheme_make_integer(scheme_current_place_id),
(uintptr_t)scheme_make_integer(-1))) {
/* released lock with no other process waiting */
} else {
/* assert: SCHEME_VEC_ELS(lock)[1] holds a negative
number corresponding to the number of waiting processes */
scheme_place_async_channel_send(SCHEME_VEC_ELS(lock)[0], scheme_false);
}
# else /* MZ_USE_PLACES undefined */
scheme_post_sema(lock);
# endif /* MZ_USE_PLACES */
}
/*****************************************************************************/ /*****************************************************************************/
/* Calling foreign function objects */ /* Calling foreign function objects */
@ -3385,8 +3511,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); intptr_t cfoff = 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];
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
#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
@ -3459,6 +3586,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
newp = NULL; newp = NULL;
} }
if (SCHEME_TRUEP(lock))
wait_ffi_lock(lock);
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
if (orig_place) if (orig_place)
ffi_call_in_orig_place(cif, c_func, cfoff, ffi_call_in_orig_place(cif, c_func, cfoff,
@ -3470,6 +3600,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
nargs, ivals, avalues, nargs, ivals, avalues,
offsets, p); offsets, p);
if (SCHEME_TRUEP(lock))
release_ffi_lock(lock);
/* Use `data' to make sure it's kept alive (as far as the GC is concerned) /* Use `data' to make sure it's kept alive (as far as the GC is concerned)
until the foreign call returns: */ until the foreign call returns: */
if ((void*)data == (void*)scheme_true) if ((void*)data == (void*)scheme_true)
@ -3546,11 +3679,12 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
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;
Scheme_Object *lock = scheme_false;
# ifdef MZ_USE_PLACES # ifdef MZ_USE_PLACES
int orig_place; int orig_place;
# define FFI_CALL_VEC_SIZE 8 # define FFI_CALL_VEC_SIZE 9
# else /* MZ_USE_PLACES undefined */ # else /* MZ_USE_PLACES undefined */
# define FFI_CALL_VEC_SIZE 7 # define FFI_CALL_VEC_SIZE 8
# endif /* MZ_USE_PLACES */ # endif /* MZ_USE_PLACES */
cp = unwrap_cpointer_property(argv[0]); cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp)) if (!SCHEME_FFIANYPTRP(cp))
@ -3586,6 +3720,13 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]); if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]);
else orig_place = 0; else orig_place = 0;
# endif /* MZ_USE_PLACES */ # endif /* MZ_USE_PLACES */
if (argc > 6) {
if (!SCHEME_FALSEP(argv[6])) {
if (!SCHEME_CHAR_STRINGP(argv[6]))
scheme_wrong_contract(MYNAME, "(or/c string? #f)", 4, argc, argv);
lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[6]));
}
}
if (SCHEME_FFIOBJP(cp)) if (SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
else else
@ -3609,8 +3750,9 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif; SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
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;
# ifdef MZ_USE_PLACES # ifdef MZ_USE_PLACES
SCHEME_VEC_ELS(data)[7] = (orig_place ? scheme_true : scheme_false); SCHEME_VEC_ELS(data)[8] = (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;
@ -4305,7 +4447,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("make-sized-byte-string", scheme_add_global_constant("make-sized-byte-string",
scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
scheme_add_global_constant("ffi-call", scheme_add_global_constant("ffi-call",
scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 6), menv); scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 7), menv);
scheme_add_global_constant("ffi-callback", scheme_add_global_constant("ffi-callback",
scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), menv); scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), menv);
scheme_add_global_constant("saved-errno", scheme_add_global_constant("saved-errno",
@ -4654,7 +4796,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("make-sized-byte-string", scheme_add_global_constant("make-sized-byte-string",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv);
scheme_add_global_constant("ffi-call", scheme_add_global_constant("ffi-call",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 6), menv); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 7), menv);
scheme_add_global_constant("ffi-callback", scheme_add_global_constant("ffi-callback",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv);
scheme_add_global_constant("saved-errno", scheme_add_global_constant("saved-errno",

152
racket/src/foreign/foreign.rktc
View File

@ -2372,6 +2372,132 @@ void do_ptr_finalizer(void *p, void *finalizer)
ptr = NULL; ptr = NULL;
} }
/*****************************************************************************/
/* FFI named locks */
THREAD_LOCAL_DECL(static Scheme_Hash_Table *ffi_lock_ht);
#ifdef MZ_PRECISE_GC
static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
Scheme_Object *vec;
void *original_gc;
original_gc = GC_switch_to_master_gc();
vec = scheme_make_vector(count, val);
GC_switch_back_from_master(original_gc);
return vec;
}
#endif
static void *name_to_ffi_lock(Scheme_Object *bstr)
{
Scheme_Object *lock;
if (!ffi_lock_ht) {
REGISTER_SO(ffi_lock_ht);
ffi_lock_ht = scheme_make_hash_table_equal();
}
lock = scheme_hash_get(ffi_lock_ht, bstr);
if (!lock) {
@@@IFDEF{MZ_USE_PLACES}{
/* implement the lock with a compare-and-swap with fallback (on
contention) to a place channel; this strategy has minimal
overhead when there's no contention, which is good for avoiding
a penalty in the common case of a single place (but it's probably
not the best strategy for a contended lock) */
void *lock_box, *old_lock_box;
lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), NULL);
if (!lock_box) {
lock = scheme_place_make_async_channel();
lock = make_vector_in_master(2, lock);
SCHEME_VEC_ELS(lock)[1] = scheme_make_integer(-1);
lock_box = scheme_malloc_immobile_box(lock);
old_lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), lock_box);
if (old_lock_box) {
scheme_free_immobile_box(lock_box);
lock_box = old_lock_box;
}
}
lock = *(Scheme_Object **)lock_box;
}{
lock = scheme_make_sema(1);
}
scheme_hash_set(ffi_lock_ht, bstr, lock);
}
return lock;
}
static void wait_ffi_lock(Scheme_Object *lock)
{
@@@IFDEF{MZ_USE_PLACES}{
while (1) {
if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)scheme_make_integer(-1),
(uintptr_t)scheme_make_integer(scheme_current_place_id))) {
/* obtained lock the fast way */
break;
} else {
Scheme_Object *owner, *new_val;
owner = SCHEME_VEC_ELS(lock)[1];
if (SCHEME_INT_VAL(owner) != -1) {
if (SCHEME_INT_VAL(owner) < -1) {
/* other processes waiting, and now there's one more: */
new_val = scheme_make_integer(SCHEME_INT_VAL(owner)-1);
} else {
/* notify owner that another process is now waiting: */
new_val = scheme_make_integer(-2);
}
if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)owner,
(uintptr_t)new_val)) {
/* wait for lock the slow way - without blocking other Racket threads */
(void)scheme_place_async_channel_receive(SCHEME_VEC_ELS(lock)[0]);
/* not waiting anymore: */
while (1) {
owner = SCHEME_VEC_ELS(lock)[1];
if (SCHEME_INT_VAL(owner) == -2) {
/* no other processes waiting */
new_val = scheme_make_integer(scheme_current_place_id);
} else {
/* one less process waiting */
new_val = scheme_make_integer(SCHEME_INT_VAL(owner)+1);
}
if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)owner,
(uintptr_t)new_val)) {
break;
}
}
break;
}
}
}
}
}{
scheme_wait_sema(lock, 0);
}
}
static void release_ffi_lock(void *lock)
{
@@@IFDEF{MZ_USE_PLACES}{
if (mzrt_cas((uintptr_t *)&(SCHEME_VEC_ELS(lock)[1]),
(uintptr_t)scheme_make_integer(scheme_current_place_id),
(uintptr_t)scheme_make_integer(-1))) {
/* released lock with no other process waiting */
} else {
/* assert: SCHEME_VEC_ELS(lock)[1] holds a negative
number corresponding to the number of waiting processes */
scheme_place_async_channel_send(SCHEME_VEC_ELS(lock)[0], scheme_false);
}
}{
scheme_post_sema(lock);
}
}
/*****************************************************************************/ /*****************************************************************************/
/* Calling foreign function objects */ /* Calling foreign function objects */
@ -2550,8 +2676,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); intptr_t cfoff = 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];
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
#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
@ -2624,6 +2751,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
newp = NULL; newp = NULL;
} }
if (SCHEME_TRUEP(lock))
wait_ffi_lock(lock);
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
if (orig_place) if (orig_place)
ffi_call_in_orig_place(cif, c_func, cfoff, ffi_call_in_orig_place(cif, c_func, cfoff,
@ -2635,6 +2765,9 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object
nargs, ivals, avalues, nargs, ivals, avalues,
offsets, p); offsets, p);
if (SCHEME_TRUEP(lock))
release_ffi_lock(lock);
/* Use `data' to make sure it's kept alive (as far as the GC is concerned) /* Use `data' to make sure it's kept alive (as far as the GC is concerned)
until the foreign call returns: */ until the foreign call returns: */
if ((void*)data == (void*)scheme_true) if ((void*)data == (void*)scheme_true)
@ -2700,7 +2833,7 @@ static Scheme_Object *ffi_name = NULL;
/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ /* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (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 6]{ @cdefine[ffi-call 3 7]{
Scheme_Object *itypes = argv[1]; Scheme_Object *itypes = argv[1];
Scheme_Object *otype = argv[2]; Scheme_Object *otype = argv[2];
Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1]; Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1];
@ -2709,11 +2842,12 @@ static Scheme_Object *ffi_name = NULL;
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;
Scheme_Object *lock = scheme_false;
@@@IFDEF{MZ_USE_PLACES}{ @@@IFDEF{MZ_USE_PLACES}{
int orig_place; int orig_place;
@DEFINE{FFI_CALL_VEC_SIZE 8} @DEFINE{FFI_CALL_VEC_SIZE 9}
}{ }{
@DEFINE{FFI_CALL_VEC_SIZE 7} @DEFINE{FFI_CALL_VEC_SIZE 8}
} }
cp = unwrap_cpointer_property(argv[0]); cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_FFIANYPTRP(cp)) if (!SCHEME_FFIANYPTRP(cp))
@ -2749,6 +2883,13 @@ static Scheme_Object *ffi_name = NULL;
if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]); if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]);
else orig_place = 0; else orig_place = 0;
} }
if (argc > 6) {
if (!SCHEME_FALSEP(argv[6])) {
if (!SCHEME_CHAR_STRINGP(argv[6]))
scheme_wrong_contract(MYNAME, "(or/c string? #f)", 4, argc, argv);
lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[6]));
}
}
if (SCHEME_FFIOBJP(cp)) if (SCHEME_FFIOBJP(cp))
name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
else else
@ -2772,8 +2913,9 @@ static Scheme_Object *ffi_name = NULL;
SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif; SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
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;
@@IFDEF{MZ_USE_PLACES}{ @@IFDEF{MZ_USE_PLACES}{
SCHEME_VEC_ELS(data)[7] = (orig_place ? scheme_true : scheme_false); SCHEME_VEC_ELS(data)[8] = (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;

2
racket/src/racket/include/schthread.h
View File

@ -369,6 +369,7 @@ typedef struct Thread_Local_Variables {
void *scheme_inotify_server_; void *scheme_inotify_server_;
struct Scheme_Object *configuration_callback_cache_[2]; struct Scheme_Object *configuration_callback_cache_[2];
struct FFI_Orig_Place_Call *cached_orig_place_todo_; struct FFI_Orig_Place_Call *cached_orig_place_todo_;
struct Scheme_Hash_Table *ffi_lock_ht_;
} Thread_Local_Variables; } Thread_Local_Variables;
#if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS)
@ -755,6 +756,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define scheme_inotify_server XOA (scheme_get_thread_local_variables()->scheme_inotify_server_) #define scheme_inotify_server XOA (scheme_get_thread_local_variables()->scheme_inotify_server_)
#define configuration_callback_cache XOA (scheme_get_thread_local_variables()->configuration_callback_cache_) #define configuration_callback_cache XOA (scheme_get_thread_local_variables()->configuration_callback_cache_)
#define cached_orig_place_todo XOA (scheme_get_thread_local_variables()->cached_orig_place_todo_) #define cached_orig_place_todo XOA (scheme_get_thread_local_variables()->cached_orig_place_todo_)
#define ffi_lock_ht XOA (scheme_get_thread_local_variables()->ffi_lock_ht_)
/* **************************************** */ /* **************************************** */

38
racket/src/racket/src/place.c
View File

@ -3078,6 +3078,18 @@ static void async_channel_refcount(Scheme_Place_Async_Channel *ch, int for_send,
mzrt_mutex_unlock(ch->lock); mzrt_mutex_unlock(ch->lock);
} }
Scheme_Object *scheme_place_make_async_channel()
{
Scheme_Place_Async_Channel *ch;
ch = place_async_channel_create();
/* we don't allocate a bi channel, so claim an implicit sender and receiver: */
async_channel_refcount(ch, 0, 1);
async_channel_refcount(ch, 1, 1);
return (Scheme_Object *)ch;
}
static void bi_channel_refcount(Scheme_Place_Bi_Channel *ch, int delta) static void bi_channel_refcount(Scheme_Place_Bi_Channel *ch, int delta)
{ {
async_channel_refcount(ch->link->sendch, 1, delta); async_channel_refcount(ch->link->sendch, 1, delta);
@ -3369,6 +3381,10 @@ static void place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *uo)
mzrt_mutex_unlock(ch->lock); mzrt_mutex_unlock(ch->lock);
} }
void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo) {
place_async_send((Scheme_Place_Async_Channel *)ch, uo);
}
static void place_object_inc_refcount(Scheme_Object *o) { static void place_object_inc_refcount(Scheme_Object *o) {
Scheme_Place_Object *place_obj; Scheme_Place_Object *place_obj;
place_obj = (Scheme_Place_Object *) o; place_obj = (Scheme_Place_Object *) o;
@ -3399,6 +3415,9 @@ static void lock_and_register_place_object_with_channel(Scheme_Place_Async_Chann
mzrt_mutex_lock(ch->lock); mzrt_mutex_lock(ch->lock);
if (ch->count)
return; /* no need for a wakeup signal, since data is available */
/* loop in case we need to release the lock temporarily to allocate: */ /* loop in case we need to release the lock temporarily to allocate: */
while (1) { while (1) {
if (ch->wakeup_signal == o) { if (ch->wakeup_signal == o) {
@ -3483,8 +3502,8 @@ static void lock_and_register_place_object_with_channel(Scheme_Place_Async_Chann
} }
} }
static Scheme_Object *scheme_place_async_try_receive_raw(Scheme_Place_Async_Channel *ch, void **msg_memory_ptr, static Scheme_Object *place_async_try_receive_raw(Scheme_Place_Async_Channel *ch, void **msg_memory_ptr,
int *_no_writers) int *_no_writers)
/* The result must not be retained past extraction from `*msg_memory_ptr'! */ /* The result must not be retained past extraction from `*msg_memory_ptr'! */
{ {
Scheme_Object *msg = NULL; Scheme_Object *msg = NULL;
@ -3532,12 +3551,12 @@ static void cleanup_msg_memmory(void *thread) {
} }
} }
static Scheme_Object *scheme_place_async_try_receive(Scheme_Place_Async_Channel *ch, int *_no_writers) { static Scheme_Object *place_async_try_receive(Scheme_Place_Async_Channel *ch, int *_no_writers) {
Scheme_Object *msg = NULL; Scheme_Object *msg = NULL;
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
GC_CAN_IGNORE void *msg_memory; GC_CAN_IGNORE void *msg_memory;
BEGIN_ESCAPEABLE(cleanup_msg_memmory, p); BEGIN_ESCAPEABLE(cleanup_msg_memmory, p);
msg = scheme_place_async_try_receive_raw(ch, &msg_memory, _no_writers); msg = place_async_try_receive_raw(ch, &msg_memory, _no_writers);
if (msg) { if (msg) {
p->place_channel_msg_in_flight = msg_memory; p->place_channel_msg_in_flight = msg_memory;
msg = scheme_places_deserialize(msg, msg_memory); msg = scheme_places_deserialize(msg, msg_memory);
@ -3587,8 +3606,8 @@ static int place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo) {
ch = (Scheme_Place_Bi_Channel *)so; ch = (Scheme_Place_Bi_Channel *)so;
} }
msg = scheme_place_async_try_receive_raw((Scheme_Place_Async_Channel *) ch->link->recvch, msg = place_async_try_receive_raw((Scheme_Place_Async_Channel *) ch->link->recvch,
&msg_memory, &no_writers); &msg_memory, &no_writers);
if (msg != NULL) { if (msg != NULL) {
Scheme_Object **msg_holder; Scheme_Object **msg_holder;
Scheme_Thread *p = ((Syncing *)(sinfo->current_syncing))->thread; Scheme_Thread *p = ((Syncing *)(sinfo->current_syncing))->thread;
@ -3621,7 +3640,7 @@ static Scheme_Object *place_async_receive(Scheme_Place_Async_Channel *ch) {
int no_writers = 0; int no_writers = 0;
while (1) { while (1) {
msg = scheme_place_async_try_receive(ch, &no_writers); msg = place_async_try_receive(ch, &no_writers);
if (msg) if (msg)
break; break;
else { else {
@ -3629,7 +3648,6 @@ static Scheme_Object *place_async_receive(Scheme_Place_Async_Channel *ch) {
/* No writers are left for this channel, so suspend the thread */ /* No writers are left for this channel, so suspend the thread */
scheme_wait_sema(scheme_make_sema(0), 0); scheme_wait_sema(scheme_make_sema(0), 0);
} }
scheme_thread_block(0); scheme_thread_block(0);
scheme_block_until((Scheme_Ready_Fun) scheme_place_async_ch_ready, NULL, (Scheme_Object *) ch, 0); scheme_block_until((Scheme_Ready_Fun) scheme_place_async_ch_ready, NULL, (Scheme_Object *) ch, 0);
} }
@ -3638,6 +3656,10 @@ static Scheme_Object *place_async_receive(Scheme_Place_Async_Channel *ch) {
return msg; return msg;
} }
Scheme_Object *scheme_place_async_channel_receive(Scheme_Object *ch) {
return place_async_receive((Scheme_Place_Async_Channel *)ch);
}
/*========================================================================*/ /*========================================================================*/
/* precise GC traversers */ /* precise GC traversers */
/*========================================================================*/ /*========================================================================*/

8
racket/src/racket/src/schpriv.h
View File

@ -4108,6 +4108,8 @@ intptr_t scheme_check_overflow(intptr_t n, intptr_t m, intptr_t a);
Scheme_Object *scheme_make_environment_variables(Scheme_Hash_Tree *ht); Scheme_Object *scheme_make_environment_variables(Scheme_Hash_Tree *ht);
void *scheme_environment_variables_to_block(Scheme_Object *env, int *_need_free); void *scheme_environment_variables_to_block(Scheme_Object *env, int *_need_free);
int scheme_compare_equal(void *v1, void *v2);
/*========================================================================*/ /*========================================================================*/
/* places */ /* places */
/*========================================================================*/ /*========================================================================*/
@ -4251,6 +4253,10 @@ void scheme_place_set_memory_use(intptr_t amt);
void scheme_place_check_memory_use(); void scheme_place_check_memory_use();
void scheme_clear_place_ifs_stack(); void scheme_clear_place_ifs_stack();
int scheme_compare_equal(void *v1, void *v2); #ifdef MZ_USE_PLACES
Scheme_Object *scheme_place_make_async_channel();
void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo);
Scheme_Object *scheme_place_async_channel_receive(Scheme_Object *ch);
#endif
#endif /* __mzscheme_private__ */ #endif /* __mzscheme_private__ */

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.2.0.4" #define MZSCHEME_VERSION "6.2.0.5"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)