From a590b5ec35f1e7f4b692c060f62028af30a10b16 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 22 Jan 2018 17:01:46 -0700
Subject: [PATCH] add collect-rendezvous

original commit: 73cf31d3625e519493918faba650bbfc303f1712
---
 LOG             |  2 ++
 c/prim.c        |  1 +
 csug/smgmt.stex | 19 +++++++++++++++++++
 mats/7.ms       | 35 +++++++++++++++++++++++++++++++++++
 s/7.ss          |  6 ++++++
 s/primdata.ss   |  1 +
 6 files changed, 64 insertions(+)

diff --git a/LOG b/LOG
index 477a911001..9032015ea0 100644
--- a/LOG
+++ b/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
diff --git a/c/prim.c b/c/prim.c
index 3b22818e71..9493de9a16 100644
--- a/c/prim.c
+++ b/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() {
diff --git a/csug/smgmt.stex b/csug/smgmt.stex
index 07d5809a89..854129866e 100644
--- a/csug/smgmt.stex
+++ b/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}
diff --git a/mats/7.ms b/mats/7.ms
index 29bba8229c..e963b9200a 100644
--- a/mats/7.ms
+++ b/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:
 
diff --git a/s/7.ss b/s/7.ss
index eeb308dbcc..e177bc71ca 100644
--- a/s/7.ss
+++ b/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 ()
diff --git a/s/primdata.ss b/s/primdata.ss
index 7dd04e73b5..b43aef5926 100644
--- a/s/primdata.ss
+++ b/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])