diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index ce9b9d3c6b..a8cefb948b 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/pkgs/racket-test/tests/racket/glib-log.rkt b/pkgs/racket-test/tests/racket/glib-log.rkt index d0d776e500..18232b65f5 100644 --- a/pkgs/racket-test/tests/racket/glib-log.rkt +++ b/pkgs/racket-test/tests/racket/glib-log.rkt @@ -1,20 +1,49 @@ #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 - (get-ffi-obj 'pthread_create #f (_fun (_ptr o _pointer) (_pointer = #f) _pointer _pointer -> _int) - (lambda () #f))) -(define scheme_glib_log_message_test-pointer - (get-ffi-obj 'scheme_glib_log_message_test #f _fpointer - (lambda () #f))) -(define scheme_glib_log_message_test - (get-ffi-obj 'scheme_glib_log_message_test #f (_fun _string -> _pointer) - (lambda () #f))) - +(define-values (pthread_create + scheme_glib_log_message_test-pointer + scheme_glib_log_message_test) + (case (system-type 'vm) + [(racket) + (values + (get-ffi-obj 'pthread_create #f (_fun (_ptr o _pointer) (_pointer = #f) _pointer _pointer -> _int) + (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) (define r (make-log-receiver (current-logger) 'warning)) diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index 73ee0ec7a6..cd69242433 100644 --- a/racket/src/cs/io.sls +++ b/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 diff --git a/racket/src/io/logger/main.rkt b/racket/src/io/logger/main.rkt index a7a97bd2e9..5d25b6ee73 100644 --- a/racket/src/io/logger/main.rkt +++ b/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) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 4d4bb1c2a5..c3862a8d45 100644 --- a/racket/src/racket/src/schvers.h +++ b/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