diff --git a/LOG b/LOG index a41d32548d..33ed3570d0 100644 --- a/LOG +++ b/LOG @@ -1027,6 +1027,21 @@ 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 +- 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 +- 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, @@ -1072,4 +1087,3 @@ 5_4.ss, 5_4.ms - added enable-arithmetic-left-associative cp0.ss, compile.ss, primdata.ss, front.ss, cp0.ms, system.stex - diff --git a/c/alloc.c b/c/alloc.c index 1c59217aca..a44f0495e6 100644 --- a/c/alloc.c +++ b/c/alloc.c @@ -930,6 +930,14 @@ ptr S_relocation_table(n) iptr 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; +} + ptr S_phantom_bytevector(sz) uptr sz; { ptr tc = get_thread_context(); ptr p; diff --git a/c/externs.h b/c/externs.h index f71f2812c3..d1c166545e 100644 --- a/c/externs.h +++ b/c/externs.h @@ -90,6 +90,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)); extern ptr S_phantom_bytevector PROTO((uptr sz)); extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz)); diff --git a/c/fasl.c b/c/fasl.c index b6dff57751..09bfbc0813 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -887,7 +887,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 */; @@ -898,7 +898,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/gc.c b/c/gc.c index efbd7cf94d..42294a9362 100644 --- a/c/gc.c +++ b/c/gc.c @@ -144,6 +144,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;\ @@ -176,9 +210,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);\ } @@ -430,8 +464,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)); @@ -601,7 +651,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"); @@ -857,8 +912,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 { \ @@ -1145,7 +1200,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 */ @@ -1226,7 +1281,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: */ @@ -1446,6 +1501,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; @@ -1549,8 +1608,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; } @@ -2355,7 +2414,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 { @@ -2445,7 +2504,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) @@ -2499,8 +2558,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/globals.h b/c/globals.h index 5a3bfa4f6c..a71a33b770 100644 --- a/c/globals.h +++ b/c/globals.h @@ -78,6 +78,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 6d75cf0e0f..91afee40e9 100644 --- a/c/prim.c +++ b/c/prim.c @@ -195,6 +195,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; @@ -217,7 +218,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 41e2db8bc1..c8ba26424e 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); @@ -1647,7 +1649,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); @@ -1677,27 +1678,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/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/scheme.c b/c/scheme.c index 094235f419..d53b625c45 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -80,6 +80,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/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 b56648b6cb..34b61c76d8 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 @@ -130,6 +134,9 @@ 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 */ +#endif octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ } seginfo; diff --git a/csug/system.stex b/csug/system.stex index 9345a13fc9..87f319e088 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -3186,6 +3186,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 @@ -3226,6 +3236,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/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: diff --git a/mats/7.ms b/mats/7.ms index 64c295fc4d..0ad25d9c0b 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) diff --git a/mats/misc.ms b/mats/misc.ms index d42ef658af..db8c01a799 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -1895,13 +1895,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) @@ -1927,6 +1922,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) @@ -1943,11 +1940,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) @@ -1973,6 +1967,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) @@ -1988,11 +1984,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) @@ -2027,6 +2062,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" @@ -2034,7 +2151,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 50c0cb0635..b10c549cdf 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} @@ -112,6 +112,19 @@ 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 +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/Mf-base b/s/Mf-base index 937f768fcb..a3c32511a3 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 ;\ 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 f917d68f3b..df61b46513 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1540,6 +1540,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 safeongoodargs]) (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])