make glib logging hook work with extra threads

If an OS-level thread other than a Racket thread logs a message, then
the message needs to be queued instead of handled immediately.

If multiple places are running, then the right handler thread is not
clear, so just queue to the main place's thread.

Closes racket/gui#66
Closes racket/drracket#77

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

@@ -0,0 +1,44 @@
+#lang racket/base
+(require ffi/unsafe
+         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)))
+
+(when (and pthread_create
+           scheme_glib_log_message_test-pointer)
+  (define r (make-log-receiver (current-logger) 'warning))
+  (scheme_glib_log_message_test "hello")
+  (check-equal? '#(warning "test: hello" #f #f) (sync r))
+  
+  (check-equal? #f (sync/timeout 0 r))
+  
+  (define (make s)
+    (define p (malloc (add1 (bytes-length s)) 'raw))
+    (memcpy p s (bytes-length s))
+    p)
+  
+  (define hello (make #"hello"))
+  (pthread_create scheme_glib_log_message_test-pointer hello)
+  (check-equal? '#(warning "test: hello" #f #f) (sync r))
+  
+  ;; Make sure it's a queue (preserves order):
+  (define seq (make #"first;middle;last"))
+  (pthread_create scheme_glib_log_message_test-pointer seq)
+  (check-equal? '#(warning "test: first" #f #f) (sync r))
+  (check-equal? '#(warning "test: middle" #f #f) (sync r))
+  (check-equal? '#(warning "test: last" #f #f) (sync r))
+  
+  (printf "Used: ~s\n" (list hello seq))
+  
+  (printf "glib logging support ok\n"))

racket/src/racket/include/mzwin.def

@@ -112,6 +112,7 @@ EXPORTS
  scheme_log_abort
  scheme_log_warning
  scheme_glib_log_message
+ scheme_glib_log_message_test
  scheme_out_of_memory_abort
  scheme_wrong_count
  scheme_wrong_count_m

racket/src/racket/include/mzwin3m.def

@@ -112,6 +112,7 @@ EXPORTS
  scheme_log_abort
  scheme_log_warning
  scheme_glib_log_message
+ scheme_glib_log_message_test
  scheme_out_of_memory_abort
  scheme_wrong_count
  scheme_wrong_count_m

racket/src/racket/include/racket.exp

@@ -109,6 +109,7 @@ scheme_log_name_pfx_message
 scheme_log_abort
 scheme_log_warning
 scheme_glib_log_message
+scheme_glib_log_message_test
 scheme_out_of_memory_abort
 scheme_wrong_count
 scheme_wrong_count_m

racket/src/racket/include/racket3m.exp

@@ -109,6 +109,7 @@ scheme_log_name_pfx_message
 scheme_log_abort
 scheme_log_warning
 scheme_glib_log_message
+scheme_glib_log_message_test
 scheme_out_of_memory_abort
 scheme_wrong_count
 scheme_wrong_count_m

racket/src/racket/include/schthread.h

@@ -142,6 +142,7 @@ typedef struct Thread_Local_Variables {
   uintptr_t GC_gen0_alloc_page_end_;
   int GC_gen0_alloc_only_;
   uintptr_t force_gc_for_place_accounting_;
+  uintptr_t scheme_os_thread_id_;
   int scheme_starting_up_;
   void *bignum_cache_[BIGNUM_CACHE_SIZE];
   int cache_count_;
@@ -546,6 +547,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define GC_gen0_alloc_only XOA (scheme_get_thread_local_variables()->GC_gen0_alloc_only_)
 #define GC_variable_stack XOA (scheme_get_thread_local_variables()->GC_variable_stack_)
 #define force_gc_for_place_accounting XOA (scheme_get_thread_local_variables()->force_gc_for_place_accounting_)
+#define scheme_os_thread_id XOA (scheme_get_thread_local_variables()->scheme_os_thread_id_)
 #define scheme_starting_up XOA (scheme_get_thread_local_variables()->scheme_starting_up_)
 #define bignum_cache XOA (scheme_get_thread_local_variables()->bignum_cache_)
 #define cache_count XOA (scheme_get_thread_local_variables()->cache_count_)

racket/src/racket/src/error.c

@@ -87,11 +87,22 @@ ROSYM static Scheme_Object *def_exe_yield_proc;
 READ_ONLY Scheme_Object *scheme_def_exit_proc;
 READ_ONLY Scheme_Object *scheme_raise_arity_error_proc;
 
-
 #ifdef MEMORY_COUNTING_ON
 intptr_t scheme_misc_count;
 #endif
 
+#ifdef MZ_USE_MZRT
+static mzrt_mutex *glib_log_queue_lock;
+typedef struct glib_log_queue_entry {
+  const char *log_domain;
+  int log_level;
+  const char *message;
+  struct glib_log_queue_entry *next;
+} glib_log_queue_entry;
+static glib_log_queue_entry *glib_log_queue;
+static void *glib_log_signal_handle;
+#endif
+
 /* locals */
 static Scheme_Object *error(int argc, Scheme_Object *argv[]);
 static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
@@ -3916,14 +3927,11 @@ void scheme_log_warning(char *buffer)
   scheme_log_message(scheme_main_logger, SCHEME_LOG_WARNING, buffer, strlen(buffer), scheme_false);
 }
 
-void scheme_glib_log_message(const char *log_domain,
+static void glib_log_message(const char *log_domain,
                              int log_level,
                              const char *message,
                              void *user_data)
-/* This handler is suitable for use as a glib logging handler.
-   Although a handler can be implemented with the FFI,
-   we build one into Racket to avoid potential problems of
-   handlers getting GCed or retaining a namespace. */
+/* in the main thread for some place */
 {
 #define mzG_LOG_LEVEL_ERROR    (1 << 2)
 #define mzG_LOG_LEVEL_CRITICAL (1 << 3)
@@ -3959,6 +3967,97 @@ void scheme_glib_log_message(const char *log_domain,
   scheme_log_message(scheme_main_logger, level, together, len2, scheme_false);
 }
 
+void scheme_glib_log_message(const char *log_domain,
+                             int log_level,
+                             const char *message,
+                             void *user_data)
+  XFORM_SKIP_PROC
+/* This handler is suitable for use as a glib logging handler.
+   Although a handler can be implemented with the FFI,
+   we build one into Racket to avoid potential problems of
+   handlers getting GCed or retaining a namespace. */
+{
+  if (scheme_is_place_main_os_thread())
+    glib_log_message(log_domain, log_level, message, user_data);
+  else {
+    /* We're in an unknown thread. Queue the message for the main Racket place's thread. */
+#ifdef MZ_USE_MZRT
+    glib_log_queue_entry *e = malloc(sizeof(glib_log_queue_entry));
+    e->log_domain = strdup(log_domain);
+    e->log_level = log_level;
+    e->message = strdup(message);
+    
+    mzrt_mutex_lock(glib_log_queue_lock);
+    e->next = glib_log_queue;
+    glib_log_queue = e;
+    mzrt_mutex_unlock(glib_log_queue_lock);
+
+    scheme_signal_received_at(glib_log_signal_handle);
+#else
+    /* We shouldn't get here, but just in case: */
+    fprintf(stderr, "%s: %s\n", log_domain, message);
+#endif
+  }
+}
+
+/* For use by testing, suitable for use with pthread_create, logs a
+   warning for ";"-separated messages in `str` */
+void *scheme_glib_log_message_test(char *str)
+  XFORM_SKIP_PROC
+{
+  int i;
+  for (i = 0; str[i]; i++) {
+    if (str[i] == ';') {
+      str[i] = 0;
+      scheme_glib_log_message("test", mzG_LOG_LEVEL_WARNING, str, NULL);
+      str[i] = ';';
+      str = str + i + 1;
+      i = 0;
+    }
+  }
+  scheme_glib_log_message("test", mzG_LOG_LEVEL_WARNING, str, NULL);
+  return NULL;
+}
+
+#ifdef MZ_USE_MZRT
+void scheme_init_glib_log_queue(void)
+{
+  mzrt_mutex_create(&glib_log_queue_lock);
+  glib_log_signal_handle = scheme_get_signal_handle();
+}
+
+void scheme_check_glib_log_messages(void)
+{
+  if (scheme_current_place_id == 0) {
+    glib_log_queue_entry *e, *prev = NULL, *next;
+    
+    mzrt_mutex_lock(glib_log_queue_lock);
+    e = glib_log_queue;
+    glib_log_queue = NULL;
+    mzrt_mutex_unlock(glib_log_queue_lock);
+
+    if (e) {
+      /* Reverse list */
+      while (e->next) {
+        next = e->next;
+        e->next = prev;
+        prev = e;
+        e = next;
+      }
+      e->next = prev;
+
+      /* Process messages */
+      for (; e; e = e->next) {
+        glib_log_message(e->log_domain, e->log_level, e->message, NULL);
+      }
+
+      /* In case a thread is blocked waiting for a log event */
+      scheme_signal_received_at(glib_log_signal_handle);
+    }
+  }
+}
+#endif
+
 static int extract_level(const char *who, int none_ok, int which, int argc, Scheme_Object **argv)
 {
   Scheme_Object *v;

racket/src/racket/src/salloc.c

@@ -319,6 +319,9 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void
 {
   scheme_setup_thread_local_key_if_needed();
   scheme_init_os_thread();
+#ifdef MZ_USE_MZRT
+  scheme_init_glib_log_queue();
+#endif
   return do_main_stack_setup(no_auto_statics, _main, data);
 }
 
@@ -412,6 +415,9 @@ void scheme_init_os_thread_like(void *other) XFORM_SKIP_PROC
 void scheme_init_os_thread(void) XFORM_SKIP_PROC
 {
   scheme_init_os_thread_like(NULL);
+#ifdef MZ_USE_MZRT
+  scheme_os_thread_id = (uintptr_t)mz_proc_os_thread_self();
+#endif
 }
 
 void scheme_done_os_thread() XFORM_SKIP_PROC
@@ -426,6 +432,19 @@ void scheme_done_os_thread() XFORM_SKIP_PROC
 #endif
 }
 
+int scheme_is_place_main_os_thread() XFORM_SKIP_PROC
+{
+#if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) || defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS)
+  if (!scheme_get_thread_local_variables())
+    return 0;
+#endif
+#ifdef MZ_USE_MZRT
+  if (scheme_os_thread_id != (uintptr_t)mz_proc_os_thread_self())
+    return 0;
+#endif
+  return 1;
+}
+
 /************************************************************************/
 /*                           memory utils                               */
 /************************************************************************/

racket/src/racket/src/schemef.h

@@ -231,6 +231,7 @@ MZ_EXTERN void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Sch
 MZ_EXTERN void scheme_log_abort(char *buffer);
 MZ_EXTERN void scheme_log_warning(char *buffer);
 MZ_EXTERN void scheme_glib_log_message(const char *log_domain, int log_level, const char *message, void *user_data);
+MZ_EXTERN void *scheme_glib_log_message_test(char *str);
 MZ_EXTERN void scheme_out_of_memory_abort();
 
 MZ_EXTERN void scheme_wrong_count(const char *name, int minc, int maxc,

racket/src/racket/src/schemex.h

@@ -170,6 +170,7 @@ void (*scheme_log_name_pfx_message)(Scheme_Logger *logger, int level, Scheme_Obj
 void (*scheme_log_abort)(char *buffer);
 void (*scheme_log_warning)(char *buffer);
 void (*scheme_glib_log_message)(const char *log_domain, int log_level, const char *message, void *user_data);
+void *(*scheme_glib_log_message_test)(char *str);
 void (*scheme_out_of_memory_abort)();
 void (*scheme_wrong_count)(const char *name, int minc, int maxc,
 				  int argc, Scheme_Object **argv);

racket/src/racket/src/schemex.inc

@@ -118,6 +118,7 @@
   scheme_extension_table->scheme_log_abort = scheme_log_abort;
   scheme_extension_table->scheme_log_warning = scheme_log_warning;
   scheme_extension_table->scheme_glib_log_message = scheme_glib_log_message;
+  scheme_extension_table->scheme_glib_log_message_test = scheme_glib_log_message_test;
   scheme_extension_table->scheme_out_of_memory_abort = scheme_out_of_memory_abort;
   scheme_extension_table->scheme_wrong_count = scheme_wrong_count;
   scheme_extension_table->scheme_wrong_count_m = scheme_wrong_count_m;

racket/src/racket/src/schemexm.h

@@ -118,6 +118,7 @@
 #define scheme_log_abort (scheme_extension_table->scheme_log_abort)
 #define scheme_log_warning (scheme_extension_table->scheme_log_warning)
 #define scheme_glib_log_message (scheme_extension_table->scheme_glib_log_message)
+#define scheme_glib_log_message_test (scheme_extension_table->scheme_glib_log_message_test)
 #define scheme_out_of_memory_abort (scheme_extension_table->scheme_out_of_memory_abort)
 #define scheme_wrong_count (scheme_extension_table->scheme_wrong_count)
 #define scheme_wrong_count_m (scheme_extension_table->scheme_wrong_count_m)

racket/src/racket/src/schpriv.h

@@ -483,6 +483,7 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
 void *scheme_get_os_thread_like();
 void scheme_init_os_thread_like(void *);
 void scheme_done_os_thread();
+int scheme_is_place_main_os_thread();
 
 /*========================================================================*/
 /*                                constants                               */
@@ -4180,6 +4181,11 @@ void scheme_write_proc_context(Scheme_Object *port, int print_width,
                                Scheme_Object *col, Scheme_Object *pos,
                                int generated);
 
+#ifdef MZ_USE_MZRT
+void scheme_init_glib_log_queue(void);
+void scheme_check_glib_log_messages(void);
+#endif
+
 /*========================================================================*/
 /*                         filesystem utilities                           */
 /*========================================================================*/

racket/src/racket/src/thread.c

@@ -5035,6 +5035,10 @@ void scheme_thread_block(float sleep_time)
   if (!do_atomic)
     scheme_check_foreign_work();
 #endif
+#if defined(MZ_USE_MZRT)
+  if (!do_atomic)
+    scheme_check_glib_log_messages();
+#endif
 
   skip_sleep = 0;
   if (check_fd_semaphores()) {