cs: fix glib logging from a foreign thread

When a glib message is logged in an OS thread not created by Racket,
then the current-future and async-callback-queue thread-local
variables were not initialized. The failure mode tended to be an
unending and memory-consuming cycle of triggering an error while
attempting to report an error.

Although there was a test for proper handling of logging calls from
foreign threads, the test previously created the "foreign" thread with
`call-in-os-thread`, which is not foreign enough.

Related to #3832

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)]))
     

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

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

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

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

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)))