collect in main thread when active

For a collect rendezvous, call the collect-notify handler in
the main thread if it is active. A collect-notify handler can
then make sure the main thread is active and try again, if
that's useful to an application.

original commit: 0bc286e81827f029dd02a3627a192edd053b3b91

c/globals.h

@@ -38,6 +38,7 @@ EXTERN char *Sdefaultheapdirs;
 EXTERN s_thread_key_t S_tc_key;
 EXTERN scheme_mutex_t S_tc_mutex;
 EXTERN s_thread_cond_t S_collect_cond;
+EXTERN s_thread_cond_t S_collect_thread0_cond;
 EXTERN INT S_tc_mutex_depth;
 #endif
 

c/prim.c

@@ -127,6 +127,7 @@ static void create_c_entry_vector() {
     install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
 #ifdef PTHREADS
     install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
+    install_c_entry(CENTRY_raw_collect_thread0_cond, (ptr)&S_collect_thread0_cond);
     install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
     install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
     install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));

c/thread.c

@@ -33,6 +33,7 @@ void S_thread_init() {
     S_tc_mutex.owner = s_thread_self();
     S_tc_mutex.count = 0;
     s_thread_cond_init(&S_collect_cond);
+    s_thread_cond_init(&S_collect_thread0_cond);
     S_tc_mutex_depth = 0;
 #endif /* PTHREADS */
   }
@@ -226,6 +227,7 @@ static IBOOL destroy_thread(tc) ptr tc; {
         if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id))
             && SYMVAL(S_G.active_threads_id) == FIX(0)) {
           s_thread_cond_signal(&S_collect_cond);
+          s_thread_cond_signal(&S_collect_thread0_cond);
         }
       }
 
@@ -425,6 +427,7 @@ IBOOL S_condition_wait(c, m, t) s_thread_cond_t *c; scheme_mutex_t *m; ptr t; {
   long sec;
   long nsec;
   INT status;
+  IBOOL is_collect;
 
   if ((count = m->count) == 0 || !s_thread_equal(m->owner, self))
     S_error1("condition-wait", "thread does not own mutex ~s", m);
@@ -443,8 +446,10 @@ IBOOL S_condition_wait(c, m, t) s_thread_cond_t *c; scheme_mutex_t *m; ptr t; {
     nsec = 0;
   }
 
-  if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) {
+  is_collect = (c == &S_collect_cond || c == &S_collect_thread0_cond);
-    deactivate_thread(tc)
+
+  if (is_collect || DISABLECOUNT(tc) == 0) {
+    deactivate_thread_signal_collect(tc, !is_collect)
   }
 
   m->count = 0;
@@ -453,7 +458,7 @@ IBOOL S_condition_wait(c, m, t) s_thread_cond_t *c; scheme_mutex_t *m; ptr t; {
   m->owner = self;
   m->count = 1;
 
-  if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) {
+  if (is_collect || DISABLECOUNT(tc) == 0) {
     reactivate_thread(tc)
   }
 

c/types.h

@@ -318,7 +318,7 @@ typedef struct {
    thread count is zero, in which case we don't signal.  collection
    is not permitted to happen when interrupts are disabled, so we
    don't let anything happen in that case. */
-#define deactivate_thread(tc) {\
+#define deactivate_thread_signal_collect(tc, check_collect) {  \
   if (ACTIVE(tc)) {\
     ptr code;\
     tc_mutex_acquire()\
@@ -327,14 +327,17 @@ typedef struct {
     Slock_object(code);\
     SETSYMVAL(S_G.active_threads_id,\
      FIX(UNFIX(SYMVAL(S_G.active_threads_id)) - 1));\
-    if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id))\
+    if (check_collect \
+        && Sboolean_value(SYMVAL(S_G.collect_request_pending_id))  \
         && SYMVAL(S_G.active_threads_id) == FIX(0)) {\
       s_thread_cond_signal(&S_collect_cond);\
+      s_thread_cond_signal(&S_collect_thread0_cond);\
     }\
     ACTIVE(tc) = 0;\
     tc_mutex_release()\
   }\
 }
+#define deactivate_thread(tc) deactivate_thread_signal_collect(tc, 1) 
 #define reactivate_thread(tc) {\
   if (!ACTIVE(tc)) {\
     tc_mutex_acquire()\

csug/smgmt.stex

@@ -164,7 +164,9 @@ The system determines which generations to collect, based on \var{g} and
 Requests a garbage collection in the same way as when the system
 determines that a collection should occur. All running threads are
 coordinated so that one of them calls the collect-request handler, while
-the other threads pause until the handler returns.
+the other threads pause until the handler returns. If the initial
+thread is active at the time of the rendezvous, it is used to call
+the collect-request handler.
 
 Note that if the collect-request handler (see
 \scheme{collect-request-handler}) does not call \scheme{collect}, then

makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.23
+Version=csv9.5.3.24
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

mats/thread.ms

@@ -1534,4 +1534,40 @@
    (check (box 0) unbox box-cas!))
  (check (vector 1 0 2) (lambda (v) (vector-ref v 1)) (lambda (v o n) (vector-cas! v 1 o n))))
 
