add collect-rendezvous

original commit: f7cb82d97e34b14bfbafe635b0d4a294527b02c3

LOG

@@ -899,3 +899,5 @@
     Mf-install.in
 - standalone export form now handles (import import-spec ...)
     8.ms, syntax.ss, release_notes.stex
+- add collect-rendezvous
+    prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex, release_notes.stex

c/prim.c

@@ -177,6 +177,7 @@ void S_prim_init() {
     Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
     Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
     Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
+    Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
 }
 
 static void s_instantiate_code_object() {

csug/smgmt.stex

@@ -153,6 +153,25 @@ The system determines which generations to collect, based on \var{g} and
 \var{tg} if provided, as described in the lead-in to this section.
 
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{collect-rendezvous}{\categoryprocedure}{(collect-rendezvous)}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\noindent
+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.
+
+Note that if the collect-request handler (see
+\scheme{collect-request-handler}) does not call \scheme{collect}, then
+\scheme{collect-rendezvous} does not actualy perform a garbage
+collection.
+
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{collect-notify}{\categoryglobalparameter}{collect-notify}

mats/7.ms

@@ -3589,6 +3589,45 @@ evaluating module init
     (or (not a) (not (assq 'static (cdr a)))))
 )
 
+(mat collect-rendezvous
+  (begin
+    (define (check-working-gc collect)
+      (with-interrupts-disabled
+       (let ([p (weak-cons (gensym) #f)])
+         (collect)
+         (eq? (car p) #!bwp))))
+    (and (check-working-gc collect)
+         (check-working-gc collect-rendezvous)))
+      
+  (or (not (threaded?))
+      (let ([m (make-mutex)]
+            [c (make-condition)]
+            [done? #f])
+        (fork-thread
+         (lambda ()
+           (let loop ()
+             (mutex-acquire m)
+             (cond
+              [done?
+               (condition-signal c)
+               (mutex-release m)]
+              [else
+               (mutex-release m)
+               (loop)]))))
+        (and (check-working-gc collect-rendezvous)
+             ;; End thread:
+             (begin
+               (mutex-acquire m)
+               (set! done? #t)
+               (condition-wait c m)
+               (mutex-release m)
+               ;; Make sure the thread is really done
+               (let loop ()
+                 (unless (= 1 (#%$top-level-value '$active-threads))
+                   (loop)))
+               ;; Plain `collect` should work again:
+               (check-working-gc collect)))))
+  )
 
 ;;; section 7.6:
 

release_notes/release_notes.stex

@@ -58,6 +58,18 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
+\subsection{Garbage collection and threads (9.5.1)}
+
+A new \scheme{collect-rendezvous} function performs a garbage
+collection in the same way as when the system determines that a
+collection should occur. For many purposes,
+\scheme{collect-rendezvous} is a variant of \scheme{collect} that
+works when multiple threads are active. More precisely, the
+\scheme{collect-rendezvous} function invokes the collect-request
+handler (in an unspecified thread) after synchronizing all active
+threads and temporarily deactivating all but the one used to call the
+collect-request handler.
+
 \subsection{Foreign-procedure struct arguments and results (9.5.1)}
 
 A new \scheme{(& \var{ftype})} form allows a struct or union to be

s/7.ss

@@ -750,6 +750,12 @@
          ($oops who "invalid target generation ~s for generation ~s" gtarget g))
        (collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))])))
 
+(set! collect-rendezvous
+  (let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)])
+    (lambda ()
+      (fire-collector)
+      ($collect-rendezvous))))
+
 (set! keyboard-interrupt-handler
    ($make-thread-parameter
       (lambda ()

s/primdata.ss

@@ -1197,6 +1197,7 @@
   (clear-input-port [sig [() (input-port) -> (void)]] [flags true])
   (clear-output-port [sig [() (output-port) -> (void)]] [flags true])
   (collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) -> (void)]] [flags true])
+  (collect-rendezvous [sig [() -> (void)]] [flags])
   (collections [sig [() -> (uint)]] [flags unrestricted alloc])
   (compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags])
   (compile-file [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])