From 20ab41bb10a09110407860202437a22512bfed8c Mon Sep 17 00:00:00 2001 From: dyb Date: Fri, 11 Jan 2019 18:10:38 -0800 Subject: [PATCH 1/8] - redirecting output of first two checkboot runs to /dev/null so the ignored exception, if any, does not show up in the make output. s/Mf-base original commit: 4de3eab4d76feea17431099f798a343a6205e50e --- LOG | 3 +++ s/Mf-base | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/LOG b/LOG index e5aae978a0..448da06fad 100644 --- a/LOG +++ b/LOG @@ -1027,3 +1027,6 @@ cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms - added initialization of seginfo sorted and trigger_ephemerons fields. segment.c +- redirecting output of first two checkboot runs to /dev/null so the + ignored exception, if any, does not show up in the make output. + s/Mf-base diff --git a/s/Mf-base b/s/Mf-base index 30427e8089..11a2a32de3 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -162,10 +162,10 @@ all: bootall ${Cheader} ${Cequates} # same as the last, i.e., the system is properly bootstrapped. allx: prettyclean saveboot $(MAKE) all - if $(MAKE) checkboot; then echo fine ; else\ + if $(MAKE) checkboot > /dev/null 2>&1; then echo fine ; else\ $(MAKE) prettyclean saveboot &&\ $(MAKE) all &&\ - if $(MAKE) checkboot; then echo fine ; else\ + if $(MAKE) checkboot > /dev/null 2>&1; then echo fine ; else\ $(MAKE) prettyclean saveboot &&\ $(MAKE) all &&\ $(MAKE) checkboot ;\ From 523384742a7c850dc52fdfaf3fc168a4ef0cf2d1 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Tue, 15 Jan 2019 13:21:17 -0500 Subject: [PATCH 2/8] fixed 7.ms to specify the relative path of testfile.boot original commit: 3ee3ffaccd2c50f69b183b4b14318b6a7aa382e7 --- LOG | 2 ++ mats/7.ms | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/LOG b/LOG index 448da06fad..ac677cb7f5 100644 --- a/LOG +++ b/LOG @@ -1030,3 +1030,5 @@ - redirecting output of first two checkboot runs to /dev/null so the ignored exception, if any, does not show up in the make output. s/Mf-base +- fixed 7.ms to specify the relative path of testfile.boot + 7.ms diff --git a/mats/7.ms b/mats/7.ms index 4fea56332f..2e5795620f 100644 --- a/mats/7.ms +++ b/mats/7.ms @@ -925,7 +925,7 @@ "testfile-5.ss")) (let-values ([(to-stdin from-stdout from-stderr pid) (open-process-ports - (format "~a -b testfile.boot -q" (patch-exec-path *scheme*)) + (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*)) (buffer-mode block) (native-transcoder))]) (close-output-port to-stdin) @@ -946,7 +946,7 @@ (make-boot-file "testfile.boot" '("petite") "testfile-libs.so")) (let-values ([(to-stdin from-stdout from-stderr pid) (open-process-ports - (format "~a -b testfile.boot -q" (patch-exec-path *scheme*)) + (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*)) (buffer-mode block) (native-transcoder))]) (pretty-print '(let () (import (B)) (printf "~s\n" b)) to-stdin) @@ -973,7 +973,7 @@ "testfile-5.so")) (let-values ([(to-stdin from-stdout from-stderr pid) (open-process-ports - (format "~a -b testfile.boot -q" (patch-exec-path *scheme*)) + (format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*)) (buffer-mode block) (native-transcoder))]) (close-output-port to-stdin) From ee9a4b3f5930c8fad5335d598507817887d33863 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 17 Jan 2019 09:43:18 -0800 Subject: [PATCH 3/8] profile counts are now maintained even for code that has been reclaimed by the collector and must be released explicitly by the programmer via (profile-release-counters). pdhtml.ss, primdata.ss, globals.h, externs.h, fasl.c, prim5.c, prim.c, alloc.c, scheme.c, misc.ms, release_notes.stex, system.stex original commit: 68e20f721618dbaf4c1634067c2bee24a493a750 --- LOG | 7 ++ c/alloc.c | 8 ++ c/externs.h | 1 + c/fasl.c | 8 +- c/globals.h | 1 + c/prim.c | 6 +- c/prim5.c | 50 ++++------- c/scheme.c | 3 + csug/system.stex | 21 +++++ mats/misc.ms | 147 +++++++++++++++++++++++++++---- release_notes/release_notes.stex | 13 +++ s/pdhtml.ss | 26 +++--- s/primdata.ss | 1 + 13 files changed, 227 insertions(+), 65 deletions(-) diff --git a/LOG b/LOG index ac677cb7f5..2292cb4037 100644 --- a/LOG +++ b/LOG @@ -1032,3 +1032,10 @@ s/Mf-base - fixed 7.ms to specify the relative path of testfile.boot 7.ms +- profile counts are now maintained even for code that has been + reclaimed by the collector and must be released explicitly by the + programmer via (profile-release-counters). + pdhtml.ss, primdata.ss, + globals.h, externs.h, fasl.c, prim5.c, prim.c, alloc.c, scheme.c, + misc.ms, + release_notes.stex, system.stex diff --git a/c/alloc.c b/c/alloc.c index efdd268969..a589b33c9a 100644 --- a/c/alloc.c +++ b/c/alloc.c @@ -911,3 +911,11 @@ ptr S_relocation_table(n) iptr n; { RELOCSIZE(p) = n; return p; } + +ptr S_weak_cons(ptr car, ptr cdr) { + ptr p; + tc_mutex_acquire(); + p = S_cons_in(space_weakpair, 0, car, cdr); + tc_mutex_release(); + return p; +} diff --git a/c/externs.h b/c/externs.h index 778db3b85b..91a5216418 100644 --- a/c/externs.h +++ b/c/externs.h @@ -89,6 +89,7 @@ extern ptr S_string PROTO((const char *s, iptr n)); extern ptr S_bignum PROTO((iptr n, IBOOL sign)); extern ptr S_code PROTO((ptr tc, iptr type, iptr n)); extern ptr S_relocation_table PROTO((iptr n)); +extern ptr S_weak_cons PROTO((ptr car, ptr cdr)); /* fasl.c */ extern void S_fasl_init PROTO((void)); diff --git a/c/fasl.c b/c/fasl.c index c659c69ec2..ec7799b9bc 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -886,7 +886,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { return; case fasl_type_code: { iptr n, m, a; INT flags; iptr free; - ptr co, reloc, name; + ptr co, reloc, name, pinfos; flags = bytein(f); free = uptrin(f); n = uptrin(f) /* length in bytes of code */; @@ -897,7 +897,11 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { CODENAME(co) = name; faslin(tc, &CODEARITYMASK(co), t, pstrbuf, f); faslin(tc, &CODEINFO(co), t, pstrbuf, f); - faslin(tc, &CODEPINFOS(co), t, pstrbuf, f); + faslin(tc, &pinfos, t, pstrbuf, f); + CODEPINFOS(co) = pinfos; + if (pinfos != Snil) { + S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); + } bytesin((octet *)&CODEIT(co, 0), n, f); m = uptrin(f); CODERELOC(co) = reloc = S_relocation_table(m); diff --git a/c/globals.h b/c/globals.h index e1c29ff3cc..b0b2979159 100644 --- a/c/globals.h +++ b/c/globals.h @@ -76,6 +76,7 @@ EXTERN struct { ptr scheme_version_id; ptr make_load_binary_id; ptr load_binary; + ptr profile_counters; /* foreign.c */ ptr foreign_static; diff --git a/c/prim.c b/c/prim.c index 85856e3be1..9f88f073b4 100644 --- a/c/prim.c +++ b/c/prim.c @@ -190,6 +190,7 @@ static void s_instantiate_code_object() { ptr tc = get_thread_context(); ptr old, cookie, proc; ptr new, oldreloc, newreloc; + ptr pinfos; uptr a, m, n; iptr i, size; @@ -212,7 +213,10 @@ static void s_instantiate_code_object() { CODEARITYMASK(new) = CODEARITYMASK(old); CODEFREE(new) = CODEFREE(old); CODEINFO(new) = CODEINFO(old); - CODEPINFOS(new) = CODEPINFOS(old); + CODEPINFOS(new) = pinfos = CODEPINFOS(old); + if (pinfos != Snil) { + S_G.profile_counters = Scons(S_weak_cons(new, pinfos), S_G.profile_counters); + } for (i = 0; i < CODELEN(old); i++) CODEIT(new,i) = CODEIT(old,i); diff --git a/c/prim5.c b/c/prim5.c index bb40e6277b..f19ca5492d 100644 --- a/c/prim5.c +++ b/c/prim5.c @@ -32,7 +32,6 @@ static iptr s_fxmul PROTO((iptr x, iptr y)); static iptr s_fxdiv PROTO((iptr x, iptr y)); static ptr s_trunc_rem PROTO((ptr x, ptr y)); static ptr s_fltofx PROTO((ptr x)); -static ptr s_weak_cons PROTO((ptr car, ptr cdr)); static ptr s_weak_pairp PROTO((ptr p)); static ptr s_ephemeron_cons PROTO((ptr car, ptr cdr)); static ptr s_ephemeron_pairp PROTO((ptr p)); @@ -86,7 +85,6 @@ static IBOOL s_fd_regularp PROTO((INT fd)); static void s_nanosleep PROTO((ptr sec, ptr nsec)); static ptr s_set_collect_trip_bytes PROTO((ptr n)); static void c_exit PROTO((I32 status)); -static ptr find_pcode PROTO((void)); static ptr s_get_reloc PROTO((ptr co)); #ifdef PTHREADS static s_thread_rv_t s_backdoor_thread_start PROTO((void *p)); @@ -117,6 +115,8 @@ static ptr s_iconv_to_string PROTO((uptr cd, ptr in, uptr i, uptr iend, ptr out, static ptr s_multibytetowidechar PROTO((unsigned cp, ptr inbv)); static ptr s_widechartomultibyte PROTO((unsigned cp, ptr inbv)); #endif +static ptr s_profile_counters PROTO((void)); +static void s_set_profile_counters PROTO((ptr counters)); #define require(test,who,msg,arg) if (!(test)) S_error1(who, msg, arg) @@ -174,15 +174,6 @@ static ptr s_fltofx(x) ptr x; { return FIX((iptr)FLODAT(x)); } -static ptr s_weak_cons(car, cdr) ptr car, cdr; { - ptr p; - - tc_mutex_acquire() - p = S_cons_in(space_weakpair, 0, car, cdr); - tc_mutex_release() - return p; -} - static ptr s_weak_pairp(p) ptr p; { seginfo *si; return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_weakpair ? Strue : Sfalse; @@ -893,6 +884,9 @@ static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) CODEARITYMASK(co) = arity_mark; CODEINFO(co) = info; CODEPINFOS(co) = pinfos; + if (pinfos != Snil) { + S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); + } return co; } @@ -1452,6 +1446,14 @@ static void s_condition_signal(s_thread_cond_t *c) { } #endif +static ptr s_profile_counters(void) { + return S_G.profile_counters; +} + +static void s_set_profile_counters(ptr counters) { + S_G.profile_counters = counters; +} + void S_dump_tc(ptr tc) { INT i; @@ -1492,7 +1494,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)s_ptr_in_heap", (void *)s_ptr_in_heap); Sforeign_symbol("(cs)generation", (void *)s_generation); Sforeign_symbol("(cs)s_fltofx", (void *)s_fltofx); - Sforeign_symbol("(cs)s_weak_cons", (void *)s_weak_cons); + Sforeign_symbol("(cs)s_weak_cons", (void *)S_weak_cons); Sforeign_symbol("(cs)s_weak_pairp", (void *)s_weak_pairp); Sforeign_symbol("(cs)s_ephemeron_cons", (void *)s_ephemeron_cons); Sforeign_symbol("(cs)s_ephemeron_pairp", (void *)s_ephemeron_pairp); @@ -1642,7 +1644,6 @@ void S_prim5_init() { Sforeign_symbol("(cs)log1p", (void *)s_log1p); #endif /* LOG1P */ - Sforeign_symbol("(cs)find_pcode", (void *)find_pcode); Sforeign_symbol("(cs)s_get_reloc", (void *)s_get_reloc); Sforeign_symbol("(cs)getenv", (void *)s_getenv); Sforeign_symbol("(cs)putenv", (void *)s_putenv); @@ -1672,27 +1673,8 @@ void S_prim5_init() { Sforeign_symbol("(cs)s_multibytetowidechar", (void *)s_multibytetowidechar); Sforeign_symbol("(cs)s_widechartomultibyte", (void *)s_widechartomultibyte); #endif -} - -static ptr find_pcode() { - ptr ls, p, *pp, *nl; - IGEN g; - - ls = Snil; - for (g = 0; g <= static_generation; g++) { - pp = (ptr *)S_G.first_loc[space_code][g]; - nl = (ptr *)S_G.next_loc[space_code][g]; - while (pp != nl) { - if (*pp == forward_marker) - pp = (ptr *)*(pp + 1); - else { - p = TYPE((ptr)pp, type_typed_object); - if (CODEPINFOS(p) != Snil) ls = Scons(p, ls); - pp += size_code(CODELEN(p)) / sizeof(ptr); - } - } - } - return ls; + Sforeign_symbol("(cs)s_profile_counters", (void *)s_profile_counters); + Sforeign_symbol("(cs)s_set_profile_counters", (void *)s_set_profile_counters); } static ptr s_get_reloc(co) ptr co; { diff --git a/c/scheme.c b/c/scheme.c index 6ecc7cdf16..4f14cbcd66 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -76,6 +76,9 @@ static void main_init() { if (!S_boot_time) return; + S_protect(&S_G.profile_counters); + S_G.profile_counters = Snil; + FXLENGTHBV(tc) = p = S_bytevector(256); for (i = 0; i < 256; i += 1) { BVIT(p, i) = diff --git a/csug/system.stex b/csug/system.stex index 19231adccc..4749833c4b 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -3030,6 +3030,16 @@ The code generated when \scheme{compile-profile} is non-false is larger and less efficient, so this parameter should be set only when profile information is needed. +The profile counters for code compiled when profile instrumentation +is enabled are retained indefinitely, even if the code with which +they are associated is reclaimed by the garbage collector. +This results in more complete and accurate profile data but can lead +to space leaks in programs that dynamically generate or load code. +Such programs can avoid the potential space leak by releasing the +counters explicitly via the procedure +\index{\scheme{profile-release-counters}}\scheme{profile-release-counters}. + + \entryheader \formdef{profile}{\categorysyntax}{(profile \var{source-object})} \returns unspecified @@ -3070,6 +3080,17 @@ that should be profiled. Calling this procedure causes profile information to be cleared, i.e., the counts associated with each section of code are set to zero. +%---------------------------------------------------------------------------- +\entryheader +\formdef{profile-release-counters}{\categoryprocedure}{(profile-release-counters)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Calling this procedure causes profile information associated with reclaimed +code objects to be dropped. + %---------------------------------------------------------------------------- \entryheader \formdef{profile-dump}{\categoryprocedure}{(profile-dump)} diff --git a/mats/misc.ms b/mats/misc.ms index 215e5b3c0a..a87b01dfb0 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -1793,13 +1793,8 @@ (eqv? ($frumble (make-list 100 5)) 9860761315262647567646607066034827870915080438862787559628486633300781) - (andmap - ; if counts for define and lambda on the first two lines are available (haven't - ; been tossed by the collector), check that they are 1 - (lambda (x) (= (car x) 1)) - (filter (lambda (x) (and (equal? (cadr x) "testfile-cp1.ss") (<= (list-ref x 4) 2))) (profile-dump-list))) (equal? - (filter (lambda (x) (and (equal? (cadr x) "testfile-cp1.ss") (>= (list-ref x 4) 3))) (profile-dump-list)) + (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list)) '((101 "testfile-cp1.ss" 36 258 3 5) (101 "testfile-cp1.ss" 40 50 3 9) (101 "testfile-cp1.ss" 41 46 3 10) @@ -1825,6 +1820,8 @@ (100 "testfile-cp1.ss" 247 248 9 24) (100 "testfile-cp1.ss" 249 250 9 26) (100 "testfile-cp1.ss" 251 252 9 28) + (1 "testfile-cp1.ss" 0 260 1 1) + (1 "testfile-cp1.ss" 19 259 2 3) (1 "testfile-cp1.ss" 59 60 4 9) (0 "testfile-cp1.ss" 128 178 7 15) (0 "testfile-cp1.ss" 129 136 7 16) @@ -1841,11 +1838,8 @@ (let ([ans ($frumble (append (make-list 50 5) (list 0) (make-list 50 7)))]) ($return ans)))) 0) - (andmap - (lambda (x) (= (car x) 1)) - (filter (lambda (x) (and (equal? (cadr x) "testfile-cp1.ss") (<= (list-ref x 4) 2))) (profile-dump-list))) (equal? - (filter (lambda (x) (and (equal? (cadr x) "testfile-cp1.ss") (>= (list-ref x 4) 3))) (profile-dump-list)) + (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list)) '((152 "testfile-cp1.ss" 36 258 3 5) (152 "testfile-cp1.ss" 40 50 3 9) (152 "testfile-cp1.ss" 41 46 3 10) @@ -1871,6 +1865,8 @@ (100 "testfile-cp1.ss" 247 248 9 24) (100 "testfile-cp1.ss" 249 250 9 26) (100 "testfile-cp1.ss" 251 252 9 28) + (1 "testfile-cp1.ss" 0 260 1 1) + (1 "testfile-cp1.ss" 19 259 2 3) (1 "testfile-cp1.ss" 59 60 4 9) (1 "testfile-cp1.ss" 128 178 7 15) (1 "testfile-cp1.ss" 129 136 7 16) @@ -1886,11 +1882,50 @@ (set! $return k) ($retry 1))) 111022302462515654042363166809082031) - (andmap - (lambda (x) (= (car x) 1)) - (filter (lambda (x) (and (equal? (cadr x) "testfile-cp1.ss") (<= (list-ref x 4) 2))) (profile-dump-list))) (equal? - (filter (lambda (x) (and (equal? (cadr x) "testfile-cp1.ss") (>= (list-ref x 4) 3))) (profile-dump-list)) + (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list)) + '((152 "testfile-cp1.ss" 36 258 3 5) + (152 "testfile-cp1.ss" 40 50 3 9) + (152 "testfile-cp1.ss" 41 46 3 10) + (152 "testfile-cp1.ss" 47 49 3 16) + (151 "testfile-cp1.ss" 69 257 5 9) + (151 "testfile-cp1.ss" 78 86 5 18) + (151 "testfile-cp1.ss" 79 82 5 19) + (151 "testfile-cp1.ss" 83 85 5 23) + (151 "testfile-cp1.ss" 99 256 6 11) + (151 "testfile-cp1.ss" 103 113 6 15) + (151 "testfile-cp1.ss" 104 108 6 16) + (151 "testfile-cp1.ss" 109 110 6 21) + (151 "testfile-cp1.ss" 111 112 6 23) + (150 "testfile-cp1.ss" 193 255 8 15) + (150 "testfile-cp1.ss" 202 221 8 24) + (150 "testfile-cp1.ss" 203 211 8 25) + (150 "testfile-cp1.ss" 212 220 8 34) + (150 "testfile-cp1.ss" 213 216 8 35) + (150 "testfile-cp1.ss" 217 219 8 39) + (150 "testfile-cp1.ss" 240 254 9 17) + (150 "testfile-cp1.ss" 241 245 9 18) + (150 "testfile-cp1.ss" 246 253 9 23) + (150 "testfile-cp1.ss" 247 248 9 24) + (150 "testfile-cp1.ss" 249 250 9 26) + (150 "testfile-cp1.ss" 251 252 9 28) + (1 "testfile-cp1.ss" 0 260 1 1) + (1 "testfile-cp1.ss" 19 259 2 3) + (1 "testfile-cp1.ss" 59 60 4 9) + (1 "testfile-cp1.ss" 128 178 7 15) + (1 "testfile-cp1.ss" 129 136 7 16) + (1 "testfile-cp1.ss" 137 177 7 24) + (1 "testfile-cp1.ss" 149 164 7 36) + (1 "testfile-cp1.ss" 162 163 7 49) + (1 "testfile-cp1.ss" 165 176 7 52) + (1 "testfile-cp1.ss" 166 173 7 53) + (1 "testfile-cp1.ss" 174 175 7 61))) + (begin + (collect (collect-maximum-generation)) ; drop code object for the define and lambda + (profile-release-counters) ; drop proile information for the dropped code object + #t) + (equal? + (filter (lambda (x) (equal? (cadr x) "testfile-cp1.ss")) (profile-dump-list)) '((152 "testfile-cp1.ss" 36 258 3 5) (152 "testfile-cp1.ss" 40 50 3 9) (152 "testfile-cp1.ss" 41 46 3 10) @@ -1925,6 +1960,88 @@ (1 "testfile-cp1.ss" 165 176 7 52) (1 "testfile-cp1.ss" 166 173 7 53) (1 "testfile-cp1.ss" 174 175 7 61))) + ; test profiling with compiled files + (begin + (with-output-to-file "testfile-cp2.ss" + (lambda () + (display-string "\ +(define cp2-fib + (rec fib + (lambda (n) + (cond + [(fx= n 0) 1] + [(fx= n 1) 1] + [else (+ (fib (- n 1)) (fib (- n 2)))])))) +")) + 'replace) + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2] [compile-profile #t]) + (compile-file "testfile-cp2")) + (profile-clear) + (load "testfile-cp2.so") + #t) + (eqv? (cp2-fib 10) 89) + (equal? + (filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list)) + '((177 "testfile-cp2.ss" 49 146 4 7) + (177 "testfile-cp2.ss" 64 73 5 10) + (177 "testfile-cp2.ss" 65 68 5 11) + (177 "testfile-cp2.ss" 69 70 5 15) + (177 "testfile-cp2.ss" 71 72 5 17) + (143 "testfile-cp2.ss" 86 95 6 10) + (143 "testfile-cp2.ss" 87 90 6 11) + (143 "testfile-cp2.ss" 91 92 6 15) + (143 "testfile-cp2.ss" 93 94 6 17) + (88 "testfile-cp2.ss" 113 144 7 15) + (88 "testfile-cp2.ss" 114 115 7 16) + (88 "testfile-cp2.ss" 116 129 7 18) + (88 "testfile-cp2.ss" 117 120 7 19) + (88 "testfile-cp2.ss" 121 128 7 23) + (88 "testfile-cp2.ss" 122 123 7 24) + (88 "testfile-cp2.ss" 124 125 7 26) + (88 "testfile-cp2.ss" 126 127 7 28) + (88 "testfile-cp2.ss" 130 143 7 32) + (88 "testfile-cp2.ss" 131 134 7 33) + (88 "testfile-cp2.ss" 135 142 7 37) + (88 "testfile-cp2.ss" 136 137 7 38) + (88 "testfile-cp2.ss" 138 139 7 40) + (88 "testfile-cp2.ss" 140 141 7 42) + (55 "testfile-cp2.ss" 96 97 6 20) + (34 "testfile-cp2.ss" 74 75 5 20) + (1 "testfile-cp2.ss" 0 149 1 1) + (1 "testfile-cp2.ss" 18 148 2 3) + (1 "testfile-cp2.ss" 23 26 2 8) + (1 "testfile-cp2.ss" 31 147 3 5))) + (begin + (collect (collect-maximum-generation)) ; drop code object for the define and lambda + (profile-release-counters) ; drop proile information for the dropped code object + #t) + (equal? + (filter (lambda (x) (equal? (cadr x) "testfile-cp2.ss")) (profile-dump-list)) + '((177 "testfile-cp2.ss" 49 146 4 7) + (177 "testfile-cp2.ss" 64 73 5 10) + (177 "testfile-cp2.ss" 65 68 5 11) + (177 "testfile-cp2.ss" 69 70 5 15) + (177 "testfile-cp2.ss" 71 72 5 17) + (143 "testfile-cp2.ss" 86 95 6 10) + (143 "testfile-cp2.ss" 87 90 6 11) + (143 "testfile-cp2.ss" 91 92 6 15) + (143 "testfile-cp2.ss" 93 94 6 17) + (88 "testfile-cp2.ss" 113 144 7 15) + (88 "testfile-cp2.ss" 114 115 7 16) + (88 "testfile-cp2.ss" 116 129 7 18) + (88 "testfile-cp2.ss" 117 120 7 19) + (88 "testfile-cp2.ss" 121 128 7 23) + (88 "testfile-cp2.ss" 122 123 7 24) + (88 "testfile-cp2.ss" 124 125 7 26) + (88 "testfile-cp2.ss" 126 127 7 28) + (88 "testfile-cp2.ss" 130 143 7 32) + (88 "testfile-cp2.ss" 131 134 7 33) + (88 "testfile-cp2.ss" 135 142 7 37) + (88 "testfile-cp2.ss" 136 137 7 38) + (88 "testfile-cp2.ss" 138 139 7 40) + (88 "testfile-cp2.ss" 140 141 7 42) + (55 "testfile-cp2.ss" 96 97 6 20) + (34 "testfile-cp2.ss" 74 75 5 20))) (eqv? (profile-clear) (void)) (begin (with-output-to-file "testfile.ss" @@ -1932,7 +2049,7 @@ (pretty-print '(define f (lambda () 0)))) 'replace) - (parameterize ([compile-profile #t]) (load "testfile.ss")) + (parameterize ([compile-profile #t]) (load "testfile.ss" compile)) #t) (begin (with-output-to-file "testfile.ss" diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 289d6d1eb5..2701219191 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,19 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{Profile data retained for reclaimed code (9.5.1)} + +Profile data is now retained indefinitely even for code objects +that have been reclaimed by the garbage collector. +Previously, the counters holding the data were reclaimed by the +collector along with the code objects. +This makes profile output more complete and accurate, but it does +represent a potential space leak in programs that create or load +and release code dynamically. +Such programs can avoid the potential space leak by releasing the +counters explicitly via the new procedure +\scheme{profile-release-counters}. + \subsection{Procedure source location without inspector information (9.5.1)} When \scheme{generate-inspector-information} is set to \scheme{#f} and diff --git a/s/pdhtml.ss b/s/pdhtml.ss index fd1b1e2210..0399ea02fd 100644 --- a/s/pdhtml.ss +++ b/s/pdhtml.ss @@ -60,14 +60,14 @@ (include "types.ss") (define op+ car) (define op- cdr) - (define find-pcode - (foreign-procedure "(cs)find_pcode" () scheme-object)) - (define find-pinfo - (lambda (x who) - (cond - [(procedure? x) ($code-pinfo* ($closure-code x))] - [($code? x) ($code-pinfo* x)] - [else ($oops who "could not find profiling info in ~s" x)]))) + (define get-counter-list (foreign-procedure "(cs)s_profile_counters" () ptr)) + (define set-counter-list! (foreign-procedure "(cs)s_set_profile_counters" (ptr) void)) + (set-who! profile-release-counters + (lambda () + (set-counter-list! + (remp + (lambda (x) (bwp-object? (car x))) + (get-counter-list))))) (set-who! profile-clear (lambda () (define clear-links @@ -80,8 +80,8 @@ (for-each (lambda (x) (for-each (lambda (node) (clear-links (rblock-op node))) - (find-pinfo x who))) - (find-pcode)))) + (cdr x))) + (get-counter-list)))) (set-who! profile-dump (lambda () (define rblock-count @@ -94,7 +94,7 @@ (- (#3%apply + (#3%map sum (op+ op))) (#3%apply + (#3%map sum (op- op)))))))) (fold-left - (lambda (r code) + (lambda (r x) (fold-left (lambda (r rblock) (fold-left @@ -102,8 +102,8 @@ (lambda (r inst) (cons (cons inst count) r))) r (rblock-srecs rblock))) - r (find-pinfo code who))) - '() (find-pcode))))) + r (cdr x))) + '() (get-counter-list))))) (let () (include "types.ss") diff --git a/s/primdata.ss b/s/primdata.ss index 244c957bd3..f81c0635aa 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1520,6 +1520,7 @@ (profile-dump-data [sig [(pathname) (pathname sub-list) -> (void)]] [flags true]) (profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true]) (profile-dump-html [sig [() (pathname) (pathname sub-list) -> (void)]] [flags true]) + (profile-release-counters [sig [() -> (void)]] [flags true]) (property-list [sig [(symbol) -> (list)]] [flags discard true]) (put-bytevector-some [sig [(binary-output-port bytevector) (binary-output-port bytevector length) (binary-output-port bytevector length length) -> (uint)]] [flags true]) (put-hash-table! [sig [(old-hash-table ptr ptr) -> (void)]] [flags true]) From 33e1149d440326046d1aebf8b2817b0262a92a1f Mon Sep 17 00:00:00 2001 From: dyb Date: Fri, 18 Jan 2019 10:15:20 -0800 Subject: [PATCH 5/8] clarified required use of scheme-start to start an application packaged as a boot file and added a short "myecho" example. use.stex original commit: 58c07fdd629a4f45e6d7e1a062a6d9dde7d11050 --- LOG | 3 +++ csug/use.stex | 39 ++++++++++++++++++++++++++++++++++++--- 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/LOG b/LOG index 2292cb4037..644f7bedc1 100644 --- a/LOG +++ b/LOG @@ -1039,3 +1039,6 @@ globals.h, externs.h, fasl.c, prim5.c, prim.c, alloc.c, scheme.c, misc.ms, release_notes.stex, system.stex +- clarified required use of scheme-start to start an application + packaged as a boot file and added a short "myecho" example. + use.stex diff --git a/csug/use.stex b/csug/use.stex index d1255a78e7..e0fe4f5dbb 100644 --- a/csug/use.stex +++ b/csug/use.stex @@ -1590,8 +1590,19 @@ application's name and spare your users from supplying any command-line arguments or running a separate script to load the application code. \end{itemize} -A boot file is simply an object file, possibly containing the code for -more than one source file, prefixed by a boot header. +\index{\scheme{scheme-start}}% +When an application is packaged into a boot file, the source code +that is compiled and converted into a boot file should set +\scheme{scheme-start} to a procedure that starts the application, +as shown in the example above. +The application should not be started directly from the boot file, +because boot files are loaded before final initialization of the +Scheme system. +The value of \scheme{scheme-start} is invoked automatically after +final initialization. + +A boot file is simply an object file containing the code for +one or more source files, prefixed by a boot header. The boot header identifies a base boot file upon which the application directly depends, or possibly two or more alternatives upon which the application can be run. @@ -1630,7 +1641,7 @@ This would allow your application to run on top of the full {\ChezScheme} if present, otherwise {\PetiteChezScheme}. In most cases, you can construct your application -so it does not depend upon features of {\ChezScheme} (specifically, +so it does not depend upon features of scheme.boot (specifically, the compiler) by specifying only \scheme{"petite"} in the call to \scheme{make-boot-file}. If your application calls \scheme{eval}, however, and you wish to @@ -1639,6 +1650,28 @@ advantage of the faster execution speed of compiled code, then specifying both \scheme{"scheme"} and \scheme{"petite"} is appropriate. +Here is how we might create and run a simple ``echo'' application +from a Linux shell: + +\schemedisplay +echo '(suppress-greeting #t)' > myecho.ss +echo '(scheme-start (lambda fns (printf "~{~a~^ ~}\n" fns)))' >> myecho.ss +echo '(compile-file "myecho.ss") \ + (make-boot-file "myecho.boot" (quote ("petite")) "myecho.so")' \ + | scheme -q +scheme -b myecho.boot hello world +\endschemedisplay + +If we take the extra step of installing a copy of the {\PetiteChezScheme} +executable as \scheme{myecho} and copying \scheme{myecho.boot} into +the same directory as \scheme{petite.boot} (or set SCHEMEHEAPDIRS to +include the directory containing myecho.boot), we can simply invoke +\scheme{myecho} to run our echo application: + +\schemedisplay +myecho hello world +\endschemedisplay + \parheader{Distributing the Application} Distributing an application involves can be as simple as creating a distribution package that includes the following items: From 90349ecc54d122e1e3310a92e0408551d5425cb2 Mon Sep 17 00:00:00 2001 From: dyb Date: Fri, 18 Jan 2019 10:26:10 -0800 Subject: [PATCH 6/8] updated date in release_notes.stex original commit: 6d44fee2b3126b9dbcca8b87694738e14e753927 --- release_notes/release_notes.stex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 2701219191..1219bd85af 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -2,8 +2,8 @@ \thisversion{Version 9.5.1} \thatversion{Version 8.4} -\pubmonth{August} -\pubyear{2018} +\pubmonth{January} +\pubyear{2019} \begin{document} From 6e999d02c3482c584ef6a0296c036d1c5d6a8cc2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 7 Jul 2017 10:36:10 -0600 Subject: [PATCH 7/8] add ordered guardians Also, avoid quadratic time in GC for guardian chains. original commit: 273f79a7be5c04370c399e6b1d8af799efc8b33f --- LOG | 4 + c/gc.c | 401 ++++++++++++++++++++++++------- c/segment.c | 3 + c/types.h | 4 +- csug/smgmt.stex | 28 ++- mats/4.ms | 256 +++++++++++++++++++- release_notes/release_notes.stex | 8 + s/cmacros.ss | 4 +- s/cp0.ss | 84 ++++--- s/cpnanopass.ss | 6 +- s/mkheader.ss | 4 + s/primdata.ss | 2 +- s/prims.ss | 8 +- 13 files changed, 681 insertions(+), 131 deletions(-) diff --git a/LOG b/LOG index 644f7bedc1..258b5c1071 100644 --- a/LOG +++ b/LOG @@ -1042,3 +1042,7 @@ - clarified required use of scheme-start to start an application packaged as a boot file and added a short "myecho" example. use.stex +- add ordered guardians through a new optional argument to make-guardian + prims.ss, primdata.ss, cp0.ss, cpnanopass.ss, + cmacros.ss, mkheader.ss, gc.c, segment.c, types.h, + 4.ms, smgmt.stex, release_notes.stex diff --git a/c/gc.c b/c/gc.c index c65215d16a..498e6ad44d 100644 --- a/c/gc.c +++ b/c/gc.c @@ -32,6 +32,8 @@ static IBOOL search_locked PROTO((ptr p)); static ptr copy PROTO((ptr pp, seginfo *si)); static void sweep_ptrs PROTO((ptr *p, iptr n)); static void sweep PROTO((ptr tc, ptr p, IBOOL sweep_pure)); +static void sweep_in_old PROTO((ptr tc, ptr p)); +static int scan_ptrs_for_self PROTO((ptr *pp, iptr len, ptr p)); static ptr copy_stack PROTO((ptr old, iptr *length, iptr clength)); static void resweep_weak_pairs PROTO((IGEN g)); static void forward_or_bwp PROTO((ptr *pp, ptr p)); @@ -44,14 +46,17 @@ static void sweep_thread PROTO((ptr p)); static void sweep_continuation PROTO((ptr p)); static void sweep_stack PROTO((uptr base, uptr size, uptr ret)); static void sweep_record PROTO((ptr x)); +static int scan_record_for_self PROTO((ptr x)); static IGEN sweep_dirty_record PROTO((ptr x)); static void sweep_code_object PROTO((ptr tc, ptr co)); static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si)); static void sweep_dirty PROTO((void)); static void resweep_dirty_weak_pairs PROTO((void)); +static void add_pending_guardian PROTO((ptr gdn, ptr tconc)); +static void add_trigger_guardians_to_recheck PROTO((ptr ls)); static void add_ephemeron_to_pending PROTO((ptr p)); static void add_trigger_ephemerons_to_repending PROTO((ptr p)); -static void check_trigger_ephemerons PROTO((seginfo *si)); +static void check_triggers PROTO((seginfo *si)); static void check_ephemeron PROTO((ptr pe, int add_to_trigger)); static void check_pending_ephemerons PROTO(()); static int check_dirty_ephemeron PROTO((ptr pe, int tg, int youngest)); @@ -72,6 +77,14 @@ static ptr sweep_loc[max_real_space+1]; static ptr orig_next_loc[max_real_space+1]; static ptr sorted_locked_objects; static ptr tlcs_to_rehash; +static ptr recheck_guardians_ls; + +/* Values for a guardian entry's `pending` field when it's added to a + seginfo's pending list: */ +enum { + GUARDIAN_PENDING_HOLD, + GUARDIAN_PENDING_FINAL +}; static ptr append_bang(ptr ls1, ptr ls2) { /* assumes ls2 pairs are older than ls1 pairs, or that we don't car */ if (ls2 == Snil) { @@ -192,15 +205,23 @@ static IBOOL search_locked(ptr p) { #define locked(p) (sorted_locked_objects != FIX(0) && search_locked(p)) -FORCEINLINE void check_trigger_ephemerons(seginfo *si) { - /* Registering ephemerons to recheck at the granularity of a segment - means that the worst-case complexity of GC is quadratic in the - number of objects that fit into a segment (but that only happens - if the objects are ephemeron keys that are reachable just through - a chain via the value field of the same ephemerons). */ - if (si->trigger_ephemerons) { - add_trigger_ephemerons_to_repending(si->trigger_ephemerons); - si->trigger_ephemerons = NULL; +FORCEINLINE void check_triggers(seginfo *si) { + /* Registering ephemerons and guardians to recheck at the + granularity of a segment means that the worst-case complexity of + GC is quadratic in the number of objects that fit into a segment + (but that only happens if the objects are ephemeron keys that are + reachable just through a chain via the value field of the same + ephemerons). */ + if (si->has_triggers) { + if (si->trigger_ephemerons) { + add_trigger_ephemerons_to_repending(si->trigger_ephemerons); + si->trigger_ephemerons = NULL; + } + if (si->trigger_guardians) { + add_trigger_guardians_to_recheck(si->trigger_guardians); + si->trigger_guardians = NULL; + } + si->has_triggers = 0; } } @@ -213,7 +234,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { change = 1; - check_trigger_ephemerons(si); + check_triggers(si); if ((t = TYPEBITS(pp)) == type_typed_object) { tf = TYPEFIELD(pp); @@ -449,7 +470,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { } else { ptr qq = Scdr(pp); ptr q; seginfo *qsi; if (qq != pp && TYPEBITS(qq) == type_pair && (qsi = MaybeSegInfo(ptr_get_segment(qq))) != NULL && qsi->space == si->space && FWDMARKER(qq) != forward_marker && !locked(qq)) { - check_trigger_ephemerons(qsi); + check_triggers(qsi); if (si->space == (space_weakpair | space_old)) { #ifdef ENABLE_OBJECT_COUNTS S_G.countof[tg][countof_weakpair] += 2; @@ -630,6 +651,119 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) { } } +/* sweep_in_old() is like sweep(), but the goal is to sweep the + object's content without copying the object itself, so we're sweep + an object while it's still in old space. If an object refers back + to itself, naively sweeping might copy the object while we're + trying to sweep the old copy, which interacts badly with the words + set to a forwarding marker and pointer. To handle that problem, + sweep_in_old() is allowed to copy the object, since the object + is going to get copied anyway. */ +static void sweep_in_old(ptr tc, ptr p) { + ptr tf; ITYPE t; + + /* Detect all the cases when we need to give up on in-place + sweeping: */ + if ((t = TYPEBITS(p)) == type_pair) { + ISPC s = SPACE(p) & ~(space_locked | space_old); + if (s == space_ephemeron) { + /* Weak reference can be ignored, so we do nothing */ + return; + } else if (s != space_weakpair) { + if (p == Scar(p)) { + relocate(&p) + return; + } + } + if (p == Scdr(p)) { + relocate(&p) + return; + } + } else if (t == type_closure) { + /* A closure can refer back to itself */ + ptr code = CLOSCODE(p); + if (!(CODETYPE(code) & (code_flag_continuation << code_flags_offset))) { + if (scan_ptrs_for_self(&CLOSIT(p, 0), CLOSLEN(p), p)) { + relocate(&p) + return; + } + } + } else if (t == type_symbol) { + /* a symbol can refer back to itself as its own value */ + if (p == SYMVAL(p)) { + relocate(&p) + return; + } + } else if (t == type_flonum) { + /* nothing to sweep */ + return; + /* typed objects */ + } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { + if (scan_ptrs_for_self(&INITVECTIT(p, 0), Svector_length(p), p)) { + relocate(&p) + return; + } + } else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) { + /* nothing to sweep */ + return; + } else if (TYPEP(tf, mask_record, type_record)) { + relocate(&RECORDINSTTYPE(p)); + if (scan_record_for_self(p)) { + relocate(&p) + return; + } + } else if (TYPEP(tf, mask_box, type_box)) { + if (Sunbox(p) == p) { + relocate(&p) + return; + } + } else if ((iptr)tf == type_ratnum) { + /* can't refer back to itself */ + } else if ((iptr)tf == type_exactnum) { + /* can't refer back to itself */ + } else if ((iptr)tf == type_inexactnum) { + /* nothing to sweep */ + return; + } else if (TYPEP(tf, mask_bignum, type_bignum)) { + /* nothing to sweep */ + return; + } else if (TYPEP(tf, mask_port, type_port)) { + /* a symbol can refer back to itself as info */ + if (p == PORTINFO(p)) { + relocate(&p) + return; + } + } else if (TYPEP(tf, mask_code, type_code)) { + /* We don't expect code to be accessible to a layer that registers + an ordered finalizer, but just in case, assume that code + includes a self-reference */ + relocate(&p) + return; + } else if ((iptr)tf == type_thread) { + /* threads are allocated with plain malloc(), so ordered + finalization cannot work on them */ + S_error_abort("sweep_in_old(gc): cannot check thread"); + } else if ((iptr)tf == type_rtd_counts) { + /* nothing to sweep */ + return; + } else { + S_error_abort("sweep_in_old(gc): illegal type"); + } + + /* We've determined that `p` won't refer immediately back to itself, + so it's ok to use sweep(). */ + sweep(tc, p, 1); +} + +static int scan_ptrs_for_self(ptr *pp, iptr len, ptr p) { + while (len--) { + if (*pp == p) + return 1; + pp += 1; + } + return 0; +} + static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { iptr n, m; ptr new; @@ -880,14 +1014,29 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { sweep_generation(tc, tg); /* handle guardians */ - { ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls; + { ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls, maybe_final_ordered_ls; ptr obj, rep, tconc, next; + IBOOL do_ordered = 0; /* move each entry in guardian lists into one of: * pend_hold_ls if obj accessible * final_ls if obj not accessible and tconc accessible - * pend_final_ls if obj not accessible and tconc not accessible */ - pend_hold_ls = final_ls = pend_final_ls = Snil; + * pend_final_ls if obj not accessible and tconc not accessible + * When a pend_hold_ls or pend_final_ls entry is tconc is + * determined to be accessible, then it moves to hold_ls or + * final_ls. When an entry in pend_hold_ls or pend_final_ls can't + * be moved to final_ls or hold_ls, the entry moves into a + * seginfo's trigger list (to avoid quadratic-time processing of + * guardians). When the trigger fires, the entry is added to + * recheck_guardians_ls, which is sorted back into pend_hold_ls + * and pend_final_ls for another iteration. + * Ordered and unordered guardian entries start out together; + * when final_ls is processed, ordered entries are delayed by + * moving them into maybe_final_ordered_ls, which is split back + * into final_ls and pend_hold_ls after all unordered entries + * have been handled. */ + pend_hold_ls = final_ls = pend_final_ls = maybe_final_ordered_ls = Snil; + recheck_guardians_ls = Snil; for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { ptr tc = (ptr)THREADTC(Scar(ls)); @@ -912,25 +1061,51 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { IBOOL relocate_rep = final_ls != Snil; /* relocate & add the final objects to their tconcs */ - for (ls = final_ls; ls != Snil; ls = GUARDIANNEXT(ls)) { + ls = final_ls; final_ls = Snil; + for (; ls != Snil; ls = next) { ptr old_end, new_end; + next = GUARDIANNEXT(ls); + rep = GUARDIANREP(ls); - relocate(&rep); + if (!do_ordered && (GUARDIANORDERED(ls) == Strue)) { + /* Sweep from the representative, but don't copy the + representative itself; if the object stays uncopied by + the end, then the entry is really final, and we copy the + representative only at that point; crucially, the + representative can't itself be a tconc, so we + won't discover any new tconcs at that point. */ + ptr obj = GUARDIANOBJ(ls); + if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) { + /* Object is reachable, so we might as well move + this one to the hold list --- via pend_hold_ls, which + leads to a copy to move to hold_ls */ + INITGUARDIANNEXT(ls) = pend_hold_ls; + pend_hold_ls = ls; + } else { + seginfo *si; + if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && (si->space & space_old) && !locked(rep)) + sweep_in_old(tc, rep); + INITGUARDIANNEXT(ls) = maybe_final_ordered_ls; + maybe_final_ordered_ls = ls; + } + } else { + relocate(&rep); - /* if tconc was old it's been forwarded */ - tconc = GUARDIANTCONC(ls); - - old_end = Scdr(tconc); + /* if tconc was old it's been forwarded */ + tconc = GUARDIANTCONC(ls); + + old_end = Scdr(tconc); /* allocating pair in tg means it will be swept, which is wasted effort, but should cause no harm */ - new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0)); + new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0)); #ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_pair] += 1; + S_G.countof[tg][countof_pair] += 1; #endif /* ENABLE_OBJECT_COUNTS */ - - SETCAR(old_end,rep); - SETCDR(old_end,new_end); - SETCDR(tconc,new_end); + + SETCAR(old_end,rep); + SETCDR(old_end,new_end); + SETCDR(tconc,new_end); + } } /* discard static pend_hold_ls entries */ @@ -944,12 +1119,12 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { if (FWDMARKER(tconc) == forward_marker) tconc = FWDADDRESS(tconc); else { - INITGUARDIANNEXT(ls) = pend_hold_ls; - pend_hold_ls = ls; + INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_HOLD); + add_pending_guardian(ls, tconc); continue; } } - + rep = GUARDIANREP(ls); relocate(&rep); relocate_rep = 1; @@ -962,18 +1137,54 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { INITGUARDIANREP(p) = rep; INITGUARDIANTCONC(p) = tconc; INITGUARDIANNEXT(p) = hold_ls; + INITGUARDIANORDERED(p) = GUARDIANORDERED(ls); + INITGUARDIANPENDING(p) = FIX(0); hold_ls = p; } } + if (!relocate_rep && !do_ordered && maybe_final_ordered_ls != Snil) { + /* Switch to finishing up ordered. Move all maybe-final + ordered entries to final_ls and pend_hold_ls */ + do_ordered = relocate_rep = 1; + ls = maybe_final_ordered_ls; maybe_final_ordered_ls = Snil; + for (; ls != Snil; ls = next) { + ptr obj = GUARDIANOBJ(ls); + next = GUARDIANNEXT(ls); + if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) { + /* Will defintely move to hold_ls, but the entry + must be copied to move from pend_hold_ls to + hold_ls: */ + INITGUARDIANNEXT(ls) = pend_hold_ls; + pend_hold_ls = ls; + } else { + INITGUARDIANNEXT(ls) = final_ls; + final_ls = ls; + } + } + } + if (!relocate_rep) break; sweep_generation(tc, tg); + ls = recheck_guardians_ls; recheck_guardians_ls = Snil; + for ( ; ls != Snil; ls = next) { + next = GUARDIANNEXT(ls); + if (GUARDIANPENDING(ls) == FIX(GUARDIAN_PENDING_HOLD)) { + INITGUARDIANNEXT(ls) = pend_hold_ls; + pend_hold_ls = ls; + } else { + INITGUARDIANNEXT(ls) = pend_final_ls; + pend_final_ls = ls; + } + } + /* move each entry in pend_final_ls into one of: * final_ls if tconc forwarded - * pend_final_ls if tconc not forwarded */ - ls = pend_final_ls; final_ls = pend_final_ls = Snil; + * pend_final_ls if tconc not forwarded + * where the output pend_final_ls coresponds to pending in a segment */ + ls = pend_final_ls; pend_final_ls = Snil; for ( ; ls != Snil; ls = next) { tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls); @@ -982,8 +1193,8 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { INITGUARDIANNEXT(ls) = final_ls; final_ls = ls; } else { - INITGUARDIANNEXT(ls) = pend_final_ls; - pend_final_ls = ls; + INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_FINAL); + add_pending_guardian(ls, tconc); } } } @@ -1571,52 +1782,62 @@ static void sweep_stack(base, fp, ret) uptr base, fp, ret; { } } +#define sweep_or_check_record(x, sweep_or_check) \ + ptr *pp; ptr num; ptr rtd; \ + \ + /* record-type descriptor was forwarded already */ \ + rtd = RECORDINSTTYPE(x); \ + num = RECORDDESCPM(rtd); \ + pp = &RECORDINSTIT(x,0); \ + \ + /* process cells for which bit in pm is set; quit when pm == 0. */ \ + if (Sfixnump(num)) { \ + /* ignore bit for already forwarded rtd */ \ + uptr mask = (uptr)UNFIX(num) >> 1; \ + if (mask == (uptr)-1 >> 1) { \ + ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; \ + while (pp < ppend) { \ + sweep_or_check(pp) \ + pp += 1; \ + } \ + } else { \ + while (mask != 0) { \ + if (mask & 1) sweep_or_check(pp) \ + mask >>= 1; \ + pp += 1; \ + } \ + } \ + } else { \ + iptr index; bigit mask; INT bits; \ + \ + /* bignum pointer mask may have been forwarded */ \ + relocate(&RECORDDESCPM(rtd)) \ + num = RECORDDESCPM(rtd); \ + index = BIGLEN(num) - 1; \ + /* ignore bit for already forwarded rtd */ \ + mask = BIGIT(num,index) >> 1; \ + bits = bigit_bits - 1; \ + for (;;) { \ + do { \ + if (mask & 1) sweep_or_check(pp) \ + mask >>= 1; \ + pp += 1; \ + } while (--bits > 0); \ + if (index-- == 0) break; \ + mask = BIGIT(num,index); \ + bits = bigit_bits; \ + } \ + } \ + static void sweep_record(x) ptr x; { - ptr *pp; ptr num; ptr rtd; + sweep_or_check_record(x, relocate) +} - /* record-type descriptor was forwarded in copy */ - rtd = RECORDINSTTYPE(x); - num = RECORDDESCPM(rtd); - pp = &RECORDINSTIT(x,0); +#define check_self(pp) if (*(pp) == x) return 1; - /* sweep cells for which bit in pm is set; quit when pm == 0. */ - if (Sfixnump(num)) { - /* ignore bit for already forwarded rtd */ - uptr mask = (uptr)UNFIX(num) >> 1; - if (mask == (uptr)-1 >> 1) { - ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; - while (pp < ppend) { - relocate(pp) - pp += 1; - } - } else { - while (mask != 0) { - if (mask & 1) relocate(pp) - mask >>= 1; - pp += 1; - } - } - } else { - iptr index; bigit mask; INT bits; - - /* bignum pointer mask may have been forwarded */ - relocate(&RECORDDESCPM(rtd)) - num = RECORDDESCPM(rtd); - index = BIGLEN(num) - 1; - /* ignore bit for already forwarded rtd */ - mask = BIGIT(num,index) >> 1; - bits = bigit_bits - 1; - for (;;) { - do { - if (mask & 1) relocate(pp) - mask >>= 1; - pp += 1; - } while (--bits > 0); - if (index-- == 0) break; - mask = BIGIT(num,index); - bits = bigit_bits; - } - } +static int scan_record_for_self(x) ptr x; { + sweep_or_check_record(x, check_self) + return 0; } static IGEN sweep_dirty_record(x) ptr x; { @@ -2033,6 +2254,25 @@ static void resweep_dirty_weak_pairs() { } } +static void add_pending_guardian(ptr gdn, ptr tconc) +{ + seginfo *si = SegInfo(ptr_get_segment(tconc)); + INITGUARDIANNEXT(gdn) = si->trigger_guardians; + si->trigger_guardians = gdn; + si->has_triggers = 1; +} + +static void add_trigger_guardians_to_recheck(ptr ls) +{ + ptr last = ls, next = GUARDIANNEXT(ls); + while (next != NULL) { + last = next; + next = GUARDIANNEXT(next); + } + INITGUARDIANNEXT(last) = recheck_guardians_ls; + recheck_guardians_ls = ls; +} + static ptr pending_ephemerons = NULL; /* Ephemerons that we haven't looked at, chained through `next`. */ @@ -2083,6 +2323,7 @@ static void check_ephemeron(ptr pe, int add_to_trigger) { /* Not reached, so far; install as trigger */ EPHEMERONTRIGGERNEXT(pe) = si->trigger_ephemerons; si->trigger_ephemerons = pe; + si->has_triggers = 1; if (add_to_trigger) { EPHEMERONNEXT(pe) = trigger_ephemerons; trigger_ephemerons = pe; @@ -2165,15 +2406,9 @@ static void clear_trigger_ephemerons() { if (EPHEMERONTRIGGERNEXT(pe) == Strue) { /* The ephemeron was triggered and retains its key and value */ } else { - seginfo *si; - ptr p = Scar(pe); /* Key never became reachable, so clear key and value */ INITCAR(pe) = Sbwp_object; INITCDR(pe) = Sbwp_object; - - /* Remove trigger */ - si = SegInfo(ptr_get_segment(p)); - si->trigger_ephemerons = NULL; } pe = EPHEMERONNEXT(pe); } diff --git a/c/segment.c b/c/segment.c index 83e3dc7707..5d44e48835 100644 --- a/c/segment.c +++ b/c/segment.c @@ -236,6 +236,9 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) { /* fill sizeof(iptr) bytes at a time with 0xff */ *dp = -1; } + si->has_triggers = 0; + si->trigger_ephemerons = 0; + si->trigger_guardians = 0; } iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; { diff --git a/c/types.h b/c/types.h index 872dc17671..3f413dadd9 100644 --- a/c/types.h +++ b/c/types.h @@ -118,7 +118,8 @@ typedef int IFASLCODE; /* fasl type codes */ typedef struct _seginfo { unsigned char space; /* space the segment is in */ unsigned char generation; /* generation the segment is in */ - unsigned char sorted; /* sorted indicator---possibly to be incorporated into space flags? */ + unsigned char sorted : 1; /* sorted indicator---possibly to be incorporated into space flags? */ + unsigned char has_triggers : 1; /* set if trigger_ephemerons or trigger_guardians is set */ octet min_dirty_byte; /* dirty byte for full segment, effectively min(dirty_bytes) */ uptr number; /* the segment number */ struct _chunkinfo *chunk; /* the chunk this segment belongs to */ @@ -126,6 +127,7 @@ typedef struct _seginfo { struct _seginfo **dirty_prev; /* pointer to the next pointer on the previous seginfo in the DirtySegments list */ struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */ ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */ + ptr trigger_guardians; /* guardians to re-check if object in segment is copied out */ octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ } seginfo; diff --git a/csug/smgmt.stex b/csug/smgmt.stex index 854129866e..7521396fd3 100644 --- a/csug/smgmt.stex +++ b/csug/smgmt.stex @@ -551,7 +551,8 @@ reference, and that non-weak reference prevents the car field from becoming %---------------------------------------------------------------------------- \entryheader \formdef{make-guardian}{\categoryprocedure}{(make-guardian)} -\returns a new guardian +\formdef{make-guardian}{\categoryprocedure}{(make-guardian \var{ordered?})} +\returns a new guardian that is unordered unless \var{ordered?} is true \listlibraries \endentryheader @@ -637,10 +638,26 @@ This feature circumvents the problems that might otherwise arise with shared or cyclic structure. A shared or cyclic structure consisting of inaccessible objects is preserved in its entirety, and each piece registered for preservation -with any guardian is placed in the inaccessible set for that guardian. +with any unordered guardian is placed in the inaccessible set for that guardian. The programmer then has complete control over the order in which pieces of the structure are processed. +An ordered guardian, as created by providing a true value for +\var{ordered?}, treats an object as inaccessible only when it is not +accessible from any representative of an object that is in any +usable guardian's inaccessible group and that is distinct from the +object itself. Cycles among objects registered with ordered guardians +can never become inaccessible unless the cycle is broken or some of +the relevant guardians are dropped by the program, and each +registered object's representative (if different from the object) can +contribute to such cycles. If an object is registered to an ordered +custodian with a representative that is different from the object but +that references the object, then the object is in a cycle and will not +become inaccessible unless the reference from the representative to +the object is destroyed. Weak references do not count, so objects that +form a cycle only when counting weak references may still become +inaccessible. + An object may be registered with a guardian more than once, in which case it will be retrievable more than once: @@ -657,7 +674,12 @@ case it will be retrievable more than once: \noindent It may also be registered with more than one guardian, and guardians -themselves can be registered with other guardians. +themselves can be registered with other guardians. If an object +is registered to both an unordered guardian and an ordered guardian +and neither guardians is dropped, the object can become +inaccessible for the ordered guardian only after it has been +determined inaccessible for the unordered guardian and then +retrieved and dropped again by the program. An object that has been registered with a guardian without a representative and placed in diff --git a/mats/4.ms b/mats/4.ms index 3d531e227f..8db8061d50 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -3367,6 +3367,13 @@ (begin (x (cons 'a 'b)) (not (x))) (begin (collect) (equal? (x) '(a . b))) (not (x))))) + ;; same for ordered: + (with-interrupts-disabled + (let ([x (make-guardian #t)]) + (and (not (x)) + (begin (x (cons 'a 'b)) (not (x))) + (begin (collect) (equal? (x) '(a . b))) + (not (x))))) (with-interrupts-disabled (let ([x1 (make-guardian)]) ; counting on a little compiler cleanliness here... @@ -3378,6 +3385,18 @@ (and (equal? (x2) x2) (not (x1)) (not (x2)))))) + ;; same for ordered: + (with-interrupts-disabled + (let ([x1 (make-guardian #t)]) + ; counting on a little compiler cleanliness here... + (let ([x2 (make-guardian #t)]) + (x1 x2) + (x2 x2)) + (collect) + (let ([x2 (x1)]) + (and (equal? (x2) x2) + (not (x1)) + (not (x2)))))) (parameterize ([collect-trip-bytes (expt 2 24)]) (let ([k 1000000]) (let ([g (make-guardian)]) @@ -3392,24 +3411,60 @@ [(g) => (lambda (x) (f (- n 1)))] [else (collect) (f n)]))) #t))) + ;; same for ordered: + (parameterize ([collect-trip-bytes (expt 2 24)]) + (let ([k 1000000]) + (let ([g (make-guardian #t)]) + (let f ([n k]) + (unless (= n 0) + (g (cons 3 4)) + (let f () (cond [(g) => (lambda (x) (g x) (f))])) + (f (- n 1)))) + (let f ([n k]) + (unless (= n 0) + (cond + [(g) => (lambda (x) (f (- n 1)))] + [else (collect) (f n)]))) + #t))) (with-interrupts-disabled (let ([x (make-guardian)]) (and (not (x)) (begin (x (cons 'a 'b) 'calvin) (not (x))) (begin (collect) (equal? (x) 'calvin)) (not (x))))) + ;; same for ordered: + (with-interrupts-disabled + (let ([x (make-guardian #t)]) + (and (not (x)) + (begin (x (cons 'a 'b) 'calvin) (not (x))) + (begin (collect) (equal? (x) 'calvin)) + (not (x))))) (with-interrupts-disabled (let ([x (make-guardian)]) (and (not (x)) (begin (x (cons 'a 'b) (cons 'calvin 'hobbes)) (not (x))) (begin (collect) (equal? (x) '(calvin . hobbes))) (not (x))))) + ;; same for ordered: + (with-interrupts-disabled + (let ([x (make-guardian #t)]) + (and (not (x)) + (begin (x (cons 'a 'b) (cons 'calvin 'hobbes)) (not (x))) + (begin (collect) (equal? (x) '(calvin . hobbes))) + (not (x))))) (with-interrupts-disabled (let ([x (make-guardian)]) (and (not (x)) (begin (x (cons 'a 'b) 17) (not (x))) (begin (collect) (equal? (x) '17)) (not (x))))) + ;; same for ordered: + (with-interrupts-disabled + (let ([x (make-guardian #t)]) + (and (not (x)) + (begin (x (cons 'a 'b) 17) (not (x))) + (begin (collect) (equal? (x) '17)) + (not (x))))) (equal? (with-interrupts-disabled (let ([g1 (make-guardian)] [g2 (make-guardian)]) @@ -3421,6 +3476,18 @@ (collect 0 0) (list ((g1)) p))))) '((c d) (b))) + ;; same for ordered: + (equal? + (with-interrupts-disabled + (let ([g1 (make-guardian #t)] [g2 (make-guardian #t)]) + (let ([p (list 'a 'b)]) + (g1 p g2) + (g2 (list 'c 'd)) + (collect 0 0) + (let ([p (cdr p)]) + (collect 0 0) + (list ((g1)) p))))) + '((c d) (b))) (eq? (with-interrupts-disabled (let* ([g (make-guardian)] [x (list 'a 'b)]) @@ -3429,6 +3496,14 @@ (#%$keep-live x) (g))) #f) + ;; same for ordered: + (eq? (with-interrupts-disabled + (let* ([g (make-guardian #t)] [x (list 'a 'b)]) + (g x) + (collect 0 0) + (#%$keep-live x) + (g))) + #f) (or (not (threaded?)) (equal? @@ -3468,7 +3543,186 @@ (error #f "no static-generation fraz in object-counts list")) (pretty-print (cons g x)) ; keep 'em live #t) - ) + + (begin + (define (measure-guardian-chain-time n get-key ordered?) + ;; Create a chain of guardians `n` long and + ;; report how long a collection takes averaged + ;; over `iters` tries + (define iters 10) + (let loop ([g #f] [accum 0] [j iters]) + (if (zero? j) + (if (zero? accum) + g + (/ accum iters)) + (let ([g (let loop ([i n]) + (let ([g (make-guardian ordered?)]) + (if (zero? i) + g + (let ([next-g (loop (sub1 i))]) + (g (get-key next-g) next-g) + g))))]) + (let ([start (current-time)]) + (collect (collect-maximum-generation)) + (let ([delta (time-difference (current-time) start)]) + (loop g + (+ accum + (* (time-second delta) 1e9) + (time-nanosecond delta)) + (sub1 j)))))))) + + ;; Make sure guardian chains imply GC times that + ;; look linear, as opposed to quadratic + (define (ok-relative-guardian-chain-time? get-key ordered?) + (let loop ([tries 3]) + (or (< (/ (measure-guardian-chain-time 10000 get-key ordered?) + (measure-guardian-chain-time 1000 get-key ordered?)) + 20) + (and (positive? tries) + (loop (sub1 tries)))))) + + (and (ok-relative-guardian-chain-time? values #f) + (ok-relative-guardian-chain-time? values #t) + (let ([obj (gensym)]) + (and + (ok-relative-guardian-chain-time? (lambda (x) obj) #f) + (ok-relative-guardian-chain-time? (lambda (x) obj) #t))))) + + ;; Ordered finalization as different from unordred: + (with-interrupts-disabled + (let ([g1 (make-guardian #t)] + [g2 (make-guardian #t)] + [s (gensym)]) + (g1 s) + (g2 (list s)) ; delays readying `s` in `g1` + (set! s #f) + (collect 0 0) + (and (list? (g2)) + (not (g1)) + (begin + (collect 0 0) + (and (symbol? (g1)) + (not (g2))))))) + ;; Unordered is different: + (with-interrupts-disabled + (let ([g1 (make-guardian #f)] + [g2 (make-guardian #f)] + [s (gensym)]) + (g1 s) + (g2 (list s)) ; no delay + (set! s #f) + (collect 0 0) + (and (list? (g2)) + (symbol? (g1)) + (begin + (collect 0 0) + (and (not (g1)) + (not (g2))))))) + + ;; cycle ok with unordered + (let ([g (make-guardian)]) + (let ([s (gensym)]) + (g s (list s))) + (collect) + (list? (g))) + ;; cycle not ok with ordered + (let ([g (make-guardian #t)]) + (let ([s (gensym)]) + (g s (list s))) + (collect) + (not (g))) + ;; self representative doesn't count as cycle + (let ([g (make-guardian #t)]) + (let ([s (gensym)]) + (g s s)) + (collect) + (symbol? (g))) + ;; try a longer cycle: + (let ([g (make-guardian #t)]) + (let ([hd (cons 0 '())]) + (set-cdr! hd + (let loop ([i 100]) + (if (zero? i) + hd + (let ([p (cons i (loop (sub1 i)))]) + (g p) + p))))) + (collect) + (not (g))) + + ;; same object, ordered and unordered => ordered first + (with-interrupts-disabled + (let ([g1 (make-guardian)] + [g2 (make-guardian #t)]) + (let ([s (gensym)]) + (g1 s) + (g2 s)) + (collect 0 0) + (collect 0 0) + (and (not (g2)) + (symbol? (g1)) + (not (g2)) + (begin + (collect 0 0) + (and (symbol? (g2)) + (not (g1)) + (not (g2))))))) + + ;; same object, both ordered => available from both + (with-interrupts-disabled + (let ([g1 (make-guardian #t)] + [g2 (make-guardian #t)]) + (let ([s (gensym)]) + (g1 s) + (g2 s)) + (collect 0 0) + (and (symbol? (g2)) + (symbol? (g1)) + (not (g1)) + (not (g2)) + (begin + (collect 0 0) + (and (not (g1)) + (not (g2))))))) + + ;; check ordered finalization on objects that immediately + ;; refer to themselves, which can create trouble for a naive + ;; approach to determining accessibility + (begin + (define (check-self-referencing p extract) + (with-interrupts-disabled + (let ([g (make-guardian #t)]) + (g p) + (let ([wb (weak-cons p #f)]) + (set! p #f) + (collect 0 0) + (let ([p (car wb)]) + (and (not (g)) + (eq? p (extract p)))))))) + (let ([p (cons #f #f)]) + (set-car! p p) + (check-self-referencing p car))) + (let ([p (cons #f #f)]) + (set-cdr! p p) + (check-self-referencing p cdr)) + (let ([p (cons #f #f)]) + (set-car! p p) + (set-cdr! p p) + (check-self-referencing p (lambda (p) + (and (eq? (car p) (cdr p)) + (car p))))) + (let ([b (box #f)]) + (set-box! b b) + (check-self-referencing b unbox)) + (let ([f (letrec ([f (lambda () f)]) f)]) + (check-self-referencing f (lambda (f) (f)))) + (let () + (define-record-type self (fields (mutable v))) + (let ([v (make-self #f)]) + (self-v-set! v v) + (check-self-referencing v self-v))) + ) + (mat weak-cons (procedure? weak-cons) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 1219bd85af..fb95d9f6f7 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,14 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{Ordered guardians (9.5.1)} + +The \scheme{make-guardian} function now accepts an optional argument to +indicate whether the guardian is ordered or unordered. A guardian is +unordered by default. An ordered guardian's objects are classified as +inaccessible only when they are not reachable from the represetative +of any inaccessible object in any other guardian. + \subsection{Profile data retained for reclaimed code (9.5.1)} Profile data is now retained indefinitely even for code objects diff --git a/s/cmacros.ss b/s/cmacros.ss index bd188e982a..b2153c8fb6 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -1441,7 +1441,9 @@ ([ptr obj] [ptr rep] [ptr tconc] - [ptr next])) + [ptr next] + [ptr ordered?] ; boolean to indicate finalization mode + [ptr pending])) ; for the GC's use ;;; forwarding addresses are recorded with a single forward-marker ;;; bit pattern (a special Scheme object) followed by the forwarding diff --git a/s/cp0.ss b/s/cp0.ss index fc599722b4..872ca270b2 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -4374,44 +4374,56 @@ [(?x) (mtp ctxt empty-env sc wd name moi #f 3)] [(?x ?p) (mtp ctxt empty-env sc wd name moi ?p 3)])))) - (define-inline 2 make-guardian - [() (and likely-to-be-compiled? + (let () + (define (build-make-guardian ordered-arg? ctxt empty-env sc wd name moi) + (and likely-to-be-compiled? (cp0 - (let* ([tc (cp0-make-temp #t)] [ref-tc (build-ref tc)]) - (build-lambda '() - (build-let (list tc) - (list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)]) - (let ([zero `(quote 0)]) - (build-let (list x) (list (build-primcall 3 'cons (list zero zero))) - (build-primcall 3 'cons (list ref-x ref-x)))))) - (build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) - (list - (list '() - (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)]) - (let ([y (cp0-make-temp #f)]) - (build-let (list x) (list (build-primcall 3 'car (list ref-tc))) - `(if ,(build-primcall 3 'eq? - (list ref-x - (build-primcall 3 'cdr (list ref-tc)))) - ,false-rec - ,(build-let (list y) (list (build-primcall 3 'car (list ref-x))) - `(seq - (seq + (let* ([tc (cp0-make-temp #t)] + [ref-tc (build-ref tc)] + [ordered? (and ordered-arg? (cp0-make-temp #f))] + [bool-ordered? (cp0-make-temp #t)] + [bool-ordered?-ref (build-ref bool-ordered?)]) + (build-lambda (if ordered? (list ordered?) '()) + (build-let (list bool-ordered?) + (list (if ordered? + `(if ,(build-ref ordered?) ,true-rec ,false-rec) + false-rec)) + (build-let (list tc) + (list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)]) + (let ([zero `(quote 0)]) + (build-let (list x) (list (build-primcall 3 'cons (list zero zero))) + (build-primcall 3 'cons (list ref-x ref-x)))))) + (build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) + (list + (list '() + (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)]) + (let ([y (cp0-make-temp #f)]) + (build-let (list x) (list (build-primcall 3 'car (list ref-tc))) + `(if ,(build-primcall 3 'eq? + (list ref-x + (build-primcall 3 'cdr (list ref-tc)))) + ,false-rec + ,(build-let (list y) (list (build-primcall 3 'car (list ref-x))) + `(seq (seq - ,(build-primcall 3 'set-car! (list ref-tc - (build-primcall 3 'cdr (list ref-x)))) - ,(build-primcall 3 'set-car! (list ref-x false-rec))) - ,(build-primcall 3 'set-cdr! (list ref-x false-rec))) - (ref #f ,y)))))))) - (let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)]) - (list (list obj) - (build-primcall 3 '$install-guardian - (list ref-obj ref-obj ref-tc)))) - (let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)]) - (list (list obj rep) - (build-primcall 3 '$install-guardian - (list (build-ref obj) (build-ref rep) ref-tc))))))))) - ctxt empty-env sc wd name moi))])) + (seq + ,(build-primcall 3 'set-car! (list ref-tc + (build-primcall 3 'cdr (list ref-x)))) + ,(build-primcall 3 'set-car! (list ref-x false-rec))) + ,(build-primcall 3 'set-cdr! (list ref-x false-rec))) + (ref #f ,y)))))))) + (let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)]) + (list (list obj) + (build-primcall 3 '$install-guardian + (list ref-obj ref-obj ref-tc bool-ordered?-ref)))) + (let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)]) + (list (list obj rep) + (build-primcall 3 '$install-guardian + (list (build-ref obj) (build-ref rep) ref-tc bool-ordered?-ref)))))))))) + ctxt empty-env sc wd name moi))) + (define-inline 2 make-guardian + [() (build-make-guardian #f ctxt empty-env sc wd name moi)] + [(?ordered?) (build-make-guardian #t ctxt empty-env sc wd name moi)]))) ) ; with-output-language (define-pass cp0 : Lsrc (ir ctxt env sc wd name moi) -> Lsrc () diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 310054441b..52f7ccb6c8 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -5375,14 +5375,16 @@ ) (define-inline 3 $install-guardian - [(e-obj e-rep e-tconc) - (bind #f (e-obj e-rep e-tconc) + [(e-obj e-rep e-tconc ordered?) + (bind #f (e-obj e-rep e-tconc ordered?) (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) (%seq (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep) (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) + (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,ordered?) + (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) (set! ,(%tc-ref guardian-entries) ,t))))]) (define-inline 2 virtual-register-count diff --git a/s/mkheader.ss b/s/mkheader.ss index e10453e9bc..8c71be462e 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -929,11 +929,15 @@ (defref GUARDIANREP guardian-entry rep) (defref GUARDIANTCONC guardian-entry tconc) (defref GUARDIANNEXT guardian-entry next) + (defref GUARDIANORDERED guardian-entry ordered?) + (defref GUARDIANPENDING guardian-entry pending) (definit INITGUARDIANOBJ guardian-entry obj) (definit INITGUARDIANREP guardian-entry rep) (definit INITGUARDIANTCONC guardian-entry tconc) (definit INITGUARDIANNEXT guardian-entry next) + (definit INITGUARDIANORDERED guardian-entry ordered?) + (definit INITGUARDIANPENDING guardian-entry pending) (defref FORWARDMARKER forward marker) (defref FORWARDADDRESS forward address) diff --git a/s/primdata.ss b/s/primdata.ss index f81c0635aa..3ce2ba5339 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1429,7 +1429,7 @@ (make-engine [sig [(procedure) -> (engine)]] [flags pure alloc]) (make-format-condition [sig [() -> (condition)]] [flags pure unrestricted mifoldable discard]) (make-fxvector [sig [(length) (length fixnum) -> (fxvector)]] [flags alloc]) - (make-guardian [sig [() -> (procedure)]] [flags alloc cp02]) + (make-guardian [sig [() (ptr) -> (procedure)]] [flags alloc cp02]) (make-hash-table [sig [() (ptr) -> (old-hash-table)]] [flags unrestricted alloc]) (make-input-port [sig [(procedure string) -> (textual-input-port)]] [flags alloc]) (make-input/output-port [sig [(procedure string string) -> (textual-input/output-port)]] [flags alloc]) diff --git a/s/prims.ss b/s/prims.ss index a56fde1174..ecb8315f34 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -1408,11 +1408,13 @@ (foreign-procedure "(cs)locked_objectp" (scheme-object) boolean)) (define-who $install-guardian - (lambda (obj rep tconc) + (lambda (obj rep tconc ordered?) (unless (and (pair? tconc) (pair? (car tconc)) (pair? (cdr tconc))) ($oops who "~s is not a tconc" tconc)) - (#3%$install-guardian obj rep tconc))) + (#3%$install-guardian obj rep tconc ordered?))) -(define make-guardian (lambda () (#2%make-guardian))) +(define make-guardian (case-lambda + [() (#2%make-guardian)] + [(ordered?) (#2%make-guardian ordered?)])) (define $address-in-heap? (foreign-procedure "(cs)s_addr_in_heap" (uptr) boolean)) From 21fc70523409118b12fdf33425a59f6ecaba163d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 22 Jan 2019 05:24:05 -0700 Subject: [PATCH 8/8] adjust GC to preserve `eq?` on flonums original commit: d405416eb2ec6d5dd147afc7a2af5a6c2f0a8130 --- c/gc.c | 85 +++++++++++++++++++++++++++++++++++++++++++++-------- c/print.c | 11 +++++-- c/segment.c | 3 ++ c/types.h | 8 +++++ 4 files changed, 91 insertions(+), 16 deletions(-) diff --git a/c/gc.c b/c/gc.c index 498e6ad44d..d8e742fbcf 100644 --- a/c/gc.c +++ b/c/gc.c @@ -119,6 +119,40 @@ uptr list_length(ptr ls) { return i; } +#ifdef PRESERVE_FLONUM_EQ + +static void flonum_set_forwarded(ptr p, seginfo *si) { + uptr delta = (uptr)UNTYPE(p, type_flonum) - (uptr)build_ptr(si->number, 0); + delta >>= log2_ptr_bytes; + if (!si->forwarded_flonums) { + ptr ff; + uptr sz = (bytes_per_segment) >> (3 + log2_ptr_bytes); + find_room(space_data, 0, typemod, ptr_align(sz), ff); + memset(ff, 0, sz); + si->forwarded_flonums = ff; + } + si->forwarded_flonums[delta >> 3] |= (1 << (delta & 0x7)); +} + +static int flonum_is_forwarded_p(ptr p, seginfo *si) { + if (!si->forwarded_flonums) + return 0; + else { + uptr delta = (uptr)UNTYPE(p, type_flonum) - (uptr)build_ptr(si->number, 0); + delta >>= log2_ptr_bytes; + return si->forwarded_flonums[delta >> 3] & (1 << (delta & 0x7)); + } +} + +# define FLONUM_FWDADDRESS(p) *(ptr*)(UNTYPE(p, type_flonum)) + +# define FORWARDEDP(p, si) ((TYPEBITS(p) == type_flonum) ? flonum_is_forwarded_p(p, si) : (FWDMARKER(p) == forward_marker)) +# define GET_FWDADDRESS(p) ((TYPEBITS(p) == type_flonum) ? FLONUM_FWDADDRESS(p) : FWDADDRESS(p)) +#else +# define FORWARDEDP(p, si) (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) +# define GET_FWDADDRESS(p) FWDADDRESS(p) +#endif + #define relocate(ppp) {\ ptr PP;\ PP = *ppp;\ @@ -151,9 +185,9 @@ uptr list_length(ptr ls) { relocate_help_help(ppp, pp, SI)\ } -#define relocate_help_help(ppp, pp, si) {\ - if (FWDMARKER(pp) == forward_marker && TYPEBITS(pp) != type_flonum)\ - *ppp = FWDADDRESS(pp);\ +#define relocate_help_help(ppp, pp, si) { \ + if (FORWARDEDP(pp, si)) \ + *ppp = GET_FWDADDRESS(pp); \ else\ *ppp = copy(pp, si);\ } @@ -405,8 +439,24 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { find_room(space_data, tg, type_typed_object, size_inexactnum, p); INEXACTNUM_TYPE(p) = type_inexactnum; +# ifdef PRESERVE_FLONUM_EQ + { + ptr pt; + pt = TYPE(&INEXACTNUM_REAL_PART(pp), type_flonum); + if (flonum_is_forwarded_p(pt, si)) + INEXACTNUM_REAL_PART(p) = FLODAT(FLONUM_FWDADDRESS(pt)); + else + INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp); + pt = TYPE(&INEXACTNUM_IMAG_PART(pp), type_flonum); + if (flonum_is_forwarded_p(pt, si)) + INEXACTNUM_IMAG_PART(p) = FLODAT(FLONUM_FWDADDRESS(pt)); + else + INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp); + } +# else INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp); INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp); +# endif } else if (TYPEP(tf, mask_bignum, type_bignum)) { iptr n; n = size_bignum(BIGLEN(pp)); @@ -559,7 +609,12 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { #endif /* ENABLE_OBJECT_COUNTS */ find_room(space_data, tg, type_flonum, size_flonum, p); FLODAT(p) = FLODAT(pp); +# ifdef PRESERVE_FLONUM_EQ + flonum_set_forwarded(pp, si); + FLONUM_FWDADDRESS(pp) = p; +# else /* no room for forwarding address, so let 'em be duplicated */ +# endif return p; } else { S_error_abort("copy(gc): illegal type"); @@ -803,8 +858,8 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { if (!(si->space & space_old) || locked(obj)) { \ INITGUARDIANNEXT(ls) = pend_hold_ls; \ pend_hold_ls = ls; \ - } else if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) { \ - INITGUARDIANOBJ(ls) = FWDADDRESS(obj); \ + } else if (FORWARDEDP(obj, si)) { \ + INITGUARDIANOBJ(ls) = GET_FWDADDRESS(obj); \ INITGUARDIANNEXT(ls) = pend_hold_ls; \ pend_hold_ls = ls; \ } else { \ @@ -1076,7 +1131,7 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { representative can't itself be a tconc, so we won't discover any new tconcs at that point. */ ptr obj = GUARDIANOBJ(ls); - if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) { + if (FORWARDEDP(obj, SegInfo(ptr_get_segment(obj)))) { /* Object is reachable, so we might as well move this one to the hold list --- via pend_hold_ls, which leads to a copy to move to hold_ls */ @@ -1151,7 +1206,7 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { for (; ls != Snil; ls = next) { ptr obj = GUARDIANOBJ(ls); next = GUARDIANNEXT(ls); - if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) { + if (FORWARDEDP(obj, SegInfo(ptr_get_segment(obj)))) { /* Will defintely move to hold_ls, but the entry must be copied to move from pend_hold_ls to hold_ls: */ @@ -1371,6 +1426,10 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { if (g == static_generation) S_G.number_of_nonstatic_segments -= 1; si->next = S_G.occupied_segments[s][g]; S_G.occupied_segments[s][g] = si; +#ifdef PRESERVE_FLONUM_EQ + /* any flonums forwarded won't be reference anymore */ + si->forwarded_flonums = NULL; +#endif } else { chunkinfo *chunk = si->chunk; if (si->generation != static_generation) S_G.number_of_nonstatic_segments -= 1; @@ -1474,8 +1533,8 @@ static void forward_or_bwp(pp, p) ptr *pp; ptr p; { seginfo *si; /* adapted from relocate */ if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) { - if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { - *pp = FWDADDRESS(p); + if (FORWARDEDP(p, si)) { + *pp = GET_FWDADDRESS(p); } else { *pp = Sbwp_object; } @@ -2225,7 +2284,7 @@ static void resweep_dirty_weak_pairs() { if (si->space & space_old) { if (locked(p)) { youngest = tg; - } else if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { + } else if (FORWARDEDP(p, si)) { *pp = FWDADDRESS(p); youngest = tg; } else { @@ -2314,7 +2373,7 @@ static void check_ephemeron(ptr pe, int add_to_trigger) { p = Scar(pe); if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) { - if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { + if (FORWARDEDP(p, si)) { INITCAR(pe) = FWDADDRESS(p); relocate(&INITCDR(pe)) if (!add_to_trigger) @@ -2365,8 +2424,8 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) { p = Scar(pe); if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { if (si->space & space_old && !locked(p)) { - if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) { - INITCAR(pe) = FWDADDRESS(p); + if (FORWARDEDP(p, si)) { + INITCAR(pe) = GET_FWDADDRESS(p); relocate(&INITCDR(pe)) youngest = tg; } else { diff --git a/c/print.c b/c/print.c index 8a8537f777..45bebd1303 100644 --- a/c/print.c +++ b/c/print.c @@ -34,6 +34,7 @@ static void pvec PROTO((ptr x)); static void pfxvector PROTO((ptr x)); static void pbytevector PROTO((ptr x)); static void pflonum PROTO((ptr x)); +static void pflodat PROTO((double x)); static void pfixnum PROTO((ptr x)); static void pbignum PROTO((ptr x)); static void wrint PROTO((ptr x)); @@ -113,9 +114,9 @@ static void pfile(UNUSED ptr x) { } static void pinexactnum(x) ptr x; { - S_prin1(TYPE(&INEXACTNUM_REAL_PART(x),type_flonum)); + pflodat(INEXACTNUM_REAL_PART(x)); if (INEXACTNUM_IMAG_PART(x) >= 0.0) putchar('+'); - S_prin1(TYPE(&INEXACTNUM_IMAG_PART(x),type_flonum)); + pflodat(INEXACTNUM_IMAG_PART(x)); putchar('i'); } @@ -246,10 +247,14 @@ static void pbytevector(x) ptr x; { } static void pflonum(x) ptr x; { + pflodat(FLODAT(x)); +} + +static void pflodat(x) double x; { char buf[256], *s; /* use snprintf to get it in a string */ - (void) snprintf(buf, 256, "%.16g",FLODAT(x)); + (void) snprintf(buf, 256, "%.16g", x); /* print the silly thing */ printf("%s", buf); diff --git a/c/segment.c b/c/segment.c index 5d44e48835..2cb3bfbef4 100644 --- a/c/segment.c +++ b/c/segment.c @@ -239,6 +239,9 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) { si->has_triggers = 0; si->trigger_ephemerons = 0; si->trigger_guardians = 0; +#ifdef PRESERVE_FLONUM_EQ + si->forwarded_flonums = NULL; +#endif } iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; { diff --git a/c/types.h b/c/types.h index 3f413dadd9..af9af3efba 100644 --- a/c/types.h +++ b/c/types.h @@ -103,6 +103,10 @@ typedef int IFASLCODE; /* fasl type codes */ }\ } +#ifndef NO_PRESERVE_FLONUM_EQ +# define PRESERVE_FLONUM_EQ +#endif + /* size of protected array used to store roots for the garbage collector */ #define max_protected 100 @@ -128,6 +132,10 @@ typedef struct _seginfo { struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */ ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */ ptr trigger_guardians; /* guardians to re-check if object in segment is copied out */ +#ifdef PRESERVE_FLONUM_EQ + octet *forwarded_flonums; /* bitmap of flonums whose payload is a forwarding pointer */ + iptr ff_when; +#endif octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ } seginfo;