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)