From 48228739fe80d8139bdefb4d24e477468eb40493 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Jul 2018 18:08:10 -0600 Subject: [PATCH] add `object-references` to reflect GC's tracing of objects The `object-references` function is intended to support debugging of memory leaks by providing a mapping from each live object to the object that retained it. original commit: 61f6602b7e6c388c529f3c5995dcf71a7c42e005 --- LOG | 6 ++ c/externs.h | 3 + c/gc-oce.c | 1 + c/gc.c | 177 ++++++++++++++++++++++++++++++++++++++--------- c/gcwrapper.c | 23 +++++- c/globals.h | 2 + c/prim.c | 3 + c/scheme.c | 1 + csug/system.stex | 75 ++++++++++++++++++++ mats/7.ms | 84 ++++++++++++++++++++++ s/back.ss | 7 ++ s/cmacros.ss | 8 ++- s/inspect.ss | 2 + s/primdata.ss | 2 + 14 files changed, 357 insertions(+), 37 deletions(-) diff --git a/LOG b/LOG index ade39025d1..20f34c5813 100644 --- a/LOG +++ b/LOG @@ -975,3 +975,9 @@ prims.ss, primdata.ss, cp0.ss, cpnanopass.ss, cmacros.ss, mkheader.ss, gc.c, segment.c, types.h, 4.ms, smgmt.stex, release_notes.stex +- add object-backreferences and enable-object-backreferences as an aid + to debugging memory leaks + back.ss, cmacros.ss, inspect.ss, primdata.ss, + gc-oce.c, gc.c, gcwrapper.c, prim.c, scheme.c, + globals.h, externs.h, + system.stex, 7.ms diff --git a/c/externs.h b/c/externs.h index 692712e357..c6e47b2275 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 498e6ad44d..fe2b636197 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,13 +556,15 @@ 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 */ - find_room(space_pure, tg, type_closure, n, p); + s = (BACKREFERENCES_ENABLED ? space_closure : space_pure); + find_room(s, tg, type_closure, n, p); copy_ptrs(type_closure, p, pp, n); SETCLOSCODE(p,code); /* pad if necessary */ @@ -569,6 +597,8 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { FWDMARKER(pp) = forward_marker; FWDADDRESS(pp) = p; + ADD_BACKREFERENCE(p) + return p; } @@ -584,6 +614,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) @@ -595,12 +627,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) { relocate(&code) - SETCLOSCODE(p,code); + SETCLOSCODE(p,code); if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) sweep_continuation(p); else @@ -627,6 +659,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)) @@ -649,6 +685,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 @@ -901,6 +939,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 @@ -958,7 +1003,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)) { @@ -1084,17 +1132,20 @@ 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); - /* if tconc was old it's been forwarded */ tconc = GUARDIANTCONC(ls); + WITH_TOP_BACKREFERENCE(tconc, relocate(&rep)); + old_end = Scdr(tconc); /* allocating pair in tg means it will be swept, which is wasted effort, but should cause no harm */ new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0)); @@ -1126,12 +1177,15 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) { } rep = GUARDIANREP(ls); - relocate(&rep); + WITH_TOP_BACKREFERENCE(tconc, 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; @@ -1484,15 +1538,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); @@ -1507,10 +1563,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); @@ -1519,11 +1577,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); @@ -1533,7 +1593,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, { @@ -1549,6 +1609,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 @@ -1590,6 +1663,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) { @@ -1612,7 +1687,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)) { @@ -1622,13 +1697,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); @@ -1640,9 +1718,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)) @@ -1658,11 +1739,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 e1c29ff3cc..86f74d89be 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; ptr scheme_version_id; ptr make_load_binary_id; ptr load_binary; @@ -126,6 +127,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 85856e3be1..8479be8cc2 100644 --- a/c/prim.c +++ b/c/prim.c @@ -184,6 +184,9 @@ void S_prim_init() { 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)fire_collector", (void *)S_fire_collector); + 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 15a10dfca4..dff881b5e0 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -990,6 +990,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/csug/system.stex b/csug/system.stex index 84df092d9e..f26e0e60d3 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -4588,6 +4588,81 @@ of \scheme{(collect-maximum-generation)}, inclusive, or the symbol (object-counts))))) ;=> (2 . 16) \endschemedisplay +%---------------------------------------------------------------------------- + +\entryheader +\formdef{enable-object-backreferences}{\categoryglobalparameter}{enable-object-backreferences} +\listlibraries +\endentryheader + +The value of \scheme{enable-object-backreferences} is a boolean value that +determines whether the collector records information about which other object +caused an object to be retained and +hence whether the backreferences reported by the procedure +\scheme{object-backreferences} are accurate. +The parameter is set to \scheme{#f} by default, since backreference recording +adds overhead to collection. + +Beware that backreference recording can have small performance affects +even after it is disabled---at least until the next collection over +the same generations---since backreference records constrain the way +that the collector stores some objects. + +\entryheader +\formdef{object-backreferences}{\categoryprocedure}{(object-backreferences)} +\returns a list of list of pairs +\listlibraries +\endentryheader + +The procedure \scheme{object-backreferences} returns a list of +backreference lists. Each backreference list is a list of pairs, where +the \scheme{car} of the pair is a referenced object, and the +\scheme{cdr} of the pair is either \scheme{#f} or a value that caused +the \scheme{car}'s value or be retained during collection. The +\scheme{cdr} of a backreference pair is \scheme{#f} if the object in +the \scheme{car} is retained by a root reference within the system's +implementation or static generation. By locating the \scheme{cdr} of +one pair as the \scheme{car} of another, chains of objects as +discovered by the collector can be traced back to roots. + +The list returned by \scheme{object-backreferences} contains one +backreference list for each nonstatic generation (in order, starting +with generation \scheme{0}). An object is recorded in a backreference +list for the destination generation to which it is moved by +collection. The collector records backreference information only when +\scheme{enable-object-backreferences} is set to a true value, and only +for objects that start in generations that are collected. + +For example, assuming that backreferences have not been previously +enabled, the result of +% +\schemedisplay +(collect-request-handler void) +(enable-object-backreferences #t) +(collect 0) +(enable-object-backreferences #f) +(object-backreferences) +\endschemedisplay +% +will have a non-empty backreference list only for the second +list in the result (i.e., the list for generation \scheme{1}). + +Although \scheme{object-backreferences} reports generation-specific +information to reflect its cooperation with generational collection, +backreference information is most useful after a collection of all +generations up to the maximum nonstatic generation. In that case, +backreference information can be used to discover why a particular +value or kind of value remains allocated or remains in a weak pair +after garbage collection. + +\schemedisplay +(collect-request-handler void) +(enable-object-backreferences #t) +(define b (box "hello")) +(collect 0) +(assq (unbox b) (cadr (object-backreferences))) ;=> ("hello" . #&"hello") +\endschemedisplay + \section{Cost Centers\label{SECTMISCCOSTCENTERS}} Cost centers are used to track the bytes allocated, instructions executed, diff --git a/mats/7.ms b/mats/7.ms index 1b8cae5751..8d37c313fe 100644 --- a/mats/7.ms +++ b/mats/7.ms @@ -3804,6 +3804,90 @@ evaluating module init (or (not a) (not (assq 'static (cdr a))))) ) +(mat object-references + (begin + (define variable-whose-value-is-a-gensym (gensym)) + (define guardian-to-hold-gensyms (make-guardian)) + ;; works on tree-shaped objects, except that + ;; weak/ephemeron pairs can create DAGs; if a weak pair has + ;; a non-#!bwp in the `car`, it must be referenced + ;; by a box or by `guardian-to-hold-gensyms` + (define (check-references obj) + (let ([backrefs (make-eq-hashtable)] + [old-collect (collect-request-handler)]) + (enable-object-backreferences #t) + (collect-request-handler void) + (collect (collect-maximum-generation)) + (for-each (lambda (brs) + (for-each (lambda (br) + (hashtable-set! backrefs (car br) (cdr br))) + brs)) + (object-backreferences)) + (enable-object-backreferences #f) + (collect-request-handler old-collect) + (and + ;; Check the given object + (let loop ([obj obj] [parent #f]) + (and (or (not parent) + (null? obj) + (boolean? obj) + (eq? parent (hashtable-ref backrefs obj #f))) + (cond + [(pair? obj) + (and (cond + [(weak-pair? obj) + (let ([a (car obj)]) + (or (eq? a #!bwp) + (let ([p (hashtable-ref backrefs a #f)]) + (or (box? p) + ;; retained by `guardian-to-hold-gensyms` + ;; means retains by it's tconc + (and (pair? p) + (eq? guardian-to-hold-gensyms + (hashtable-ref backrefs p #f)))))))] + [(ephemeron-pair? obj) #t] + [else + (loop (car obj) obj)]) + (loop (cdr obj) obj))] + [(vector? obj) + (let vloop ([i 0]) + (or (= i (vector-length obj)) + (and (loop (vector-ref obj i) obj) + (vloop (add1 i)))))] + [(box? obj) + (loop (unbox obj) obj)] + [(procedure? obj) + (let ([insp (inspect/object obj)]) + (let ploop ([i 0]) + (or (= i (insp 'length)) + (and (loop (((insp 'ref i) 'ref) 'value) obj) + (ploop (add1 i))))))] + [else #t]))) + ;; Check a symbol binding + (let ([var (hashtable-ref backrefs variable-whose-value-is-a-gensym #f)]) + (and (eq? 'symbol ((inspect/object var) 'type)) + (equal? "variable-whose-value-is-a-gensym" + (((inspect/object var) 'name) 'value))))))) + #t) + (check-references (list (gensym) + (vector (gensym) (box (cons (gensym) (gensym))) (gensym)) + (let ([v (gensym)]) + (lambda () + v)) + ;; make sure `weak-cons` doesn't retain + (weak-cons (gensym) #f) + (let ([v (gensym)]) + ;; weak pair won't count as retaining reference + (weak-cons v + ;; containing box will count + (box v))) + (let ([v (gensym)]) + (guardian-to-hold-gensyms v) + (weak-cons v #f)) + (let ([v (gensym)]) + (list v (ephemeron-cons v (gensym)))))) +) + (mat collect-rendezvous (begin (define (check-working-gc collect) diff --git a/s/back.ss b/s/back.ss index c932edd766..7f8b59fe99 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 616572ef59..7fcb3944e9 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 242c41fb0f..7fd023c0e5 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 af9ebe8dfc..385683019f 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -947,6 +947,7 @@ (default-record-equal-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags]) (default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags]) (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]) @@ -1464,6 +1465,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])