diff --git a/pkgs/racket-test/tests/racket/glib-log.rkt b/pkgs/racket-test/tests/racket/glib-log.rkt index f2c571456d..68dae8f664 100644 --- a/pkgs/racket-test/tests/racket/glib-log.rkt +++ b/pkgs/racket-test/tests/racket/glib-log.rkt @@ -38,14 +38,32 @@ [else (loop (subbytes bstr 0 (caar m))) (loop (subbytes bstr (cdar m)))]))])))) - (values - ;; pthread_create - (lambda (proc arg) - (call-in-os-thread (lambda () (proc arg)))) - ;; scheme_glib_log_message_test-pointer - scheme_glib_log_message_test - ;; scheme_glib_log_message_test - scheme_glib_log_message_test)] + (cond + ;; prefer C library `pthread_create`, because that makes the thread more foreign to Chez Scheme: + [(get-ffi-obj 'pthread_create #f (_fun (_ptr o _pointer) (_pointer = #f) _intptr _pointer -> _int) + (lambda () #f)) + => (lambda (pthread_create) + (values + pthread_create + (vm-eval + ;; We have to drop down to Chez Scheme here, because `__collect-safe` + ;; is accessible from Racket only via `#:async-apply`, and that ends up + ;; testing the FFI instead of a part of glib logging. + `(let ([callable (foreign-callable __collect_safe + ',scheme_glib_log_message_test + (string) + void)]) + (lock-object callable) + (foreign-callable-entry-point callable))) + scheme_glib_log_message_test))] + [else + (values + (lambda (proc arg) + (call-in-os-thread (lambda () (proc arg)))) + ;; scheme_glib_log_message_test-pointer + scheme_glib_log_message_test + ;; scheme_glib_log_message_test + scheme_glib_log_message_test)])] [else (values #f #f #f)])) diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index e63b2e7351..4d4d245a3a 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -494,6 +494,7 @@ (cond [(eqv? 0 (get-thread-id)) (go)] [else + (ensure-virtual-registers) (post-as-asynchronous-callback go)]))))]) (let ([callable (foreign-callable __collect_safe glib-log-message (string int string) void)]) (values diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index ed097ba98d..207c5eadf0 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -744,6 +744,7 @@ continuation-current-primitive call-as-asynchronous-callback post-as-asynchronous-callback + ensure-virtual-registers ;; compile-time use in "thread.sls" current-atomic-virtual-register diff --git a/racket/src/cs/rumble/async-callback.ss b/racket/src/cs/rumble/async-callback.ss index 8671cb4969..fadd41f6d2 100644 --- a/racket/src/cs/rumble/async-callback.ss +++ b/racket/src/cs/rumble/async-callback.ss @@ -22,7 +22,7 @@ (define (async-callback-queue-call async-callback-queue run-thunk thunk interrupts-disabled? need-atomic? wait-for-result?) (let* ([result-done? (box #f)] [result #f] - [q async-callback-queue] + [q (or async-callback-queue orig-place-async-callback-queue)] [m (async-callback-queue-lock q)]) (when interrupts-disabled? (enable-interrupts)) ; interrupt "lock" ordered after mutex (when need-atomic? (scheduler-start-atomic)) ; don't abandon engine after mutex is acquired diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index 1d004bb502..8e827ca072 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -1813,6 +1813,7 @@ ;; Not in a place's main thread; queue an async callback ;; and wait for the response (let ([known-thread? (eqv? (place-thread-category) PLACE-KNOWN-THREAD)]) + (unless known-thread? (ensure-virtual-registers)) (async-callback-queue-call async-callback-queue async-apply thunk diff --git a/racket/src/cs/rumble/virtual-register.ss b/racket/src/cs/rumble/virtual-register.ss index 2874061aa2..060b50e690 100644 --- a/racket/src/cs/rumble/virtual-register.ss +++ b/racket/src/cs/rumble/virtual-register.ss @@ -38,3 +38,10 @@ #'(define (id) init ... (set-virtual-register! future-pos #f)))])) + +(define (ensure-virtual-registers) + ;; Use the `current-future` register to detect when we're in a + ;; foreign thread that has not yet been initialized to run Rumble + ;; and later layers: + (when (eq? 0 (current-future)) + (init-virtual-registers)))