add collect-rendezvous

original commit: 73cf31d3625e519493918faba650bbfc303f1712

LOG

@@ -788,3 +788,5 @@
 - fix bounds checking with an immediate index on immutable vectors,
   fxvectors, strings, and bytevectors
     cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms
+- add collect-rendezvous
+    prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex

c/prim.c

@@ -186,6 +186,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,41 @@ 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)
+               ;; Plain `collect` should work again:
+               (check-working-gc collect)))))
+  )
 
 ;;; section 7.6:
 

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

@@ -1194,6 +1194,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])