From 0cdfda55c5d41a57f576a2b0ec545201b0aaf439 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Dec 2017 21:55:06 -0700 Subject: [PATCH] first cut at backreference support from GC original commit: 49fff33f7284980823e9d993869396a145778abe --- c/externs.h | 3 + c/gc-oce.c | 1 + c/gc.c | 183 ++++++++++++++++++++++++++++++++++++++++---------- c/gcwrapper.c | 23 ++++++- c/globals.h | 2 + c/prim.c | 3 + c/scheme.c | 1 + s/back.ss | 7 ++ s/cmacros.ss | 8 ++- s/inspect.ss | 2 + s/primdata.ss | 2 + 11 files changed, 195 insertions(+), 40 deletions(-) diff --git a/c/externs.h b/c/externs.h index 98fa0f80b3..8bc22f0160 100644 --- a/c/externs.h +++ b/c/externs.h @@ -132,6 +132,9 @@ extern void S_register_child_process PROTO((INT child)); extern IBOOL S_enable_object_counts PROTO((void)); extern void S_set_enable_object_counts PROTO((IBOOL eoc)); 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 void S_compact_heap PROTO((void)); diff --git a/c/gc-oce.c b/c/gc-oce.c index ab910e74fb..a1d629e7f8 100644 --- a/c/gc-oce.c +++ b/c/gc-oce.c @@ -16,4 +16,5 @@ #define GCENTRY S_gc_oce #define ENABLE_OBJECT_COUNTS +#define ENABLE_BACKREFERENCE #include "gc.c" diff --git a/c/gc.c b/c/gc.c index 7979910233..0035a080ca 100644 --- a/c/gc.c +++ b/c/gc.c @@ -39,7 +39,7 @@ 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 iptr sweep_typed_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)); @@ -79,6 +79,31 @@ static ptr sorted_locked_objects; static ptr tlcs_to_rehash; static ptr recheck_guardians_ls; +#ifdef ENABLE_BACKREFERENCE +static ptr sweep_from; +# define BACKREFERENCES_ENABLED S_G.enable_object_backreferences +# define SET_SWEEP_FROM(p) if (S_G.enable_object_backreferences) sweep_from = p +# define WITH_TOP_BACKREFERENCE(v, e) SET_SWEEP_FROM(v); e; SET_SWEEP_FROM(Sfalse) +# define SET_BACKREFERENCE(p) sweep_from = p; +# define PUSH_BACKREFERENCE(p) ptr old_sweep_from = sweep_from; SET_SWEEP_FROM(p); +# define POP_BACKREFERENCE() SET_SWEEP_FROM(old_sweep_from); +# define ADD_BACKREFERENCE_FROM(p, from_p) \ + { IGEN tg = target_generation; \ + if ((S_G.enable_object_backreferences) && (target_generation < static_generation)) \ + S_G.gcbackreference[tg] = S_cons_in(space_impure, tg, \ + S_cons_in(space_impure, tg, p, from_p), \ + S_G.gcbackreference[tg]); } +# define ADD_BACKREFERENCE(p) ADD_BACKREFERENCE_FROM(p, sweep_from) +#else +# define BACKREFERENCES_ENABLED 0 +# define WITH_TOP_BACKREFERENCE(v, e) e +# define SET_BACKREFERENCE(p) +# define PUSH_BACKREFERENCE(p) +# define POP_BACKREFERENCE() +# define ADD_BACKREFERENCE(p) +# define ADD_BACKREFERENCE_FROM(p, from_p) +#endif + /* Values for a guardian entry's `pending` field when it's added to a seginfo's pending list: */ enum { @@ -280,7 +305,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { carefully we may reduce fragmentation and sweeping cost */ s = RECORDDESCPM(rtd) == FIX(1) && RECORDDESCMPM(rtd) == FIX(0) ? space_data : - RECORDDESCPM(rtd) == FIX(-1) ? + ((RECORDDESCPM(rtd) == FIX(-1)) && !BACKREFERENCES_ENABLED) ? RECORDDESCMPM(rtd) == FIX(0) ? space_pure : space_impure : @@ -302,6 +327,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { } } 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 @@ -309,11 +335,10 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { 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 */ - if ((uptr)tf & vector_immutable_flag) { - find_room(space_pure, tg, type_typed_object, n, p); - } else { - find_room(space_impure, tg, type_typed_object, n, p); - } + 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); @@ -350,7 +375,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { #ifdef ENABLE_OBJECT_COUNTS S_G.countof[tg][countof_tlc] += 1; #endif /* ENABLE_OBJECT_COUNTS */ - find_room(space_impure, tg, type_typed_object, size_tlc, p); + 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); @@ -364,14 +389,14 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { 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 */ - if ((uptr)tf == type_immutable_box) { - find_room(space_pure, tg, type_typed_object, size_box, p); - } else { - find_room(space_impure, tg, type_typed_object, size_box, p); - } + 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) { @@ -489,6 +514,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { 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 @@ -530,17 +556,19 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { } } else { iptr len, n; + ISPC s; 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 (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) { - find_room(space_impure, tg, type_closure, n, p); - } else { - find_room(space_pure, tg, type_closure, n, p); - } + s = (BACKREFERENCES_ENABLED + ? space_closure + : ((CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) + ? space_impure + : space_pure)); + find_room(s, tg, type_closure, n, p); copy_ptrs(type_closure, p, pp, n); SETCLOSCODE(p,code); /* pad if necessary */ @@ -573,6 +601,8 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { FWDMARKER(pp) = forward_marker; FWDADDRESS(pp) = p; + ADD_BACKREFERENCE(p) + return p; } @@ -588,6 +618,8 @@ static void sweep_ptrs(pp, n) ptr *pp; iptr n; { 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) @@ -599,12 +631,12 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) { relocate(&INITCDR(p)) } } else if (t == type_closure) { - if (sweep_pure) { - ptr code; + ptr code; - code = CLOSCODE(p); + code = CLOSCODE(p); + if (sweep_pure || (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset))) { relocate(&code) - SETCLOSCODE(p,code); + SETCLOSCODE(p,code); if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) sweep_continuation(p); else @@ -631,6 +663,10 @@ static void sweep(ptr tc, ptr p, IBOOL 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)) @@ -653,6 +689,8 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) { } else { S_error_abort("sweep(gc): illegal type"); } + + POP_BACKREFERENCE() } /* sweep_in_old() is like sweep(), but the goal is to sweep the @@ -905,6 +943,13 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { } #endif /* ENABLE_OBJECT_COUNTS */ + /* Clear any backreference lists for copied generations */ + for (g = 0; g <= mcg; g += 1) { + S_G.gcbackreference[g] = Snil; + } + + SET_BACKREFERENCE(Sfalse) /* #f => root or locked */ + /* pre-collection handling of locked objects. */ /* create a single sorted_locked_object vector for all copied generations @@ -962,7 +1007,10 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { v = sorted_locked_objects; i = Svector_length(v); x = *(vp = &INITVECTIT(v, 0)); - do sweep(tc, x, 1); while (--i != 0 && (x = *++vp) != MAXPTR); + 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)) { @@ -1088,13 +1136,16 @@ 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(rep)) { + PUSH_BACKREFERENCE(rep) sweep_in_old(tc, rep); + POP_BACKREFERENCE() + } INITGUARDIANNEXT(ls) = maybe_final_ordered_ls; maybe_final_ordered_ls = ls; } } else { - relocate(&rep); + WITH_TOP_BACKREFERENCE(ls, relocate(&rep)); /* if tconc was old it's been forwarded */ tconc = GUARDIANTCONC(ls); @@ -1130,12 +1181,15 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { } rep = GUARDIANREP(ls); - relocate(&rep); + WITH_TOP_BACKREFERENCE(ls, relocate(&rep)); relocate_rep = 1; #ifdef ENABLE_OBJECT_COUNTS S_G.countof[tg][countof_guardian] += 1; #endif /* ENABLE_OBJECT_COUNTS */ + /* In backreference mode, we rely on sweep of the guardian + entry not registering any backreferences. Otherwise, + bogus pair pointers would get created. */ find_room(space_pure, tg, typemod, size_guardian_entry, p); INITGUARDIANOBJ(p) = GUARDIANOBJ(ls); INITGUARDIANREP(p) = rep; @@ -1488,15 +1542,17 @@ static void forward_or_bwp(pp, p) ptr *pp; ptr p; { static void sweep_generation(tc, g) ptr tc; IGEN g; { ptr *slp, *nlp; ptr *pp, p, *nl; - + do { change = 0; sweep_space(space_impure, { + SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) /* only pairs put here in backreference mode */ relocate_help(pp, p) p = *(pp += 1); relocate_help(pp, p) pp += 1; }) + SET_BACKREFERENCE(Sfalse) sweep_space(space_symbol, { p = TYPE((ptr)pp, type_symbol); @@ -1511,10 +1567,12 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { }) sweep_space(space_weakpair, { + SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) p = *(pp += 1); relocate_help(pp, p) pp += 1; }) + SET_BACKREFERENCE(Sfalse) sweep_space(space_ephemeron, { p = TYPE((ptr)pp, type_pair); @@ -1523,11 +1581,13 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { }) sweep_space(space_pure, { + SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) /* only pairs put here in backreference mode */ relocate_help(pp, p) p = *(pp += 1); relocate_help(pp, p) pp += 1; }) + SET_BACKREFERENCE(Sfalse) sweep_space(space_continuation, { p = TYPE((ptr)pp, type_closure); @@ -1537,7 +1597,7 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { sweep_space(space_pure_typed_object, { p = TYPE((ptr)pp, type_typed_object); - pp = (ptr *)((uptr)pp + sweep_typed_object(p)); + pp = (ptr *)((uptr)pp + sweep_typed_object(tc, p)); }) sweep_space(space_code, { @@ -1553,6 +1613,19 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); }) + /* space used only as needed for backreferences: */ + sweep_space(space_impure_typed_object, { + p = TYPE((ptr)pp, type_typed_object); + pp = (ptr *)((uptr)pp + sweep_typed_object(tc, p)); + }) + + /* space used only as needed for backreferences: */ + sweep_space(space_closure, { + p = TYPE((ptr)pp, type_closure); + sweep(tc, p, 1); + pp = (ptr *)((uptr)pp + size_object(p)); + }) + /* 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 @@ -1594,6 +1667,8 @@ static iptr size_object(p) ptr p; { 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) { @@ -1616,7 +1691,7 @@ static iptr size_object(p) ptr p; { } } -static iptr sweep_typed_object(p) ptr p; { +static iptr sweep_typed_object(tc, p) ptr tc; ptr p; { ptr tf = TYPEFIELD(p); if (TYPEP(tf, mask_record, type_record)) { @@ -1626,13 +1701,16 @@ static iptr sweep_typed_object(p) ptr p; { sweep_thread(p); return size_thread; } else { - S_error_abort("sweep_typed_object(gc): unexpected type"); - return 0 /* not reached */; + /* We get here only if backreference mode pushed othertyped objects into + a typed space */ + sweep(tc, p, 1); + return size_object(p); } } static void sweep_symbol(p) ptr p; { ptr val, code; + PUSH_BACKREFERENCE(p) val = SYMVAL(p); relocate(&val); @@ -1644,9 +1722,12 @@ static void sweep_symbol(p) ptr 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)) @@ -1662,11 +1743,13 @@ static void sweep_port(p) ptr 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); @@ -1722,9 +1805,12 @@ static void sweep_thread(p) ptr p; { relocate(&VIRTREG(tc, i)); } } + + POP_BACKREFERENCE() } static void sweep_continuation(p) ptr p; { + PUSH_BACKREFERENCE(p) relocate(&CONTWINDERS(p)) /* bug out for shot 1-shot continuations */ @@ -1738,6 +1824,8 @@ static void sweep_continuation(p) ptr 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 */ @@ -1830,7 +1918,9 @@ static void sweep_stack(base, fp, ret) uptr base, fp, ret; { } \ 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; @@ -1842,6 +1932,7 @@ static int scan_record_for_self(x) ptr x; { static IGEN sweep_dirty_record(x) ptr x; { ptr *pp; ptr num; ptr rtd; IGEN tg, youngest; + PUSH_BACKREFERENCE(x) tg = target_generation; youngest = 0xff; @@ -1882,12 +1973,16 @@ static IGEN sweep_dirty_record(x) ptr x; { } } + 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); @@ -1942,6 +2037,8 @@ static void sweep_code_object(tc, co) ptr tc, co; { } S_record_code_mod(tc, (uptr)&CODEIT(co,0), (uptr)CODELEN(co)); + + POP_BACKREFERENCE() } typedef struct _weakseginfo { @@ -1975,6 +2072,8 @@ static void sweep_dirty(void) { IGEN from_g, to_g; seginfo *dirty_si, *nextsi; + PUSH_BACKREFERENCE(Snil) /* '() => from unspecified old object */ + tg = target_generation; mcg = max_copied_generation; weaksegments_to_resweep = NULL; @@ -2032,7 +2131,7 @@ static void sweep_dirty(void) { /* assume we won't find any wrong-way pointers */ youngest = 0xff; - if (s == space_impure) { + if ((s == space_impure) || (s == space_impure_typed_object) || (s == space_closure)) { while (pp < ppend && *pp != forward_marker) { /* handle two pointers at a time */ relocate_dirty(pp,tg,youngest) @@ -2052,9 +2151,8 @@ static void sweep_dirty(void) { (size_symbol / sizeof(ptr)); while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a symbol. no harm. */ - ptr p, val, code; - - p = TYPE((ptr)pp, type_symbol); + ptr val, code, p = TYPE((ptr)pp, type_symbol); + PUSH_BACKREFERENCE(p) val = SYMVAL(p); relocate_dirty(&val,tg,youngest) @@ -2068,6 +2166,8 @@ static void sweep_dirty(void) { relocate_dirty(&INITSYMHASH(p),tg,youngest) pp += size_symbol / sizeof(ptr); + + POP_BACKREFERENCE() } } else if (s == space_port) { /* old ports cannot overlap segment boundaries @@ -2082,6 +2182,7 @@ static void sweep_dirty(void) { while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a port. no harm. */ ptr p = TYPE((ptr)pp, type_typed_object); + PUSH_BACKREFERENCE(p) relocate_dirty(&PORTHANDLER(p),tg,youngest) relocate_dirty(&PORTINFO(p),tg,youngest) @@ -2100,6 +2201,8 @@ static void sweep_dirty(void) { } pp += size_port / sizeof(ptr); + + POP_BACKREFERENCE() } } else if (s == space_impure_record) { /* abandon hope all ye who enter here */ uptr j; ptr p, pnext; seginfo *si; @@ -2184,6 +2287,8 @@ static void sweep_dirty(void) { } } } + + POP_BACKREFERENCE() } static void resweep_dirty_weak_pairs() { @@ -2311,6 +2416,7 @@ static void add_trigger_ephemerons_to_repending(ptr pe) { static void check_ephemeron(ptr pe, int add_to_trigger) { ptr p; seginfo *si; + PUSH_BACKREFERENCE(pe); p = Scar(pe); if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) { @@ -2332,6 +2438,8 @@ static void check_ephemeron(ptr pe, int add_to_trigger) { } else { relocate(&INITCDR(pe)) } + + POP_BACKREFERENCE(); } static void check_pending_ephemerons() { @@ -2361,7 +2469,8 @@ static void check_pending_ephemerons() { static int check_dirty_ephemeron(ptr pe, int tg, int youngest) { ptr p; seginfo *si; - + PUSH_BACKREFERENCE(pe); + p = Scar(pe); if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { if (si->space & space_old && !locked(p)) { @@ -2391,6 +2500,8 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) { relocate_dirty(&INITCDR(pe), tg, youngest) } + POP_BACKREFERENCE() + return youngest; } diff --git a/c/gcwrapper.c b/c/gcwrapper.c index 5516e86fd7..8b2ba58f66 100644 --- a/c/gcwrapper.c +++ b/c/gcwrapper.c @@ -349,6 +349,27 @@ ptr S_object_counts(void) { return outer_alist; } +IBOOL S_enable_object_backreferences(void) { + return S_G.enable_object_backreferences; +} + +void S_set_enable_object_backreferences(IBOOL eoc) { + S_G.enable_object_backreferences = eoc; +} + +ptr S_object_backreferences(void) { + IGEN g; ptr ls = Snil; + + tc_mutex_acquire() + + for (g = S_G.max_nonstatic_generation+1; g--; ) + ls = Scons(S_G.gcbackreference[g], ls); + + tc_mutex_release() + + return ls; +} + /* Scompact_heap(). Compact into as few O/S chunks as possible and * move objects into static generation */ @@ -819,7 +840,7 @@ void S_do_gc(IGEN mcg, IGEN tg) { void S_gc(ptr tc, IGEN mcg, IGEN tg) { - if (tg == static_generation || S_G.enable_object_counts) + if (tg == static_generation || S_G.enable_object_counts || S_G.enable_object_backreferences) S_gc_oce(tc, mcg, tg); else S_gc_ocd(tc, mcg, tg); diff --git a/c/globals.h b/c/globals.h index 9006d1a7a3..168b6f1391 100644 --- a/c/globals.h +++ b/c/globals.h @@ -73,6 +73,7 @@ EXTERN struct { ptr heap_reserve_ratio_id; IBOOL retain_static_relocation; IBOOL enable_object_counts; + IBOOL enable_object_backreferences; /* foreign.c */ ptr foreign_static; @@ -123,6 +124,7 @@ EXTERN struct { uptr countof_size[countof_types]; ptr static_id; ptr countof_names; + ptr gcbackreference[static_generation+1]; /* intern.c */ iptr *oblist_length_pointer; diff --git a/c/prim.c b/c/prim.c index 0041012a81..644b3a557e 100644 --- a/c/prim.c +++ b/c/prim.c @@ -177,6 +177,9 @@ void S_prim_init() { Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts); Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts); Sforeign_symbol("(cs)object_counts", (void *)S_object_counts); + Sforeign_symbol("(cs)enable_object_backreferences", (void *)S_enable_object_backreferences); + Sforeign_symbol("(cs)set_enable_object_backreferences", (void *)S_set_enable_object_backreferences); + Sforeign_symbol("(cs)object_backreferences", (void *)S_object_backreferences); } static void s_instantiate_code_object() { diff --git a/c/scheme.c b/c/scheme.c index 7717f581a9..dc1f4d1a85 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -948,6 +948,7 @@ extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); { S_G.retain_static_relocation = 0; S_G.enable_object_counts = 0; + S_G.enable_object_backreferences = 0; boot_count = 0; diff --git a/s/back.ss b/s/back.ss index ad18b522c0..2a9b8d6e19 100644 --- a/s/back.ss +++ b/s/back.ss @@ -73,6 +73,13 @@ [() ($get-enable-object-counts)] [(b) ($set-enable-object-counts b)]))) +(define-who enable-object-backreferences + (let ([$get-enable-object-backreferences (foreign-procedure "(cs)enable_object_backreferences" () boolean)] + [$set-enable-object-backreferences (foreign-procedure "(cs)set_enable_object_backreferences" (boolean) void)]) + (case-lambda + [() ($get-enable-object-backreferences)] + [(b) ($set-enable-object-backreferences b)]))) + (define-who collect-trip-bytes (make-parameter (constant default-collect-trip-bytes) diff --git a/s/cmacros.ss b/s/cmacros.ss index 34bb833644..a695e7bb1f 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -645,11 +645,13 @@ (continuation "cont" #\k 7) ; (code "code" #\c 8) ; (pure-typed-object "p-tobj" #\r 9) ; - (impure-record "ip-rec" #\s 10)) ; + (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 (unswept - (data "data" #\d 11))) ; unswept objects allocated here + (data "data" #\d 13))) ; unswept objects allocated here (unreal - (empty "empty" #\e 12))) ; available segments + (empty "empty" #\e 14))) ; available segments ;;; enumeration of types for which gc tracks object counts ;;; also update gc.c diff --git a/s/inspect.ss b/s/inspect.ss index bd54c87116..213a8573f0 100644 --- a/s/inspect.ss +++ b/s/inspect.ss @@ -2880,3 +2880,5 @@ [(x g) ($compute-composition x (filter-generation who g))]))) (define object-counts (foreign-procedure "(cs)object_counts" () ptr)) + +(define object-backreferences (foreign-procedure "(cs)object_backreferences" () ptr)) diff --git a/s/primdata.ss b/s/primdata.ss index 6a36e6a1f4..3015a7ca48 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -944,6 +944,7 @@ (debug-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags]) (debug-on-exception [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) + (enable-object-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) (expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags]) @@ -1465,6 +1466,7 @@ (nonnegative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) (nonpositive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) (number->string [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc]) ; radix not restricted to 2, 4, 8, 16 + (object-backreferences [sig [() -> (ptr)]] [flags alloc]) (object-counts [sig [() -> (ptr)]] [flags alloc]) (oblist [sig [() -> (list)]] [flags alloc]) (open-fd-input-port [sig [(sub-ufixnum) (sub-ufixnum sub-symbol) (sub-ufixnum sub-symbol maybe-transcoder) -> (input-port)]] [flags true])