first cut at backreference support from GC
original commit: 49fff33f7284980823e9d993869396a145778abe
This commit is contained in:
Matthew Flatt
parent
bc3d26bd55
commit
0cdfda55c5
|
|
@ -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"
|
||||
|
|
|
|||
173
c/gc.c
173
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,10 +631,10 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) {
|
|||
relocate(&INITCDR(p))
|
||||
}
|
||||
} else if (t == type_closure) {
|
||||
if (sweep_pure) {
|
||||
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))
|
||||
|
|
@ -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;
|
||||
|
|
@ -1492,11 +1546,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);
|
||||
|
|
@ -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,6 +2469,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) {
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
/* 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;
|
||||
|
|
|
|||
3
c/prim.c
3
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() {
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user