From c920f3953d9e19df35259f3495ad844f831fcc6b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2020 14:23:10 -0600 Subject: [PATCH] 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 | 1 + c/prim.c | 1 + c/thread.c | 11 +++++-- c/types.h | 7 ++-- csug/smgmt.stex | 4 ++- makefiles/Mf-install.in | 2 +- mats/thread.ms | 36 +++++++++++++++++++++ s/7.ss | 71 +++++++++++++++++++++++++---------------- s/cmacros.ss | 3 +- s/cpnanopass.ss | 4 ++- s/primdata.ss | 2 ++ s/prims.ss | 3 ++ 12 files changed, 109 insertions(+), 36 deletions(-) diff --git a/c/globals.h b/c/globals.h index 55df219397..92cfe40875 100644 --- a/c/globals.h +++ b/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 diff --git a/c/prim.c b/c/prim.c index 8871783217..1580eabbfc 100644 --- a/c/prim.c +++ b/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)); diff --git a/c/thread.c b/c/thread.c index 17ecdfbc49..1bc6967f1c 100644 --- a/c/thread.c +++ b/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) { - deactivate_thread(tc) + is_collect = (c == &S_collect_cond || c == &S_collect_thread0_cond); + + 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) } diff --git a/c/types.h b/c/types.h index 30c45ffdac..7ac7b7a816 100644 --- a/c/types.h +++ b/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()\ diff --git a/csug/smgmt.stex b/csug/smgmt.stex index 604396df78..48983231cf 100644 --- a/csug/smgmt.stex +++ b/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 diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index f4943db824..2c603dd305 100644 --- a/makefiles/Mf-install.in +++ b/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 diff --git a/mats/thread.ms b/mats/thread.ms index b441dc66a7..f59e924e06 100644 --- a/mats/thread.ms +++ b/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))))) +) + + ) diff --git a/s/7.ss b/s/7.ss index 7d691de6ef..99b8961940 100644 --- a/s/7.ss +++ b/s/7.ss @@ -1157,33 +1157,50 @@ ) (define $collect-rendezvous - (lambda () - (define once - (let ([once #f]) - (lambda () - (when (eq? once #t) - ($oops '$collect-rendezvous - "cannot return to the collect-request-handler")) - (set! once #t)))) - (if-feature pthreads - (with-tc-mutex - (let f () - (when $collect-request-pending - (if (= $active-threads 1) ; last one standing - (dynamic-wind - once - (collect-request-handler) - (lambda () - (set! $collect-request-pending #f) - (condition-broadcast $collect-cond))) - (begin - (condition-wait $collect-cond $tc-mutex) - (f)))))) - (critical-section - (dynamic-wind - once - (collect-request-handler) - (lambda () (set! $collect-request-pending #f))))))) + (let ([thread0-waiting? #f]) + (lambda () + (define once + (let ([once #f]) + (lambda () + (when (eq? once #t) + ($oops '$collect-rendezvous + "cannot return to the collect-request-handler")) + (set! once #t)))) + (if-feature pthreads + ;; If the main thread is active, perform the GC there + (with-tc-mutex + (let f () + (when $collect-request-pending + (cond + [(= $active-threads 1) ; last one standing + (cond + [(or (eqv? 0 (get-thread-id)) + (not thread0-waiting?)) + (dynamic-wind + once + (collect-request-handler) + (lambda () + (set! $collect-request-pending #f) + (condition-broadcast $collect-cond) + (condition-broadcast $collect-thread0-cond)))] + [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 diff --git a/s/cmacros.ss b/s/cmacros.ss index f1f34cdc8e..dc66ec1de9 100644 --- a/s/cmacros.ss +++ b/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 diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 85df5f56ac..9d94a18913 100644 --- a/s/cpnanopass.ss +++ b/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 diff --git a/s/primdata.ss b/s/primdata.ss index 15ff232e0d..4861035d14 100644 --- a/s/primdata.ss +++ b/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]) diff --git a/s/prims.ss b/s/prims.ss index 578df57dbf..14ffc67bfc 100644 --- a/s/prims.ss +++ b/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))])