Merge branch 'gcbt' of github.com:mflatt/ChezScheme
original commit: 51c6b2a880000ce754e1595f4481957e9fc7f722
This commit is contained in:
Matthew Flatt
commit
efb93d2653
6
LOG
6
LOG
|
|
@ -1035,3 +1035,9 @@
|
|||
cmacros.ss, cpnanopass.ss, interpret.ss, library.ss,
|
||||
primdata.ss, prims.ss, gc.c, objects.stex, release_notes.stex
|
||||
misc.ms, mats/patch*, mats/root*
|
||||
- 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
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -16,4 +16,5 @@
|
|||
|
||||
#define GCENTRY S_gc_oce
|
||||
#define ENABLE_OBJECT_COUNTS
|
||||
#define ENABLE_BACKREFERENCE
|
||||
#include "gc.c"
|
||||
|
|
|
|||
165
c/gc.c
165
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
|
||||
|
|
@ -536,7 +562,9 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
|
|||
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)) {
|
||||
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
|
||||
|
|
@ -577,6 +605,8 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
|
|||
FWDMARKER(pp) = forward_marker;
|
||||
FWDADDRESS(pp) = p;
|
||||
|
||||
ADD_BACKREFERENCE(p)
|
||||
|
||||
return p;
|
||||
}
|
||||
|
||||
|
|
@ -592,6 +622,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)
|
||||
|
|
@ -635,6 +667,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))
|
||||
|
|
@ -657,6 +693,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
|
||||
|
|
@ -909,6 +947,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
|
||||
|
|
@ -966,7 +1011,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)) {
|
||||
|
|
@ -1092,17 +1140,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));
|
||||
|
|
@ -1134,12 +1185,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;
|
||||
|
|
@ -1496,11 +1550,13 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; {
|
|||
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);
|
||||
|
|
@ -1515,10 +1571,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);
|
||||
|
|
@ -1527,11 +1585,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);
|
||||
|
|
@ -1541,7 +1601,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, {
|
||||
|
|
@ -1557,6 +1617,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
|
||||
|
|
@ -1598,6 +1671,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) {
|
||||
|
|
@ -1620,7 +1695,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)) {
|
||||
|
|
@ -1630,13 +1705,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);
|
||||
|
|
@ -1648,9 +1726,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))
|
||||
|
|
@ -1666,11 +1747,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);
|
||||
|
|
@ -1730,9 +1813,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 */
|
||||
|
|
@ -1746,6 +1832,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 */
|
||||
|
|
@ -1838,7 +1926,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;
|
||||
|
|
@ -1850,6 +1940,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;
|
||||
|
|
@ -1890,12 +1981,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);
|
||||
|
|
@ -1950,6 +2045,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 {
|
||||
|
|
@ -1983,6 +2080,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;
|
||||
|
|
@ -2040,7 +2139,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)
|
||||
|
|
@ -2060,9 +2159,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)
|
||||
|
|
@ -2076,6 +2174,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
|
||||
|
|
@ -2090,6 +2190,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)
|
||||
|
|
@ -2108,6 +2209,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;
|
||||
|
|
@ -2192,6 +2295,8 @@ static void sweep_dirty(void) {
|
|||
}
|
||||
}
|
||||
}
|
||||
|
||||
POP_BACKREFERENCE()
|
||||
}
|
||||
|
||||
static void resweep_dirty_weak_pairs() {
|
||||
|
|
@ -2319,6 +2424,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)) {
|
||||
|
|
@ -2340,6 +2446,8 @@ static void check_ephemeron(ptr pe, int add_to_trigger) {
|
|||
} else {
|
||||
relocate(&INITCDR(pe))
|
||||
}
|
||||
|
||||
POP_BACKREFERENCE();
|
||||
}
|
||||
|
||||
static void check_pending_ephemerons() {
|
||||
|
|
@ -2369,6 +2477,7 @@ 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) {
|
||||
|
|
@ -2399,6 +2508,8 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) {
|
|||
relocate_dirty(&INITCDR(pe), tg, youngest)
|
||||
}
|
||||
|
||||
POP_BACKREFERENCE()
|
||||
|
||||
return youngest;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
3
c/prim.c
3
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() {
|
||||
|
|
|
|||
|
|
@ -996,6 +996,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;
|
||||
|
||||
|
|
|
|||
|
|
@ -4622,6 +4622,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,
|
||||
|
|
|
|||
84
mats/7.ms
84
mats/7.ms
|
|
@ -3841,6 +3841,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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
@ -1470,6 +1471,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])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user