From afebbdd6a9f38f4fb65f352a1b9f001e812f1cd8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 31 Mar 2020 20:38:59 -0600 Subject: [PATCH] convert GC to "mkgc.ss" implementation Replace repetitive C code in "gc.c" and "vfasl.c" with an implementation using a little "Parenthe-C" language, which is a somewhat declarative description of object tracing. From that descrition, we generate different kinds of tracing functions, such as the copy function or the sweep function. The little language is still bascially C, just with parentheses and parameterization that is much better than trying to use the C preprocessor. (The "mkgc.ss" file includes the compiler from Parenthe-C to C.) Besides replacing existing code, we also generate a new traversal to implement `compute-object-sizes`. Finally, the GC can now perform a fused `collect` and `compute-object-sizes` in a single traversal. Also improve the way that locked objects are detected during GC. This can make a significant difference (on the order of 10-20% for a full collection) when locked objects are long-lived. original commit: de1f5c41d729ac75822a1f1e633ec6d042c883dc --- c/Mf-base | 3 + c/externs.h | 10 +- c/gc-oce.c | 1 + c/gc.c | 1737 +++++++++++-------------------------- c/gcwrapper.c | 66 +- c/prim.c | 1 + c/types.h | 13 + c/vfasl.c | 435 ++-------- csug/smgmt.stex | 16 +- mats/misc.ms | 84 +- mats/thread.ms | 3 +- s/7.ss | 44 +- s/Mf-base | 51 +- s/cmacros.ss | 13 +- s/inspect.ss | 39 +- s/mkgc.ss | 2171 +++++++++++++++++++++++++++++++++++++++++++++++ s/mkheader.ss | 18 +- s/primdata.ss | 2 +- workarea | 2 + 19 files changed, 3011 insertions(+), 1698 deletions(-) create mode 100644 s/mkgc.ss diff --git a/c/Mf-base b/c/Mf-base index 52cc7e9644..28faafa01a 100644 --- a/c/Mf-base +++ b/c/Mf-base @@ -69,6 +69,9 @@ ${kernelobj}: ${Include}/equates.h ${Include}/scheme.h ${mainobj}: ${Include}/scheme.h ${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep} gc-ocd.o gc-oce.o: gc.c +gc-ocd.o: ${Include}/gc-ocd.inc +gc-oce.o: ${Include}/gc-oce.inc +vfasl.o: ${Include}/vfasl.inc ../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log diff --git a/c/externs.h b/c/externs.h index b83c071ae3..79c2302305 100644 --- a/c/externs.h +++ b/c/externs.h @@ -139,8 +139,8 @@ extern void S_gc_init PROTO((void)); extern void S_register_child_process PROTO((INT child)); #endif /* WIN32 */ extern void S_fixup_counts PROTO((ptr counts)); -extern void S_do_gc PROTO((IGEN g, IGEN gtarget)); -extern void S_gc PROTO((ptr tc, IGEN mcg, IGEN tg)); +extern ptr S_do_gc PROTO((IGEN g, IGEN gtarget, ptr count_roots)); +extern ptr S_gc PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots)); extern void S_gc_init PROTO((void)); extern void S_set_maxgen PROTO((IGEN g)); extern IGEN S_maxgen PROTO((void)); @@ -155,17 +155,17 @@ extern ptr S_object_counts PROTO((void)); extern IBOOL S_enable_object_backreferences PROTO((void)); extern void S_set_enable_object_backreferences PROTO((IBOOL eoc)); extern ptr S_object_backreferences PROTO((void)); -extern void S_do_gc PROTO((IGEN g, IGEN gtarget)); extern ptr S_locked_objects PROTO((void)); extern ptr S_unregister_guardian PROTO((ptr tconc)); extern void S_compact_heap PROTO((void)); extern void S_check_heap PROTO((IBOOL aftergc)); /* gc-ocd.c */ -extern void S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg)); +extern ptr S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots)); /* gc-oce.c */ -extern void S_gc_oce PROTO((ptr tc, IGEN mcg, IGEN tg)); +extern ptr S_gc_oce PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots)); +extern ptr S_count_size_increments PROTO((ptr ls, IGEN generation)); /* intern.c */ extern void S_intern_init PROTO((void)); diff --git a/c/gc-oce.c b/c/gc-oce.c index a1d629e7f8..ed8ac751df 100644 --- a/c/gc-oce.c +++ b/c/gc-oce.c @@ -17,4 +17,5 @@ #define GCENTRY S_gc_oce #define ENABLE_OBJECT_COUNTS #define ENABLE_BACKREFERENCE +#define ENABLE_MEASURE #include "gc.c" diff --git a/c/gc.c b/c/gc.c index 8d1dd76ab6..e7ef0864ba 100644 --- a/c/gc.c +++ b/c/gc.c @@ -24,31 +24,25 @@ #define enable_object_counts do_not_use_enable_object_counts_in_this_file_use_ifdef_ENABLE_OBJECT_COUNTS_instead /* locally defined functions */ -static ptr append_bang PROTO((ptr ls1, ptr ls2)); -static uptr count_unique PROTO((ptr ls)); static uptr list_length PROTO((ptr ls)); static ptr copy_list PROTO((ptr ls, IGEN tg)); static ptr dosort PROTO((ptr ls, uptr n)); static ptr domerge PROTO((ptr l1, ptr l2)); -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 PROTO((ptr tc, ptr p)); static void sweep_in_old PROTO((ptr tc, ptr p)); -static int scan_ptrs_for_self PROTO((ptr *pp, iptr len, ptr p)); +static IBOOL object_directly_refers_to_self PROTO((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)); static void sweep_generation PROTO((ptr tc, IGEN g)); -static iptr size_object PROTO((ptr p)); +static uptr size_object PROTO((ptr p)); static iptr sweep_typed_object PROTO((ptr tc, ptr p)); static void sweep_symbol PROTO((ptr p)); static void sweep_port PROTO((ptr p)); 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, IGEN tg, IGEN youngest)); static IGEN sweep_dirty_port PROTO((ptr x, IGEN tg, IGEN youngest)); static IGEN sweep_dirty_symbol PROTO((ptr x, IGEN tg, IGEN youngest)); @@ -69,8 +63,24 @@ static int check_dirty_ephemeron PROTO((ptr pe, int tg, int youngest)); static void clear_trigger_ephemerons PROTO(()); static void sanitize_locked_segment PROTO((seginfo *si)); -/* MAXPTR is used to pad the sorted_locked_object vector. The pad value must be greater than any heap address */ -#define MAXPTR ((ptr)-1) +#ifdef ENABLE_OBJECT_COUNTS +static uptr total_size_so_far(); +#endif + +#ifdef ENABLE_MEASURE +static void init_measure(IGEN min_gen, IGEN max_gen); +static void finish_measure(); +static void measure(ptr p); +static IBOOL flush_measure_stack(); +static void init_measure_mask(seginfo *si); +static void init_counting_mask(seginfo *si); +static void push_measure(ptr p); +static void measure_add_stack_size(ptr stack, uptr size); +static void add_ephemeron_to_pending_measure(ptr pe); +static void add_trigger_ephemerons_to_pending_measure(ptr pe); +static void check_ephemeron_measure(ptr pe); +static void check_pending_measure_ephemerons(); +#endif #define OLDSPACE(x) (SPACE(x) & space_old) @@ -82,11 +92,26 @@ static IGEN target_generation; static IGEN max_copied_generation; 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 conts_to_promote; static ptr recheck_guardians_ls; +#ifdef ENABLE_OBJECT_COUNTS +static int measure_all_enabled; +static uptr count_root_bytes; +# define COUNTING_OR(e) 1 +#else +# define COUNTING_OR(e) e +#endif + +#ifdef ENABLE_MEASURE +static uptr measure_total; /* updated by `measure` */ +static IGEN min_measure_generation, max_measure_generation; +static ptr *measure_stack_start, *measure_stack, *measure_stack_limit; +static ptr measured_seginfos; +static ptr pending_measure_ephemerons; +#endif + #ifdef ENABLE_BACKREFERENCE static ptr sweep_from; # define BACKREFERENCES_ENABLED S_G.enable_object_backreferences @@ -119,30 +144,6 @@ enum { 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) { - return ls1; - } else if (ls1 == Snil) { - return ls2; - } else { - ptr this = ls1, next; - while ((next = Scdr(this)) != Snil) this = next; - INITCDR(this) = ls2; - return ls1; - } -} - -static uptr count_unique(ls) ptr ls; { /* assumes ls is sorted and nonempty */ - uptr i = 1; ptr x = Scar(ls), y; - while ((ls = Scdr(ls)) != Snil) { - if ((y = Scar(ls)) != x) { - i += 1; - x = y; - } - } - return i; -} - static ptr copy_list(ptr ls, IGEN tg) { ptr ls2 = Snil; for (; ls != Snil; ls = Scdr(ls)) @@ -162,16 +163,17 @@ uptr list_length(ptr ls) { #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); + find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), ff); + memset(ff, 0, segment_bitmap_bytes); si->forwarded_flonums = ff; } - si->forwarded_flonums[delta >> 3] |= (1 << (delta & 0x7)); + { + uptr byte = segment_bitmap_byte(p); + uptr bit = segment_bitmap_bit(p); + si->forwarded_flonums[byte] |= bit; + } } static int flonum_is_forwarded_p(ptr p, seginfo *si) { @@ -221,7 +223,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { #define relocate_help(ppp, pp) {\ seginfo *SI; \ - if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL && SI->space & space_old)\ + if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL && COUNTING_OR(SI->space & space_old)) \ relocate_help_help(ppp, pp, SI)\ } @@ -232,52 +234,11 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { *ppp = copy(pp, si);\ } -#define relocate_return_addr(pcp) {\ - seginfo *SI;\ - ptr XCP;\ - XCP = *(pcp);\ - if ((SI = SegInfo(ptr_get_segment(XCP)))->space & space_old) { \ - iptr CO;\ - CO = ENTRYOFFSET(XCP) + ((uptr)XCP - (uptr)ENTRYOFFSETADDR(XCP));\ - relocate_code(pcp,XCP,CO,SI)\ - }\ -} +#define locked(si, p) (si->locked_mask && (si->locked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) -/* in the call to copy below, assuming SPACE(PP) == SPACE(XCP) since - PP and XCP point to/into the same object */ -#define relocate_code(pcp,XCP,CO,SI) {\ - ptr PP;\ - PP = (ptr)((uptr)XCP - CO);\ - if (FWDMARKER(PP) == forward_marker)\ - PP = FWDADDRESS(PP);\ - else\ - PP = copy(PP, SI);\ - *pcp = (ptr)((uptr)PP + CO);\ -} - -/* rkd 2015/06/05: tried to use sse instructions. abandoned the code - because the collector ran slower */ -#define copy_ptrs(ty, p1, p2, n) {\ - ptr *Q1, *Q2, *Q1END;\ - Q1 = (ptr *)UNTYPE((p1),ty);\ - Q2 = (ptr *)UNTYPE((p2),ty);\ - Q1END = (ptr *)((uptr)Q1 + n);\ - while (Q1 != Q1END) *Q1++ = *Q2++;} - -static IBOOL search_locked(ptr p) { - uptr k; ptr v, *vp, x; - v = sorted_locked_objects; - k = Svector_length(v); - vp = &INITVECTIT(v, 0); - for (;;) { - k >>= 1; - if ((x = vp[k]) == p) return 1; - if (k == 0) return 0; - if (x < p) vp += k + 1; - } -} - -#define locked(p) (sorted_locked_objects != FIX(0) && search_locked(p)) +#ifdef ENABLE_OBJECT_COUNTS +# define is_counting_root(si, p) (si->counting_mask && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) +#endif FORCEINLINE void check_triggers(seginfo *si) { /* Registering ephemerons and guardians to recheck at the @@ -299,503 +260,11 @@ FORCEINLINE void check_triggers(seginfo *si) { } } -static ptr copy(pp, si) ptr pp; seginfo *si; { - ptr p, tf; ITYPE t; IGEN tg; - - if (locked(pp)) return pp; - - tg = target_generation; - - change = 1; - - check_triggers(si); - - if ((t = TYPEBITS(pp)) == type_typed_object) { - tf = TYPEFIELD(pp); - if (TYPEP(tf, mask_record, type_record)) { - ptr rtd; iptr n; ISPC s; - - /* relocate to make sure we aren't using an oldspace descriptor - that has been overwritten by a forwarding marker, but don't loop - on tag-reflexive base descriptor */ - if ((rtd = tf) != pp) relocate(&rtd) - - n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); - -#ifdef ENABLE_OBJECT_COUNTS - { ptr counts; IGEN g; - counts = RECORDDESCCOUNTS(rtd); - if (counts == Sfalse) { - IGEN grtd = rtd == pp ? tg : GENERATION(rtd); - S_G.countof[grtd][countof_rtd_counts] += 1; - /* allocate counts struct in same generation as rtd. initialize timestamp & counts */ - find_room(space_data, grtd, type_typed_object, size_rtd_counts, counts); - RTDCOUNTSTYPE(counts) = type_rtd_counts; - RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0]; - for (g = 0; g <= static_generation; g += 1) RTDCOUNTSIT(counts, g) = 0; - RECORDDESCCOUNTS(rtd) = counts; - S_G.rtds_with_counts[grtd] = S_cons_in((grtd == 0 ? space_new : space_impure), grtd, rtd, S_G.rtds_with_counts[grtd]); - S_G.countof[grtd][countof_pair] += 1; - } else { - relocate(&counts) - RECORDDESCCOUNTS(rtd) = counts; - if (RTDCOUNTSTIMESTAMP(counts) != S_G.gctimestamp[0]) S_fixup_counts(counts); - } - RTDCOUNTSIT(counts, tg) += 1; - } -#endif /* ENABLE_OBJECT_COUNTS */ - - /* if the rtd is the only pointer and is immutable, put the record - into space data. if the record contains only pointers, put it - into space_pure or space_impure. otherwise put it into - space_pure_typed_object or space_impure_record. we could put all - records into space_{pure,impure}_record or even into - space_impure_record, but by picking the target space more - carefully we may reduce fragmentation and sweeping cost */ - s = RECORDDESCPM(rtd) == FIX(1) && RECORDDESCMPM(rtd) == FIX(0) ? - space_data : - ((RECORDDESCPM(rtd) == FIX(-1)) && !BACKREFERENCES_ENABLED) ? - RECORDDESCMPM(rtd) == FIX(0) ? - space_pure : - space_impure : - RECORDDESCMPM(rtd) == FIX(0) ? - space_pure_typed_object : - space_impure_record; - - find_room(s, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - - /* overwrite type field with forwarded descriptor */ - RECORDINSTTYPE(p) = rtd == pp ? p : rtd; - - /* pad if necessary */ - if (s == space_pure || s == space_impure) { - iptr m = unaligned_size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); - if (m != n) - *((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0); - } - } else if (TYPEP(tf, mask_vector, type_vector)) { - iptr len, n; - ISPC s; - len = Svector_length(pp); - n = size_vector(len); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_vector] += 1; - S_G.bytesof[tg][countof_vector] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - /* assumes vector lengths look like fixnums; if not, vectors will need their own space */ - s = (((uptr)tf & vector_immutable_flag) - ? (BACKREFERENCES_ENABLED ? space_pure_typed_object : space_pure) - : (BACKREFERENCES_ENABLED ? space_impure_typed_object : space_impure)); - find_room(s, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - /* pad if necessary */ - if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0); - } else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - iptr len, n; - ISPC s; - len = Sstencil_vector_length(pp); - n = size_stencil_vector(len); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_stencil_vector] += 1; - S_G.bytesof[tg][countof_stencil_vector] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - /* assumes stencil types look like immediate; if not, stencil vectors will need their own space */ - s = (BACKREFERENCES_ENABLED ? space_impure_typed_object : space_impure); - find_room(s, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - /* pad if necessary */ - if ((len & 1) == 0) INITSTENVECTIT(p, len) = FIX(0); - } else if (TYPEP(tf, mask_string, type_string)) { - iptr n; - n = size_string(Sstring_length(pp)); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_string] += 1; - S_G.bytesof[tg][countof_string] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { - iptr n; - n = size_fxvector(Sfxvector_length(pp)); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_fxvector] += 1; - S_G.bytesof[tg][countof_fxvector] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - iptr n; - n = size_bytevector(Sbytevector_length(pp)); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_bytevector] += 1; - S_G.bytesof[tg][countof_bytevector] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if ((iptr)tf == type_tlc) { - ptr keyval, next; - -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_tlc] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room((BACKREFERENCES_ENABLED ? space_impure_typed_object : space_impure), tg, type_typed_object, size_tlc, p); - TLCTYPE(p) = type_tlc; - INITTLCKEYVAL(p) = keyval = TLCKEYVAL(pp); - INITTLCHT(p) = TLCHT(pp); - INITTLCNEXT(p) = next = TLCNEXT(pp); - - /* if next isn't false and keyval is old, add tlc to a list of tlcs - * to process later. determining if keyval is old is a (conservative) - * approximation to determining if key is old. we can't easily - * determine if key is old, since keyval might or might not have been - * swept already. NB: assuming keyvals are always pairs. */ - if (next != Sfalse && SPACE(keyval) & space_old) - tlcs_to_rehash = S_cons_in(space_new, 0, p, tlcs_to_rehash); - } else if (TYPEP(tf, mask_box, type_box)) { - ISPC s; -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_box] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - s = (((uptr)tf == type_immutable_box) - ? (BACKREFERENCES_ENABLED ? space_pure_typed_object : space_pure) - : (BACKREFERENCES_ENABLED ? space_impure_typed_object : space_impure)); - find_room(s, tg, type_typed_object, size_box, p); - BOXTYPE(p) = (iptr)tf; - INITBOXREF(p) = Sunbox(pp); - } else if ((iptr)tf == type_ratnum) { - /* not recursive: place in space_data and relocate fields immediately */ -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_ratnum] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, - type_typed_object, size_ratnum, p); - RATTYPE(p) = type_ratnum; - RATNUM(p) = RATNUM(pp); - RATDEN(p) = RATDEN(pp); - relocate(&RATNUM(p)) - relocate(&RATDEN(p)) - } else if ((iptr)tf == type_exactnum) { - /* not recursive: place in space_data and relocate fields immediately */ -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_exactnum] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, - type_typed_object, size_exactnum, p); - EXACTNUM_TYPE(p) = type_exactnum; - EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp); - EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp); - relocate(&EXACTNUM_REAL_PART(p)) - relocate(&EXACTNUM_IMAG_PART(p)) - } else if ((iptr)tf == type_inexactnum) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_inexactnum] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - 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)); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_bignum] += 1; - S_G.bytesof[tg][countof_bignum] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if (TYPEP(tf, mask_port, type_port)) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_port] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_port, tg, - type_typed_object, size_port, p); - PORTTYPE(p) = PORTTYPE(pp); - PORTHANDLER(p) = PORTHANDLER(pp); - PORTNAME(p) = PORTNAME(pp); - PORTINFO(p) = PORTINFO(pp); - PORTOCNT(p) = PORTOCNT(pp); - PORTICNT(p) = PORTICNT(pp); - PORTOBUF(p) = PORTOBUF(pp); - PORTOLAST(p) = PORTOLAST(pp); - PORTIBUF(p) = PORTIBUF(pp); - PORTILAST(p) = PORTILAST(pp); - } else if (TYPEP(tf, mask_code, type_code)) { - iptr n; - n = size_code(CODELEN(pp)); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_code] += 1; - S_G.bytesof[tg][countof_code] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_code, tg, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if ((iptr)tf == type_thread) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_thread] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_pure_typed_object, tg, - type_typed_object, size_thread, p); - TYPEFIELD(p) = (ptr)type_thread; - THREADTC(p) = THREADTC(pp); /* static */ - } else if ((iptr)tf == type_rtd_counts) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_rtd_counts] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, tg, type_typed_object, size_rtd_counts, p); - copy_ptrs(type_typed_object, p, pp, size_rtd_counts); - } else if (TYPEP(tf, mask_phantom, type_phantom)) { - find_room(space_data, tg, type_typed_object, size_phantom, p); - PHANTOMTYPE(p) = PHANTOMTYPE(pp); - PHANTOMLEN(p) = PHANTOMLEN(pp); - S_G.phantom_sizes[tg] += PHANTOMLEN(p); - } else { - S_error_abort("copy(gc): illegal type"); - return (ptr)0 /* not reached */; - } - } else if (t == type_pair) { - if (si->space == (space_ephemeron | space_old)) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_ephemeron] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_ephemeron, tg, type_pair, size_ephemeron, p); - INITCAR(p) = Scar(pp); - INITCDR(p) = Scdr(pp); - } 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_triggers(qsi); - if (si->space == (space_weakpair | space_old)) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_weakpair] += 2; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_weakpair, tg, type_pair, 2 * size_pair, p); - } else { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_pair] += 2; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_impure, tg, type_pair, 2 * size_pair, p); - } - q = (ptr)((uptr)p + size_pair); - INITCAR(p) = Scar(pp); - INITCDR(p) = q; - INITCAR(q) = Scar(qq); - INITCDR(q) = Scdr(qq); - FWDMARKER(qq) = forward_marker; - FWDADDRESS(qq) = q; - ADD_BACKREFERENCE_FROM(q, p) - } else { - if (si->space == (space_weakpair | space_old)) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_weakpair] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_weakpair, tg, type_pair, size_pair, p); - } else { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_pair] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_impure, tg, type_pair, size_pair, p); - } - INITCAR(p) = Scar(pp); - INITCDR(p) = qq; - } - } - } else if (t == type_closure) { - ptr code; - - /* relocate before accessing code type field, which otherwise might - be a forwarding marker */ - code = CLOSCODE(pp); - relocate(&code) - if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_continuation] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_continuation, tg, - type_closure, size_continuation, p); - SETCLOSCODE(p,code); - /* don't promote general one-shots, but promote opportunistic one-shots */ - if (CONTLENGTH(pp) == opportunistic_1_shot_flag) { - CONTLENGTH(p) = CONTCLENGTH(pp); - /* may need to recur at end to promote link: */ - conts_to_promote = S_cons_in(space_new, 0, p, conts_to_promote); - } else - CONTLENGTH(p) = CONTLENGTH(pp); - CONTCLENGTH(p) = CONTCLENGTH(pp); - CONTWINDERS(p) = CONTWINDERS(pp); - CONTATTACHMENTS(p) = CONTATTACHMENTS(pp); - if (CONTLENGTH(p) != scaled_shot_1_shot_flag) { - CONTLINK(p) = CONTLINK(pp); - CONTRET(p) = CONTRET(pp); - CONTSTACK(p) = CONTSTACK(pp); - } - } else { - iptr len, n; - len = CLOSLEN(pp); - n = size_closure(len); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_closure] += 1; - S_G.bytesof[tg][countof_closure] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - if (BACKREFERENCES_ENABLED) { - find_room(space_closure, tg, type_closure, n, p); - } else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) { - /* Using `space_impure` is ok because the code slot of a mutable - closure is never mutated, so the code is never newer than the - closure. If it were, then because the code pointer looks like - a fixnum, an old-generation sweep wouldn't update it properly. */ - find_room(space_impure, tg, type_closure, n, p); - } else { - find_room(space_pure, tg, type_closure, n, p); - } - copy_ptrs(type_closure, p, pp, n); - SETCLOSCODE(p,code); - /* pad if necessary */ - if ((len & 1) == 0) CLOSIT(p, len) = FIX(0); - } - } else if (t == type_symbol) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_symbol] += 1; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_symbol, tg, type_symbol, size_symbol, p); - INITSYMVAL(p) = SYMVAL(pp); - INITSYMPVAL(p) = SYMPVAL(pp); - INITSYMPLIST(p) = SYMPLIST(pp); - INITSYMSPLIST(p) = SYMSPLIST(pp); - INITSYMNAME(p) = SYMNAME(pp); - INITSYMHASH(p) = SYMHASH(pp); - } else if (t == type_flonum) { -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[tg][countof_flonum] += 1; -#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"); - return (ptr)0 /* not reached */; - } - - FWDMARKER(pp) = forward_marker; - FWDADDRESS(pp) = p; - - ADD_BACKREFERENCE(p) - - return p; -} - -static void sweep_ptrs(pp, n) ptr *pp; iptr n; { - ptr *end = pp + n; - - while (pp != end) { - relocate(pp) - pp += 1; - } -} - -static void sweep(ptr tc, ptr p, IBOOL sweep_pure) { - ptr tf; ITYPE t; - - PUSH_BACKREFERENCE(p) - - if ((t = TYPEBITS(p)) == type_pair) { - ISPC s = SPACE(p) & ~(space_locked | space_old); - if (s == space_ephemeron) - add_ephemeron_to_pending(p); - else { - if (s != space_weakpair) { - relocate(&INITCAR(p)) - } - relocate(&INITCDR(p)) - } - } else if (t == type_closure) { - ptr code; - - code = CLOSCODE(p); - if (sweep_pure || (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset))) { - relocate(&code) - SETCLOSCODE(p,code); - if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) - sweep_continuation(p); - else - sweep_ptrs(&CLOSIT(p, 0), CLOSLEN(p)); - } - } else if (t == type_symbol) { - sweep_symbol(p); - } else if (t == type_flonum) { - /* nothing to sweep */; - /* typed objects */ - } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { - sweep_ptrs(&INITVECTIT(p, 0), Svector_length(p)); - } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - sweep_ptrs(&INITVECTIT(p, 0), Sstencil_vector_length(p)); - } else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) { - /* nothing to sweep */; - } else if (TYPEP(tf, mask_record, type_record)) { - relocate(&RECORDINSTTYPE(p)); - if (sweep_pure || RECORDDESCMPM(RECORDINSTTYPE(p)) != FIX(0)) { - sweep_record(p); - } - } else if (TYPEP(tf, mask_box, type_box)) { - relocate(&INITBOXREF(p)) - } else if ((iptr)tf == type_ratnum) { - if (sweep_pure) { - relocate(&RATNUM(p)) - relocate(&RATDEN(p)) - } - } else if ((iptr)tf == type_tlc) { - relocate(&INITTLCKEYVAL(p)); - relocate(&INITTLCHT(p)); - relocate(&INITTLCNEXT(p)); - } else if ((iptr)tf == type_exactnum) { - if (sweep_pure) { - relocate(&EXACTNUM_REAL_PART(p)) - relocate(&EXACTNUM_IMAG_PART(p)) - } - } else if ((iptr)tf == type_inexactnum) { - /* nothing to sweep */; - } else if (TYPEP(tf, mask_bignum, type_bignum)) { - /* nothing to sweep */; - } else if (TYPEP(tf, mask_port, type_port)) { - sweep_port(p); - } else if (TYPEP(tf, mask_code, type_code)) { - if (sweep_pure) { - sweep_code_object(tc, p); - } - } else if ((iptr)tf == type_thread) { - sweep_thread(p); - } else if ((iptr)tf == type_rtd_counts) { - /* nothing to sweep */; - } else if ((iptr)tf == type_phantom) { - /* nothing to sweep */; - } else { - S_error_abort("sweep(gc): illegal type"); - } - - POP_BACKREFERENCE() -} +#ifndef ENABLE_OBJECT_COUNTS +# include "gc-ocd.inc" +#else +# include "gc-oce.inc" +#endif /* 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 @@ -806,113 +275,16 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) { 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 (tf = TYPEFIELD(p), TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - if (scan_ptrs_for_self(&INITSTENVECTIT(p, 0), Sstencil_vector_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 */ + if (object_directly_refers_to_self(p)) { 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; + sweep(tc, p); } static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { @@ -936,7 +308,7 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { find_room(space_data, target_generation, typemod, n, new); n = ptr_align(clength); /* warning: stack may have been left non-double-aligned by split_and_resize */ - copy_ptrs(typemod, new, old, n); + memcpy_aligned(new, old, n); /* also returning possibly updated value in *length */ return new; @@ -951,7 +323,7 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { next = GUARDIANNEXT(ls); \ \ if (FILTER(si, obj)) { \ - if (!(si->space & space_old) || locked(obj)) { \ + if (!(si->space & space_old) || locked(si, obj)) { \ INITGUARDIANNEXT(ls) = pend_hold_ls; \ pend_hold_ls = ls; \ } else if (FORWARDEDP(obj, si)) { \ @@ -959,8 +331,10 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { INITGUARDIANNEXT(ls) = pend_hold_ls; \ pend_hold_ls = ls; \ } else { \ + seginfo *t_si; \ tconc = GUARDIANTCONC(ls); \ - if (!OLDSPACE(tconc) || locked(tconc)) { \ + t_si = SegInfo(ptr_get_segment(tconc)); \ + if (!(t_si->space & space_old) || locked(t_si, tconc)) { \ INITGUARDIANNEXT(ls) = final_ls; \ final_ls = ls; \ } else if (FWDMARKER(tconc) == forward_marker) { \ @@ -976,11 +350,21 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { } \ } -void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { +typedef struct count_root_t { + ptr p; + IBOOL weak; +} count_root_t; + +ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { IGEN g; ISPC s; seginfo *oldspacesegments, *si, *nextsi; - ptr ls; + ptr ls, younger_locked_objects; bucket_pointer_list *buckets_to_rebuild; +#ifdef ENABLE_OBJECT_COUNTS + ptr count_roots_counts = Snil; + iptr count_roots_len; + count_root_t *count_roots; +#endif /* flush instruction cache: effectively clear_code_mod but safer */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { @@ -1064,63 +448,138 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { SET_BACKREFERENCE(Sfalse) /* #f => root or locked */ +#ifdef ENABLE_OBJECT_COUNTS + /* set flag on count_roots objects so they get copied to space_count_root */ + if (count_roots_ls != Sfalse) { + iptr i; + + count_roots_len = list_length(count_roots_ls); + find_room(space_data, 0, typemod, ptr_align(count_roots_len*sizeof(count_root_t)), count_roots); + + for (ls = count_roots_ls, i = 0; ls != Snil; ls = Scdr(ls), i++) { + ptr p = Scar(ls); + if (IMMEDIATE(p)) { + count_roots[i].p = p; + count_roots[i].weak = 0; + } else { + seginfo *ls_si = SegInfo(ptr_get_segment(ls)); + seginfo *si = SegInfo(ptr_get_segment(p)); + + if (!si->counting_mask) + init_counting_mask(si); + + si->counting_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + + count_roots[i].p = p; + count_roots[i].weak = (((ls_si->space & ~(space_old|space_locked)) == space_weakpair) + || ((ls_si->space & ~(space_old|space_locked)) == space_ephemeron)); + } + } + } else { + count_roots_len = 0; + count_roots = NULL; + } +#endif + /* pre-collection handling of locked objects. */ - /* create a single sorted_locked_object vector for all copied generations - * to accelerate the search for locked objects in copy(). copy wants - * a vector of some size n=2^k-1 so it doesn't have to check bounds */ - ls = Snil; - /* note: append_bang and dosort reuse pairs, which can result in older - * objects pointing to newer ones...but we don't care since they are all - * oldspace and going away after this collection. */ - { - seginfo *si; + /* set up locked-object masks */ + younger_locked_objects = Snil; for (si = oldspacesegments; si != NULL; si = si->next) { - ptr copied = copy_list(si->locked_objects, tg); - ls = append_bang(si->locked_objects, ls); - si->locked_objects = copied; - si->unlocked_objects = Snil; - } - } - if (ls == Snil) { - sorted_locked_objects = FIX(0); - } else { - ptr v, x, y; uptr i, n; + if (si->locked_objects != Snil) { + find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->locked_mask); + memset(si->locked_mask, 0, segment_bitmap_bytes); - /* dosort is destructive, so have to store the result back */ - ls = dosort(ls, list_length(ls)); - - /* create vector of smallest size n=2^k-1 that will fit all of - the list's unique elements */ - i = count_unique(ls); - for (n = 1; n < i; n = (n << 1) | 1); - sorted_locked_objects = v = S_vector_in(space_new, 0, n); - - /* copy list elements in, skipping duplicates */ - INITVECTIT(v,0) = x = Scar(ls); - i = 1; - while ((ls = Scdr(ls)) != Snil) { - if ((y = Scar(ls)) != x) { - INITVECTIT(v, i) = x = y; - i += 1; - } + ls = copy_list(si->locked_objects, tg); + si->locked_objects = ls; + si->unlocked_objects = Snil; + + while (ls != Snil) { + ptr p = Scar(ls); + uptr byte = segment_bitmap_byte(p); + uptr bit = segment_bitmap_bit(p); + if (!(si->locked_mask[byte] & bit)) { + si->locked_mask[byte] |= bit; + younger_locked_objects = S_cons_in(space_new, 0, p, younger_locked_objects); + } + ls = Scdr(ls); + } + } } - /* fill remaining slots with largest ptr value */ - while (i < n) { INITVECTIT(v, i) = MAXPTR; i += 1; } - } +#ifdef ENABLE_OBJECT_COUNTS + /* sweep count_roots in order and accumulate counts */ + if (count_roots_len > 0) { + ptr prev = NULL; uptr prev_total = total_size_so_far(); + iptr i; + +# ifdef ENABLE_MEASURE + init_measure(tg+1, static_generation); +# endif + + for (i = 0; i < count_roots_len; i++) { + uptr total; + ptr p = count_roots[i].p; + if (IMMEDIATE(p)) { + /* nothing to do */ + } else { + seginfo *si = SegInfo(ptr_get_segment(p)); + + si->counting_mask[segment_bitmap_byte(p)] -= segment_bitmap_bit(p); + + if (!(si->space & space_old) || FORWARDEDP(p, si) || locked(si, p) + || !count_roots[i].weak) { + /* reached or older; sweep transitively */ + relocate(&p) + if ((si->space & ~(space_old|space_locked)) != space_ephemeron) /* not ok to resweep ephemeron */ + sweep(tc, p); + ADD_BACKREFERENCE(p) + sweep_generation(tc, tg); +# ifdef ENABLE_MEASURE + while (flush_measure_stack()) { + sweep_generation(tc, tg); + } +# endif + + /* now count this object's size, if we have deferred it before */ + si = SegInfo(ptr_get_segment(p)); + if ((si->space == space_count_pure) || (si->space == space_count_impure)) + count_root_bytes -= size_object(p); + } + } + + total = total_size_so_far(); + p = S_cons_in(space_new, 0, FIX(total-prev_total), Snil); + if (prev != NULL) + Scdr(prev) = p; + else + count_roots_counts = p; + prev = p; + prev_total = total; + } + +# ifdef ENABLE_MEASURE + finish_measure(); +# endif + + /* clear `counting_mask`s */ + for (i = 0; i < count_roots_len; i++) { + ptr p = count_roots[i].p; + if (!IMMEDIATE(p)) { + seginfo *si = SegInfo(ptr_get_segment(p)); + si->counting_mask = NULL; + } + } + } +#endif + + /* sweep younger locked objects */ + for (ls = younger_locked_objects; ls != Snil; ls = Scdr(ls)) { + ptr x = Scar(ls); + sweep(tc, x); + ADD_BACKREFERENCE(x) + } - /* sweep younger locked objects, working from sorted vector to avoid redundant sweeping of duplicates */ - if (sorted_locked_objects != FIX(0)) { - uptr i; ptr x, v, *vp; - v = sorted_locked_objects; - i = Svector_length(v); - x = *(vp = &INITVECTIT(v, 0)); - do { - sweep(tc, x, 1); - ADD_BACKREFERENCE(x) - } while (--i != 0 && (x = *++vp) != MAXPTR); - } /* sweep non-oldspace threads, since any thread may have an active stack */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { ptr thread; @@ -1256,7 +715,7 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { pend_hold_ls = ls; } else { seginfo *si; - if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && (si->space & space_old) && !locked(rep)) { + if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && (si->space & space_old) && !locked(si, rep)) { PUSH_BACKREFERENCE(rep) sweep_in_old(tc, rep); POP_BACKREFERENCE() @@ -1287,9 +746,14 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { /* copy each entry in pend_hold_ls into hold_ls if tconc accessible */ ls = pend_hold_ls; pend_hold_ls = Snil; for ( ; ls != Snil; ls = next) { - tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls); ptr p; - - if (OLDSPACE(tconc) && !locked(tconc)) { + ptr p; + seginfo *t_si; + + tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls); + + t_si = SegInfo(ptr_get_segment(tconc)); + + if ((t_si->space & space_old) && !locked(t_si, tconc)) { if (FWDMARKER(tconc) == forward_marker) tconc = FWDADDRESS(tconc); else { @@ -1387,27 +851,24 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { clear_trigger_ephemerons(); /* forward car fields of locked oldspace weak pairs */ - if (sorted_locked_objects != FIX(0)) { - uptr i; ptr x, v, *vp; - v = sorted_locked_objects; - i = Svector_length(v); - x = *(vp = &INITVECTIT(v, 0)); - do { - if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) { - forward_or_bwp(&INITCAR(x), Scar(x)); - } - } while (--i != 0 && (x = *++vp) != MAXPTR); + for (ls = younger_locked_objects; ls != Snil; ls = Scdr(ls)) { + ptr x = Scar(ls); + if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) { + forward_or_bwp(&INITCAR(x), Scar(x)); + } } /* post-gc oblist handling. rebuild old buckets in the target generation, pruning unforwarded symbols */ - { bucket_list *bl, *blnext; bucket *b, *bnext; bucket_pointer_list *bpl; bucket **pb; ptr sym; + { bucket_list *bl, *blnext; bucket *b, *bnext; bucket_pointer_list *bpl; bucket **pb; + ptr sym; seginfo *si; bl = tg == static_generation ? NULL : S_G.buckets_of_generation[tg]; for (bpl = buckets_to_rebuild; bpl != NULL; bpl = bpl->cdr) { pb = bpl->car; for (b = (bucket *)((uptr)*pb - 1); b != NULL && ((uptr)(b->next) & 1); b = bnext) { bnext = (bucket *)((uptr)(b->next) - 1); sym = b->sym; - if (locked(sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) { + si = SegInfo(ptr_get_segment(sym)); + if (locked(si, sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) { find_room(space_data, tg, typemod, sizeof(bucket), b); #ifdef ENABLE_OBJECT_COUNTS S_G.countof[tg][countof_oblist] += 1; @@ -1436,11 +897,12 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { } /* rebuild rtds_with_counts lists, dropping otherwise inaccessible rtds */ - { IGEN g; ptr ls, p, newls = tg == mcg ? Snil : S_G.rtds_with_counts[tg]; + { IGEN g; ptr ls, p, newls = tg == mcg ? Snil : S_G.rtds_with_counts[tg]; seginfo *si; for (g = 0; g <= mcg; g += 1) { for (ls = S_G.rtds_with_counts[g], S_G.rtds_with_counts[g] = Snil; ls != Snil; ls = Scdr(ls)) { p = Scar(ls); - if (!OLDSPACE(p) || locked(p)) { + si = SegInfo(ptr_get_segment(p)); + if (!(si->space & space_old) || locked(si, p)) { newls = S_cons_in(space_impure, tg, p, newls); S_G.countof[tg][countof_pair] += 1; } else if (FWDMARKER(p) == forward_marker) { @@ -1478,15 +940,8 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { /* post-collection handling of locked objects. This must come after any use of relocate or any other use of sorted_locked_objects */ - if (sorted_locked_objects != FIX(0)) { - ptr x, v, *vp; iptr i; - - v = sorted_locked_objects; - - /* work from sorted vector to avoid redundant processing of duplicates */ - i = Svector_length(v); - x = *(vp = &INITVECTIT(v, 0)); - do { + for (ls = younger_locked_objects; ls != Snil; ls = Scdr(ls)) { + ptr x = Scar(ls); ptr a1, a2; uptr seg; uptr n; /* promote the segment(s) containing x to the target generation. @@ -1507,10 +962,10 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { if (!(si->space & space_locked)) { si->generation = tg; si->space = (si->space & ~space_old) | space_locked; + si->locked_mask = NULL; sanitize_locked_segment(si); } } - } while (--i != 0 && (x = *++vp) != MAXPTR); } /* move old space segments to empty space */ @@ -1613,6 +1068,15 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { /* tell profile_release_counters to look for bwp'd counters at least through tg */ if (S_G.prcgeneration < tg) S_G.prcgeneration = tg; + + if (count_roots_ls != Sfalse) { +#ifdef ENABLE_OBJECT_COUNTS + return count_roots_counts; +#else + return Snil; +#endif + } else + return Svoid; } #define sweep_space(s, body)\ @@ -1642,7 +1106,7 @@ static void resweep_weak_pairs(g) IGEN g; { 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 (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(si, p)) { if (FORWARDEDP(p, si)) { *pp = GET_FWDADDRESS(p); } else { @@ -1733,10 +1197,12 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { /* space used only as needed for backreferences: */ sweep_space(space_closure, { p = TYPE((ptr)pp, type_closure); - sweep(tc, p, 1); + sweep(tc, p); pp = (ptr *)((uptr)pp + size_object(p)); }) + /* don't sweep from space_count_pure or space_count_impure */ + /* Waiting until sweeping doesn't trigger a change reduces the chance that an ephemeron must be reigistered as a segment-specific trigger or gets triggered for recheck, but @@ -1746,66 +1212,6 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { } while (change); } -static iptr size_object(p) ptr p; { - ITYPE t; ptr tf; - - if ((t = TYPEBITS(p)) == type_pair) { - seginfo *si; - if ((si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~(space_locked | space_old)) == space_ephemeron) - return size_ephemeron; - else - return size_pair; - } else if (t == type_closure) { - ptr code = CLOSCODE(p); - if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) - return size_continuation; - else - return size_closure(CLOSLEN(p)); - } else if (t == type_symbol) { - return size_symbol; - } else if (t == type_flonum) { - return size_flonum; - /* typed objects */ - } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { - return size_vector(Svector_length(p)); - } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - return size_vector(Sstencil_vector_length(p)); - } else if (TYPEP(tf, mask_string, type_string)) { - return size_string(Sstring_length(p)); - } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - return size_bytevector(Sbytevector_length(p)); - } else if (TYPEP(tf, mask_record, type_record)) { - return size_record_inst(UNFIX(RECORDDESCSIZE(tf))); - } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { - return size_fxvector(Sfxvector_length(p)); - } else if (TYPEP(tf, mask_box, type_box)) { - return size_box; - } else if ((iptr)tf == type_tlc) { - return size_tlc; - } else if ((iptr)tf == type_ratnum) { - return size_ratnum; - } else if ((iptr)tf == type_exactnum) { - return size_exactnum; - } else if ((iptr)tf == type_inexactnum) { - return size_inexactnum; - } else if (TYPEP(tf, mask_bignum, type_bignum)) { - return size_bignum(BIGLEN(p)); - } else if (TYPEP(tf, mask_port, type_port)) { - return size_port; - } else if (TYPEP(tf, mask_code, type_code)) { - return size_code(CODELEN(p)); - } else if ((iptr)tf == type_thread) { - return size_thread; - } else if ((iptr)tf == type_rtd_counts) { - return size_rtd_counts; - } else if ((iptr)tf == type_phantom) { - return size_phantom; - } else { - S_error_abort("size_object(gc): illegal type"); - return 0 /* not reached */; - } -} - static iptr sweep_typed_object(tc, p) ptr tc; ptr p; { ptr tf = TYPEFIELD(p); @@ -1816,398 +1222,13 @@ static iptr sweep_typed_object(tc, p) ptr tc; ptr p; { sweep_thread(p); return size_thread; } else { - /* We get here only if backreference mode pushed othertyped objects into - a typed space */ - sweep(tc, p, 1); + /* We get here only if backreference mode pushed other typed objects into + a typed space or if an object is a counting root */ + sweep(tc, p); return size_object(p); } } -static void sweep_symbol(p) ptr p; { - ptr val, code; - PUSH_BACKREFERENCE(p) - - val = SYMVAL(p); - relocate(&val); - INITSYMVAL(p) = val; - code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p); - relocate(&code); - INITSYMCODE(p,code); - relocate(&INITSYMPLIST(p)) - relocate(&INITSYMSPLIST(p)) - relocate(&INITSYMNAME(p)) - relocate(&INITSYMHASH(p)) - - POP_BACKREFERENCE() -} - -static void sweep_port(p) ptr p; { - PUSH_BACKREFERENCE(p) - relocate(&PORTHANDLER(p)) - relocate(&PORTINFO(p)) - relocate(&PORTNAME(p)) - - if (PORTTYPE(p) & PORT_FLAG_OUTPUT) { - iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p); - relocate(&PORTOBUF(p)) - PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n); - } - - if (PORTTYPE(p) & PORT_FLAG_INPUT) { - iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p); - relocate(&PORTIBUF(p)) - PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n); - } - POP_BACKREFERENCE() -} - -static void sweep_thread(p) ptr p; { - ptr tc = (ptr)THREADTC(p); - INT i; - PUSH_BACKREFERENCE(p) - - if (tc != (ptr)0) { - ptr old_stack = SCHEMESTACK(tc); - if (OLDSPACE(old_stack)) { - iptr clength = (uptr)SFP(tc) - (uptr)old_stack; - /* include SFP[0], which contains the return address */ - SCHEMESTACK(tc) = copy_stack(old_stack, &SCHEMESTACKSIZE(tc), clength + sizeof(ptr)); - SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + clength); - ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + SCHEMESTACKSIZE(tc) - stack_slop); - } - STACKCACHE(tc) = Snil; - relocate(&CCHAIN(tc)) - /* U32 RANDOMSEED(tc) */ - /* I32 ACTIVE(tc) */ - relocate(&STACKLINK(tc)) - /* iptr SCHEMESTACKSIZE */ - relocate(&WINDERS(tc)) - relocate(&ATTACHMENTS(tc)) - CACHEDFRAME(tc) = Sfalse; - relocate_return_addr(&FRAME(tc,0)) - sweep_stack((uptr)SCHEMESTACK(tc), (uptr)SFP(tc), (uptr)FRAME(tc,0)); - relocate(&U(tc)) - relocate(&V(tc)) - relocate(&W(tc)) - relocate(&X(tc)) - relocate(&Y(tc)) - /* immediate SOMETHINGPENDING(tc) */ - /* immediate TIMERTICKS */ - /* immediate DISABLE_COUNT */ - /* immediate SIGNALINTERRUPTPENDING */ - /* void* SIGNALINTERRUPTQUEUE(tc) */ - /* immediate KEYBOARDINTERRUPTPENDING */ - relocate(&THREADNO(tc)) - relocate(&CURRENTINPUT(tc)) - relocate(&CURRENTOUTPUT(tc)) - relocate(&CURRENTERROR(tc)) - /* immediate BLOCKCOUNTER */ - relocate(&SFD(tc)) - relocate(&CURRENTMSO(tc)) - relocate(&TARGETMACHINE(tc)) - relocate(&FXLENGTHBV(tc)) - relocate(&FXFIRSTBITSETBV(tc)) - relocate(&NULLIMMUTABLEVECTOR(tc)) - relocate(&NULLIMMUTABLEFXVECTOR(tc)) - relocate(&NULLIMMUTABLEBYTEVECTOR(tc)) - relocate(&NULLIMMUTABLESTRING(tc)) - /* immediate METALEVEL */ - relocate(&COMPILEPROFILE(tc)) - /* immediate GENERATEINSPECTORINFORMATION */ - /* immediate GENERATEPROFILEFORMS */ - /* immediate OPTIMIZELEVEL */ - relocate(&SUBSETMODE(tc)) - /* immediate SUPPRESSPRIMITIVEINLINING */ - relocate(&DEFAULTRECORDEQUALPROCEDURE(tc)) - relocate(&DEFAULTRECORDHASHPROCEDURE(tc)) - relocate(&COMPRESSFORMAT(tc)) - relocate(&COMPRESSLEVEL(tc)) - /* void* LZ4OUTBUFFER(tc) */ - /* U64 INSTRCOUNTER(tc) */ - /* U64 ALLOCCOUNTER(tc) */ - relocate(&PARAMETERS(tc)) - for (i = 0 ; i < virtual_register_count ; i += 1) { - relocate(&VIRTREG(tc, i)); - } - } - - POP_BACKREFERENCE() -} - -static void sweep_continuation(p) ptr p; { - PUSH_BACKREFERENCE(p) - relocate(&CONTWINDERS(p)) - relocate(&CONTATTACHMENTS(p)) - - /* bug out for shot 1-shot continuations */ - if (CONTLENGTH(p) == scaled_shot_1_shot_flag) return; - - if (OLDSPACE(CONTSTACK(p))) - CONTSTACK(p) = copy_stack(CONTSTACK(p), &CONTLENGTH(p), CONTCLENGTH(p)); - - relocate(&CONTLINK(p)) - relocate_return_addr(&CONTRET(p)) - - /* use CLENGTH to avoid sweeping unoccupied portion of one-shots */ - sweep_stack((uptr)CONTSTACK(p), (uptr)CONTSTACK(p) + CONTCLENGTH(p), (uptr)CONTRET(p)); - - POP_BACKREFERENCE() -} - -/* assumes stack has already been copied to newspace */ -static void sweep_stack(base, fp, ret) uptr base, fp, ret; { - ptr *pp; iptr oldret; - ptr num; - - while (fp != base) { - if (fp < base) - S_error_abort("sweep_stack(gc): malformed stack"); - fp = fp - ENTRYFRAMESIZE(ret); - pp = (ptr *)fp; - - oldret = ret; - ret = (iptr)(*pp); - relocate_return_addr(pp) - - num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 0x0001) relocate(pp) - mask >>= 1; - } - } else { - iptr index; - - relocate(ENTRYNONCOMPACTLIVEMASKADDR(oldret)) - num = ENTRYLIVEMASK(oldret); - index = BIGLEN(num); - while (index-- != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num,index); - while (bits-- > 0) { - pp += 1; - if (mask & 1) relocate(pp) - mask >>= 1; - } - } - } - } -} - -#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; { - PUSH_BACKREFERENCE(x) - sweep_or_check_record(x, relocate) - POP_BACKREFERENCE() -} - -#define check_self(pp) if (*(pp) == x) return 1; - -static int scan_record_for_self(x) ptr x; { - sweep_or_check_record(x, check_self) - return 0; -} - -static IGEN sweep_dirty_record(x, tg, youngest) ptr x; IGEN tg, youngest; { - ptr *pp; ptr num; ptr rtd; - PUSH_BACKREFERENCE(x) - - /* warning: assuming rtd is immutable */ - rtd = RECORDINSTTYPE(x); - - /* warning: assuming MPM field is immutable */ - num = RECORDDESCMPM(rtd); - pp = &RECORDINSTIT(x,0); - - /* sweep cells for which bit in mpm is set - include rtd in case it's mutable */ - if (Sfixnump(num)) { - /* ignore bit for assumed immutable rtd */ - uptr mask = (uptr)UNFIX(num) >> 1; - while (mask != 0) { - if (mask & 1) relocate_dirty(pp,tg,youngest) - mask >>= 1; - pp += 1; - } - } else { - iptr index; bigit mask; INT bits; - - index = BIGLEN(num) - 1; - /* ignore bit for assumed immutable rtd */ - mask = BIGIT(num,index) >> 1; - bits = bigit_bits - 1; - for (;;) { - do { - if (mask & 1) relocate_dirty(pp,tg,youngest) - mask >>= 1; - pp += 1; - } while (--bits > 0); - if (index-- == 0) break; - mask = BIGIT(num,index); - bits = bigit_bits; - } - } - - POP_BACKREFERENCE() - - return youngest; -} - -static IGEN sweep_dirty_port(p, tg, youngest) ptr p; IGEN tg, youngest; { - PUSH_BACKREFERENCE(p) - - relocate_dirty(&PORTHANDLER(p),tg,youngest) - relocate_dirty(&PORTINFO(p),tg,youngest) - relocate_dirty(&PORTNAME(p),tg,youngest) - - if (PORTTYPE(p) & PORT_FLAG_OUTPUT) { - iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p); - relocate_dirty(&PORTOBUF(p),tg,youngest) - PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n); - } - - if (PORTTYPE(p) & PORT_FLAG_INPUT) { - iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p); - relocate_dirty(&PORTIBUF(p),tg,youngest) - PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n); - } - - POP_BACKREFERENCE() - - return youngest; -} - -static IGEN sweep_dirty_symbol(p, tg, youngest) ptr p; IGEN tg, youngest; { - ptr val, code; - PUSH_BACKREFERENCE(p) - - val = SYMVAL(p); - relocate_dirty(&val,tg,youngest) - INITSYMVAL(p) = val; - code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p); - relocate_dirty(&code,tg,youngest) - INITSYMCODE(p,code); - relocate_dirty(&INITSYMPLIST(p),tg,youngest) - relocate_dirty(&INITSYMSPLIST(p),tg,youngest) - relocate_dirty(&INITSYMNAME(p),tg,youngest) - relocate_dirty(&INITSYMHASH(p),tg,youngest) - - POP_BACKREFERENCE() - - return youngest; -} - -static void sweep_code_object(tc, co) ptr tc, co; { - ptr t, oldco; iptr a, m, n; - - PUSH_BACKREFERENCE(co) - -#ifdef DEBUG - if ((CODETYPE(co) & mask_code) != type_code) { - (void)printf("unexpected type %x sweeping code object %p\n", CODETYPE(co), co); - (void)fflush(stdout); - } -#endif - - relocate(&CODENAME(co)) - relocate(&CODEARITYMASK(co)) - relocate(&CODEINFO(co)) - relocate(&CODEPINFOS(co)) - - t = CODERELOC(co); - m = RELOCSIZE(t); - oldco = RELOCCODE(t); - a = 0; - n = 0; - while (n < m) { - uptr entry, item_off, code_off; ptr obj; - entry = RELOCIT(t, n); n += 1; - if (RELOC_EXTENDED_FORMAT(entry)) { - item_off = RELOCIT(t, n); n += 1; - code_off = RELOCIT(t, n); n += 1; - } else { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a += code_off; - obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate(&obj) - S_set_code_obj("gc", RELOC_TYPE(entry), co, a, obj, item_off); - } - - if (target_generation == static_generation && !S_G.retain_static_relocation && (CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0) { - CODERELOC(co) = (ptr)0; - } else { - /* Don't copy non-oldspace relocation tables, since we may be - sweeping a locked code object that is older than target_generation - Doing so would be a waste of work anyway. */ - if (OLDSPACE(t)) { - ptr oldt = t; - n = size_reloc_table(RELOCSIZE(oldt)); -#ifdef ENABLE_OBJECT_COUNTS - S_G.countof[target_generation][countof_relocation_table] += 1; - S_G.bytesof[target_generation][countof_relocation_table] += n; -#endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_data, target_generation, typemod, n, t); - copy_ptrs(typemod, t, oldt, n); - } - RELOCCODE(t) = co; - CODERELOC(co) = t; - } - - S_record_code_mod(tc, (uptr)&CODEIT(co,0), (uptr)CODELEN(co)); - - POP_BACKREFERENCE() -} - typedef struct _weakseginfo { seginfo *si; IGEN youngest[cards_per_segment]; @@ -2371,7 +1392,9 @@ static void sweep_dirty(void) { backp = (ptr)(((uptr)backp) - bytes_per_segment); } } - } else if ((s == space_impure) || (s == space_impure_typed_object) || (s == space_closure)) { + } else if ((s == space_impure) + || (s == space_impure_typed_object) || (s == space_count_impure) + || (s == space_closure)) { while (pp < ppend && *pp != forward_marker) { /* handle two pointers at a time */ relocate_dirty(pp,tg,youngest) @@ -2615,7 +1638,7 @@ static void resweep_dirty_weak_pairs() { /* handle car field */ if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { if (si->space & space_old) { - if (locked(p)) { + if (locked(si, p)) { youngest = tg; } else if (FORWARDEDP(p, si)) { *pp = FWDADDRESS(p); @@ -2706,7 +1729,7 @@ static void check_ephemeron(ptr pe, int add_to_trigger) { PUSH_BACKREFERENCE(pe); p = Scar(pe); - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) { + if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(si, p)) { if (FORWARDEDP(p, si)) { INITCAR(pe) = FWDADDRESS(p); relocate(&INITCDR(pe)) @@ -2760,7 +1783,7 @@ 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 (si->space & space_old && !locked(si, p)) { if (FORWARDEDP(p, si)) { INITCAR(pe) = GET_FWDADDRESS(p); relocate(&INITCDR(pe)) @@ -2811,3 +1834,275 @@ static void clear_trigger_ephemerons() { pe = EPHEMERONNEXT(pe); } } + +#ifdef ENABLE_OBJECT_COUNTS +static uptr total_size_so_far() { + IGEN g; + int i; + uptr total = 0; + + for (g = 0; g <= static_generation; g += 1) { + for (i = 0; i < countof_types; i += 1) { + uptr bytes; + bytes = S_G.bytesof[g][i]; + if (bytes == 0) bytes = S_G.countof[g][i] * S_G.countof_size[i]; + total += bytes; + } + total += S_G.phantom_sizes[g]; + } + + return total - count_root_bytes; +} +#endif + +/* **************************************** */ + +#ifdef ENABLE_MEASURE + +static void init_measure(IGEN min_gen, IGEN max_gen) { + uptr init_stack_len = 1024; + + min_measure_generation = min_gen; + max_measure_generation = max_gen; + + find_room(space_data, 0, typemod, init_stack_len, measure_stack_start); + measure_stack = (ptr *)measure_stack_start; + measure_stack_limit = (ptr *)((uptr)measure_stack_start + init_stack_len); + + measured_seginfos = Snil; + + measure_all_enabled = 1; +} + +static void finish_measure() { + ptr ls; + + for (ls = measured_seginfos; ls != Snil; ls = Scdr(ls)) { + seginfo *si = (seginfo *)Scar(ls); + si->measured_mask = NULL; + si->trigger_ephemerons = NULL; + } + + measure_all_enabled = 0; +} + +static void init_counting_mask(seginfo *si) { + find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->counting_mask); + memset(si->counting_mask, 0, segment_bitmap_bytes); +} + +static void init_measure_mask(seginfo *si) { + find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->measured_mask); + memset(si->measured_mask, 0, segment_bitmap_bytes); + + measured_seginfos = S_cons_in(space_new, 0, (ptr)si, measured_seginfos); +} + +#define measure_unreached(si, p) \ + (!si->measured_mask \ + || !(si->measured_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) + +#define measure_mask_set(mm, si, p) \ + mm[segment_bitmap_byte(p)] |= segment_bitmap_bit(p) +#define measure_mask_unset(mm, si, p) \ + mm[segment_bitmap_byte(p)] -= segment_bitmap_bit(p) + +static void push_measure(ptr p) +{ + seginfo *si = MaybeSegInfo(ptr_get_segment(p)); + + if (!si) + return; + + if (si->space & space_old) { + /* We must be in a GC--measure fusion, so switch back to GC */ + if (!locked(si, p)) { + relocate(&p) + return; + } + } + + if (si->generation > max_measure_generation) + return; + else if (si->generation < min_measure_generation) { + /* this only happens in fusion mode, too; si must be a new segment */ + return; + } else { + uptr byte = segment_bitmap_byte(p); + uptr bit = segment_bitmap_bit(p); + + if (!si->measured_mask) + init_measure_mask(si); + else if (si->measured_mask[byte] & bit) + return; + + si->measured_mask[byte] |= bit; + } + + if (si->trigger_ephemerons) { + add_trigger_ephemerons_to_pending_measure(si->trigger_ephemerons); + si->trigger_ephemerons = NULL; + } + + if (measure_stack == measure_stack_limit) { + uptr sz = ptr_bytes * (measure_stack_limit - measure_stack_start); + uptr new_sz = 2*sz; + ptr new_measure_stack; + find_room(space_data, 0, typemod, ptr_align(new_sz), new_measure_stack); + memcpy(new_measure_stack, measure_stack_start, sz); + measure_stack_start = (ptr *)new_measure_stack; + measure_stack_limit = (ptr *)((uptr)new_measure_stack + new_sz); + measure_stack = (ptr *)((uptr)new_measure_stack + sz); + } + + *(measure_stack++) = p; +} + +static void measure_add_stack_size(ptr stack, uptr size) { + seginfo *si = SegInfo(ptr_get_segment(stack)); + if (!(si->space & space_old) + && (si->generation <= max_measure_generation) + && (si->generation >= min_measure_generation)) + measure_total += size; +} + +static void add_ephemeron_to_pending_measure(ptr pe) { + EPHEMERONNEXT(pe) = pending_measure_ephemerons; + pending_measure_ephemerons = pe; +} + +static void add_trigger_ephemerons_to_pending_measure(ptr pe) { + ptr last_pe = pe, next_pe = EPHEMERONNEXT(pe); + + while (next_pe != NULL) { + last_pe = next_pe; + next_pe = EPHEMERONNEXT(next_pe); + } + EPHEMERONNEXT(last_pe) = pending_measure_ephemerons; + pending_measure_ephemerons = pe; +} + +static void check_ephemeron_measure(ptr pe) { + ptr p; + seginfo *si; + + p = Scar(pe); + if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL + && (si->generation <= max_measure_generation) + && (si->generation >= min_measure_generation) + && (!(si->space & space_old) || !FORWARDEDP(p, si)) + && (measure_unreached(si, p) + || (si->counting_mask + && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))))) { + /* Not reached, so far; install as trigger */ + EPHEMERONNEXT(pe) = si->trigger_ephemerons; + si->trigger_ephemerons = pe; + if (!si->measured_mask) + init_measure_mask(si); /* so triggers are cleared at end */ + return; + } + + p = Scdr(pe); + if (!IMMEDIATE(p)) + push_measure(p); +} + +static void check_pending_measure_ephemerons() { + ptr pe, next_pe; + + pe = pending_measure_ephemerons; + pending_measure_ephemerons = NULL; + while (pe != NULL) { + next_pe = EPHEMERONNEXT(pe); + check_ephemeron_measure(pe); + pe = next_pe; + } +} + +void gc_measure_one(ptr p) { + seginfo *si = SegInfo(ptr_get_segment(p)); + + if (si->trigger_ephemerons) { + add_trigger_ephemerons_to_pending_measure(si->trigger_ephemerons); + si->trigger_ephemerons = NULL; + } + + measure(p); + + (void)flush_measure_stack(); +} + +IBOOL flush_measure_stack() { + if ((measure_stack <= measure_stack_start) + && !pending_measure_ephemerons) + return 0; + + while (1) { + while (measure_stack > measure_stack_start) + measure(*(--measure_stack)); + + if (!pending_measure_ephemerons) + break; + check_pending_measure_ephemerons(); + } + + return 1; +} + +ptr S_count_size_increments(ptr ls, IGEN generation) { + ptr l, totals = Snil, totals_prev = NULL; + + tc_mutex_acquire(); + + init_measure(0, generation); + + for (l = ls; l != Snil; l = Scdr(l)) { + ptr p = Scar(l); + if (!IMMEDIATE(p)) { + seginfo *si = si = SegInfo(ptr_get_segment(p)); + + if (!si->measured_mask) + init_measure_mask(si); + measure_mask_set(si->measured_mask, si, p); + + if (!si->counting_mask) + init_counting_mask(si); + measure_mask_set(si->counting_mask, si, p); + } + } + + for (l = ls; l != Snil; l = Scdr(l)) { + ptr p = Scar(l); + + measure_total = 0; + + if (!IMMEDIATE(p)) { + seginfo *si = si = SegInfo(ptr_get_segment(p)); + measure_mask_unset(si->counting_mask, si, p); + gc_measure_one(p); + } + + p = Scons(FIX(measure_total), Snil); + if (totals_prev) + Scdr(totals_prev) = p; + else + totals = p; + totals_prev = p; + } + + for (l = ls; l != Snil; l = Scdr(l)) { + ptr p = Scar(l); + if (!IMMEDIATE(p)) { + seginfo *si = si = SegInfo(ptr_get_segment(p)); + si->counting_mask = NULL; + } + } + + finish_measure(); + + tc_mutex_release(); + + return totals; +} + +#endif diff --git a/c/gcwrapper.c b/c/gcwrapper.c index c7ed817b87..ed3852bd0b 100644 --- a/c/gcwrapper.c +++ b/c/gcwrapper.c @@ -128,9 +128,11 @@ void S_gc_init() { INITVECTIT(S_G.countof_names, countof_oblist) = S_intern((const unsigned char *)"oblist"); S_G.countof_size[countof_guardian] = 0; INITVECTIT(S_G.countof_names, countof_ephemeron) = S_intern((const unsigned char *)"ephemeron"); - S_G.countof_size[countof_ephemeron] = 0; + S_G.countof_size[countof_ephemeron] = size_ephemeron; INITVECTIT(S_G.countof_names, countof_stencil_vector) = S_intern((const unsigned char *)"stencil-vector"); S_G.countof_size[countof_stencil_vector] = 0; + INITVECTIT(S_G.countof_names, countof_record) = S_intern((const unsigned char *)"record"); + S_G.countof_size[countof_record] = 0; for (i = 0; i < countof_types; i += 1) { if (Svector_ref(S_G.countof_names, i) == FIX(0)) { fprintf(stderr, "uninitialized countof_name at index %d\n", i); @@ -351,29 +353,31 @@ ptr S_object_counts(void) { /* add primary types w/nonozero counts to the alist */ for (i = 0 ; i < countof_types; i += 1) { - ptr inner_alist = Snil; - for (g = 0; g <= static_generation; INCRGEN(g)) { - IGEN gcurrent = g; - uptr count = S_G.countof[g][i]; - uptr bytes = S_G.bytesof[g][i]; + if (i != countof_record) { /* covered by rtd-specific counts */ + ptr inner_alist = Snil; + for (g = 0; g <= static_generation; INCRGEN(g)) { + IGEN gcurrent = g; + uptr count = S_G.countof[g][i]; + uptr bytes = S_G.bytesof[g][i]; - if (g == S_G.new_max_nonstatic_generation) { - while (g < S_G.max_nonstatic_generation) { - g += 1; - /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */ - /* coverity[overrun-buffer-val] */ - count += S_G.countof[g][i]; - /* coverity[overrun-buffer-val] */ - bytes += S_G.bytesof[g][i]; + if (g == S_G.new_max_nonstatic_generation) { + while (g < S_G.max_nonstatic_generation) { + g += 1; + /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */ + /* coverity[overrun-buffer-val] */ + count += S_G.countof[g][i]; + /* coverity[overrun-buffer-val] */ + bytes += S_G.bytesof[g][i]; + } + } + + if (count != 0) { + if (bytes == 0) bytes = count * S_G.countof_size[i]; + inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist); } } - - if (count != 0) { - if (bytes == 0) bytes = count * S_G.countof_size[i]; - inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist); - } + if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist); } - if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist); } tc_mutex_release() @@ -408,7 +412,7 @@ ptr S_object_backreferences(void) { void Scompact_heap() { ptr tc = get_thread_context(); S_pants_down += 1; - S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation); + S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, Sfalse); S_pants_down -= 1; } @@ -755,9 +759,9 @@ void S_fixup_counts(ptr counts) { RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0]; } -void S_do_gc(IGEN mcg, IGEN tg) { +ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) { ptr tc = get_thread_context(); - ptr code; + ptr code, result; code = CP(tc); if (Sprocedurep(code)) code = CLOSCODE(code); @@ -777,7 +781,7 @@ void S_do_gc(IGEN mcg, IGEN tg) { new_g = S_G.new_max_nonstatic_generation; old_g = S_G.max_nonstatic_generation; /* first, collect everything to old_g */ - S_gc(tc, old_g, old_g); + result = S_gc(tc, old_g, old_g, count_roots); /* now transfer old_g info to new_g, and clear old_g info */ for (s = 0; s <= max_real_space; s += 1) { S_G.first_loc[s][new_g] = S_G.first_loc[s][old_g]; S_G.first_loc[s][old_g] = FIX(0); @@ -859,7 +863,7 @@ void S_do_gc(IGEN mcg, IGEN tg) { S_G.min_free_gen = S_G.new_min_free_gen; S_G.max_nonstatic_generation = new_g; } else { - S_gc(tc, mcg, tg); + result = S_gc(tc, mcg, tg, count_roots); } S_pants_down -= 1; @@ -869,12 +873,16 @@ void S_do_gc(IGEN mcg, IGEN tg) { S_reset_allocation_pointer(tc); Sunlock_object(code); + + return result; } -void S_gc(ptr tc, IGEN mcg, IGEN tg) { - if (tg == static_generation || S_G.enable_object_counts || S_G.enable_object_backreferences) - S_gc_oce(tc, mcg, tg); +ptr S_gc(ptr tc, IGEN mcg, IGEN tg, ptr count_roots) { + if (tg == static_generation + || S_G.enable_object_counts || S_G.enable_object_backreferences + || (count_roots != Sfalse)) + return S_gc_oce(tc, mcg, tg, count_roots); else - S_gc_ocd(tc, mcg, tg); + return S_gc_ocd(tc, mcg, tg, Sfalse); } diff --git a/c/prim.c b/c/prim.c index 1580eabbfc..8904a3605d 100644 --- a/c/prim.c +++ b/c/prim.c @@ -177,6 +177,7 @@ void S_prim_init() { Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp); Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap); Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors); + Sforeign_symbol("(cs)count_size_increments", (void *)S_count_size_increments); Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry); Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object); Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry); diff --git a/c/types.h b/c/types.h index 7ac7b7a816..8e681192a6 100644 --- a/c/types.h +++ b/c/types.h @@ -114,6 +114,11 @@ typedef int IFASLCODE; /* fasl type codes */ #define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits) #define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits) +#define segment_bitmap_bytes (bytes_per_segment >> (log2_ptr_bytes+3)) +#define segment_bitmap_index(p) ((((uptr)p + (typemod-1)) & (bytes_per_segment - 1)) >> log2_ptr_bytes) +#define segment_bitmap_byte(p) (segment_bitmap_index(p) >> 3) +#define segment_bitmap_bit(p) ((uptr)1 << (segment_bitmap_index(p) & 0x7)) + #define SPACE(p) SegmentSpace(ptr_get_segment(p)) #define GENERATION(p) SegmentGeneration(ptr_get_segment(p)) @@ -136,9 +141,12 @@ typedef struct _seginfo { ptr trigger_guardians; /* guardians to re-check if object in segment is copied out */ ptr locked_objects; /* list of objects (including duplicates) for locked in this segment */ ptr unlocked_objects; /* list of objects (no duplicates) for formerly locked */ + octet *locked_mask; /* bitmap of locked objects, used only during GC */ #ifdef PRESERVE_FLONUM_EQ octet *forwarded_flonums; /* bitmap of flonums whose payload is a forwarding pointer */ #endif + octet *counting_mask; /* bitmap of counting roots during a GC */ + octet *measured_mask; /* bitmap of objects that have been measured */ octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ } seginfo; @@ -403,3 +411,8 @@ typedef struct { #define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1) #define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x)) + +/* For `memcpy_aligned, that the first two arguments are word-aligned + and it would be ok to round up the length to a word size. But + probably the compiler does a fine job with plain old `mempcy`. */ +#define memcpy_aligned memcpy diff --git a/c/vfasl.c b/c/vfasl.c index ed86c223a8..1cd45421b1 100644 --- a/c/vfasl.c +++ b/c/vfasl.c @@ -164,17 +164,16 @@ static uptr symbol_pos_to_offset(uptr sym_pos) { static ptr vfasl_copy_all(vfasl_info *vfi, ptr v); static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si); -static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n); -static uptr sweep_code_object(vfasl_info *vfi, ptr co); -static uptr sweep_record(vfasl_info *vfi, ptr co); static uptr sweep(vfasl_info *vfi, ptr p); static int is_rtd(ptr tf, vfasl_info *vfi); +static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj); static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static); static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets); static void vfasl_relocate(vfasl_info *vfi, ptr *ppp); static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp); +static ptr vfasl_relocate_code(vfasl_info *vfi, ptr code); static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n); static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp); static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p); @@ -182,6 +181,8 @@ static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int whi static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p); static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p); +static iptr vfasl_symbol_to_index(vfasl_info *vfi, ptr pp); + static void fasl_init_entry_tables(); static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name); @@ -992,198 +993,7 @@ static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { #define FIND_ROOM(vfi, s, t, n, p) p = vfasl_find_room(vfi, s, t, n) -#define copy_ptrs(ty, p1, p2, n) {\ - ptr *Q1, *Q2, *Q1END;\ - Q1 = (ptr *)UNTYPE((p1),ty);\ - Q2 = (ptr *)UNTYPE((p2),ty);\ - Q1END = (ptr *)((uptr)Q1 + n);\ - while (Q1 != Q1END) *Q1++ = *Q2++;} - -static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { - ptr p, tf; ITYPE t; - - if ((t = TYPEBITS(pp)) == type_typed_object) { - tf = TYPEFIELD(pp); - if (TYPEP(tf, mask_record, type_record)) { - ptr rtd; iptr n; int s; - - rtd = tf; - - if (is_rtd(tf, vfi)) { - if (pp != S_G.base_rtd) { - /* make sure rtd's type is registered first */ - (void)vfasl_relocate_help(vfi, rtd); - } - /* need parent before child */ - vfasl_relocate_parents(vfi, RECORDDESCPARENT(pp)); - - s = vspace_rtd; - } else { - /* See gc.c for original rationale, but the fine-grained - choices only matter when loading into the static - generation, so we make */ - s = (RECORDDESCMPM(rtd) == FIX(0) - ? vspace_pure_typed - : vspace_impure_record); - } - - n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); - - FIND_ROOM(vfi, s, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - - if (pp == S_G.base_rtd) - vfi->base_rtd = p; - - /* pad if necessary */ - { - iptr m = unaligned_size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); - if (m != n) - *((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0); - } - } else if (TYPEP(tf, mask_vector, type_vector)) { - iptr len, n; - len = Svector_length(pp); - n = size_vector(len); - FIND_ROOM(vfi, vspace_impure, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - /* pad if necessary */ - if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0); - } else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - iptr len, n; - len = Sstencil_vector_length(pp); - n = size_stencil_vector(len); - FIND_ROOM(vfi, vspace_impure, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - /* pad if necessary */ - if ((len & 1) == 0) INITSTENVECTIT(p, len) = FIX(0); - } else if (TYPEP(tf, mask_string, type_string)) { - iptr n; - n = size_string(Sstring_length(pp)); - FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { - iptr n; - n = size_fxvector(Sfxvector_length(pp)); - FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - iptr n; - n = size_bytevector(Sbytevector_length(pp)); - FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if ((iptr)tf == type_tlc) { - vfasl_fail(vfi, "tlc"); - return (ptr)0; - } else if (TYPEP(tf, mask_box, type_box)) { - FIND_ROOM(vfi, vspace_impure, type_typed_object, size_box, p); - BOXTYPE(p) = (iptr)tf; - INITBOXREF(p) = Sunbox(pp); - } else if ((iptr)tf == type_ratnum) { - /* note: vspace_impure is suboptimal for loading into static - generation, but these will be rare in boot code */ - FIND_ROOM(vfi, vspace_impure, type_typed_object, size_ratnum, p); - RATTYPE(p) = type_ratnum; - RATNUM(p) = RATNUM(pp); - RATDEN(p) = RATDEN(pp); - /* pad */ - ((void **)UNTYPE(p, type_typed_object))[3] = (ptr)0; - } else if ((iptr)tf == type_exactnum) { - /* note: vspace_impure is suboptimal for loading into static - generation, but these will be rare in boot code */ - FIND_ROOM(vfi, vspace_impure, type_typed_object, size_exactnum, p); - EXACTNUM_TYPE(p) = type_exactnum; - EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp); - EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp); - /* pad */ - ((void **)UNTYPE(p, type_typed_object))[3] = (ptr)0; - } else if ((iptr)tf == type_inexactnum) { - FIND_ROOM(vfi, vspace_data, type_typed_object, size_inexactnum, p); - INEXACTNUM_TYPE(p) = type_inexactnum; - INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp); - INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp); - } else if (TYPEP(tf, mask_bignum, type_bignum)) { - iptr n; - n = size_bignum(BIGLEN(pp)); - FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - } else if (TYPEP(tf, mask_port, type_port)) { - vfasl_fail(vfi, "port"); - return (ptr)0; - } else if (TYPEP(tf, mask_code, type_code)) { - iptr n; - n = size_code(CODELEN(pp)); - FIND_ROOM(vfi, vspace_code, type_typed_object, n, p); - copy_ptrs(type_typed_object, p, pp, n); - if (CODERELOC(pp) == (ptr)0) - vfasl_fail(vfi, "code without relocation"); - } else if ((iptr)tf == type_rtd_counts) { - /* prune counts, since GC will recreate as needed */ - return Sfalse; - } else if ((iptr)tf == type_thread) { - vfasl_fail(vfi, "thread"); - return (ptr)0; - } else { - S_error_abort("vfasl: illegal type"); - return (ptr)0 /* not reached */; - } - } else if (t == type_pair) { - if (si->space == space_ephemeron) { - vfasl_fail(vfi, "emphemeron"); - return (ptr)0; - } else if (si->space == space_weakpair) { - vfasl_fail(vfi, "weakpair"); - return (ptr)0; - } else { - FIND_ROOM(vfi, vspace_impure, type_pair, size_pair, p); - } - INITCAR(p) = Scar(pp); - INITCDR(p) = Scdr(pp); - } else if (t == type_closure) { - ptr code; - code = CLOSCODE(pp); - if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) { - vfasl_fail(vfi, "continuation"); - return (ptr)0; - } else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) { - vfasl_fail(vfi, "mutable closure"); - return (ptr)0; - } else { - iptr len, n; - len = CLOSLEN(pp); - n = size_closure(len); - FIND_ROOM(vfi, vspace_closure, type_closure, n, p); - copy_ptrs(type_closure, p, pp, n); - /* pad if necessary */ - if ((len & 1) == 0) CLOSIT(p, len) = FIX(0); - } - } else if (t == type_symbol) { - iptr pos = vfi->sym_count++; - ptr name = SYMNAME(pp); - if (Sstringp(name)) - vfasl_check_install_library_entry(vfi, name); - else if (!Spairp(name) || (Scar(name) == Sfalse)) - vfasl_fail(vfi, "gensym without unique name"); - FIND_ROOM(vfi, vspace_symbol, type_symbol, size_symbol, p); - INITSYMVAL(p) = FIX(pos); /* stores symbol index for now; will get reset on load */ - INITSYMPVAL(p) = Snil; /* will get reset on load */ - INITSYMPLIST(p) = Snil; - INITSYMSPLIST(p) = Snil; - INITSYMNAME(p) = name; - INITSYMHASH(p) = SYMHASH(pp); - } else if (t == type_flonum) { - FIND_ROOM(vfi, vspace_data, type_flonum, size_flonum, p); - FLODAT(p) = FLODAT(pp); - /* note: unlike GC, sharing flonums */ - } else { - S_error_abort("copy(gc): illegal type"); - return (ptr)0 /* not reached */; - } - - vfasl_register_forward(vfi, pp, p); - - return p; -} +#include "vfasl.inc" static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp) { ptr fpp; @@ -1225,133 +1035,10 @@ static void vfasl_relocate(vfasl_info *vfi, ptr *ppp) { } } -static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n) { - ptr *end = pp + n; - - while (pp != end) { - vfasl_relocate(vfi, pp); - pp += 1; - } -} - -static uptr sweep(vfasl_info *vfi, ptr p) { - ptr tf; ITYPE t; - - t = TYPEBITS(p); - if (t == type_closure) { - uptr len; - ptr code; - - len = CLOSLEN(p); - sweep_ptrs(vfi, &CLOSIT(p, 0), len); - - /* To code-entry pointer looks like an immediate to - sweep, so relocate the code directly, and also make it - relative to the base address. */ - code = vfasl_relocate_help(vfi, CLOSCODE(p)); - code = (ptr)ptr_diff(code, vfi->base_addr); - SETCLOSCODE(p,code); - - return size_closure(len); - } else if (t == type_symbol) { - vfasl_relocate(vfi, &INITSYMNAME(p)); - /* other parts are replaced on load */ - return size_symbol; - } else if (t == type_flonum) { - /* nothing to sweep */; - return size_flonum; - /* typed objects */ - } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { - uptr len = Svector_length(p); - sweep_ptrs(vfi, &INITVECTIT(p, 0), len); - return size_vector(len); - } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - uptr len = Sstencil_vector_length(p); - sweep_ptrs(vfi, &INITSTENVECTIT(p, 0), len); - return size_stencil_vector(len); - } else if (TYPEP(tf, mask_record, type_record)) { - return sweep_record(vfi, p); - } else if (TYPEP(tf, mask_box, type_box)) { - vfasl_relocate(vfi, &INITBOXREF(p)); - return size_box; - } else if ((iptr)tf == type_ratnum) { - vfasl_relocate(vfi, &RATNUM(p)); - vfasl_relocate(vfi, &RATDEN(p)); - return size_ratnum; - } else if ((iptr)tf == type_exactnum) { - vfasl_relocate(vfi, &EXACTNUM_REAL_PART(p)); - vfasl_relocate(vfi, &EXACTNUM_IMAG_PART(p)); - return size_exactnum; - } else if (TYPEP(tf, mask_code, type_code)) { - return sweep_code_object(vfi, p); - } else { - S_error_abort("vfasl_sweep: illegal type"); - return 0; - } -} - -static uptr sweep_record(vfasl_info *vfi, ptr x) -{ - ptr *pp; ptr num; ptr rtd; - - rtd = RECORDINSTTYPE(x); - - if (x == vfi->base_rtd) { - /* Don't need to save fields of base-rtd */ - ptr *pp = &RECORDINSTIT(x,0); - ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; - while (pp < ppend) { - *pp = Snil; - pp += 1; - } - return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); - } - - vfasl_relocate(vfi, &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) { - vfasl_relocate(vfi, pp); - pp += 1; - } - } else { - while (mask != 0) { - if (mask & 1) vfasl_relocate(vfi, pp); - mask >>= 1; - pp += 1; - } - } - } else { - iptr index; bigit mask; INT bits; - - /* bignum pointer mask */ - num = RECORDDESCPM(rtd); - vfasl_relocate(vfi, &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) vfasl_relocate(vfi, pp); - mask >>= 1; - pp += 1; - } while (--bits > 0); - if (index-- == 0) break; - mask = BIGIT(num,index); - bits = bigit_bits; - } - } - - return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); +static ptr vfasl_relocate_code(vfasl_info *vfi, ptr code) { + /* We don't want to register `code` as a pointer, since it is + treated more directly */ + return vfasl_relocate_help(vfi, code); } static int is_rtd(ptr tf, vfasl_info *vfi) @@ -1389,70 +1076,34 @@ static int is_rtd(ptr tf, vfasl_info *vfi) #define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1)) #define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS) -static uptr sweep_code_object(vfasl_info *vfi, ptr co) { - ptr t, oldco, oldt; iptr a, m, n; +static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj) { + ptr pos; + int which_singleton; + + if ((which_singleton = detect_singleton(obj))) { + obj = FIX(VFASL_RELOC_SINGLETON(which_singleton)); + } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) { + if ((uptr)pos == CENTRY_install_library_entry) + vfi->installs_library_entry = 1; + obj = FIX(VFASL_RELOC_C_ENTRY(pos)); + } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) { + obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos)); + } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) { + obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos)); + } else if (Ssymbolp(obj)) { + obj = vfasl_relocate_help(vfi, obj); + obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj)))); + } else if (IMMEDIATE(obj)) { + /* as-is */ + if (Sfixnump(obj)) + if (obj != FIX(0)) /* allow 0 for fcallable cookie */ + S_error("vfasl", "unexpected fixnum in relocation"); + } else { + obj = vfasl_relocate_help(vfi, obj); + obj = (ptr)ptr_diff(obj, vfi->base_addr); + } - vfasl_relocate(vfi, &CODENAME(co)); - vfasl_relocate(vfi, &CODEARITYMASK(co)); - vfasl_relocate(vfi, &CODEINFO(co)); - vfasl_relocate(vfi, &CODEPINFOS(co)); - - oldt = CODERELOC(co); - - n = size_reloc_table(RELOCSIZE(oldt)); - t = vfasl_find_room(vfi, vspace_reloc, typemod, n); - copy_ptrs(typemod, t, oldt, n); - - m = RELOCSIZE(t); - oldco = RELOCCODE(t); - a = 0; - n = 0; - while (n < m) { - uptr entry, item_off, code_off; ptr obj, pos; - int which_singleton; - - entry = RELOCIT(t, n); n += 1; - if (RELOC_EXTENDED_FORMAT(entry)) { - item_off = RELOCIT(t, n); n += 1; - code_off = RELOCIT(t, n); n += 1; - } else { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a += code_off; - obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - - if ((which_singleton = detect_singleton(obj))) { - obj = FIX(VFASL_RELOC_SINGLETON(which_singleton)); - } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) { - if ((uptr)pos == CENTRY_install_library_entry) - vfi->installs_library_entry = 1; - obj = FIX(VFASL_RELOC_C_ENTRY(pos)); - } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) { - obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos)); - } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) { - obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos)); - } else if (Ssymbolp(obj)) { - obj = vfasl_relocate_help(vfi, obj); - obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj)))); - } else if (IMMEDIATE(obj)) { - /* as-is */ - if (Sfixnump(obj)) - if (obj != FIX(0)) /* allow 0 for fcallable cookie */ - S_error("vfasl", "unexpected fixnum in relocation"); - } else { - obj = vfasl_relocate_help(vfi, obj); - obj = (ptr)ptr_diff(obj, vfi->base_addr); - } - - S_set_code_obj("vfasl", reloc_abs, co, a, obj, item_off); - } - - RELOCCODE(t) = (ptr)ptr_diff(co, vfi->base_addr); - CODERELOC(co) = (ptr)ptr_diff(t, vfi->base_addr); - /* no vfasl_register_pointer, since relink_code can handle it */ - - return size_code(CODELEN(co)); + return obj; } static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static) { @@ -1553,6 +1204,20 @@ static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offse return TYPE(ptr_add(vspaces[s], p_off - vspace_offsets[s]), t); } +/*************************************************************/ +/* Symbol names */ + +static iptr vfasl_symbol_to_index(vfasl_info *vfi, ptr pp) +{ + uptr pos = vfi->sym_count++; + ptr name = SYMNAME(pp); + if (Sstringp(name)) + vfasl_check_install_library_entry(vfi, name); + else if (!Spairp(name) || (Scar(name) == Sfalse)) + vfasl_fail(vfi, "gensym without unique name"); + return pos; +} + /*************************************************************/ /* C and library entries */ diff --git a/csug/smgmt.stex b/csug/smgmt.stex index 48983231cf..8db85446ed 100644 --- a/csug/smgmt.stex +++ b/csug/smgmt.stex @@ -128,7 +128,8 @@ storage management for dynamically typed languages''~\cite{Dybvig:sm}. \formdef{collect}{\categoryprocedure}{(collect)} \formdef{collect}{\categoryprocedure}{(collect \var{g})} \formdef{collect}{\categoryprocedure}{(collect \var{g} \var{tg})} -\returns unspecified +\formdef{collect}{\categoryprocedure}{(collect \var{g} \var{tg} \var{objs})} +\returns a list if \var{objs} is a list, unspecified otherwise \listlibraries \endentryheader @@ -141,6 +142,7 @@ If \var{g} is the maximum nonstatic generation, \scheme{static}. Otherwise, \var{tg} must be a fixnum equal to or one greater than \var{g}. +\var{objs} must be either \scheme{#f} or a list. This procedure causes the storage manager to perform a garbage collection. \scheme{collect} is invoked periodically via the collect-request @@ -152,6 +154,18 @@ In the threaded versions of {\ChezScheme}, the thread that invokes The system determines which generations to collect, based on \var{g} and \var{tg} if provided, as described in the lead-in to this section. +If \var{objs} is a list, the collection is combined with counting as +in \scheme{compute-size-increments}. Counting looks through all +generations, as when \scheme{'static} is the second argument to +\scheme{compute-size-increments}, but the returned sizes from +\scheme{collect} do not include any objects in a generation older than +\var{g}. Another difference is that an object later in \var{objs} are +treated as unreachable by earlier objects in \var{objs} only when the +later object is a record, thread, or procedure (including +continuations). Finally, if an object is included in \var{objs} using +a weak pair, then the object's result size is 0 unless it is reachable +from earlier objects; if the object is not reachable at all, it can be +collected. %---------------------------------------------------------------------------- \entryheader diff --git a/mats/misc.ms b/mats/misc.ms index 95e00edaca..af999a4b32 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -1057,6 +1057,7 @@ (error? (compute-size-increments (list 0) '())) (begin (define pair-size (compute-size (cons 1 2))) + (define ephemeron-size (compute-size (ephemeron-cons 1 2))) #t) (equal? (list pair-size pair-size) (compute-size-increments (list (cons 1 2) (cons 3 4)))) @@ -1070,25 +1071,25 @@ (equal? (compute-size-increments ls) (reverse (compute-size-increments (reverse ls))))) ;; Ephemeron(s) found before key: - (equal? (list pair-size (* 2 pair-size)) + (equal? (list ephemeron-size (* 2 pair-size)) (compute-size-increments (let* ([p (cons 0 0)] [e (ephemeron-cons p (cons 0 0))]) (list e p)))) - (equal? (list pair-size (* 3 pair-size)) + (equal? (list ephemeron-size (* 3 pair-size)) (let* ([v (cons 1 2)] [e (ephemeron-cons v (cons 3 4))]) (compute-size-increments (list e (cons v #f))))) - (equal? (list (* 4 pair-size) (* 4 pair-size)) + (equal? (list (* 2 (+ ephemeron-size pair-size)) (* 4 pair-size)) (let* ([v (cons 1 2)] [e* (list (ephemeron-cons v (cons 3 4)) (ephemeron-cons v (cons 5 6)))]) (compute-size-increments (list e* (cons v #f))))) ;; Key found before ephemeron(s): - (equal? (list (* 2 pair-size) (* 2 pair-size)) + (equal? (list (* 2 pair-size) (+ ephemeron-size pair-size)) (let* ([v (cons 1 2)] [e (ephemeron-cons v (cons 3 4))]) (compute-size-increments (list (cons v #f) e)))) - (equal? (list (* 2 pair-size) (* 6 pair-size)) + (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size))) (let* ([v (cons 1 2)] [e* (list (ephemeron-cons v (cons 3 4)) (ephemeron-cons v (cons 5 6)))]) @@ -1150,6 +1151,79 @@ (or (eq? (current-eval) interpret) ; interpreter continuaton is not precise enough (and (> (car pre-sizes) N) (< (car post-sizes) N))))))) + ) + +(mat collect+compute-size-increments + (eq? (void) (collect 0 0 #f)) + (eq? '() (collect 0 0 '())) + + (error? (collect 0 0 'not-a-list)) + (error? (collect 0 0 0)) + (error? (collect 'not-a-generation 0 '())) + (error? (collect 0 'not-a-generation '())) + (error? (collect 1 0 '())) + + (begin + (define-record-type count-wrap (fields val)) + (collect 0 0 (list (make-count-wrap 0))) ; take care of one-time initialization costs + (define wrap-size (car (collect 0 0 (list (make-count-wrap 0))))) ; includes rtd + (define just-wrap-size (cadr (collect 0 0 (list (make-count-wrap 0) (make-count-wrap 1))))) + (define pair-size (compute-size (cons 1 2))) + (define ephemeron-size (compute-size (ephemeron-cons 1 2))) + #t) + (equal? (list pair-size pair-size) + (collect 0 0 (list (cons 1 2) (cons 3 4)))) + (equal? (list (* 3 pair-size) pair-size) + (let ([l (list 1 2)]) + (collect 0 0 (list (cons 3 l) (cons 4 l))))) + (equal? (list pair-size) + (collect 0 0 (list (weak-cons (make-bytevector 100) #f)))) + ;; Ephemeron(s) found before key: + (equal? (list ephemeron-size (+ (* 2 pair-size) wrap-size)) + (collect 0 0 (let* ([p (make-count-wrap (cons 0 0))] + [e (ephemeron-cons p (cons 0 0))]) + (list e p)))) + (equal? (list ephemeron-size (+ (* 3 pair-size) wrap-size)) + (let* ([v (make-count-wrap (cons 1 2))] + [e (ephemeron-cons v (cons 3 4))]) + (collect 0 0 (list e (cons v #f))))) + (equal? (list (* 2 (+ ephemeron-size pair-size)) (+ (* 4 pair-size) wrap-size)) + (let* ([v (make-count-wrap (cons 1 2))] + [e* (list (ephemeron-cons v (cons 3 4)) + (ephemeron-cons v (cons 5 6)))]) + (collect 0 0 (list e* (cons v #f))))) + ;; Key found before ephemeron(s): + (equal? (list (+ (* 2 pair-size) wrap-size) (+ ephemeron-size pair-size)) + (let* ([v (make-count-wrap (cons 1 2))] + [e (ephemeron-cons v (cons 3 4))]) + (collect 0 0 (list (cons v #f) e)))) + (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size))) + (let* ([v (cons 1 2)] + [e* (list (ephemeron-cons v (cons 3 4)) + (ephemeron-cons v (cons 5 6)))]) + (collect 0 0 (list (cons v #f) e*)))) + ;; Weakly held objects: + (equal? '(0) + (let* ([v (make-count-wrap (cons 1 2))] + [ls (weak-cons v '())]) + (collect 0 0 ls))) + (equal? (list wrap-size pair-size (+ just-wrap-size pair-size)) + (let* ([v (make-count-wrap (cons 1 2))] + [ls (cons* (make-count-wrap 0) (cons v 1) (weak-cons v '()))]) + (collect 0 0 ls))) + (equal? (list 0 (+ wrap-size (* 2 pair-size))) + (let* ([v (make-count-wrap (cons 1 2))] + [ls (weak-cons v (cons (cons v 1) '()))]) + (collect 0 0 ls))) + (equal? #!bwp + (let* ([v (make-count-wrap (cons 1 2))] + [ls (weak-cons v '())]) + (collect 0 0 ls) + (car ls))) + ;; These calls will encounter many kinds of objects, just to make + ;; sure they don't fail: + (list? (collect 0 0 (list (call/cc values)))) + (list? (collect (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values)))) ) (mat compute-composition diff --git a/mats/thread.ms b/mats/thread.ms index f59e924e06..8d4cbfb77d 100644 --- a/mats/thread.ms +++ b/mats/thread.ms @@ -1553,7 +1553,8 @@ (unless (= i 0) (fork-thread (lambda () (let loop () (unless (with-mutex m - (condition-wait c m) + (unless done? + (condition-wait c m)) done?) (collect-rendezvous) (loop))))) diff --git a/s/7.ss b/s/7.ss index 99b8961940..4fe5e1ed41 100644 --- a/s/7.ss +++ b/s/7.ss @@ -754,12 +754,12 @@ (define gc-count 0) (define start-bytes 0) (define docollect - (let ([do-gc (foreign-procedure "(cs)do_gc" (int int) void)]) + (let ([do-gc (foreign-procedure "(cs)do_gc" (int int ptr) ptr)]) (lambda (p) (with-tc-mutex (unless (= $active-threads 1) ($oops 'collect "cannot collect when multiple threads are active")) - (let-values ([(trip g gtarget) (p gc-trip)]) + (let-values ([(trip g gtarget count-roots) (p gc-trip)]) (set! gc-trip trip) (let ([cpu (current-time 'time-thread)] [real (current-time 'time-monotonic)]) (set! gc-bytes (+ gc-bytes (bytes-allocated))) @@ -770,17 +770,18 @@ (flush-output-port (console-output-port))) (when (eqv? g (collect-maximum-generation)) ($clear-source-lines-cache)) - (do-gc g gtarget) - ($close-resurrected-files) - (when-feature pthreads - ($close-resurrected-mutexes&conditions)) - (when (collect-notify) - (fprintf (console-output-port) "done]~%") - (flush-output-port (console-output-port))) - (set! gc-bytes (- gc-bytes (bytes-allocated))) - (set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu))) - (set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real))) - (set! gc-count (1+ gc-count)))))))) + (let ([gc-result (do-gc g gtarget count-roots)]) + ($close-resurrected-files) + (when-feature pthreads + ($close-resurrected-mutexes&conditions)) + (when (collect-notify) + (fprintf (console-output-port) "done]~%") + (flush-output-port (console-output-port))) + (set! gc-bytes (- gc-bytes (bytes-allocated))) + (set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu))) + (set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real))) + (set! gc-count (1+ gc-count)) + gc-result))))))) (define collect-init (lambda () (set! gc-trip 0) @@ -815,11 +816,11 @@ (let loop ([g (collect-maximum-generation)]) (if (= (modulo gct (expt (collect-generation-radix) g)) 0) (if (fx= g (collect-maximum-generation)) - (values 0 g g) - (values gct g (fx+ g 1))) + (values 0 g g #f) + (values gct g (fx+ g 1) #f)) (loop (fx- g 1))))))))) (define collect2 - (lambda (g gtarget) + (lambda (g gtarget count-roots) (docollect (lambda (gct) (values @@ -833,21 +834,24 @@ (+ gct (modulo (- n gct) n)))) (let ([next (trip g)] [limit (trip (fx+ g 1))]) (if (< next limit) next (- limit 1))))) - g gtarget))))) + g gtarget count-roots))))) (case-lambda [() (collect0)] [(g) (unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) ($oops who "invalid generation ~s" g)) - (collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)))] - [(g gtarget) + (collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)) #f)] + [(g gtarget) (collect g gtarget #f)] + [(g gtarget count-roots) (unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) ($oops who "invalid generation ~s" g)) (unless (if (fx= g (collect-maximum-generation)) (or (eqv? gtarget g) (eq? gtarget 'static)) (or (eqv? gtarget g) (eqv? gtarget (fx+ g 1)))) ($oops who "invalid target generation ~s for generation ~s" gtarget g)) - (collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))]))) + (unless (or (not count-roots) (list? count-roots)) + ($oops who "invalid counting-roots list ~s" count-roots)) + (collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget) count-roots)]))) (set! collect-rendezvous (let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)]) diff --git a/s/Mf-base b/s/Mf-base index 09c9e41200..1a6c03b3ab 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -108,6 +108,9 @@ PetiteBoot = ../boot/$m/petite.boot SchemeBoot = ../boot/$m/scheme.boot Cheader = ../boot/$m/scheme.h Cequates = ../boot/$m/equates.h +Cgcocd = ../boot/$m/gc-ocd.inc +Cgcoce = ../boot/$m/gc-oce.inc +Cvfasl = ../boot/$m/vfasl.inc Revision = ../boot/$m/revision # The following controls the patch files loaded before compiling, typically used only @@ -164,11 +167,11 @@ allsrc =\ np-languages.ss bitset.ss fxmap.ss # doit uses a different Scheme process to compile each target -doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Revision} +doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision} # all uses a single Scheme process to compile all targets. this is typically # faster when most of the targets need to be recompiled. -all: bootall ${Cheader} ${Cequates} ${Revision} +all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision} # allx runs all up to three times and checks to see if the new boot file is the # same as the last, i.e., the system is properly bootstrapped. @@ -194,7 +197,7 @@ bootstrap: ${allsrc} | ${Revision} touch bootstrap # source eagerly creates links to most of the files that might be needed -source: ${allsrc} mkheader.ss script.all +source: ${allsrc} mkheader.ss mkgc.ss script.all # profiled goes through the involved process of building a profile-optimized boot file profiled: @@ -414,6 +417,21 @@ mkheader.so: mkheader.ss cmacros.so primvars.so env.so '(compile-file "$*.ss" "$*.so")'\ | ${Scheme} -q cmacros.so priminfo.so primvars.so env.so +mkgc.so: mkgc.ss mkheader.so cmacros.so primvars.so env.so + echo '(reset-handler abort)'\ + '(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\ + '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ + '(optimize-level 0)'\ + '(debug-level $d)'\ + '(commonization-level $(cl))'\ + '(compile-compressed #$(cc))'\ + '(compress-format $(xf))'\ + '(compress-level $(xl))'\ + '(generate-inspector-information #$i)'\ + '(subset-mode (quote system))'\ + '(compile-file "$*.ss" "$*.so")'\ + | ${Scheme} -q cmacros.so priminfo.so primvars.so env.so mkheader.so + nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss echo '(reset-handler abort)'\ '(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\ @@ -582,6 +600,33 @@ ${Cequates}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss pri then mv -f ${Cequates}.bak ${Cequates};\ else rm -f ${Cequates}.bak; fi) +${Cgcocd}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss + (if [ -r ${Cgcocd} ]; then mv -f ${Cgcocd} ${Cgcocd}.bak; fi) + echo '(reset-handler abort)'\ + '(mkgc-ocd.inc "${Cgcocd}")' |\ + ${Scheme} -q ${macroobj} mkheader.so mkgc.so + (if `cmp -s ${Cgcocd} ${Cgcocd}.bak`;\ + then mv -f ${Cgcocd}.bak ${Cgcocd};\ + else rm -f ${Cgcocd}.bak; fi) + +${Cgcoce}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss + (if [ -r ${Cgcoce} ]; then mv -f ${Cgcoce} ${Cgcoce}.bak; fi) + echo '(reset-handler abort)'\ + '(mkgc-oce.inc "${Cgcoce}")' |\ + ${Scheme} -q ${macroobj} mkheader.so mkgc.so + (if `cmp -s ${Cgcoce} ${Cgcoce}.bak`;\ + then mv -f ${Cgcoce}.bak ${Cgcoce};\ + else rm -f ${Cgcoce}.bak; fi) + +${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss + (if [ -r ${Cvfasl} ]; then mv -f ${Cvfasl} ${Cvfasl}.bak; fi) + echo '(reset-handler abort)'\ + '(mkvfasl.inc "${Cvfasl}")' |\ + ${Scheme} -q ${macroobj} mkheader.so mkgc.so + (if `cmp -s ${Cvfasl} ${Cvfasl}.bak`;\ + then mv -f ${Cvfasl}.bak ${Cvfasl};\ + else rm -f ${Cvfasl}.bak; fi) + .PHONY: ${Revision} ${Revision}: update-revision @./update-revision > ${Revision} diff --git a/s/cmacros.ss b/s/cmacros.ss index dc66ec1de9..2aeaf0f003 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -662,11 +662,13 @@ (pure-typed-object "p-tobj" #\r 9) ; (impure-record "ip-rec" #\s 10) ; (impure-typed-object "ip-tobj" #\t 11) ; as needed (instead of impure) for backtraces - (closure "closure" #\l 12)) ; as needed (instead of pure/impure) for backtraces + (closure "closure" #\l 12) ; as needed (instead of pure/impure) for backtraces + (count-pure "count-pure" #\y 13) ; like pure, but delayed for counting from roots + (count-impure "count-impure" #\z 14)); like impure-typed-object, but delayed for counting from roots (unswept - (data "data" #\d 13))) ; unswept objects allocated here + (data "data" #\d 15))) ; unswept objects allocated here (unreal - (empty "empty" #\e 14))) ; available segments + (empty "empty" #\e 16))) ; available segments ;;; enumeration of types for which gc tracks object counts ;;; also update gc.c @@ -698,7 +700,8 @@ (define-constant countof-oblist 24) (define-constant countof-ephemeron 25) (define-constant countof-stencil-vector 26) -(define-constant countof-types 27) +(define-constant countof-record 27) +(define-constant countof-types 28) ;;; type-fixnum is assumed to be all zeros by at least by vector, fxvector, ;;; and bytevector index checks @@ -1367,7 +1370,7 @@ [ptr data 0])) (define-primitive-structure-disps thread type-typed-object - ([ptr type] [uptr tc])) + ([iptr type] [uptr tc])) (define-constant virtual-register-count 16) diff --git a/s/inspect.ss b/s/inspect.ss index d1fd894aa9..08112b28ec 100644 --- a/s/inspect.ss +++ b/s/inspect.ss @@ -2604,24 +2604,27 @@ [(and (eqv? space (constant space-weakpair)) (not single-inspect-mode?)) (fx+ (constant size-pair) (compute-size (cdr x)))] - [(and (eqv? space (constant space-ephemeron)) - (not single-inspect-mode?) - (let ([a (car x)]) - (not (or ($immediate? a) - (let ([g ($generation a)]) - (or (not g) (fx> g maxgen))) - (and (eq-bitset-member? size-ht-or-bitset a) - (not (eq-hashtable-ref ephemeron-non-keys a #f))))))) - (let ([d (cdr x)]) - (unless ($immediate? d) - (unless ephemeron-triggers-bitset - (set! ephemeron-triggers-bitset (make-eq-bitset)) - (set! ephemeron-triggers (make-eq-hashtable))) - (let ([v (car x)]) - (eq-bitset-add! ephemeron-triggers-bitset v) - (let ([a (eq-hashtable-cell ephemeron-triggers v '())]) - (set-cdr! a (cons d (cdr a))))))) - (constant size-pair)] + [(eqv? space (constant space-ephemeron)) + (cond + [(and (not single-inspect-mode?) + (let ([a (car x)]) + (not (or ($immediate? a) + (let ([g ($generation a)]) + (or (not g) (fx> g maxgen))) + (and (eq-bitset-member? size-ht-or-bitset a) + (not (eq-hashtable-ref ephemeron-non-keys a #f))))))) + (let ([d (cdr x)]) + (unless ($immediate? d) + (unless ephemeron-triggers-bitset + (set! ephemeron-triggers-bitset (make-eq-bitset)) + (set! ephemeron-triggers (make-eq-hashtable))) + (let ([v (car x)]) + (eq-bitset-add! ephemeron-triggers-bitset v) + (let ([a (eq-hashtable-cell ephemeron-triggers v '())]) + (set-cdr! a (cons d (cdr a))))))) + (constant size-ephemeron)] + [else + (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))])] [else (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]))] [(symbol? x) diff --git a/s/mkgc.ss b/s/mkgc.ss new file mode 100644 index 0000000000..4ce374e770 --- /dev/null +++ b/s/mkgc.ss @@ -0,0 +1,2171 @@ +;; This file defines the traversal of objects for the GC and similar +;; purposes. The description supports the generatation of multiple C +;; functions, each specialized to a particular traversal mode, while +;; sharing the overall traversal implementation. + +;; Roughy the first half of this file is the semi-declarative +;; specification in Parenthe-C, and the second half is the Parenthe-C +;; compiler that generates C code. The lines between the +;; specification, compiler, and supporting C code in "gc.c" are +;; (unfortunately) not very strict. + +;; Code is generated by calling the functions listed here: +(disable-unbound-warning + mkgc-ocd.inc + mkgc-oce.inc + mkvfasl.inc) + +;; Currently supported traversal modes: +;; - copy +;; - sweep +;; - self-test : check immediate pointers only for self references +;; - size : immediate size, so does not recur +;; - measure : recurs for reachable size +;; - vfasl-copy +;; - vfasl-sweep + +;; For the specification, there are a few declaration forms described +;; below, such as `trace` to declare a pointer-valued field within an +;; object (to be copied in copy mode and swept in sweep mode). +;; Otherwise, the "declaration" nature of the specification is based +;; on selecting code fragments statically via `case-mode` and +;; `case-flag`. Macros that expand to those forms (e.g., `trace-tlc`) +;; provide a further declarative vaneer. + +;; Internals: +(disable-unbound-warning + trace-base-types + trace-object-types + trace-macros) + +(define trace-base-types '()) +(define trace-object-types '()) +(define trace-macros (make-eq-hashtable)) + +;; This macro just makes sure our main specification has a fixed +;; shape: +(define-syntax define-trace-root + (syntax-rules (case-type typed-object case-typedfield) + [(_ (case-type + [type type-stmt ...] + ... + [typed-object + (case-typefield + [object-type object-type-stmt ...] + ...)])) + (begin + (set! trace-base-types '((type type-stmt ...) ...)) + (set! trace-object-types '((object-type object-type-stmt ...) ...)))])) + +;; A "trace macro" is non-hygienically expanded: +(define-syntax define-trace-macro + (syntax-rules () + [(_ (id arg ...) body ...) + (eq-hashtable-set! trace-macros 'id '((arg ...) body ...))])) + +;; Primitive actions/declarations, must be used as statements in roughly +;; this order (but there are exceptions to the order): +;; - (space ) : target for copy; works as a constraint for other modes +;; - (vspace ) : target for vfasl +;; - (size []) : size for copy +;; - (trace ) : relocate for sweep, copy for copy, recur otherwise +;; - (trace-early ) : relocate for sweep or copy, recur otherwise +;; - (trace-now ) : direct recur +;; - (trace-early-rtd ) : for record types, avoid recur on #!base-rtd +;; - (trace-ptrs ) : trace an array of pointerrs +;; - (copy ) : copy for copy, ignore otherwise +;; - (copy-bytes ) : copy an array of bytes +;; - (copy-flonum ) : copy flonum and forward +;; - (copy-flonum* ) : copy potentially forwaded flonum +;; - (copy-type ) : copy type from `_` to `_copy_` +;; - (count [ [ []]]) : +;; : uses preceding `size` declaration unless ; +;; normally counts in copy mode, but can override +;; - (skip-forwarding) : disable forward-pointer installation in copy mode +;; +;; In the above declarations, nonterminals like can be +;; an identifier or a Parenthe-C expression. The meaning of a plain +;; identifier depends on the nonterminal: +;; - : should be a `space-...` from cmacro +;; - : should be a `vspace_...` +;; - : should be a constant from cmacro +;; - : accessor from cmacro, implicitly applied to `_` and `_copy_` + +;; Parenthe-C is just what it sounds like: C code written in S-expression +;; form. Use `( ...)` as usual, and the generated code transforms +;; to infix as appropriate for regonized operators. The statement versus +;; expression distnction is important; primitive declarations must be in +;; statement positions. +;; +;; Statements: +;; - +;; - : like `(space )`, etc., above +;; - (set! ) : renders as ` = ;` +;; - (set! ) : renders as ` ;` +;; - (cond [ ...] ... [else ...]) +;; - (when ...) : shorthand for `(cond [ ...] [else])` +;; - (while :? ...) +;; - (do-while ... :? ) +;; - (break) +;; - (define : ) : discarded if is unused +;; - (let* ([ : ] ...) ...) +;; - (case-mode [ ...] ... [else ]) : static +;; case dispatch based on mode, where can be one or +;; a parenthesized sequence of s +;; - (case-flag [on ...] [off ...]) : static dispatch +;; based on a configuration flag +;; - (case-space [ ...] .... [else ...]) : run-time +;; dispatch based on the space of _ +;; +;; Expressions: +;; - : a constant from cmacros or a C name +;; - : a literal number or string +;; - ( ) : function call, operation use, or field access +;; - ( ) : function call, operation use, or array +;; field access +;; - ( ...) : function call or operation use +;; - (just ) : same as , sometimes useful when is a symbol +;; - (cond [ ] ... [else ]) +;; - (case-flag [on ] [off ]) : static dispatch +;; - (cast ) +;; - (array-ref ) +;; +;; Built-in variables: +;; - _ : object being copied, swept, etc. +;; - _copy_ : target in copy or vfasl mode, same as _ otherwise +;; - _tf_ : type word +;; - _backreferences?_ : dynamic flag indicating whether backreferences are on +;; +;; Stylistically, prefer constants and fields using the hyphenated +;; names from cmacros instead of the corresponding C name. Use C names +;; for derived functions, like `size_record_inst` or `FIX`. + +(define-trace-root + (case-type + + [pair + (case-space + [space-ephemeron + (space space-ephemeron) + (vfasl-fail "ephemeron") + (size size-ephemeron) + (copy pair-car) + (copy pair-cdr) + (add-ephemeron-to-pending) + (count countof-ephemeron)] + [space-weakpair + (space space-weakpair) + (vfasl-fail "weakpair") + (try-double-pair copy pair-car + trace pair-cdr + countof-weakpair)] + [else + (space space-impure) + (vspace vspace_impure) + (try-double-pair trace pair-car + trace pair-cdr + countof-pair)])] + + [closure + (define code : ptr (CLOSCODE _)) + (trace-code-early code) + (cond + [(or-assume-continuation + (& (code-type code) (<< code-flag-continuation code-flags-offset))) + ;; continuation + (space (cond + [(and-counts (is_counting_root si _)) space-count-pure] + [else space-continuation])) + (vfasl-fail "closure") + (size size-continuation) + (case-mode + [self-test] + [else + (copy-clos-code code) + (copy-stack-length continuation-stack-length continuation-stack-clength) + (copy continuation-stack-clength) + (trace-nonself continuation-winders) + (trace-nonself continuation-attachments) + (cond + [(== (continuation-stack-length _) scaled-shot-1-shot-flag)] + [else + (case-mode + [sweep + (when (OLDSPACE (continuation-stack _)) + (set! (continuation-stack _) + (copy_stack (continuation-stack _) + (& (continuation-stack-length _)) + (continuation-stack-clength _))))] + [else]) + (count countof-stack (continuation-stack-length _) 1 [sweep measure]) + (trace continuation-link) + (trace-return continuation-return-address (continuation-return-address _)) + (case-mode + [copy (copy continuation-stack)] + [else + (define stack : uptr (cast uptr (continuation-stack _))) + (trace-stack stack + (+ stack (continuation-stack-clength _)) + (cast uptr (continuation-return-address _)))])]) + (count countof-continuation)])] + + [else + ;; closure (not a continuation) + (space + (cond + [(and-counts (is_counting_root si _)) space-count-impure] + [_backreferences?_ + space-closure] + [else + (cond + [(& (code-type code) (<< code-flag-mutable-closure code-flags-offset)) + space-impure] + [else + space-pure])])) + (vspace vspace_closure) + (when-vfasl + (when (& (code-type code) (<< code-flag-mutable-closure code-flags-offset)) + (vfasl-fail "mutable closure"))) + (define len : uptr (code-closure-length code)) + (size (size_closure len)) + (copy-clos-code code) + (trace-ptrs closure-data len) + (pad (when (== (& len 1) 0) + (set! (closure-data _copy_ len) (FIX 0)))) + (count countof-closure)])] + + [symbol + (space space-symbol) + (vspace vspace_symbol) + (size size-symbol) + (trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _))) + (trace-symcode symbol-pvalue val) + (trace-nonself/vfasl-as-nil symbol-plist) + (trace-nonself symbol-name) + (trace-nonself/vfasl-as-nil symbol-splist) + (trace-nonself symbol-hash) + (count countof-symbol)] + + [flonum + (space space-data) + (vspace vspace_data) + (size size-flonum) + (copy-flonum flonum-data) + (count countof-flonum) + (skip-forwarding)] + + [typed-object + (case-typefield + + [record + (trace-early-rtd record-type) + ;; If the rtd is the only pointer and is immutable, put the record + ;; into space-data. If the record contains only pointers, put it + ;; into space-pure or space-impure. Otherwise, put it into + ;; space-pure-typed-object or space-impure-record. We could put all + ;; records into space-{pure,impure}-record or even into + ;; space-impure-record, but by picking the target space more + ;; carefully, we may reduce fragmentation and sweeping cost. + (define rtd : ptr (record-type _)) + (space + (cond + [(and-counts (is_counting_root si _)) + space-count-impure] + [(&& (== (record-type-pm rtd) (FIX 1)) + (== (record-type-mpm rtd) (FIX 0))) + ;; No pointers except for type + space-data] + [(== (record-type-pm rtd) (FIX -1)) + ;; All pointers + (cond + [_backreferences?_ + (cond + [(== (record-type-mpm rtd) (FIX 0)) + ;; All immutable + space-pure-typed-object] + [else + space-impure-record])] + [else + (cond + [(== (record-type-mpm rtd) (FIX 0)) + ;; All immutable + space-pure] + [else + space-impure])])] + [else + ;; Mixture of pointers and non-pointers + (cond + [(== (record-type-mpm rtd) (FIX 0)) + ;; All immutable + space-pure-typed-object] + [else + space-impure-record])])) + (vspace (cond + [(is_rtd rtd vfi) vspace_rtd] + [(== (record-type-mpm rtd) (FIX 0)) vspace_pure_typed] + [else vspace_impure_record])) + (vfasl-check-parent-rtd rtd) + (define len : uptr (UNFIX (record-type-size rtd))) + (size (size_record_inst len)) + (trace-record rtd len) + (vfasl-set-base-rtd) + (pad (when (or-vfasl + (\|\| (== p_spc space-pure) (\|\| (== p_spc space-impure) + (and-counts (== p_spc space-count-impure))))) + (let* ([ua_size : uptr (unaligned_size_record_inst len)]) + (when (!= p_sz ua_size) + (set! (* (cast ptr* (+ (cast uptr (UNTYPE _copy_ type_typed_object)) ua_size))) + (FIX 0)))))) + (count-record rtd)] + + [vector + ;; Assumes vector lengths look like fixnums; + ;; if not, vectors will need their own space + (space + (cond + [(& (cast uptr _tf_) vector_immutable_flag) + (cond + [_backreferences?_ space-pure-typed-object] + [else space-pure])] + [else + (cond + [_backreferences?_ space-impure-typed-object] + [else space-impure])])) + (vspace vspace_impure) + (define len : uptr (Svector_length _)) + (size (size_vector len)) + (copy-type vector-type) + (trace-ptrs vector-data len) + (pad (when (== (& len 1) 0) + (set! (vector-data _copy_ len) (FIX 0)))) + (count countof-vector)] + + [stencil-vector + ;; Assumes stencil-vector masks look like fixnums; + ;; if not, stencil vectors will need their own space + (space + (cond + [_backreferences?_ space-impure-typed-object] + [else space-impure])) + (vspace vspace_impure) + (define len : uptr (Sstencil_vector_length _)) + (size (size_stencil_vector len)) + (copy-type stencil-vector-type) + (trace-ptrs stencil-vector-data len) + (pad (when (== (& len 1) 0) + (set! (stencil-vector-data _copy_ len) (FIX 0)))) + (count countof-stencil-vector)] + + [string + (space space-data) + (vspace vspace_data) + (define sz : uptr (size_string (Sstring_length _))) + (size (just sz)) + (copy-bytes string-type sz) + (count countof-string)] + + [fxvector + (space space-data) + (vspace vspace_data) + (define sz : uptr (size_fxvector (Sfxvector_length _))) + (size (just sz)) + (copy-bytes fxvector-type sz) + (count countof-fxvector)] + + [bytevector + (space space-data) + (vspace vspace_data) + (define sz : uptr (size_bytevector (Sbytevector_length _))) + (size (just sz)) + (copy-bytes bytevector-type sz) + (count countof-bytevector)] + + [tlc + (space + (cond + [_backreferences?_ space-impure-typed-object] + [else space-impure])) + (vfasl-fail "tlc") + (size size-tlc) + (copy-type tlc-type) + (trace-nonself tlc-ht) + (trace-tlc tlc-next tlc-keyval) + (count countof-tlc)] + + [box + (space + (cond + [(== (box-type _) type-immutable-box) + (cond + [_backreferences?_ space-pure-typed-object] + [else space-pure])] + [else + (cond + [_backreferences?_ space-impure-typed-object] + [else space-impure])])) + (vspace vspace_impure) + (size size-box) + (copy-type box-type) + (trace box-ref) + (count countof-box)] + + [ratnum + (space space-data) + (vspace vspace_impure) ; would be better if we had pure, but these are rare + (size size-ratnum) + (copy-type ratnum-type) + (trace-now ratnum-numerator) + (trace-now ratnum-denominator) + (vfasl-pad-word) + (count countof-ratnum)] + + [exactnum + (space space-data) + (vspace vspace_impure) ; same rationale as ratnum + (size size-exactnum) + (copy-type exactnum-type) + (trace-now exactnum-real) + (trace-now exactnum-imag) + (vfasl-pad-word) + (count countof-exactnum)] + + [inexactnum + (space space-data) + (vspace vspace_data) + (size size-inexactnum) + (copy-type inexactnum-type) + (copy-flonum* inexactnum-real) + (copy-flonum* inexactnum-imag) + (count countof-inexactnum)] + + [bignum + (space space-data) + (vspace vspace_data) + (define sz : uptr (size_bignum (BIGLEN _))) + (size (just sz)) + (copy-bytes bignum-type sz) + (count countof-bignum)] + + [port + (space space-port) + (vfasl-fail "port") + (size size-port) + (copy-type port-type) + (trace-nonself port-handler) + (copy port-ocount) + (copy port-icount) + (trace-buffer PORT_FLAG_OUTPUT port-obuffer port-olast) + (trace-buffer PORT_FLAG_INPUT port-ibuffer port-ilast) + (trace port-info) + (trace-nonself port-name) + (count countof-port)] + + [code + (space space-code) + (vspace vspace_code) + (define len : uptr (code-length _)) ; in bytes + (size (size_code len)) + (copy-type code-type) + (copy code-length) + (copy code-reloc) + (trace-nonself code-name) + (trace-nonself code-arity-mask) + (copy code-closure-length) + (trace-nonself code-info) + (trace-nonself code-pinfo*) + (trace-code len) + (count countof-code)] + + [thread + (space (cond + [(and-counts (is_counting_root si _)) space-count-pure] + [else space-pure-typed-object])) + (vfasl-fail "thread") + (size size-thread) + (case-mode + [self-test] + [else + (copy-type thread-type) + (trace-tc thread-tc) + (count countof-thread)])] + + [rtd-counts + (space space-data) + (vfasl-as-false "rtd-counts") ; prune counts, since GC will recreate as needed + (size size-rtd-counts) + (copy-bytes rtd-counts-type size_rtd_counts) + (count countof-rtd-counts)] + + [phantom + (space space-data) + (vfasl-fail "phantom") + (size size-phantom) + (copy-type phantom-type) + (copy phantom-length) + (case-mode + [copy (set! (array-ref S_G.phantom_sizes tg) + += + (phantom-length _))] + [measure (set! measure_total += (phantom-length _))] + [else])])])) + +(define-trace-macro (trace-nonself field) + (case-mode + [self-test] + [else + (trace field)])) + +(define-trace-macro (trace-nonself/vfasl-as-nil field) + (case-mode + [vfasl-copy + (set! (field _copy_) Snil)] + [else + (trace-nonself field)])) + +(define-trace-macro (try-double-pair do-car pair-car + do-cdr pair-cdr + count-pair) + (case-mode + [copy + ;; Try to copy two pairs at a time + (define cdr_p : ptr (Scdr _)) + (define qsi : seginfo* NULL) + (cond + [(&& (!= cdr_p _) + (&& (== (TYPEBITS cdr_p) type_pair) + (&& (!= (set! qsi (MaybeSegInfo (ptr_get_segment cdr_p))) NULL) + (&& (== (-> qsi space) (-> si space)) + (&& (!= (FWDMARKER cdr_p) forward_marker) + (! (locked si cdr_p))))))) + (check_triggers qsi) + (size size-pair 2) + (define new_cdr_p : ptr (cast ptr (+ (cast uptr _copy_) size_pair))) + (set! (pair-car _copy_) (pair-car _)) + (set! (pair-cdr _copy_) new_cdr_p) + (set! (pair-car new_cdr_p) (pair-car cdr_p)) + (set! (pair-cdr new_cdr_p) (pair-cdr cdr_p)) + (set! (FWDMARKER cdr_p) forward_marker) + (set! (FWDADDRESS cdr_p) new_cdr_p) + (case-flag maybe-backreferences? + [on (ADD_BACKREFERENCE_FROM new_cdr_p new_p)] + [off]) + (count count-pair size-pair 2)] + [else + (size size-pair) + (do-car pair-car) + (do-cdr pair-cdr) + (count count-pair)])] + [else + (size size-pair) + (do-car pair-car) + (do-cdr pair-cdr) + (count count-pair)])) + +(define-trace-macro (add-ephemeron-to-pending) + (case-mode + [sweep + (add_ephemeron_to_pending _)] + [measure + (add_ephemeron_to_pending_measure _)] + [else])) + +(define-trace-macro (trace-code-early code) + (unless-code-relocated + (case-mode + [(vfasl-sweep) + ;; Special relocation handling for code in a closure: + (set! code (vfasl_relocate_code vfi code))] + [else + (trace-early (just code))]))) + +(define-trace-macro (copy-clos-code code) + (case-mode + [(copy vfasl-copy) + (SETCLOSCODE _copy_ code)] + [(sweep) + (unless-code-relocated + (SETCLOSCODE _copy_ code))] + [(vfasl-sweep) + ;; Make the code pointer relative to the base address. + ;; It's turned back absolute when loading from vfasl + (define rel_code : ptr (cast ptr (ptr_diff code (-> vfi base_addr)))) + (SETCLOSCODE p rel_code)] + [else])) + +(define-trace-macro (copy-stack-length continuation-stack-length continuation-stack-clength) + (case-mode + [copy + ;; Don't promote general one-shots, but promote opportunistic one-shots + (cond + [(== (continuation-stack-length _) opportunistic-1-shot-flag) + (set! (continuation-stack-length _copy_) (continuation-stack-clength _)) + ;; May need to recur at end to promote link: + (set! conts_to_promote (S_cons_in space_new 0 new_p conts_to_promote))] + [else + (copy continuation-stack-length)])] + [else + (copy continuation-stack-length)])) + +(define-trace-macro (trace/define ref val :vfasl-as vfasl-val) + (case-mode + [(copy measure) + (trace ref)] + [sweep + (define val : ptr (ref _)) + (trace (just val)) + (set! (ref _) val)] + [vfasl-copy + (set! (ref _copy_) vfasl-val)] + [else])) + +(define-trace-macro (trace-symcode symbol-pvalue val) + (case-mode + [sweep + (define code : ptr (cond + [(Sprocedurep val) (CLOSCODE val)] + [else (SYMCODE _)])) + (trace (just code)) + (INITSYMCODE _ code)] + [measure] + [vfasl-copy + (set! (symbol-pvalue _copy_) Snil)] + [else + (copy symbol-pvalue)])) + +(define-trace-macro (trace-tlc tlc-next tlc-keyval) + (case-mode + [copy + (define next : ptr (tlc-next _)) + (define keyval : ptr (tlc-keyval _)) + (set! (tlc-next _copy_) next) + (set! (tlc-keyval _copy_) keyval) + ;; If next isn't false and keyval is old, add tlc to a list of tlcs + ;; to process later. Determining if keyval is old is a (conservative) + ;; approximation to determining if key is old. We can't easily + ;; determine if key is old, since keyval might or might not have been + ;; swept already. NB: assuming keyvals are always pairs. + (when (&& (!= next Sfalse) (& (SPACE keyval) space_old)) + (set! tlcs_to_rehash (S_cons_in space_new 0 _copy_ tlcs_to_rehash)))] + [else + (trace-nonself tlc-keyval) + (trace-nonself tlc-next)])) + +(define-trace-macro (trace-record trd len) + (case-mode + [(copy vfasl-copy) + (copy-bytes record-data (- len ptr_bytes))] + [else + ;; record-type descriptor was forwarded already + (let* ([num : ptr (case-flag as-dirty? + [on (record-type-mpm rtd)] + [off (record-type-pm rtd)])] + [pp : ptr* (& (record-data _ 0))]) + ;; Process cells for which bit in pm is set, and quit when pm == 0 + (cond + [(Sfixnump num) + ;; Ignore bit for already forwarded rtd + (let* ([mask : uptr (>> (cast uptr (UNFIX num)) 1)]) + (cond + [(case-flag as-dirty? + [on 0] + [off (== mask (>> (cast uptr -1) 1))]) + (let* ([ppend : ptr* (- (cast ptr* (+ (cast uptr pp) len)) 1)]) + (while + :? (< pp ppend) + (trace (* pp)) + (set! pp += 1)))] + [else + (while + :? (!= mask 0) + (when (& mask 1) + (trace (* pp))) + (set! mask >>= 1) + (set! pp += 1))]))] + [else + (case-flag as-dirty? + [on] + [off + (case-mode + [(sweep self-test) + ;; Bignum pointer mask may need forwarding + (trace (record-type-pm rtd)) + (set! num (record-type-pm rtd))] + [else])]) + (let* ([index : iptr (- (BIGLEN num) 1)] + ;; Ignore bit for already forwarded rtd + [mask : bigit (>> (bignum-data num index) 1)] + [bits : INT (- bigit_bits 1)]) + (while + :? 1 + (do-while + (when (& mask 1) + (trace (* pp))) + (set! mask >>= 1) + (set! pp += 1) + (set! bits -= 1) + ;; while: + :? (> bits 0)) + (when (== index 0) (break)) + (set! index -= 1) + (set! mask (bignum-data num index)) + (set! bits bigit_bits)))]))])) + +(define-trace-macro (vfasl-check-parent-rtd rtd) + (case-mode + [(vfasl-copy) + (when (is_rtd rtd vfi) + (when (!= _ S_G.base_rtd) + ;; Make sure rtd's type is registered firs, but + ;; discard the relocated pointer (leaving to sweep) + (cast void (vfasl_relocate_help vfi rtd))) + ;; Need parent before child + (vfasl_relocate_parents vfi (record-type-parent _)))] + [(vfasl-sweep) + ;; Don't need to save fields of base-rtd + (when (== _ (-> vfi base_rtd)) + (let* ([pp : ptr* (& (record-data _ 0))] + [ppend : ptr* (- (cast ptr* (+ (cast uptr pp) (UNFIX (record-type-size rtd)))) 1)]) + (while + :? (< pp ppend) + (set! (* pp) Snil) + (set! pp += 1)) + (return (size_record_inst (UNFIX (record-type-size rtd)))))) + ;; Relocation of rtd fields was deferred + (vfasl_relocate vfi (& (record-type _)))] + [else])) + +(define-trace-macro (vfasl-set-base-rtd) + (case-mode + [(vfasl-copy) + (when (== _ S_G.base_rtd) + (set! (-> vfi base_rtd) _copy_))] + [else])) + +(define-trace-macro (count-record rtd) + (case-mode + [copy + (case-flag counts? + [on + (let* ([c_rtd : ptr (cond + [(== _tf_ _) _copy_] + [else rtd])] + [counts : ptr (record-type-counts c_rtd)]) + (cond + [(== counts Sfalse) + (let* ([grtd : IGEN (GENERATION c_rtd)]) + (set! (array-ref (array-ref S_G.countof grtd) countof_rtd_counts) += 1) + ;; Allocate counts struct in same generation as rtd. Initialize timestamp & counts. + (find_room space_data grtd type_typed_object size_rtd_counts counts) + (set! (rtd-counts-type counts) type_rtd_counts) + (set! (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0)) + (let* ([g : IGEN 0]) + (while + :? (<= g static_generation) + (set! (rtd-counts-data counts g) 0) + (set! g += 1))) + (set! (record-type-counts c_rtd) counts) + (set! (array-ref S_G.rtds_with_counts grtd) + (S_cons_in (cond [(== grtd 0) space_new] [else space_impure]) grtd c_rtd + (array-ref S_G.rtds_with_counts grtd))) + (set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))] + [else + (trace-early (just counts)) + (set! (record-type-counts c_rtd) counts) + (when (!= (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0)) + (S_fixup_counts counts))]) + (set! (rtd-counts-data counts tg) (+ (rtd-counts-data counts tg) 1)) + ;; Copies size that we've already gathered, but needed for counting from roots: + (when (== p_spc space-count-impure) (set! count_root_bytes += p_sz)) + (count countof-record))] + [off])] + [else])) + +(define-trace-macro (trace-buffer flag port-buffer port-last) + (case-mode + [(copy measure) + (copy port-last) + (copy port-buffer)] + [sweep + (when (& (cast uptr _tf_) flag) + (define n : iptr (- (cast iptr (port-last _)) + (cast iptr (port-buffer _)))) + (trace port-buffer) + (set! (port-last _) (cast ptr (+ (cast iptr (port-buffer _)) n))))] + [else + (trace-nonself port-buffer)])) + +(define-trace-macro (trace-tc offset) + (case-mode + [copy + (copy offset)] + [else + (define tc : ptr (cast ptr (offset _))) + (when (!= tc (cast ptr 0)) + (case-mode + [sweep + (let* ([old_stack : ptr (tc-scheme-stack tc)]) + (when (OLDSPACE old_stack) + (let* ([clength : iptr (- (cast uptr (SFP tc)) (cast uptr old_stack))]) + ;; Include SFP[0], which contains the return address + (set! (tc-scheme-stack tc) (copy_stack old_stack + (& (tc-scheme-stack-size tc)) + (+ clength (sizeof ptr)))) + (count countof-stack (tc-scheme-stack-size tc) 1 sweep) + (set! (tc-sfp tc) (cast ptr (+ (cast uptr (tc-scheme-stack tc)) clength))) + (set! (tc-esp tc) (cast ptr (- (+ (cast uptr (tc-scheme-stack tc)) + (tc-scheme-stack-size tc)) + stack_slop))))))] + [measure + (measure_add_stack_size (tc-scheme-stack tc) (tc-scheme-stack-size tc))] + [else]) + (set! (tc-stack-cache tc) Snil) + (trace (tc-cchain tc)) + (trace (tc-stack-link tc)) + (trace (tc-winders tc)) + (trace (tc-attachments tc)) + (case-mode + [sweep + (set! (tc-cached-frame tc) Sfalse)] + [else]) + (trace-return NO-COPY-MODE (FRAME tc 0)) + (trace-stack (cast uptr (tc-scheme-stack tc)) + (cast uptr (SFP tc)) + (cast uptr (FRAME tc 0))) + (trace (tc-U tc)) + (trace (tc-V tc)) + (trace (tc-W tc)) + (trace (tc-X tc)) + (trace (tc-Y tc)) + (trace (tc-threadno tc)) + (trace (tc-current-input tc)) + (trace (tc-current-output tc)) + (trace (tc-current-error tc)) + (trace (tc-sfd tc)) + (trace (tc-current-mso tc)) + (trace (tc-target-machine tc)) + (trace (tc-fxlength-bv tc)) + (trace (tc-fxfirst-bit-set-bv tc)) + (trace (tc-null-immutable-vector tc)) + (trace (tc-null-immutable-fxvector tc)) + (trace (tc-null-immutable-bytevector tc)) + (trace (tc-null-immutable-string tc)) + (trace (tc-compile-profile tc)) + (trace (tc-subset-mode tc)) + (trace (tc-default-record-equal-procedure tc)) + (trace (tc-default-record-hash-procedure tc)) + (trace (tc-compress-format tc)) + (trace (tc-compress-level tc)) + (trace (tc-parameters tc)) + (let* ([i : INT 0]) + (while + :? (< i virtual_register_count) + (trace (tc-virtual-registers tc i)) + (set! i += 1))))])) + +(define-trace-macro (trace-stack base-expr fp-expr ret-expr) + (define base : uptr base-expr) + (define fp : uptr fp-expr) + (define ret : uptr ret-expr) + + (while + :? (!= fp base) + (when (< fp base) + (S_error_abort "sweep_stack(gc): malformed stack")) + (set! fp (- fp (ENTRYFRAMESIZE ret))) + (let* ([pp : ptr* (cast ptr* fp)] + [oldret : iptr ret]) + (set! ret (cast iptr (* pp))) + (trace-return NO-COPY-MODE (* pp)) + (let* ([num : ptr (ENTRYLIVEMASK oldret)]) + (cond + [(Sfixnump num) + (let* ([mask : uptr (UNFIX num)]) + (while + :? (!= mask 0) + (set! pp += 1) + (when (& mask #x0001) + (trace (* pp))) + (set! mask >>= 1)))] + [else + (trace (* (ENTRYNONCOMPACTLIVEMASKADDR oldret))) + + (let* ([num : ptr (ENTRYLIVEMASK oldret)] + [index : iptr (BIGLEN num)]) + (while + :? (!= index 0) + (set! index -= 1) + (let* ([bits : INT bigit_bits] + [mask : bigit (bignum-data num index)]) + (while + :? (> bits 0) + (set! bits -= 1) + (set! pp += 1) + (when (& mask 1) (trace (* pp))) + (set! mask >>= 1)))))]))))) + +(define-trace-macro (trace-return copy-field field) + (case-mode + [copy + (copy copy-field)] + [else + (define xcp : ptr field) + (case-mode + [sweep + (define x_si : seginfo* (SegInfo (ptr_get_segment xcp))) + (when (& (-> x_si space) space_old) + (trace-return-code field xcp x_si))] + [else + (trace-return-code field xcp no_x_si)])])) + +(define-trace-macro (trace-return-code field xcp x_si) + (define co : iptr (+ (ENTRYOFFSET xcp) (- (cast uptr xcp) (cast uptr (ENTRYOFFSETADDR xcp))))) + ;; In the call to copy below, assuming SPACE(c_p) == SPACE(xcp) since + ;; c_p and XCP point to/into the same object + (define c_p : ptr (cast ptr (- (cast uptr xcp) co))) + (case-mode + [sweep + (cond + [(== (FWDMARKER c_p) forward_marker) + (set! c_p (FWDADDRESS c_p))] + [else + (set! c_p (copy c_p x_si))]) + (set! field (cast ptr (+ (cast uptr c_p) co)))] + [else + (trace (just c_p))])) + +(define-trace-macro (trace-code len) + (case-mode + [(copy vfasl-copy) + (copy-bytes code-data len)] + [else + (define t : ptr (code-reloc _)) + (case-mode + [(sweep vfasl-sweep) + (define m : iptr (reloc-table-size t)) + (define oldco : ptr (reloc-table-code t))] + [else + (define m : iptr (cond + [t (reloc-table-size t)] + [else 0])) + (define oldco : ptr (cond + [t (reloc-table-code t)] + [else 0]))]) + (case-mode + [vfasl-sweep + (let* ([r_sz : uptr (size_reloc_table m)] + [new_t : ptr (vfasl_find_room vfi vspace_reloc typemod r_sz)]) + (memcpy_aligned new_t t r_sz) + (set! t new_t))] + [else]) + (define a : iptr 0) + (define n : iptr 0) + (while + :? (< n m) + (let* ([entry : uptr (reloc-table-data t n)] + [item_off : uptr 0] + [code_off : uptr 0]) + (set! n (+ n 1)) + (cond + [(RELOC_EXTENDED_FORMAT entry) + (set! item_off (reloc-table-data t n)) + (set! n (+ n 1)) + (set! code_off (reloc-table-data t n)) + (set! n (+ n 1))] + [else + (set! item_off (RELOC_ITEM_OFFSET entry)) + (set! code_off (RELOC_CODE_OFFSET entry))]) + (set! a (+ a code_off)) + (let* ([obj : ptr (S_get_code_obj (RELOC_TYPE entry) oldco a item_off)]) + (case-mode + [vfasl-sweep + (set! obj (vfasl_encode_relocation vfi obj))] + [else + (trace (just obj))]) + (case-mode + [sweep + (S_set_code_obj "gc" (RELOC_TYPE entry) _ a obj item_off)] + [vfasl-sweep + (S_set_code_obj "vfasl" (abs-for-vfasl (RELOC_TYPE entry)) _ a obj item_off)] + [else])))) + + (case-mode + [sweep + (cond + [(&& (== target_generation static_generation) + (&& (! S_G.retain_static_relocation) + (== 0 (& (code-type _) (<< code_flag_template code_flags_offset))))) + (set! (code-reloc _) (cast ptr 0))] + [else + ;; Don't copy non-oldspace relocation tables, since we may be + ;; sweeping a locked code object that is older than target_generation. + ;; Doing so would be a waste of work anyway. + (when (OLDSPACE t) + (let* ([oldt : ptr t]) + (set! n (size_reloc_table (reloc-table-size oldt))) + (count countof-relocation-table (just n) 1 sweep) + (find_room space_data target_generation typemod n t) + (memcpy_aligned t oldt n))) + (set! (reloc-table-code t) _) + (set! (code-reloc _) t)]) + (S_record_code_mod tc_in (cast uptr (& (code-data _ 0))) (cast uptr (code-length _)))] + [vfasl-sweep + ;; no vfasl_register_pointer, since relink_code can handle it + (set! (reloc-table-code t) (cast ptr (ptr_diff _ (-> vfi base_addr)))) + (set! (code-reloc _) (cast ptr (ptr_diff t (-> vfi base_addr))))] + [else])])) + +(define-trace-macro (unless-code-relocated stmt) + (case-flag code-relocated? + [on] + [off stmt])) + +(define-trace-macro (or-assume-continuation e) + (case-flag assume-continuation? + [on 1] + [off e])) + +(define-trace-macro (and-counts e) + (case-flag counts? + [on e] + [off 0])) + +(define-trace-macro (or-vfasl e) + (case-mode + [vfasl-copy 1] + [else e])) + +(define-trace-macro (when-vfasl e) + (case-mode + [(vfasl-copy vfasl-sweep) e] + [else])) + +(define-trace-macro (abs-for-vfasl e) + (case-mode + [vfasl-sweep reloc_abs] + [else e])) + +(define-trace-macro (pad e) + (case-mode + [(copy vfasl-copy) e] + [else])) + +(define-trace-macro (vfasl-pad-word) + (case-mode + [(vfasl-copy) + (set! (array-ref (cast void** (UNTYPE _copy_ type_typed_object)) 3) + (cast ptr 0))] + [else])) + +(define-trace-macro (vfasl-fail what) + (case-mode + [(vfasl-copy vfasl-sweep) + (vfasl_fail vfi what) + (case-mode + [vfasl-copy (return (cast ptr 0))] + [vfasl-sweep (return 0)]) + (vspace #f)] + [else])) + +(define-trace-macro (vfasl-as-false what) + (case-mode + [(vfasl-copy) + (return Sfalse) + (vspace #f)] + [(vfasl-sweep) + (vfasl-fail what) + (vspace #f)] + [else])) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parenthe-C compiler +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Every compiler needs its own little implementation of `match`, right? +;; Just pairs and literals, no ellipses. +(define-syntax (match stx) + (syntax-case stx (else) + [(_ expr [pattern rhs ...] ... [else else-rhs ...]) + #'(let ([v expr]) (matching v [pattern rhs ...] ... [else else-rhs ...]))] + [(_ expr [pattern rhs ...] ...) + #'(let ([v expr]) (match v [pattern rhs ...] ... [else (error 'match "no matching clause: ~s" v)]))])) + +(define-syntax (matching stx) + (syntax-case stx () + [(_ v [else rhs ...]) + #'(let () rhs ...)] + [(_ v [pattern rhs ...] more ...) + (letrec ([gen-match (lambda (pat quoted?) + (cond + [(identifier? pat) + (if quoted? + #`(eq? v '#,pat) + #t)] + [else + (syntax-case pat (quasiquote unquote) + [(quasiquote p) + (if quoted? + (error 'match "bad quasiquote") + (gen-match #'p #t))] + [(unquote p) + (if quoted? + (gen-match #'p #f) + (error 'match "bad unquote"))] + [(a . b) + #`(and (pair? v) + (let ([v (car v)]) + #,(gen-match #'a quoted?)) + (let ([v (cdr v)]) + #,(gen-match #'b quoted?)))] + [other + #'(equal? v 'other)])]))] + [get-binds (lambda (pat quoted?) + (cond + [(identifier? pat) + (if quoted? + '() + (list pat))] + [else + (syntax-case pat (quasiquote unquote) + [(quasiquote p) + (get-binds #'p #t)] + [(unquote p) + (get-binds #'p #f)] + [(a . b) + (append (get-binds #'a quoted?) + (get-binds #'b quoted?))] + [other '()])]))] + [get-vals (lambda (pat quoted?) + (cond + [(identifier? pat) + (if quoted? + #''() + #'(list v))] + [else + (syntax-case pat (quasiquote unquote) + [(quasiquote p) + (get-vals #'p #t)] + [(unquote p) + (get-vals #'p #f)] + [(a . b) + #`(append (let ([v (car v)]) + #,(get-vals #'a quoted?)) + (let ([v (cdr v)]) + #,(get-vals #'b quoted?)))] + [other #''()])]))]) + (syntax-case #'pattern (quasiquote) + [(quasiquote p) + #`(if #,(gen-match #'pattern #f) + (let-values ([#,(get-binds #'pattern #f) + (apply values #,(get-vals #'pattern #f))]) + rhs ...) + (matching v more ...))] + [_ + (error 'match "bad pattern ~s" #'pattern)]))])) + +(let () + + (define preserve-flonum-eq? #t) + + ;; A config is an association list. Mostly, it determines the + ;; generation mode, but it is also used to some degree as an + ;; environment-like map to communicate information from one + ;; statement to later statements. + ;; + ;; Some keys: + ;; - 'mode [required] + ;; - 'maybe-backreferences? + ;; - 'known-space [to prune generated cases] + ;; - 'known-types [to prune generated cases] + + (define lookup + (case-lambda + [(key config default) + (let ([a (assq key config)]) + (if a + (cadr a) + default))] + [(key config) + (let ([a (assq key config)]) + (if a + (cadr a) + (error 'lookup "not found: ~s" key)))])) + + ;; A sqeuence wraps a list of string and other sequences with + ;; formatting information + (define-record-type seq + (fields l)) + (define-record-type block-seq + (fields l)) + (define-record-type indent-seq + (fields pre mid post)) + + ;; More convenient constructors for sequences: + (define (code . l) (make-seq l)) + (define (code-block . l) (make-block-seq l)) + (define (code-indent pre mid post) (make-indent-seq pre mid post)) + + ;; Main C-generation entry point: + (define (generate name config) + (define base-types (prune trace-base-types config)) + (define object-types (prune trace-object-types config)) + (define mode (lookup 'mode config)) + (code + (format "static ~a ~a(~aptr p~a)" + (case (lookup 'mode config) + [(copy vfasl-copy) "ptr"] + [(size vfasl-sweep) "uptr"] + [(self-test) "IBOOL"] + [(sweep) (if (lookup 'as-dirty? config #f) + "IGEN" + "void")] + [else "void"]) + name + (case (lookup 'mode config) + [(sweep) + (if (type-included? 'code config) + "ptr tc_in, " + "")] + [(vfasl-copy vfasl-sweep) + "vfasl_info *vfi, "] + [else ""]) + (case (lookup 'mode config) + [(copy vfasl-copy) ", seginfo *si"] + [(sweep) + (if (lookup 'as-dirty? config #f) + ", IGEN tg, IGEN youngest" + "")] + [else ""])) + (let ([body + (lambda () + (let ([config (cons (list 'used (make-eq-hashtable)) config)]) + (cond + [(null? base-types) + (cond + [(null? object-types) + (error 'generate "no relevant types")] + [(null? (cdr object-types)) + (code-block (statements (cdar object-types) + (cons `(type ,(caar object-types)) config)))] + [else + (generate-typed-object-dispatch object-types (cons '(basetype typed-object) config))])] + [else + (cond + [(null? object-types) + (generate-type-dispatch base-types config)] + [else + (generate-type-dispatch + (cons (cons 'typed-object + (generate-typed-object-dispatch object-types (cons '(basetype typed-object) + config))) + base-types) + config)])])))]) + (case (lookup 'mode config) + [(copy) + (code-block + (cond + [(lookup 'counts? config #f) + (code + "if (!(si->space & space_old) || locked(si, p)) {" + " if (measure_all_enabled) push_measure(p);" + " return p;" + "}")] + [else + "if (locked(si, p)) return p;"]) + "change = 1;" + "check_triggers(si);" + (code-block + "ptr new_p;" + "IGEN tg = target_generation;" + (body) + "FWDMARKER(p) = forward_marker;" + "FWDADDRESS(p) = new_p;" + (and (lookup 'maybe-backreferences? config #f) + "ADD_BACKREFERENCE(p)") + "return new_p;"))] + [(sweep) + (code-block + (and (lookup 'maybe-backreferences? config #f) + "PUSH_BACKREFERENCE(p)") + (body) + (and (lookup 'maybe-backreferences? config #f) + "POP_BACKREFERENCE()") + (and (lookup 'as-dirty? config #f) + "return youngest;"))] + [(measure) + (body)] + [(self-test) + (code-block + (body) + "return 0;")] + [(vfasl-copy) + (code-block + "ptr new_p;" + (body) + "vfasl_register_forward(vfi, p, new_p);" + "return new_p;")] + [(vfasl-sweep) + (code-block + "uptr result_sz;" + (body) + "return result_sz;")] + [else + (body)])))) + + (define (generate-type-dispatch l config) + (let ([multi? (and (pair? l) (pair? (cdr l)))]) + (code-block + (and multi? "ITYPE t = TYPEBITS(p);") + (let loop ([l l] [else? #f]) + (cond + [(null? l) + (and multi? + (code "else" + (code-block + (format "S_error_abort(\"~a: illegal type\");" (lookup 'mode config)))))] + [else + (code + (and multi? + (format "~aif (t == ~a)" (if else? "else " "") (as-c 'type (caar l)))) + (let ([c (cdar l)]) + (if (block-seq? c) + c + (code-block (statements c (cons (list 'basetype (caar l)) + config))))) + (loop (cdr l) #t))]))))) + + (define (generate-typed-object-dispatch l config) + (code-block + "ptr tf = TYPEFIELD(p);" + (let loop ([l l] [else? #f]) + (cond + [(null? l) + (code "else" + (code-block + (format "S_error_abort(\"~a: illegal typed object type\");" (lookup 'mode config))))] + [else + (let* ([ty (caar l)] + [mask (lookup-constant (string->symbol (format "mask-~a" ty)))] + [type-constant? (eqv? mask (constant byte-constant-mask))]) + (code (format "~aif (~a)" (if else? "else " "") + (if type-constant? + (format "(iptr)tf == ~a" (as-c 'type ty)) + (format "TYPEP(tf, ~a, ~a)" (as-c 'mask ty) (as-c 'type ty)))) + (code-block (statements (cdar l) (cons* (list 'tf "tf") + (list 'type ty) + (if type-constant? + (cons `(type-constant ,(as-c 'type ty)) + config) + config)))) + (loop (cdr l) #t)))])))) + + ;; list of S-expressions -> code sequence + (define (statements l config) + (cond + [(null? l) (code)] + [else + (let ([a (car l)]) + (match a + [`(case-mode . ,all-clauses) + (let ([body (find-matching-mode (lookup 'mode config) all-clauses)]) + (statements (append body (cdr l)) config))] + [`(case-space . ,all-clauses) + (code + (code-block + (format "ISPC p_at_spc = ~a;" + (case (lookup 'mode config) + [(copy vfasl-copy) "si->space"] + [else "SPACE(p) & ~(space_locked | space_old)"])) + (let loop ([all-clauses all-clauses] [else? #f]) + (match all-clauses + [`([else . ,body]) + (code + "else" + (code-block (statements body config)))] + [`([,spc . ,body] . ,rest) + (code + (format "~aif (p_at_spc == ~a)" + (if else? "else " "") + (case (lookup 'mode config) + [(copy) (format "(~a | space_old)" (as-c spc))] + [else (as-c spc)])) + (code-block (statements body config)) + (loop rest #t))]))) + (statements (cdr l) config))] + [`(case-flag ,flag + [on . ,on] + [off . ,off]) + (let ([body (if (lookup flag config #f) + on + off)]) + (statements (append body (cdr l)) config))] + [`(trace-early-rtd ,field) + (code (case (and (not (lookup 'only-dirty? config #f)) + (not (lookup 'rtd-relocated? config #f)) + (lookup 'mode config)) + [(copy sweep) + (code + "/* Relocate to make sure we aren't using an oldspace descriptor" + " that has been overwritten by a forwarding marker, but don't loop" + " on tag-reflexive base descriptor */" + (format "if (p != ~a)" + (lookup 'tf config (format "TYPEFIELD(p)"))) + (code-block + (statements `((trace-early ,field)) config)))] + [(measure) + (statements `((trace-early ,field)) config)] + [else #f]) + (statements (cdr l) (cons `(copy-extra-rtd ,field) config)))] + [`(trace ,field) + (code (trace-statement field config #f) + (statements (cdr l) config))] + [`(trace-early ,field) + (code (trace-statement field config #t) + (statements (cdr l) (if (symbol? field) + (cons `(copy-extra ,field) config) + config)))] + [`(trace-now ,field) + (code + (case (lookup 'mode config) + [(copy) + (code-block + (format "ptr tmp_p = ~a;" (field-expression field config "p" #f)) + (relocate-statement "tmp_p" config) + (format "~a = tmp_p;" (field-expression field config "new_p" #f)))] + [(self-test) #f] + [(measure vfasl-copy vfasl-sweep) + (statements (list `(trace ,field)) config)] + [else + (trace-statement field config #f)]) + (statements (cdr l) config))] + [`(copy ,field) + (code (copy-statement field config) + (statements (cdr l) config))] + [`(copy-flonum ,field) + (cond + [(and preserve-flonum-eq? + (eq? 'copy (lookup 'mode config))) + (code (copy-statement field config) + "flonum_set_forwarded(p, si);" + "FLONUM_FWDADDRESS(p) = new_p;" + (statements (cdr l) config))] + [else + (statements (cons `(copy ,field) (cdr l)) config)])] + [`(copy-flonum* ,field) + (cond + [preserve-flonum-eq? + (case (lookup 'mode config) + [(copy) + (code (code-block + (format "ptr tmp_p = TYPE(&~a, type_flonum);" (field-expression field config "p" #t)) + "if (flonum_is_forwarded_p(tmp_p, si))" + (format " ~a = FLODAT(FLONUM_FWDADDRESS(tmp_p));" + (field-expression field config "new_p" #f)) + "else" + (format " ~a = ~a;" + (field-expression field config "new_p" #f) + (field-expression field config "p" #f))) + (statements (cdr l) config))] + [(vfasl-copy) + (statements (cons `(copy ,field) (cdr l)) config)] + [else (statements (cdr l) config)])] + [else + (statements (cons `(copy ,field) (cdr l)) config)])] + [`(copy-bytes ,offset ,len) + (code (case (lookup 'mode config) + [(copy vfasl-copy) + (format "memcpy_aligned(&~a, &~a, ~a);" + (field-expression offset config "new_p" #t) + (field-expression offset config "p" #t) + (expression len config))] + [else #f]) + (statements (cdr l) config))] + [`(copy-type ,field) + (case (lookup 'mode config) + [(copy vfasl-copy) + (code + (format "~a = ~a;" + (field-expression field config "new_p" #f) + (or (lookup 'type-constant config #f) + "(uptr)tf")) + (statements (cdr l) config))] + [else + (statements (cons `(copy ,field) (cdr l)) config)])] + [`(trace-ptrs ,offset ,len) + (case (lookup 'mode config) + [(copy vfasl-copy) + (statements (cons `(copy-bytes ,offset (* ptr_bytes ,len)) + (cdr l)) + config)] + [(sweep measure vfasl-sweep) + (code + (loop-over-pointers + (field-expression offset config "p" #t) + len + (trace-statement `(array-ref p_p idx) config #f) + config))] + [(self-test) + (code + (loop-over-pointers (field-expression offset config "p" #t) + len + (code "if (p_p[idx] == p) return 1;") + config) + (statements (cdr l) config))] + [else (statements (cdr l) config)])] + [`(count ,counter) + (code (count-statement counter #f 1 'copy config) + (statements (cdr l) config))] + [`(count ,counter ,size) + (statements (cons `(count ,counter ,size 1 copy) (cdr l)) config)] + [`(count ,counter ,size ,scale) + (statements (cons `(count ,counter ,size ,scale copy) (cdr l)) config)] + [`(count ,counter ,size ,scale ,modes) + (code (count-statement counter size scale modes + (cons `(constant-size? ,(symbol? size)) + config)) + (statements (cdr l) config))] + [`(space ,s) + (case (lookup 'mode config) + [(copy) + (code (code-indent "ISPC p_spc = " + (expression s config #f #t) + ";") + (statements (cdr l) (cons '(space-ready? #t) config)))] + [else (statements (cdr l) config)])] + [`(vspace ,s) + (case (lookup 'mode config) + [(vfasl-copy) + (cond + [(not s) (code)] + [else + (code (code-indent "int p_vspc = " + (expression s config #f #t) + ";") + (statements (cdr l) (cons '(vspace-ready? #t) config)))])] + [(vfasl-sweep) + (cond + [(not s) (code)] + [else (statements (cdr l) config)])] + [else (statements (cdr l) config)])] + [`(size ,sz) + (statements (cons `(size ,sz ,1) (cdr l)) config)] + [`(size ,sz ,scale) + (let* ([mode (lookup 'mode config)] + [mode (if (lookup 'return-size? config #f) + (case mode + [(sweep) 'sweep+size] + [else mode]) + mode)]) + (code-block + (case mode + [(copy sweep+size size measure vfasl-copy vfasl-sweep) + (format "uptr p_sz = ~a;" (let ([s (size-expression sz config)]) + (if (= scale 1) + s + (format "~a * (~a)" scale s))))] + [else #f]) + (case mode + [(copy vfasl-copy) + (case mode + [(copy) (unless (lookup 'space-ready? config #f) + (error 'generate "size before space"))] + [(vfasl-copy) (unless (lookup 'vspace-ready? config #f) + (error 'generate "size before vspace for ~a/~a" + (lookup 'basetype config) + (lookup 'type config #f)))]) + (code (format "~a, ~a, p_sz, new_p);" + (case mode + [(copy) "find_room(p_spc, tg"] + [(vfasl-copy) "FIND_ROOM(vfi, p_vspc"]) + (as-c 'type (lookup 'basetype config))) + (statements (let ([extra (lookup 'copy-extra config #f)]) + (if extra + (cons `(copy ,extra) (cdr l)) + (let* ([mode (lookup 'mode config)] + [extra (and (memq mode '(copy vfasl-copy)) + (lookup 'copy-extra-rtd config #f))]) + (if extra + (cons `(set! (,extra _copy_) + ,(case mode + [(copy) + `(cond + [(== tf _) _copy_] + [else rtd])] + [else 'rtd])) + (cdr l)) + (cdr l))))) + (cons '(copy-ready? #t) + (if (symbol? sz) + (cons '(constant-size? #t) + config) + config))))] + [(size) + (code "return p_sz;")] + [(vfasl-sweep) + (code "result_sz = p_sz;" + (statements (cdr l) config))] + [(measure) + (code "measure_total += p_sz;" + (statements (cdr l) config))] + [else (statements (cdr l) config)])))] + [`(skip-forwarding) + (case (lookup 'mode config) + [(copy) + (unless (null? (cdr l)) + (error 'skip-forwarding "not at end")) + (code "return new_p;")] + [else + (statements (cdr l) config)])] + [`(define ,id : ,type ,rhs) + (let* ([used (lookup 'used config)] + [prev-used? (hashtable-ref used id #f)]) + (hashtable-set! used id #f) + (let* ([rest (statements (cdr l) config)] + [used? (hashtable-ref (lookup 'used config) id #f)]) + (hashtable-set! used id prev-used?) + (if used? + (code-block (code-indent (format "~a ~a = " type id) + (expression rhs config #f #t) + ";") + rest) + rest)))] + [`(cond . ,clauses) + (code + (let loop ([clauses clauses] [else? #f]) + (match clauses + [`() (code)] + [`([else . ,rhss]) + (cond + [(null? rhss) + (code)] + [else + (if else? + (code "else" + (code-block + (statements rhss config))) + (statements rhss config))])] + [`([,test . ,rhss] . ,clauses) + (let ([tst (expression test config)]) + (cond + [(equal? tst "0") + (loop clauses else?)] + [else + (let ([rhs (statements rhss config)]) + (cond + [(equal? tst "1") + (if else? + (code-block "else" rhs) + rhs)] + [else + (code (format "~aif (~a)" (if else? "else " "") tst) + (code-block rhs) + (loop clauses #t))]))]))])) + (statements (cdr l) config))] + [`(let* ,binds . ,body) + (code + (code-block + (let loop ([binds binds]) + (match binds + [`() (statements body config)] + [`([,id : ,type ,rhs] . ,binds) + (code (code-indent (format "~a ~a = " type id) + (expression rhs config #f #t) + ";") + (loop binds))]))) + (statements (cdr l) config))] + [`(while :? ,tst . ,body) + (code (format "while (~a)" (expression tst config)) + (code-block + (statements body config)) + (statements (cdr l) config))] + [`(do-while . ,body+test) + (let-values ([(body tst) + (let loop ([body+test body+test] [rev-body '()]) + (match body+test + [`(:? ,test) (values (reverse rev-body) test)] + [`(,e . ,rest) + (loop rest (cons e rev-body))]))]) + (code "do" + (code-block + (statements body config)) + (format "while (~a);" (expression tst config)) + (statements (cdr l) config)))] + [`(when ,tst . ,body) + (statements (cons `(cond [,tst . ,body][else]) (cdr l)) + config)] + [`(set! ,lhs ,rhs) + (code (code-indent (format "~a = " + (expression lhs config)) + (expression rhs config #f #t) + ";") + (statements (cdr l) config))] + [`(set! ,lhs ,op ,rhs) + (unless (memq op '(+= -= <<= >>=)) + (error 'set! "not an update op ~s" op)) + (code (format "~a ~a ~a;" + (expression lhs config) + op + (expression rhs config)) + (statements (cdr l) config))] + [`(break) + (code "break;")] + [`(,id . ,args) + (let ([m (eq-hashtable-ref trace-macros id #f)]) + (if m + (statements (append (apply-macro m args) + (cdr l)) + config) + (code (format "~a;" (expression a config #f #t)) + (statements (cdr l) config))))] + [else + (code (format "~a;" (expression a config #f #t)) + (statements (cdr l) config))]))])) + + ;; S-expresison -> string + (define expression + (case-lambda + [(a config) (expression a config #f #f)] + [(a config protect?) (expression a config protect? #f)] + [(a config protect? multiline?) + (define (protect s) + (if protect? (format "(~a)" s) s)) + (match a + [`_ "p"] + [`_copy_ (case (lookup 'mode config) + [(copy vfasl-copy) "new_p"] + [else "p"])] + [`_tf_ + (lookup 'tf config "TYPEFIELD(p)")] + [`_backreferences?_ + (if (lookup 'maybe-backreferences? config #f) + "BACKREFERENCES_ENABLED" + "0")] + [`(just ,id) + (hashtable-set! (lookup 'used config) id #t) + (symbol->string id)] + [`(case-flag ,flag + [on ,on] + [off ,off]) + (let ([e (if (lookup flag config #f) + on + off)]) + (expression e config protect? multiline?))] + [`(case-mode . ,all-clauses) + (match (find-matching-mode (lookup 'mode config) all-clauses) + [`(,e) + (expression e config protect? multiline?)] + [`,any + (error 'case-mode "bad form ~s" a)])] + [`(cond . ,clauses) + (let loop ([clauses clauses] [protect? protect?]) + (match clauses + [`([else ,rhs]) (expression rhs config protect? multiline?)] + [`([,test ,rhs] . ,clauses) + (let ([tst (expression test config #t #t)]) + (cond + [(equal? tst "0") + (loop clauses protect?)] + [(equal? tst "1") + (expression rhs config protect? multiline?)] + [else + (if multiline? + (format "(~a\n ? ~a\n : ~a)" + tst + (indent-newlines (expression rhs config #t #t) 3) + (indent-newlines (loop clauses #t) 3)) + (format "(~a ? ~a : ~a)" + tst + (expression rhs config #t #f) + (loop clauses #t)))]))]))] + [`(cast ,type ,e) + (protect (format "(~a)~a" type (expression e config #t)))] + [`(array-ref ,array ,index) + (protect (format "~a[~a]" + (expression array config #t) + (expression index config)))] + [`(set! ,lhs ,rhs) ; a `set!` used as an expression + (format "(~a = ~a)" + (expression lhs config #t) + (expression rhs config #t))] + [`(,op ,a) + (cond + [(memq op '(& - !)) + (protect (format "~a~a" op (expression a config #t)))] + [(get-offset-value op) + => (lambda (v) + (protect (field-ref-expression (expression a config) v op #f config)))] + [(eq-hashtable-ref trace-macros op #f) + => (lambda (m) + (expression (car (apply-macro m (list a))) config protect? multiline?))] + [else + (protect (format "~a(~a)" op (expression a config #t)))])] + [`(,op ,a ,b) + (cond + [(memq op '(& && \|\| == != + - * < > <= >= << >> ->)) + (protect (format "~a ~a ~a" (expression a config #t) op (expression b config #t)))] + [(get-offset-value op) + => (lambda (v) + (protect (field-ref-expression (expression a config) v op b config)))] + [else + (protect (format "~a(~a, ~a)" op (expression a config) (expression b config)))])] + [`(,rator . ,rands) + (unless (symbol? rator) + (error 'expression "expected a symbol for funciton name: ~s" rator)) + (format "~a(~a)" + rator + (comma-ize (map (lambda (r) (expression r config)) rands)))] + [else + (cond + [(symbol? a) + (cond + [(getprop a '*c-name* #f) + => (lambda (c-name) c-name)] + [else + (hashtable-set! (lookup 'used config) a #t) + (symbol->string a)])] + [else + (format "~s" a)])])])) + + (define (find-matching-mode mode all-clauses) + (let loop ([clauses all-clauses]) + (match clauses + [`([else . ,body]) + body] + [`([,cl-mode . ,cl-body] . ,clauses) + (if (or (eq? cl-mode mode) + (and (pair? cl-mode) + (memq mode cl-mode))) + cl-body + (loop clauses))] + [`() + (error 'case-mode "no matching case for ~s in ~s" mode all-clauses)]))) + + (define (loop-over-pointers ptr-e len body config) + (code-block + (format "uptr idx, p_len = ~a;" (expression len config)) + (format "ptr *p_p = &~a;" ptr-e) + "for (idx = 0; idx < p_len; idx++)" + (code-block body))) + + (define (trace-statement field config early?) + (define mode (lookup 'mode config)) + (cond + [(or (eq? mode 'sweep) + (eq? mode 'vfasl-sweep) + (and early? (eq? mode 'copy))) + (relocate-statement (field-expression field config "p" #t) config)] + [(or (eq? mode 'copy) + (eq? mode 'vfasl-copy)) + (copy-statement field config)] + [(eq? mode 'measure) + (measure-statement (field-expression field config "p" #f))] + [(eq? mode 'self-test) + (format "if (p == ~a) return 1;" (field-expression field config "p" #f))] + [else #f])) + + (define (relocate-statement e config) + (define mode (lookup 'mode config)) + (case mode + [(vfasl-sweep) + (format "vfasl_relocate(vfi, &~a);" e)] + [else + (if (lookup 'as-dirty? config #f) + (format "relocate_dirty(&~a, tg, youngest);" e) + (format "relocate(&~a);" e))])) + + (define (measure-statement e) + (code + "{ /* measure */" + (format " ptr r_p = ~a;" e) + " if (!IMMEDIATE(r_p))" + " push_measure(r_p);" + "}")) + + (define (copy-statement field config) + (define mode (lookup 'mode config)) + (case mode + [(copy vfasl-copy) + (cond + [(symbol? field) + (unless (lookup 'copy-ready? config #f) + (error 'copy "need size before: ~s" field)) + (format "~a = ~a;" + (field-expression field config "new_p" #f) + (field-expression field config "p" #f))] + [else + (when (eq? mode 'copy) + (error 'copy "pointless copy to self for ~s" field)) + #f])] + [else #f])) + + (define (count-statement counter size scale modes config) + (let ([mode (lookup 'mode config)]) + (cond + [(or (eq? mode modes) (and (pair? modes) (memq mode modes))) + (cond + [(lookup 'counts? config #f) + (let ([tg (if (eq? mode 'copy) + "tg" + "target_generation")]) + (code + (format "S_G.countof[~a][~a] += ~a;" tg (as-c counter) scale) + (if (lookup 'constant-size? config #f) + #f + (format "S_G.bytesof[~a][~a] += ~a;" + tg + (as-c counter) + (let ([s (if size + (expression size config) + "p_sz")]) + (if (eqv? scale 1) + s + (format "~a * (~a)" scale s)))))))] + [else #f])] + [else #f]))) + + (define (field-expression field config arg protect?) + (if (symbol? field) + (cond + [(get-offset-value field) + => (lambda (v) + (field-ref-expression arg v field 0 config))] + [else + (error 'field "identifier is not a field accessor: ~s" field)]) + (expression field config protect?))) + + (define (size-expression sz config) + (if (symbol? sz) + (cond + [(get-size-value sz) + => (lambda (v) (as-c sz))] + [else + (error 'size "identifier is not a size: ~s" sz)]) + (expression sz config))) + + (define (field-ref-expression obj v acc-name index config) + (let ([c-ref (getprop acc-name '*c-ref* #f)]) + (unless c-ref + (error 'field-ref "could not find accessor for ~s" acc-name)) + (cond + [(pair? c-ref) + (unless index + (error 'field-ref "missing index for array field ~s" acc-name)) + (format "~a(~a, ~a)" (car c-ref) obj (expression index config))] + [else + (when (and index (not (eq? index 0))) + (error 'field-ref "index not allowed for non-array field ~s" acc-name)) + (format "~a(~a)" c-ref obj)]))) + + ;; Slightly hacky way to check whether `op` is an accessor + (define (get-offset-value op) + (getprop (string->symbol (format "~a-disp" op)) '*constant* #f)) + + ;; Check whether `op` is a size (probably) + (define (get-size-value op) + (getprop op '*constant* #f)) + + ;; Convert to C constant name + (define as-c + (case-lambda + [(sym) + (or (getprop sym '*c-name* #f) + (error 'as-type "failed for ~s" sym))] + [(prefix base) + (or (getprop (string->symbol (format "~a-~a" prefix base)) '*c-name* #f) + (error 'as-type "failed for ~s ~s" prefix base))])) + + (define (comma-ize l) + (apply string-append + (let loop ([l l]) + (if (null? l) + '("") + (if (null? (cdr l)) + (list (car l)) + (list* (car l) ", " (loop (cdr l)))))))) + + (define (apply-macro m l) + (define args (car m)) + (define body (cdr m)) + (unless (= (length args) (length l)) + (error 'apply-macro "wrong macro argument count: ~s vs ~s" args l)) + (let ([subs (map cons args l)]) + (let loop ([m body]) + (cond + [(symbol? m) + (let ([a (assq m subs)]) + (if a + (cdr a) + m))] + [(pair? m) + (cons (loop (car m)) (loop (cdr m)))] + [else m])))) + + (define (type-included? type config) + (let ([types (lookup 'known-types config #f)]) + (if (not types) + #t + (memq type types)))) + + (define (prune types config) + (let loop ([types types]) + (if (null? types) + '() + (let ([s (prune-one (car types) config)]) + (if s + (cons s (loop (cdr types))) + (loop (cdr types))))))) + + (define (prune-one type config) + (define known-types (lookup 'known-types config #f)) + (cond + [(or (not known-types) + (memq (car type) known-types)) + (let ([known-space (lookup 'known-space config #f)]) + (cond + [(or (not known-space) + (body-has-space? (cdr type) known-space config)) + type] + [else #f]))] + [else #f])) + + (define (body-has-space? body space config) + (cond + [(null? body) (error 'base-has-space? "no `space` specification in body")] + [else + (let ([a (car body)]) + (cond + [(and (pair? a) (eq? (car a) 'space)) + (body-has-tail? (cdr a) space config)] + [(and (pair? a) (memq (car a) '(case-space cond))) + (unless (null? (cdr body)) (error 'body-has-space? "there's more?")) + (let loop ([clauses (cdr a)]) + (if (null? clauses) + #f + (or (body-has-space? (cdar clauses) space config) + (loop (cdr clauses)))))] + [else + (body-has-space? (cdr body) space config)]))])) + + (define (body-has-tail? body key config) + (cond + [(null? body) #f] + [else + (let ([a (car body)]) + (match a + [`(cond . ,clauses) + (ormap (lambda (clause) + (body-has-tail? (cdr clause) key config)) + clauses)] + [else + (body-has-tail? (cdr body) key config)]))])) + + (define print-code + (case-lambda + [(c) + (print-code c 0) + (newline)] + [(c indentation) + (cond + [(not c) (void)] + [(seq? c) + (for-each (lambda (p) + (print-code p indentation)) + (seq-l c))] + [(block-seq? c) + (let ([l (block-seq-l c)]) + (cond + [(and (pair? l) + (null? (cdr l)) + (block-seq? (car l))) + (print-code (car l) indentation)] + [else + (indent indentation) + (printf "{\n") + (for-each (lambda (p) + (print-code p (+ indentation 2))) + l) + (indent indentation) + (printf "}\n")]))] + [(indent-seq? c) + (indent indentation) + (printf "~a" (indent-seq-pre c)) + (printf "~a" (indent-newlines (indent-seq-mid c) + (+ indentation (string-length (indent-seq-pre c))))) + (printf "~a" (indent-seq-post c)) + (newline)] + [else + (indent indentation) + (printf "~a\n" (indent-newlines c indentation))])])) + + (define (indent n) + (display (make-string n #\space))) + + (define (indent-newlines s n) + (list->string + (let loop ([l (string->list s)]) + (cond + [(null? l) '()] + [(eqv? #\newline (car l)) + (cons #\newline (append (string->list (make-string n #\space)) + (loop (cdr l))))] + [else (cons (car l) (loop (cdr l)))])))) + + (define (gen-gc ofn count? measure?) + (guard + (x [#t (raise x)]) + (parameterize ([current-output-port (open-output-file ofn 'replace)]) + (print-code (generate "copy" + `((mode copy) + (maybe-backreferences? ,count?) + (counts? ,count?)))) + (print-code (generate "sweep" + `((mode sweep) + (maybe-backreferences? ,count?) + (counts? ,count?)))) + (letrec ([sweep1 + (case-lambda + [(type) (sweep1 type (format "sweep_~a" type) '())] + [(type name) (sweep1 type name '())] + [(type name extra-configs) + (print-code (generate name + (append + extra-configs + `((mode sweep) + (known-types (,type)) + (maybe-backreferences? ,count?) + (counts? ,count?)))))])]) + (sweep1 'record "sweep_record" '((rtd-relocated? #t))) + (sweep1 'record "sweep_dirty_record" '((rtd-relocated? #t) + (as-dirty? #t))) + (sweep1 'symbol) + (sweep1 'symbol "sweep_dirty_symbol" '((as-dirty? #t))) + (sweep1 'thread) + (sweep1 'port) + (sweep1 'port "sweep_dirty_port" '((as-dirty? #t))) + (sweep1 'closure "sweep_continuation" '((code-relocated? #t) + (assume-continuation? #t))) + (sweep1 'code "sweep_code_object")) + (print-code (generate "size_object" + `((mode size)))) + (print-code (generate "object_directly_refers_to_self" + `((mode self-test)))) + (when measure? + (print-code (generate "measure" `((mode measure)))))))) + + (define (gen-vfasl ofn) + (guard + (x [#t (raise x)]) + (parameterize ([current-output-port (open-output-file ofn 'replace)]) + (print-code (generate "copy" + `((mode vfasl-copy)))) + (print-code (generate "sweep" + `((mode vfasl-sweep) + (return-size? #t))))))) + + ;; Render via mkequates to record a mapping from selectors to C + ;; macros: + (let-values ([(op get) (open-bytevector-output-port (native-transcoder))]) + (mkequates.h op)) + + (set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f))) + (set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t))) + (set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn)))) diff --git a/s/mkheader.ss b/s/mkheader.ss index a1ba5ccad6..84bf8e91e0 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -76,6 +76,9 @@ (lambda (a) (apply (lambda (field type disp len) + (putprop (string->symbol (format "~a-~a" struct field)) '*c-ref* (if len + (cons name len) + name)) (if len (def (format "~s(x,i)" name) (format (if (eq? ref &ref) "(~a+i)" "(~a[i])") @@ -170,7 +173,9 @@ (set-who! mkscheme.h (lambda (ofn target-machine) - (fluid-let ([op (open-output-file ofn 'replace)]) + (fluid-let ([op (if (output-port? ofn) + ofn + (open-output-file ofn 'replace))]) (comment "scheme.h for Chez Scheme Version ~a (~a)" scheme-version target-machine) (nl) @@ -706,7 +711,9 @@ (set! mkequates.h (lambda (ofn) - (fluid-let ([op (open-output-file ofn 'replace)]) + (fluid-let ([op (if (output-port? ofn) + ofn + (open-output-file ofn 'replace))]) (comment "equates.h for Chez Scheme Version ~a" scheme-version) (nl) @@ -736,8 +743,10 @@ (cond [(getprop x '*constant* #f) => (lambda (k) - (let ([type (getprop x '*constant-ctype* #f)]) - (def (sanitize x) + (let ([type (getprop x '*constant-ctype* #f)] + [c-name (sanitize x)]) + (putprop x '*c-name* c-name) + (def c-name (if (or (fixnum? k) (bignum? k)) (if (< k 0) (if (or (not type) (eq? type 'int)) @@ -994,6 +1003,7 @@ (nl) (comment "threads") + (defref THREADTYPE thread type) (defref THREADTC thread tc) (nl) diff --git a/s/primdata.ss b/s/primdata.ss index 9c1d06d7f3..6a2452ecb4 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1220,7 +1220,7 @@ (chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags]) (clear-input-port [sig [() (input-port) -> (void)]] [flags true]) (clear-output-port [sig [() (output-port) -> (void)]] [flags true]) - (collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) -> (void)]] [flags true]) + (collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) (sub-ufixnum ptr ptr) -> (void/list)]] [flags true]) (collect-rendezvous [sig [() -> (void)]] [flags]) (collections [sig [() -> (uint)]] [flags unrestricted alloc]) (compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags]) diff --git a/workarea b/workarea index 414757c0c2..2716a312eb 100755 --- a/workarea +++ b/workarea @@ -182,6 +182,8 @@ workdir $W/boot workdir $W/boot/$M (cd $W/boot/$M; workln ../../../boot/$M/scheme.h scheme.h) (cd $W/boot/$M; workln ../../../boot/$M/equates.h equates.h) +(cd $W/boot/$M; workln ../../../boot/$M/gc-ocd.inc gc-ocd.inc) +(cd $W/boot/$M; workln ../../../boot/$M/gc-oce.inc gc-oce.inc) (cd $W/boot/$M; workln ../../../boot/$M/petite.boot petite.boot) (cd $W/boot/$M; workln ../../../boot/$M/scheme.boot scheme.boot) (cd $W/boot/$M; workln ../../../boot/$M/def.so def.so)