+(mat rendezvous-in-main
+  ;; make sure that every collect rendezvous triggers the handler in the
+  ;; main thread
+  (let ([done? #f]
+        [gc-ids (list (get-thread-id))]
+        [gc-count 0]
+        [m #%$tc-mutex] ; using tc-mutex means main thread is not deactivated
+        [c (make-condition)])
+    (parameterize ([collect-request-handler
+                    (let ([orig (collect-request-handler)])
+                      (lambda ()
+                        (set! gc-count (add1 gc-count))
+                        (unless (memv (get-thread-id) gc-ids)
+                          (set! gc-ids (cons (get-thread-id) gc-ids)))
+                        (orig)))])
+      (let loop ([i 4])
+        (unless (= i 0)
+          (fork-thread (lambda () (let loop ()
+                                    (unless (with-mutex m
+                                               (condition-wait c m)
+                                               done?)
+                                      (collect-rendezvous)
+                                      (loop)))))
+          (loop (sub1 i))))
+      (let loop ()
+        (unless (> gc-count 1000)
+          (with-mutex m (condition-broadcast c))
+          (collect-rendezvous)
+          (loop)))
+      (with-mutex m
+        (set! done? #t)
+        (condition-broadcast c))
+      (equal? gc-ids (list (get-thread-id)))))
+)
+  
+
 )

s/7.ss

@@ -1157,33 +1157,50 @@
 )
 
 (define $collect-rendezvous
-  (lambda ()
+  (let ([thread0-waiting? #f])
-    (define once
+    (lambda ()
-      (let ([once #f])
+      (define once
-        (lambda ()
+        (let ([once #f])
-          (when (eq? once #t)
+          (lambda ()
-            ($oops '$collect-rendezvous
+            (when (eq? once #t)
-              "cannot return to the collect-request-handler"))
+              ($oops '$collect-rendezvous
-          (set! once #t))))
+                "cannot return to the collect-request-handler"))
-    (if-feature pthreads
+            (set! once #t))))
-      (with-tc-mutex
+      (if-feature pthreads
-        (let f ()
+        ;; If the main thread is active, perform the GC there
-          (when $collect-request-pending
+        (with-tc-mutex
-            (if (= $active-threads 1) ; last one standing
+          (let f ()
-                (dynamic-wind
+            (when $collect-request-pending
-                  once
+              (cond
-                  (collect-request-handler)
+                [(= $active-threads 1) ; last one standing
-                  (lambda ()
+                 (cond
-                    (set! $collect-request-pending #f)
+                   [(or (eqv? 0 (get-thread-id))
-                    (condition-broadcast $collect-cond)))
+                        (not thread0-waiting?))
-                (begin
+                    (dynamic-wind
-                  (condition-wait $collect-cond $tc-mutex)
+                      once
-                  (f))))))
+                      (collect-request-handler)
-      (critical-section
+                      (lambda ()
-        (dynamic-wind 
+                        (set! $collect-request-pending #f)
-          once
+                        (condition-broadcast $collect-cond)
-          (collect-request-handler)
+                        (condition-broadcast $collect-thread0-cond)))]
-          (lambda () (set! $collect-request-pending #f)))))))
+                   [else
+                    ;; get main thread to perform the GC, instead
+                    (condition-broadcast $collect-thread0-cond)
+                    (condition-wait $collect-cond $tc-mutex)
+                    (f)])]
+                [(eqv? 0 (get-thread-id))
+                 (set! thread0-waiting? #t)
+                 (condition-wait $collect-thread0-cond $tc-mutex)
+                 (set! thread0-waiting? #f)
+                 (f)]
+                [else
+                 (condition-wait $collect-cond $tc-mutex)
+                 (f)]))))
+        (critical-section
+          (dynamic-wind 
+            once
+            (collect-request-handler)
+            (lambda () (set! $collect-request-pending #f))))))))
 
 (define collect-request-handler
    (make-parameter

s/cmacros.ss

@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050317)
+(define-constant scheme-version #x09050318)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -2799,6 +2799,7 @@
      thread-list
      split-and-resize
      raw-collect-cond
+     raw-collect-thread0-cond
      raw-tc-mutex
      activate-thread
      deactivate-thread

s/cpnanopass.ss

@@ -6050,7 +6050,9 @@
           (define-inline 2 $raw-tc-mutex
             [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-tc-mutex) 0))])
           (define-inline 2 $raw-collect-cond
-            [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-cond) 0))]))
+            [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-cond) 0))])
+          (define-inline 2 $raw-collect-thread0-cond
+            [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-thread0-cond) 0))]))
         (define-inline 2 not
           [(e) `(if ,e ,(%constant sfalse) ,(%constant strue))])
         (define-inline 2 most-negative-fixnum

s/primdata.ss

@@ -2252,6 +2252,7 @@
   ($ratio-denominator [flags single-valued])
   ($ratio-numerator [flags single-valued])
   ($raw-collect-cond [feature pthreads] [flags single-valued])
+  ($raw-collect-thread0-cond [feature pthreads] [flags single-valued])
   ($raw-tc-mutex [feature pthreads] [flags single-valued])
   ($read-performance-monitoring-counter [flags single-valued])
   ($read-time-stamp-counter [flags single-valued])
@@ -2412,6 +2413,7 @@
   ($active-threads [flags])
   ($c-bufsiz [flags])
   ($collect-cond [feature pthreads] [flags])
+  ($collect-thread0-cond [feature pthreads] [flags])
   ($collect-request-pending [flags])
   ($compiler-is-loaded? [flags])
   ($console-error-port [flags])

s/prims.ss

@@ -1699,6 +1699,7 @@
 (when-feature pthreads
 
 (define $raw-collect-cond (lambda () ($raw-collect-cond)))
+(define $raw-collect-thread0-cond (lambda () ($raw-collect-thread0-cond)))
 (define $raw-tc-mutex (lambda () ($raw-tc-mutex)))
 (define fork-thread)
 (define make-mutex)
@@ -1715,6 +1716,7 @@
 (define $close-resurrected-mutexes&conditions)
 (define $tc-mutex)
 (define $collect-cond)
+(define $collect-thread0-cond)
 (define get-initial-thread)
 (let ()
 ; scheme-object's below are mutex and condition addresses, which are
@@ -1891,6 +1893,7 @@
 
 (set! $tc-mutex ($make-mutex ($raw-tc-mutex) '$tc-mutex))
 (set! $collect-cond ($make-condition ($raw-collect-cond) '$collect-cond))
+(set! $collect-thread0-cond ($make-condition ($raw-collect-thread0-cond) '$collect-thread0-cond))
 
 (set! get-initial-thread
   (let ([thread (car (ts))])