suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

collect in main thread when active

Browse Source 
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
This commit is contained in:
Matthew Flatt 2020-03-23 14:23:10 -06:00
parent b5bce547d2
commit c920f3953d
12 changed files with 109 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
c/globals.h
View File

@ -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

1
c/prim.c
View File

@ -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));

11
c/thread.c
View File

@ -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)
}

7
c/types.h
View File

@ -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()\

4
csug/smgmt.stex
View File

@ -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

2
makefiles/Mf-install.in
View File

@ -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

36
mats/thread.ms
View File

@ -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)))))
)
)

71
s/7.ss
View File

@ -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

3
s/cmacros.ss
View File

@ -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

4
s/cpnanopass.ss
View File

@ -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

2
s/primdata.ss
View File

@ -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])

3
s/prims.ss
View File

@ -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))])