From 5c455885734dddd4400f11af1c0ba1e7348e9189 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Oct 2020 17:55:12 -0600 Subject: [PATCH] cs: provide hint to GC about places The collector tries to use roughly the same amount of parallelism as the number of active threads, but make sure that it doesn't fall back to an ownership-mangling non-parallel collection if all but one place happens to be stalled. --- .makefile | 2 +- Makefile | 12 ++++---- pkgs/base/info.rkt | 2 +- racket/src/ChezScheme/c/gcwrapper.c | 5 +++- racket/src/ChezScheme/c/globals.h | 2 ++ racket/src/ChezScheme/c/prim.c | 3 +- racket/src/ChezScheme/c/prim5.c | 11 ++++++++ racket/src/ChezScheme/c/thread.c | 9 +++++- racket/src/ChezScheme/c/types.h | 1 + racket/src/ChezScheme/csug/threads.stex | 28 ++++++++++++++++--- racket/src/ChezScheme/makefiles/Mf-install.in | 2 +- racket/src/ChezScheme/s/cmacros.ss | 3 +- racket/src/ChezScheme/s/cpnanopass.ss | 2 ++ racket/src/ChezScheme/s/primdata.ss | 4 +++ racket/src/ChezScheme/s/prims.ss | 28 +++++++++++++++++++ racket/src/cs/rumble/place.ss | 1 + racket/src/version/racket_version.h | 2 +- 17 files changed, 99 insertions(+), 18 deletions(-) diff --git a/.makefile b/.makefile index 269b972925..c4a944ee3e 100644 --- a/.makefile +++ b/.makefile @@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET) RACKET_FOR_BUILD = $(RACKET) # This branch name changes each time the pb boot files are updated: -PB_BRANCH == circa-7.9.0.2-2 +PB_BRANCH == circa-7.9.0.2-3 PB_REPO = https://github.com/racket/pb # Alternative source for Chez Scheme boot files, normally set by diff --git a/Makefile b/Makefile index 3db5178ad9..ed6b30b347 100644 --- a/Makefile +++ b/Makefile @@ -47,7 +47,7 @@ RACKETCS_SUFFIX = RACKET = RACKET_FOR_BOOTFILES = $(RACKET) RACKET_FOR_BUILD = $(RACKET) -PB_BRANCH = circa-7.9.0.2-2 +PB_BRANCH = circa-7.9.0.2-3 PB_REPO = https://github.com/racket/pb EXTRA_REPOS_BASE = CS_CROSS_SUFFIX = @@ -306,14 +306,14 @@ maybe-fetch-pb-as-is: echo done fetch-pb-from: mkdir -p racket/src/ChezScheme/boot - if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.2-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.2-2:remotes/origin/circa-7.9.0.2-2 ; fi - cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.2-2 + if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.2-3 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.2-3:remotes/origin/circa-7.9.0.2-3 ; fi + cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.2-3 pb-stage: - cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.2-2 - cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.2-2 + cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.2-3 + cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.2-3 cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build" pb-push: - cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.2-2 + cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.2-3 win-cs-base: IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)" diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 43b11a9fdf..f8f439d018 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.9.0.2") +(define version "7.9.0.3") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/racket/src/ChezScheme/c/gcwrapper.c b/racket/src/ChezScheme/c/gcwrapper.c index 5591620594..767ff8d8da 100644 --- a/racket/src/ChezScheme/c/gcwrapper.c +++ b/racket/src/ChezScheme/c/gcwrapper.c @@ -1286,7 +1286,10 @@ ptr S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { if (S_G.enable_object_backreferences) min_tg = max_tg; return S_gc_oce(tc, max_cg, min_tg, max_tg, count_roots); #if defined(PTHREADS) - } else if (S_collect_waiting_threads != 0) { + } else if ((S_collect_waiting_threads != 0) + || (Spairp(S_threads) + && Spairp(Scdr(S_threads)) + && (S_num_preserve_ownership_threads > 0))) { return S_gc_par(tc, max_cg, min_tg, max_tg, Sfalse); #endif } else if (max_cg == 0 && min_tg == 1 && max_tg == 1 diff --git a/racket/src/ChezScheme/c/globals.h b/racket/src/ChezScheme/c/globals.h index ecdf11697f..ed5e52977b 100644 --- a/racket/src/ChezScheme/c/globals.h +++ b/racket/src/ChezScheme/c/globals.h @@ -40,8 +40,10 @@ 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 scheme_mutex_t S_alloc_mutex; /* ordered after S_tc_mutex */ +EXTERN s_thread_cond_t S_terminated_cond; EXTERN int S_collect_waiting_threads; EXTERN ptr S_collect_waiting_tcs[maximum_parallel_collect_threads]; +EXTERN int S_num_preserve_ownership_threads; # ifdef IMPLICIT_ATOMIC_AS_EXPLICIT EXTERN s_thread_mutex_t S_implicit_mutex; # endif diff --git a/racket/src/ChezScheme/c/prim.c b/racket/src/ChezScheme/c/prim.c index e6ffca80d6..6c612a9e98 100644 --- a/racket/src/ChezScheme/c/prim.c +++ b/racket/src/ChezScheme/c/prim.c @@ -132,6 +132,7 @@ static void create_c_entry_vector() { S_install_c_entry(CENTRY_raw_collect_cond, TO_PTR(&S_collect_cond)); S_install_c_entry(CENTRY_raw_collect_thread0_cond, TO_PTR(&S_collect_thread0_cond)); S_install_c_entry(CENTRY_raw_tc_mutex, TO_PTR(&S_tc_mutex)); + S_install_c_entry(CENTRY_raw_terminated_cond, TO_PTR(&S_terminated_cond)); S_install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread)); S_install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread)); S_install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread)); @@ -158,7 +159,7 @@ void S_check_c_entry_vector() { for (i = 0; i < c_entry_vector_size; i++) { #ifndef PTHREADS if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_collect_thread0_cond - || i == CENTRY_raw_tc_mutex + || i == CENTRY_raw_tc_mutex || i == CENTRY_raw_terminated_cond || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread || i == CENTRY_unactivate_thread) continue; diff --git a/racket/src/ChezScheme/c/prim5.c b/racket/src/ChezScheme/c/prim5.c index 40f8d7a778..335e69ac5f 100644 --- a/racket/src/ChezScheme/c/prim5.c +++ b/racket/src/ChezScheme/c/prim5.c @@ -99,6 +99,7 @@ static void s_mutex_acquire PROTO((scheme_mutex_t *m)); static ptr s_mutex_acquire_noblock PROTO((scheme_mutex_t *m)); static void s_condition_broadcast PROTO((s_thread_cond_t *c)); static void s_condition_signal PROTO((s_thread_cond_t *c)); +static void s_thread_preserve_ownership PROTO((ptr tc)); #endif static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); @@ -1522,6 +1523,15 @@ static void s_condition_broadcast(s_thread_cond_t *c) { static void s_condition_signal(s_thread_cond_t *c) { s_thread_cond_signal(c); } + +/* called with tc mutex held */ +static void s_thread_preserve_ownership(ptr tc) { + if (!THREAD_GC(tc)->preserve_ownership) { + THREAD_GC(tc)->preserve_ownership = 1; + S_num_preserve_ownership_threads++; + } +} + #endif static ptr s_profile_counters(void) { @@ -1601,6 +1611,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)condition_broadcast", (void *)s_condition_broadcast); Sforeign_symbol("(cs)condition_signal", (void *)s_condition_signal); Sforeign_symbol("(cs)condition_wait", (void *)S_condition_wait); + Sforeign_symbol("(cs)thread_preserve_ownership", (void *)s_thread_preserve_ownership); #endif Sforeign_symbol("(cs)s_addr_in_heap", (void *)s_addr_in_heap); Sforeign_symbol("(cs)s_ptr_in_heap", (void *)s_ptr_in_heap); diff --git a/racket/src/ChezScheme/c/thread.c b/racket/src/ChezScheme/c/thread.c index 586e0ae93f..87d1fb40fa 100644 --- a/racket/src/ChezScheme/c/thread.c +++ b/racket/src/ChezScheme/c/thread.c @@ -37,6 +37,7 @@ void S_thread_init() { s_thread_cond_init(&S_collect_cond); s_thread_cond_init(&S_collect_thread0_cond); s_thread_mutex_init(&S_alloc_mutex.pmutex); + s_thread_cond_init(&S_terminated_cond); S_alloc_mutex.owner = 0; S_alloc_mutex.count = 0; @@ -167,7 +168,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { for (i = 0; i < (int)DIRTY_SEGMENT_LISTS; i++) tgc->dirty_segments[i] = NULL; tgc->thread = (ptr)0; - + tgc->preserve_ownership = 0; + tc_mutex_release(); return thread; @@ -289,6 +291,9 @@ static IBOOL destroy_thread(tc) ptr tc; { if (LZ4OUTBUFFER(tc) != (ptr)0) free(TO_VOIDP(LZ4OUTBUFFER(tc))); if (SIGNALINTERRUPTQUEUE(tc) != (ptr)0) free(TO_VOIDP(SIGNALINTERRUPTQUEUE(tc))); + if (THREAD_GC(tc)->preserve_ownership) + --S_num_preserve_ownership_threads; + /* Never free a thread_gc, since it may be recorded in a segment as the segment's creator. Recycle manually, instead. */ THREAD_GC(tc)->sweeper = main_sweeper_index; @@ -300,6 +305,8 @@ static IBOOL destroy_thread(tc) ptr tc; { THREADTC(thread) = 0; /* mark it dead */ status = 1; + + s_thread_cond_broadcast(&S_terminated_cond); break; } ls = &Scdr(*ls); diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index 4acf568f0a..235f16b0f0 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -470,6 +470,7 @@ typedef struct thread_gc { int during_alloc; IBOOL queued_fire; + IBOOL preserve_ownership; struct thread_gc *next; diff --git a/racket/src/ChezScheme/csug/threads.stex b/racket/src/ChezScheme/csug/threads.stex index c495006b7f..747d261574 100644 --- a/racket/src/ChezScheme/csug/threads.stex +++ b/racket/src/ChezScheme/csug/threads.stex @@ -89,15 +89,21 @@ synchronized across processors. \scheme{fork-thread} invokes \var{thunk} in a new thread and returns a thread object. -Nothing can be done with the thread object returned by -\scheme{fork-thread}, other than to print it or use it with inspection -functions such as \scheme{compute-size}. - Threads created by foreign code using some means other than \scheme{fork-thread} must call \scheme{Sactivate_thread} (Section~\ref{SECTFOREIGNCLIB}) before touching any Scheme data or calling any Scheme procedures. +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{thread-join}{\categoryprocedure}{(thread-join \var{thread})} +\returns unspecified +\listlibraries +\endnoskipentryheader + +\noindent +Waits until \var{thread} has commpleted. + %---------------------------------------------------------------------------- \entryheader \formdef{get-initial-thread}{\categoryprocedure}{(get-initial-thread)} @@ -126,6 +132,20 @@ relationship to the process id returned by \index{\scheme{get-process-id}}\scheme{get-process-id}, which is the same in all threads. +%---------------------------------------------------------------------------- +\noskipentryheader +\formdef{thread-preserve-ownership!}{\categoryprocedure}{(thread-preserve-ownership!)} +\formdef{thread-preserve-ownership!}{\categoryprocedure}{(thread-preserve-ownership! \var{thread})} +\returns unspecified +\listlibraries +\endnoskipentryheader + +\noindent +Provides a hint to the storage manager that \var{thread} (which +defaults to the current thread if not supplied) can particularly +benefit from tracking the objects that it allocates for parallel +collection. + \section{Mutexes} %---------------------------------------------------------------------------- diff --git a/racket/src/ChezScheme/makefiles/Mf-install.in b/racket/src/ChezScheme/makefiles/Mf-install.in index 2fbaf09aa4..2b0a799cfe 100644 --- a/racket/src/ChezScheme/makefiles/Mf-install.in +++ b/racket/src/ChezScheme/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.40 +Version=csv9.5.3.41 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index ea2289980f..6a7972345c 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -357,7 +357,7 @@ ;; --------------------------------------------------------------------- ;; Version and machine types: -(define-constant scheme-version #x09050328) +(define-constant scheme-version #x09050329) (define-syntax define-machine-types (lambda (x) @@ -2942,6 +2942,7 @@ raw-collect-cond raw-collect-thread0-cond raw-tc-mutex + raw-terminated-cond activate-thread deactivate-thread unactivate-thread diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 27c0c34626..478b1a23f0 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -6553,6 +6553,8 @@ (when-feature pthreads (define-inline 2 $raw-tc-mutex [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-tc-mutex) 0))]) + (define-inline 2 $raw-terminated-cond + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-terminated-cond) 0))]) (define-inline 2 $raw-collect-cond [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-cond) 0))]) (define-inline 2 $raw-collect-thread0-cond diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index a1dec8f61d..da69d8394d 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -1765,6 +1765,8 @@ (textual-port-output-size [sig [(textual-output-port) -> (length)]] [flags discard]) (thread? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (thread-condition? [feature pthreads] [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (thread-join [feature pthreads] [sig [(ptr) -> (void)]] [flags true]) + (thread-preserve-ownership! [feature pthreads] [sig [() -> (void)] [(ptr) -> (void)]] [flags true]) (top-level-bound? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-mutable? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-syntax [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard]) @@ -2275,6 +2277,7 @@ ($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]) + ($raw-terminated-cond [feature pthreads] [flags single-valued]) ($read-performance-monitoring-counter [flags single-valued]) ($read-time-stamp-counter [flags single-valued]) ($real->flonum [flags single-valued arith-op mifoldable discard]) @@ -2450,6 +2453,7 @@ ($session-key [flags]) ($symbol-ht-rtd [flags]) ($tc-mutex [feature pthreads] [flags]) + ($terminated-cond [feature pthreads] [flags]) ) (define-symbol-flags* ([libraries] [flags system-keyword]) ; condition types diff --git a/racket/src/ChezScheme/s/prims.ss b/racket/src/ChezScheme/s/prims.ss index 22909f79fb..f92ba6b249 100644 --- a/racket/src/ChezScheme/s/prims.ss +++ b/racket/src/ChezScheme/s/prims.ss @@ -1760,7 +1760,10 @@ (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 $raw-terminated-cond (lambda () ($raw-terminated-cond))) (define fork-thread) +(define thread-join) +(define thread-preserve-ownership!) (define make-mutex) (define mutex?) (define mutex-name) @@ -1776,6 +1779,7 @@ (define $tc-mutex) (define $collect-cond) (define $collect-thread0-cond) +(define $terminated-cond) (define get-initial-thread) (let () ; scheme-object's below are mutex and condition addresses, which are @@ -1837,6 +1841,29 @@ (t) (void)))))))) +(set-who! thread-join + (lambda (t) + (unless (thread? t) + ($oops who "~a is not a thread" t)) + (with-tc-mutex + (let f () + (unless (eq? ($thread-tc t) 0) + (condition-wait $terminated-cond $tc-mutex) + (f)))))) + +(set-who! thread-preserve-ownership! + (let ([preserve! (foreign-procedure "(cs)thread_preserve_ownership" (ptr) void)]) + (case-lambda + [(t) + (unless (thread? t) + ($oops who "~a is not a thread" t)) + (with-tc-mutex + (let ([tc ($thread-tc t)]) + (unless (eq? tc 0) + (preserve! tc))))] + [() + (with-tc-mutex (preserve! ($tc)))]))) + (set-who! make-mutex (case-lambda [() (make-mutex-no-check #f)] @@ -1953,6 +1980,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! $terminated-cond ($make-condition ($raw-terminated-cond) '$terminated-cond)) (set! get-initial-thread (let ([thread (car (ts))]) diff --git a/racket/src/cs/rumble/place.ss b/racket/src/cs/rumble/place.ss index bf8a9d1dad..9d5b9191bd 100644 --- a/racket/src/cs/rumble/place.ss +++ b/racket/src/cs/rumble/place.ss @@ -82,6 +82,7 @@ (do-prepare-for-place) (fork-thread (lambda () (collect-trip-for-allocating-places! +1) + (thread-preserve-ownership!) ; encourages parallel GC (init-virtual-registers) (place-registers (vector-copy place-register-inits)) (root-thread-cell-values (make-empty-thread-cell-values)) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index ed88288e3f..1f255fa123 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 9 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x