diff --git a/LOG b/LOG index d5f7e40a72..a1b161c06f 100644 --- a/LOG +++ b/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 diff --git a/c/prim.c b/c/prim.c index 0041012a81..65269ad948 100644 --- a/c/prim.c +++ b/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() { 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..36d062c723 100644 --- a/mats/7.ms +++ b/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: diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 278017dc88..564c013d50 100644 --- a/release_notes/release_notes.stex +++ b/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 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 47aa9a4172..6f719e2eda 100644 --- a/s/primdata.ss +++ b/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])