From ee9a4b3f5930c8fad5335d598507817887d33863 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 17 Jan 2019 09:43:18 -0800 Subject: [PATCH] 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])