diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index 6bdb574c21..94ffd8833d 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -705,12 +705,13 @@ For @tech{callbacks} to Racket functions with the generated type: @racket[keep] is based on the original function for the callback, not the result of @racket[wrapper].} - @item{If @racket[atomic?] is true, then when a Racket procedure is - given this procedure type and called as a @tech{callback} from - foreign code, then the Racket process is put into atomic mode - while evaluating the Racket procedure body. + @item{If @racket[atomic?] is true or when using the @CS[] variant of + Racket, then when a Racket procedure is given this type and + called as a @tech{callback} from foreign code, then the Racket + process is put into atomic mode while evaluating the Racket + procedure body. - In atomic mode, other Racket threads do not run, so the Racket + In atomic mode, other Racket threads do not run, so the Racket code must not call any function that potentially blocks on synchronization with other threads, or else it may lead to deadlock. In addition, the Racket code must not perform any @@ -718,7 +719,13 @@ For @tech{callbacks} to Racket functions with the generated type: 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.} + crash or misbehave. + + Callbacks are always atomic in the @CS[] variant of Racket, + because Racket threads do not capture C-stack context. Even on + the @3m[] or @CGC[] variants of Racket, atomic mode is + typically needed for callbacks, because capturing by copying a + portion of the C stack is often incompatible with C libraries.} @item{If a @racket[async-apply] is provided as a procedure or box, then a Racket @tech{callback} procedure with the generated procedure type can diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.c b/pkgs/racket-test-core/tests/racket/foreign-test.c index 1a31a62c27..40af3f089e 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.c +++ b/pkgs/racket-test-core/tests/racket/foreign-test.c @@ -290,14 +290,13 @@ void *do_f(void *_data) return data; } -X void* foreign_thread_callback(test_callback_t f, - void *data, - sleep_callback_t s) +X void** foreign_thread_callback_setup(test_callback_t f, + void *data) { pthread_t th; - void *r, **d; + void **d; - d = malloc(3 * sizeof(void*)); + d = malloc(4 * sizeof(void*)); d[0] = f; d[1] = data; d[2] = NULL; @@ -305,15 +304,42 @@ X void* foreign_thread_callback(test_callback_t f, if (pthread_create(&th, NULL, do_f, d)) return NULL; - while (!d[2]) { - s(); - } - + d[3] = (void *)th; + + return d; +} + +X int foreign_thread_callback_check_done(void **d) +{ + return d[2] != NULL; +} + +X void *foreign_thread_callback_finish(void **d) +{ + void *r; + pthread_t th = (pthread_t)d[3]; + if (pthread_join(th, &r)) return NULL; + free(d); + return r; } + +/* only works if callbacks can be in non-atomic mode: */ +X void* foreign_thread_callback(test_callback_t f, + void *data, + sleep_callback_t s) +{ + void **d = foreign_thread_callback_setup(f, data); + + while (!foreign_thread_callback_check_done(d)) { + s(); + } + + return foreign_thread_callback_finish(d); +} #endif /* This testing function doesn't work reliably on Windows, because it sometimes diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index 28c7b7083b..efeb58804b 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -869,15 +869,36 @@ ;; check async: (when test-async? (define (check async like) - (define foreign_thread_callback (get-ffi-obj 'foreign_thread_callback test-lib - (_fun #:blocking? #t - (_fun #:async-apply async - _intptr -> _intptr) - _intptr - (_fun #:async-apply (lambda (f) (f)) - -> _void) - -> _intptr))) - (test (like 16) foreign_thread_callback (lambda (v) (add1 v)) 16 sleep)) + (cond + [(eq? (system-type 'vm) 'racket) + (define foreign_thread_callback (get-ffi-obj 'foreign_thread_callback test-lib + (_fun #:blocking? #t + (_fun #:async-apply async + _intptr -> _intptr) + _intptr + (_fun #:async-apply (lambda (f) (f)) + -> _void) + -> _intptr))) + (test (like 16) foreign_thread_callback (lambda (v) (add1 v)) 16 sleep)] + [else + (define foreign_thread_callback_setup (get-ffi-obj 'foreign_thread_callback_setup test-lib + (_fun #:blocking? #t ; doesn't do anything in this case + (_fun #:async-apply async + _intptr -> _intptr) + _intptr + -> _pointer))) + (define foreign_thread_callback_check_done (get-ffi-obj 'foreign_thread_callback_check_done test-lib + (_fun _pointer + -> _bool))) + (define foreign_thread_callback_finish (get-ffi-obj 'foreign_thread_callback_finish test-lib + (_fun _pointer + -> _intptr))) + (define d (foreign_thread_callback_setup (lambda (v) (add1 v)) 16)) + (let loop () + (unless (foreign_thread_callback_check_done d) + (sleep) + (loop))) + (test (like 16) foreign_thread_callback_finish d)])) (check (lambda (f) (f)) add1) (check (box 20) (lambda (x) 20))) diff --git a/racket/src/cs/README.txt b/racket/src/cs/README.txt index 5b1175aa29..10e03be60d 100644 --- a/racket/src/cs/README.txt +++ b/racket/src/cs/README.txt @@ -381,6 +381,9 @@ several different ways: cannot be usefully passed to foreign functions, since the layout is not actually an array of pointers. + * Callbacks are always in atomic mode (i.e., the `#:atomic?` option + in `_fun` and `_cprocedure` is ignored). + Threads, Threads, Atomicity, Atomicity, and Atomicity ----------------------------------------------------- diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index e993420559..7a73ff74a1 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -1849,7 +1849,7 @@ (addr->gcpointer-memory arg)] [else arg])]))]) (cons arg (loop (cdr args) (cdr in-types))))]))))) - atomic? + (or #t atomic?) ; force all callbacks to be atomic async-apply async-callback-queue)]) (if ret-id