cs: add glib logging hook

Building glib-specific support into the main Racket executable is
unsatisfying, but it's consistent with Racket BC, and the alternative
is especially tedious to deal with places and namespaces and
allocation.

pkgs/base/info.rkt

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

pkgs/racket-test/tests/racket/glib-log.rkt

@@ -1,19 +1,48 @@
 #lang racket/base
 (require ffi/unsafe
+         ffi/unsafe/os-thread
+         ffi/unsafe/vm
          rackunit)
 
 ;; Check whether glib-logging support works right when use by
 ;; different threads
 
-(define pthread_create
+(define-values (pthread_create
-  (get-ffi-obj 'pthread_create #f (_fun (_ptr o _pointer) (_pointer = #f) _pointer _pointer -> _int)
+                scheme_glib_log_message_test-pointer
-               (lambda () #f)))
+                scheme_glib_log_message_test)
-(define scheme_glib_log_message_test-pointer
+  (case (system-type 'vm)
-  (get-ffi-obj 'scheme_glib_log_message_test #f _fpointer
+    [(racket)
-               (lambda () #f)))
+     (values
-(define scheme_glib_log_message_test
+      (get-ffi-obj 'pthread_create #f (_fun (_ptr o _pointer) (_pointer = #f) _pointer _pointer -> _int)
-  (get-ffi-obj 'scheme_glib_log_message_test #f (_fun _string -> _pointer)
+                   (lambda () #f))
-               (lambda () #f)))
+      (get-ffi-obj 'scheme_glib_log_message_test #f _fpointer
+                   (lambda () #f))
+      (get-ffi-obj 'scheme_glib_log_message_test #f (_fun _string -> _pointer)
+                   (lambda () #f)))]
+    [(chez-scheme)
+     (define scheme_glib_log_message_test
+       (let ([glib-log-message (cast (vm-primitive 'glib-log-message)
+                                     _intptr
+                                     (_fun _bytes/nul-terminated _int _bytes/nul-terminated -> _void))])
+         (lambda (msg)
+           (let loop ([bstr (if (string? msg) (string->bytes/utf-8 msg) (cast msg _pointer _bytes))])
+             (define m (regexp-match-positions #rx";" bstr))
+             (cond
+               [(not m)
+                (glib-log-message #"test" (arithmetic-shift 1 4) bstr)]
+               [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)]
+    [else
+     (values #f #f #f)]))
     
 (when (and pthread_create
            scheme_glib_log_message_test-pointer)

racket/src/cs/io.sls

@@ -440,6 +440,46 @@
 
   ;; ----------------------------------------
 
+  ;; For glib logging, we need a function pointer that works across
+  ;; places and logs to the main place's root logger. Although it's
+  ;; kind of a hack, it's much simpler to implement that here and
+  ;; export the function pointer as a primitive.
+  
+  (export glib-log-message)
+
+  (define G_LOG_LEVEL_ERROR    2)
+  (define G_LOG_LEVEL_CRITICAL 3)
+  (define G_LOG_LEVEL_WARNING  4)
+  (define G_LOG_LEVEL_MESSAGE  5)
+  (define G_LOG_LEVEL_INFO     6)
+  (define G_LOG_LEVEL_DEBUG    7)
+  
+  (define glib-log-message
+    (let ([glib-log-message
+           (lambda (domain glib-level message)
+             (let ([level (cond
+                           [(fxbit-set? glib-level G_LOG_LEVEL_ERROR) 'fatal]
+                           [(fxbit-set? glib-level G_LOG_LEVEL_CRITICAL) 'error]
+                           [(fxbit-set? glib-level G_LOG_LEVEL_WARNING) 'warning]
+                           [(fxbit-set? glib-level G_LOG_LEVEL_MESSAGE) 'warning]
+                           [(fxbit-set? glib-level G_LOG_LEVEL_INFO) 'info]
+                           [else 'debug])])
+               (let ([go (lambda ()
+                           (unsafe-start-atomic)
+                           (disable-interrupts)
+                           (log-message* (unsafe-root-logger) level #f (string-append domain ": " message) #f #f #f)
+                           (enable-interrupts)
+                           (unsafe-end-atomic))])
+                 (cond
+                  [(eqv? 0 (get-thread-id)) (go)]
+                  [else
+                   (post-as-asynchronous-callback go)]))))])
+      (let ([callable (foreign-callable __collect_safe glib-log-message (string int string) void)])
+        (lock-object callable)
+        (foreign-callable-entry-point callable))))
+  
+  ;; ----------------------------------------
+
   (export system-library-subpath)
   (define system-library-subpath
     (case-lambda

racket/src/io/logger/main.rkt

@@ -10,6 +10,7 @@
 (provide logger?
          logger-name
          current-logger
+         unsafe-root-logger
          make-logger
          log-level?
          log-level?*   ; ok to call in host-Scheme interrupt handler
@@ -34,6 +35,8 @@
 
 (define-place-local root-logger (make-root-logger))
 
+(define (unsafe-root-logger) root-logger)
+
 (define current-logger
   (make-parameter root-logger
                   (lambda (l)

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 6
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 12
+#define MZSCHEME_VERSION_W 13
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x