Merge branch 'orderfnl' of github.com:mflatt/ChezScheme
original commit: abb84eb7b0dbb9824d0b32407143589ff309a0fb
This commit is contained in:
Matthew Flatt
commit
b54495f58d
4
LOG
4
LOG
|
|
@ -991,3 +991,7 @@
|
|||
system.stex, release_notes.stex
|
||||
- fix boot_call and the invoke code object to handle multiple values
|
||||
scheme.c, cpnanopass.ss, 7.ms, release_notes.stex, system.stex
|
||||
- add ordered guardians through a new optional argument to make-guardian
|
||||
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
|
||||
|
|
|
|||
401
c/gc.c
401
c/gc.c
|
|
@ -32,6 +32,8 @@ static IBOOL search_locked PROTO((ptr p));
|
|||
static ptr copy PROTO((ptr pp, seginfo *si));
|
||||
static void sweep_ptrs PROTO((ptr *p, iptr n));
|
||||
static void sweep PROTO((ptr tc, ptr p, IBOOL sweep_pure));
|
||||
static void sweep_in_old PROTO((ptr tc, ptr p));
|
||||
static int scan_ptrs_for_self PROTO((ptr *pp, iptr len, ptr p));
|
||||
static ptr copy_stack PROTO((ptr old, iptr *length, iptr clength));
|
||||
static void resweep_weak_pairs PROTO((IGEN g));
|
||||
static void forward_or_bwp PROTO((ptr *pp, ptr p));
|
||||
|
|
@ -44,14 +46,17 @@ static void sweep_thread PROTO((ptr p));
|
|||
static void sweep_continuation PROTO((ptr p));
|
||||
static void sweep_stack PROTO((uptr base, uptr size, uptr ret));
|
||||
static void sweep_record PROTO((ptr x));
|
||||
static int scan_record_for_self PROTO((ptr x));
|
||||
static IGEN sweep_dirty_record PROTO((ptr x));
|
||||
static void sweep_code_object PROTO((ptr tc, ptr co));
|
||||
static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si));
|
||||
static void sweep_dirty PROTO((void));
|
||||
static void resweep_dirty_weak_pairs PROTO((void));
|
||||
static void add_pending_guardian PROTO((ptr gdn, ptr tconc));
|
||||
static void add_trigger_guardians_to_recheck PROTO((ptr ls));
|
||||
static void add_ephemeron_to_pending PROTO((ptr p));
|
||||
static void add_trigger_ephemerons_to_repending PROTO((ptr p));
|
||||
static void check_trigger_ephemerons PROTO((seginfo *si));
|
||||
static void check_triggers PROTO((seginfo *si));
|
||||
static void check_ephemeron PROTO((ptr pe, int add_to_trigger));
|
||||
static void check_pending_ephemerons PROTO(());
|
||||
static int check_dirty_ephemeron PROTO((ptr pe, int tg, int youngest));
|
||||
|
|
@ -72,6 +77,14 @@ static ptr sweep_loc[max_real_space+1];
|
|||
static ptr orig_next_loc[max_real_space+1];
|
||||
static ptr sorted_locked_objects;
|
||||
static ptr tlcs_to_rehash;
|
||||
static ptr recheck_guardians_ls;
|
||||
|
||||
/* Values for a guardian entry's `pending` field when it's added to a
|
||||
seginfo's pending list: */
|
||||
enum {
|
||||
GUARDIAN_PENDING_HOLD,
|
||||
GUARDIAN_PENDING_FINAL
|
||||
};
|
||||
|
||||
static ptr append_bang(ptr ls1, ptr ls2) { /* assumes ls2 pairs are older than ls1 pairs, or that we don't car */
|
||||
if (ls2 == Snil) {
|
||||
|
|
@ -192,15 +205,23 @@ static IBOOL search_locked(ptr p) {
|
|||
|
||||
#define locked(p) (sorted_locked_objects != FIX(0) && search_locked(p))
|
||||
|
||||
FORCEINLINE void check_trigger_ephemerons(seginfo *si) {
|
||||
/* Registering ephemerons to recheck at the granularity of a segment
|
||||
means that the worst-case complexity of GC is quadratic in the
|
||||
number of objects that fit into a segment (but that only happens
|
||||
if the objects are ephemeron keys that are reachable just through
|
||||
a chain via the value field of the same ephemerons). */
|
||||
if (si->trigger_ephemerons) {
|
||||
add_trigger_ephemerons_to_repending(si->trigger_ephemerons);
|
||||
si->trigger_ephemerons = NULL;
|
||||
FORCEINLINE void check_triggers(seginfo *si) {
|
||||
/* Registering ephemerons and guardians to recheck at the
|
||||
granularity of a segment means that the worst-case complexity of
|
||||
GC is quadratic in the number of objects that fit into a segment
|
||||
(but that only happens if the objects are ephemeron keys that are
|
||||
reachable just through a chain via the value field of the same
|
||||
ephemerons). */
|
||||
if (si->has_triggers) {
|
||||
if (si->trigger_ephemerons) {
|
||||
add_trigger_ephemerons_to_repending(si->trigger_ephemerons);
|
||||
si->trigger_ephemerons = NULL;
|
||||
}
|
||||
if (si->trigger_guardians) {
|
||||
add_trigger_guardians_to_recheck(si->trigger_guardians);
|
||||
si->trigger_guardians = NULL;
|
||||
}
|
||||
si->has_triggers = 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -213,7 +234,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
|
|||
|
||||
change = 1;
|
||||
|
||||
check_trigger_ephemerons(si);
|
||||
check_triggers(si);
|
||||
|
||||
if ((t = TYPEBITS(pp)) == type_typed_object) {
|
||||
tf = TYPEFIELD(pp);
|
||||
|
|
@ -449,7 +470,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
|
|||
} else {
|
||||
ptr qq = Scdr(pp); ptr q; seginfo *qsi;
|
||||
if (qq != pp && TYPEBITS(qq) == type_pair && (qsi = MaybeSegInfo(ptr_get_segment(qq))) != NULL && qsi->space == si->space && FWDMARKER(qq) != forward_marker && !locked(qq)) {
|
||||
check_trigger_ephemerons(qsi);
|
||||
check_triggers(qsi);
|
||||
if (si->space == (space_weakpair | space_old)) {
|
||||
#ifdef ENABLE_OBJECT_COUNTS
|
||||
S_G.countof[tg][countof_weakpair] += 2;
|
||||
|
|
@ -630,6 +651,119 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) {
|
|||
}
|
||||
}
|
||||
|
||||
/* sweep_in_old() is like sweep(), but the goal is to sweep the
|
||||
object's content without copying the object itself, so we're sweep
|
||||
an object while it's still in old space. If an object refers back
|
||||
to itself, naively sweeping might copy the object while we're
|
||||
trying to sweep the old copy, which interacts badly with the words
|
||||
set to a forwarding marker and pointer. To handle that problem,
|
||||
sweep_in_old() is allowed to copy the object, since the object
|
||||
is going to get copied anyway. */
|
||||
static void sweep_in_old(ptr tc, ptr p) {
|
||||
ptr tf; ITYPE t;
|
||||
|
||||
/* Detect all the cases when we need to give up on in-place
|
||||
sweeping: */
|
||||
if ((t = TYPEBITS(p)) == type_pair) {
|
||||
ISPC s = SPACE(p) & ~(space_locked | space_old);
|
||||
if (s == space_ephemeron) {
|
||||
/* Weak reference can be ignored, so we do nothing */
|
||||
return;
|
||||
} else if (s != space_weakpair) {
|
||||
if (p == Scar(p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
}
|
||||
if (p == Scdr(p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
} else if (t == type_closure) {
|
||||
/* A closure can refer back to itself */
|
||||
ptr code = CLOSCODE(p);
|
||||
if (!(CODETYPE(code) & (code_flag_continuation << code_flags_offset))) {
|
||||
if (scan_ptrs_for_self(&CLOSIT(p, 0), CLOSLEN(p), p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
}
|
||||
} else if (t == type_symbol) {
|
||||
/* a symbol can refer back to itself as its own value */
|
||||
if (p == SYMVAL(p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
} else if (t == type_flonum) {
|
||||
/* nothing to sweep */
|
||||
return;
|
||||
/* typed objects */
|
||||
} else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) {
|
||||
if (scan_ptrs_for_self(&INITVECTIT(p, 0), Svector_length(p), p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
} else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) {
|
||||
/* nothing to sweep */
|
||||
return;
|
||||
} else if (TYPEP(tf, mask_record, type_record)) {
|
||||
relocate(&RECORDINSTTYPE(p));
|
||||
if (scan_record_for_self(p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
} else if (TYPEP(tf, mask_box, type_box)) {
|
||||
if (Sunbox(p) == p) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
} else if ((iptr)tf == type_ratnum) {
|
||||
/* can't refer back to itself */
|
||||
} else if ((iptr)tf == type_exactnum) {
|
||||
/* can't refer back to itself */
|
||||
} else if ((iptr)tf == type_inexactnum) {
|
||||
/* nothing to sweep */
|
||||
return;
|
||||
} else if (TYPEP(tf, mask_bignum, type_bignum)) {
|
||||
/* nothing to sweep */
|
||||
return;
|
||||
} else if (TYPEP(tf, mask_port, type_port)) {
|
||||
/* a symbol can refer back to itself as info */
|
||||
if (p == PORTINFO(p)) {
|
||||
relocate(&p)
|
||||
return;
|
||||
}
|
||||
} else if (TYPEP(tf, mask_code, type_code)) {
|
||||
/* We don't expect code to be accessible to a layer that registers
|
||||
an ordered finalizer, but just in case, assume that code
|
||||
includes a self-reference */
|
||||
relocate(&p)
|
||||
return;
|
||||
} else if ((iptr)tf == type_thread) {
|
||||
/* threads are allocated with plain malloc(), so ordered
|
||||
finalization cannot work on them */
|
||||
S_error_abort("sweep_in_old(gc): cannot check thread");
|
||||
} else if ((iptr)tf == type_rtd_counts) {
|
||||
/* nothing to sweep */
|
||||
return;
|
||||
} else {
|
||||
S_error_abort("sweep_in_old(gc): illegal type");
|
||||
}
|
||||
|
||||
/* We've determined that `p` won't refer immediately back to itself,
|
||||
so it's ok to use sweep(). */
|
||||
sweep(tc, p, 1);
|
||||
}
|
||||
|
||||
static int scan_ptrs_for_self(ptr *pp, iptr len, ptr p) {
|
||||
while (len--) {
|
||||
if (*pp == p)
|
||||
return 1;
|
||||
pp += 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; {
|
||||
iptr n, m; ptr new;
|
||||
|
||||
|
|
@ -880,14 +1014,29 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
|
|||
sweep_generation(tc, tg);
|
||||
|
||||
/* handle guardians */
|
||||
{ ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls;
|
||||
{ ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls, maybe_final_ordered_ls;
|
||||
ptr obj, rep, tconc, next;
|
||||
IBOOL do_ordered = 0;
|
||||
|
||||
/* move each entry in guardian lists into one of:
|
||||
* pend_hold_ls if obj accessible
|
||||
* final_ls if obj not accessible and tconc accessible
|
||||
* pend_final_ls if obj not accessible and tconc not accessible */
|
||||
pend_hold_ls = final_ls = pend_final_ls = Snil;
|
||||
* pend_final_ls if obj not accessible and tconc not accessible
|
||||
* When a pend_hold_ls or pend_final_ls entry is tconc is
|
||||
* determined to be accessible, then it moves to hold_ls or
|
||||
* final_ls. When an entry in pend_hold_ls or pend_final_ls can't
|
||||
* be moved to final_ls or hold_ls, the entry moves into a
|
||||
* seginfo's trigger list (to avoid quadratic-time processing of
|
||||
* guardians). When the trigger fires, the entry is added to
|
||||
* recheck_guardians_ls, which is sorted back into pend_hold_ls
|
||||
* and pend_final_ls for another iteration.
|
||||
* Ordered and unordered guardian entries start out together;
|
||||
* when final_ls is processed, ordered entries are delayed by
|
||||
* moving them into maybe_final_ordered_ls, which is split back
|
||||
* into final_ls and pend_hold_ls after all unordered entries
|
||||
* have been handled. */
|
||||
pend_hold_ls = final_ls = pend_final_ls = maybe_final_ordered_ls = Snil;
|
||||
recheck_guardians_ls = Snil;
|
||||
|
||||
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
|
||||
ptr tc = (ptr)THREADTC(Scar(ls));
|
||||
|
|
@ -912,25 +1061,51 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
|
|||
IBOOL relocate_rep = final_ls != Snil;
|
||||
|
||||
/* relocate & add the final objects to their tconcs */
|
||||
for (ls = final_ls; ls != Snil; ls = GUARDIANNEXT(ls)) {
|
||||
ls = final_ls; final_ls = Snil;
|
||||
for (; ls != Snil; ls = next) {
|
||||
ptr old_end, new_end;
|
||||
|
||||
next = GUARDIANNEXT(ls);
|
||||
|
||||
rep = GUARDIANREP(ls);
|
||||
relocate(&rep);
|
||||
if (!do_ordered && (GUARDIANORDERED(ls) == Strue)) {
|
||||
/* Sweep from the representative, but don't copy the
|
||||
representative itself; if the object stays uncopied by
|
||||
the end, then the entry is really final, and we copy the
|
||||
representative only at that point; crucially, the
|
||||
representative can't itself be a tconc, so we
|
||||
won't discover any new tconcs at that point. */
|
||||
ptr obj = GUARDIANOBJ(ls);
|
||||
if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) {
|
||||
/* Object is reachable, so we might as well move
|
||||
this one to the hold list --- via pend_hold_ls, which
|
||||
leads to a copy to move to hold_ls */
|
||||
INITGUARDIANNEXT(ls) = pend_hold_ls;
|
||||
pend_hold_ls = ls;
|
||||
} else {
|
||||
seginfo *si;
|
||||
if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && (si->space & space_old) && !locked(rep))
|
||||
sweep_in_old(tc, rep);
|
||||
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);
|
||||
|
||||
old_end = Scdr(tconc);
|
||||
/* if tconc was old it's been forwarded */
|
||||
tconc = GUARDIANTCONC(ls);
|
||||
|
||||
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));
|
||||
new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0));
|
||||
#ifdef ENABLE_OBJECT_COUNTS
|
||||
S_G.countof[tg][countof_pair] += 1;
|
||||
S_G.countof[tg][countof_pair] += 1;
|
||||
#endif /* ENABLE_OBJECT_COUNTS */
|
||||
|
||||
SETCAR(old_end,rep);
|
||||
SETCDR(old_end,new_end);
|
||||
SETCDR(tconc,new_end);
|
||||
|
||||
SETCAR(old_end,rep);
|
||||
SETCDR(old_end,new_end);
|
||||
SETCDR(tconc,new_end);
|
||||
}
|
||||
}
|
||||
|
||||
/* discard static pend_hold_ls entries */
|
||||
|
|
@ -944,12 +1119,12 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
|
|||
if (FWDMARKER(tconc) == forward_marker)
|
||||
tconc = FWDADDRESS(tconc);
|
||||
else {
|
||||
INITGUARDIANNEXT(ls) = pend_hold_ls;
|
||||
pend_hold_ls = ls;
|
||||
INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_HOLD);
|
||||
add_pending_guardian(ls, tconc);
|
||||
continue;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
rep = GUARDIANREP(ls);
|
||||
relocate(&rep);
|
||||
relocate_rep = 1;
|
||||
|
|
@ -962,18 +1137,54 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
|
|||
INITGUARDIANREP(p) = rep;
|
||||
INITGUARDIANTCONC(p) = tconc;
|
||||
INITGUARDIANNEXT(p) = hold_ls;
|
||||
INITGUARDIANORDERED(p) = GUARDIANORDERED(ls);
|
||||
INITGUARDIANPENDING(p) = FIX(0);
|
||||
hold_ls = p;
|
||||
}
|
||||
}
|
||||
|
||||
if (!relocate_rep && !do_ordered && maybe_final_ordered_ls != Snil) {
|
||||
/* Switch to finishing up ordered. Move all maybe-final
|
||||
ordered entries to final_ls and pend_hold_ls */
|
||||
do_ordered = relocate_rep = 1;
|
||||
ls = maybe_final_ordered_ls; maybe_final_ordered_ls = Snil;
|
||||
for (; ls != Snil; ls = next) {
|
||||
ptr obj = GUARDIANOBJ(ls);
|
||||
next = GUARDIANNEXT(ls);
|
||||
if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) {
|
||||
/* Will defintely move to hold_ls, but the entry
|
||||
must be copied to move from pend_hold_ls to
|
||||
hold_ls: */
|
||||
INITGUARDIANNEXT(ls) = pend_hold_ls;
|
||||
pend_hold_ls = ls;
|
||||
} else {
|
||||
INITGUARDIANNEXT(ls) = final_ls;
|
||||
final_ls = ls;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (!relocate_rep) break;
|
||||
|
||||
sweep_generation(tc, tg);
|
||||
|
||||
ls = recheck_guardians_ls; recheck_guardians_ls = Snil;
|
||||
for ( ; ls != Snil; ls = next) {
|
||||
next = GUARDIANNEXT(ls);
|
||||
if (GUARDIANPENDING(ls) == FIX(GUARDIAN_PENDING_HOLD)) {
|
||||
INITGUARDIANNEXT(ls) = pend_hold_ls;
|
||||
pend_hold_ls = ls;
|
||||
} else {
|
||||
INITGUARDIANNEXT(ls) = pend_final_ls;
|
||||
pend_final_ls = ls;
|
||||
}
|
||||
}
|
||||
|
||||
/* move each entry in pend_final_ls into one of:
|
||||
* final_ls if tconc forwarded
|
||||
* pend_final_ls if tconc not forwarded */
|
||||
ls = pend_final_ls; final_ls = pend_final_ls = Snil;
|
||||
* pend_final_ls if tconc not forwarded
|
||||
* where the output pend_final_ls coresponds to pending in a segment */
|
||||
ls = pend_final_ls; pend_final_ls = Snil;
|
||||
for ( ; ls != Snil; ls = next) {
|
||||
tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls);
|
||||
|
||||
|
|
@ -982,8 +1193,8 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
|
|||
INITGUARDIANNEXT(ls) = final_ls;
|
||||
final_ls = ls;
|
||||
} else {
|
||||
INITGUARDIANNEXT(ls) = pend_final_ls;
|
||||
pend_final_ls = ls;
|
||||
INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_FINAL);
|
||||
add_pending_guardian(ls, tconc);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1571,52 +1782,62 @@ static void sweep_stack(base, fp, ret) uptr base, fp, ret; {
|
|||
}
|
||||
}
|
||||
|
||||
#define sweep_or_check_record(x, sweep_or_check) \
|
||||
ptr *pp; ptr num; ptr rtd; \
|
||||
\
|
||||
/* record-type descriptor was forwarded already */ \
|
||||
rtd = RECORDINSTTYPE(x); \
|
||||
num = RECORDDESCPM(rtd); \
|
||||
pp = &RECORDINSTIT(x,0); \
|
||||
\
|
||||
/* process cells for which bit in pm is set; quit when pm == 0. */ \
|
||||
if (Sfixnump(num)) { \
|
||||
/* ignore bit for already forwarded rtd */ \
|
||||
uptr mask = (uptr)UNFIX(num) >> 1; \
|
||||
if (mask == (uptr)-1 >> 1) { \
|
||||
ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; \
|
||||
while (pp < ppend) { \
|
||||
sweep_or_check(pp) \
|
||||
pp += 1; \
|
||||
} \
|
||||
} else { \
|
||||
while (mask != 0) { \
|
||||
if (mask & 1) sweep_or_check(pp) \
|
||||
mask >>= 1; \
|
||||
pp += 1; \
|
||||
} \
|
||||
} \
|
||||
} else { \
|
||||
iptr index; bigit mask; INT bits; \
|
||||
\
|
||||
/* bignum pointer mask may have been forwarded */ \
|
||||
relocate(&RECORDDESCPM(rtd)) \
|
||||
num = RECORDDESCPM(rtd); \
|
||||
index = BIGLEN(num) - 1; \
|
||||
/* ignore bit for already forwarded rtd */ \
|
||||
mask = BIGIT(num,index) >> 1; \
|
||||
bits = bigit_bits - 1; \
|
||||
for (;;) { \
|
||||
do { \
|
||||
if (mask & 1) sweep_or_check(pp) \
|
||||
mask >>= 1; \
|
||||
pp += 1; \
|
||||
} while (--bits > 0); \
|
||||
if (index-- == 0) break; \
|
||||
mask = BIGIT(num,index); \
|
||||
bits = bigit_bits; \
|
||||
} \
|
||||
} \
|
||||
|
||||
static void sweep_record(x) ptr x; {
|
||||
ptr *pp; ptr num; ptr rtd;
|
||||
sweep_or_check_record(x, relocate)
|
||||
}
|
||||
|
||||
/* record-type descriptor was forwarded in copy */
|
||||
rtd = RECORDINSTTYPE(x);
|
||||
num = RECORDDESCPM(rtd);
|
||||
pp = &RECORDINSTIT(x,0);
|
||||
#define check_self(pp) if (*(pp) == x) return 1;
|
||||
|
||||
/* sweep cells for which bit in pm is set; quit when pm == 0. */
|
||||
if (Sfixnump(num)) {
|
||||
/* ignore bit for already forwarded rtd */
|
||||
uptr mask = (uptr)UNFIX(num) >> 1;
|
||||
if (mask == (uptr)-1 >> 1) {
|
||||
ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1;
|
||||
while (pp < ppend) {
|
||||
relocate(pp)
|
||||
pp += 1;
|
||||
}
|
||||
} else {
|
||||
while (mask != 0) {
|
||||
if (mask & 1) relocate(pp)
|
||||
mask >>= 1;
|
||||
pp += 1;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
iptr index; bigit mask; INT bits;
|
||||
|
||||
/* bignum pointer mask may have been forwarded */
|
||||
relocate(&RECORDDESCPM(rtd))
|
||||
num = RECORDDESCPM(rtd);
|
||||
index = BIGLEN(num) - 1;
|
||||
/* ignore bit for already forwarded rtd */
|
||||
mask = BIGIT(num,index) >> 1;
|
||||
bits = bigit_bits - 1;
|
||||
for (;;) {
|
||||
do {
|
||||
if (mask & 1) relocate(pp)
|
||||
mask >>= 1;
|
||||
pp += 1;
|
||||
} while (--bits > 0);
|
||||
if (index-- == 0) break;
|
||||
mask = BIGIT(num,index);
|
||||
bits = bigit_bits;
|
||||
}
|
||||
}
|
||||
static int scan_record_for_self(x) ptr x; {
|
||||
sweep_or_check_record(x, check_self)
|
||||
return 0;
|
||||
}
|
||||
|
||||
static IGEN sweep_dirty_record(x) ptr x; {
|
||||
|
|
@ -2033,6 +2254,25 @@ static void resweep_dirty_weak_pairs() {
|
|||
}
|
||||
}
|
||||
|
||||
static void add_pending_guardian(ptr gdn, ptr tconc)
|
||||
{
|
||||
seginfo *si = SegInfo(ptr_get_segment(tconc));
|
||||
INITGUARDIANNEXT(gdn) = si->trigger_guardians;
|
||||
si->trigger_guardians = gdn;
|
||||
si->has_triggers = 1;
|
||||
}
|
||||
|
||||
static void add_trigger_guardians_to_recheck(ptr ls)
|
||||
{
|
||||
ptr last = ls, next = GUARDIANNEXT(ls);
|
||||
while (next != NULL) {
|
||||
last = next;
|
||||
next = GUARDIANNEXT(next);
|
||||
}
|
||||
INITGUARDIANNEXT(last) = recheck_guardians_ls;
|
||||
recheck_guardians_ls = ls;
|
||||
}
|
||||
|
||||
static ptr pending_ephemerons = NULL;
|
||||
/* Ephemerons that we haven't looked at, chained through `next`. */
|
||||
|
||||
|
|
@ -2083,6 +2323,7 @@ static void check_ephemeron(ptr pe, int add_to_trigger) {
|
|||
/* Not reached, so far; install as trigger */
|
||||
EPHEMERONTRIGGERNEXT(pe) = si->trigger_ephemerons;
|
||||
si->trigger_ephemerons = pe;
|
||||
si->has_triggers = 1;
|
||||
if (add_to_trigger) {
|
||||
EPHEMERONNEXT(pe) = trigger_ephemerons;
|
||||
trigger_ephemerons = pe;
|
||||
|
|
@ -2165,15 +2406,9 @@ static void clear_trigger_ephemerons() {
|
|||
if (EPHEMERONTRIGGERNEXT(pe) == Strue) {
|
||||
/* The ephemeron was triggered and retains its key and value */
|
||||
} else {
|
||||
seginfo *si;
|
||||
ptr p = Scar(pe);
|
||||
/* Key never became reachable, so clear key and value */
|
||||
INITCAR(pe) = Sbwp_object;
|
||||
INITCDR(pe) = Sbwp_object;
|
||||
|
||||
/* Remove trigger */
|
||||
si = SegInfo(ptr_get_segment(p));
|
||||
si->trigger_ephemerons = NULL;
|
||||
}
|
||||
pe = EPHEMERONNEXT(pe);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -234,6 +234,9 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) {
|
|||
/* fill sizeof(iptr) bytes at a time with 0xff */
|
||||
*dp = -1;
|
||||
}
|
||||
si->has_triggers = 0;
|
||||
si->trigger_ephemerons = 0;
|
||||
si->trigger_guardians = 0;
|
||||
}
|
||||
|
||||
iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; {
|
||||
|
|
|
|||
|
|
@ -118,7 +118,8 @@ typedef int IFASLCODE; /* fasl type codes */
|
|||
typedef struct _seginfo {
|
||||
unsigned char space; /* space the segment is in */
|
||||
unsigned char generation; /* generation the segment is in */
|
||||
unsigned char sorted; /* sorted indicator---possibly to be incorporated into space flags? */
|
||||
unsigned char sorted : 1; /* sorted indicator---possibly to be incorporated into space flags? */
|
||||
unsigned char has_triggers : 1; /* set if trigger_ephemerons or trigger_guardians is set */
|
||||
octet min_dirty_byte; /* dirty byte for full segment, effectively min(dirty_bytes) */
|
||||
uptr number; /* the segment number */
|
||||
struct _chunkinfo *chunk; /* the chunk this segment belongs to */
|
||||
|
|
@ -126,6 +127,7 @@ typedef struct _seginfo {
|
|||
struct _seginfo **dirty_prev; /* pointer to the next pointer on the previous seginfo in the DirtySegments list */
|
||||
struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */
|
||||
ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */
|
||||
ptr trigger_guardians; /* guardians to re-check if object in segment is copied out */
|
||||
octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */
|
||||
} seginfo;
|
||||
|
||||
|
|
|
|||
|
|
@ -551,7 +551,8 @@ reference, and that non-weak reference prevents the car field from becoming
|
|||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{make-guardian}{\categoryprocedure}{(make-guardian)}
|
||||
\returns a new guardian
|
||||
\formdef{make-guardian}{\categoryprocedure}{(make-guardian \var{ordered?})}
|
||||
\returns a new guardian that is unordered unless \var{ordered?} is true
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
|
|
@ -637,10 +638,26 @@ This feature circumvents the problems that might otherwise arise with
|
|||
shared or cyclic structure.
|
||||
A shared or cyclic structure consisting of inaccessible objects is
|
||||
preserved in its entirety, and each piece registered for preservation
|
||||
with any guardian is placed in the inaccessible set for that guardian.
|
||||
with any unordered guardian is placed in the inaccessible set for that guardian.
|
||||
The programmer then has complete control over the order in which pieces
|
||||
of the structure are processed.
|
||||
|
||||
An ordered guardian, as created by providing a true value for
|
||||
\var{ordered?}, treats an object as inaccessible only when it is not
|
||||
accessible from any representative of an object that is in any
|
||||
usable guardian's inaccessible group and that is distinct from the
|
||||
object itself. Cycles among objects registered with ordered guardians
|
||||
can never become inaccessible unless the cycle is broken or some of
|
||||
the relevant guardians are dropped by the program, and each
|
||||
registered object's representative (if different from the object) can
|
||||
contribute to such cycles. If an object is registered to an ordered
|
||||
custodian with a representative that is different from the object but
|
||||
that references the object, then the object is in a cycle and will not
|
||||
become inaccessible unless the reference from the representative to
|
||||
the object is destroyed. Weak references do not count, so objects that
|
||||
form a cycle only when counting weak references may still become
|
||||
inaccessible.
|
||||
|
||||
An object may be registered with a guardian more than once, in which
|
||||
case it will be retrievable more than once:
|
||||
|
||||
|
|
@ -657,7 +674,12 @@ case it will be retrievable more than once:
|
|||
|
||||
\noindent
|
||||
It may also be registered with more than one guardian, and guardians
|
||||
themselves can be registered with other guardians.
|
||||
themselves can be registered with other guardians. If an object
|
||||
is registered to both an unordered guardian and an ordered guardian
|
||||
and neither guardians is dropped, the object can become
|
||||
inaccessible for the ordered guardian only after it has been
|
||||
determined inaccessible for the unordered guardian and then
|
||||
retrieved and dropped again by the program.
|
||||
|
||||
An object that has been registered with a guardian without a
|
||||
representative and placed in
|
||||
|
|
|
|||
256
mats/4.ms
256
mats/4.ms
|
|
@ -3367,6 +3367,13 @@
|
|||
(begin (x (cons 'a 'b)) (not (x)))
|
||||
(begin (collect) (equal? (x) '(a . b)))
|
||||
(not (x)))))
|
||||
;; same for ordered:
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian #t)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b)) (not (x)))
|
||||
(begin (collect) (equal? (x) '(a . b)))
|
||||
(not (x)))))
|
||||
(with-interrupts-disabled
|
||||
(let ([x1 (make-guardian)])
|
||||
; counting on a little compiler cleanliness here...
|
||||
|
|
@ -3378,6 +3385,18 @@
|
|||
(and (equal? (x2) x2)
|
||||
(not (x1))
|
||||
(not (x2))))))
|
||||
;; same for ordered:
|
||||
(with-interrupts-disabled
|
||||
(let ([x1 (make-guardian #t)])
|
||||
; counting on a little compiler cleanliness here...
|
||||
(let ([x2 (make-guardian #t)])
|
||||
(x1 x2)
|
||||
(x2 x2))
|
||||
(collect)
|
||||
(let ([x2 (x1)])
|
||||
(and (equal? (x2) x2)
|
||||
(not (x1))
|
||||
(not (x2))))))
|
||||
(parameterize ([collect-trip-bytes (expt 2 24)])
|
||||
(let ([k 1000000])
|
||||
(let ([g (make-guardian)])
|
||||
|
|
@ -3392,24 +3411,60 @@
|
|||
[(g) => (lambda (x) (f (- n 1)))]
|
||||
[else (collect) (f n)])))
|
||||
#t)))
|
||||
;; same for ordered:
|
||||
(parameterize ([collect-trip-bytes (expt 2 24)])
|
||||
(let ([k 1000000])
|
||||
(let ([g (make-guardian #t)])
|
||||
(let f ([n k])
|
||||
(unless (= n 0)
|
||||
(g (cons 3 4))
|
||||
(let f () (cond [(g) => (lambda (x) (g x) (f))]))
|
||||
(f (- n 1))))
|
||||
(let f ([n k])
|
||||
(unless (= n 0)
|
||||
(cond
|
||||
[(g) => (lambda (x) (f (- n 1)))]
|
||||
[else (collect) (f n)])))
|
||||
#t)))
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b) 'calvin) (not (x)))
|
||||
(begin (collect) (equal? (x) 'calvin))
|
||||
(not (x)))))
|
||||
;; same for ordered:
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian #t)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b) 'calvin) (not (x)))
|
||||
(begin (collect) (equal? (x) 'calvin))
|
||||
(not (x)))))
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b) (cons 'calvin 'hobbes)) (not (x)))
|
||||
(begin (collect) (equal? (x) '(calvin . hobbes)))
|
||||
(not (x)))))
|
||||
;; same for ordered:
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian #t)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b) (cons 'calvin 'hobbes)) (not (x)))
|
||||
(begin (collect) (equal? (x) '(calvin . hobbes)))
|
||||
(not (x)))))
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b) 17) (not (x)))
|
||||
(begin (collect) (equal? (x) '17))
|
||||
(not (x)))))
|
||||
;; same for ordered:
|
||||
(with-interrupts-disabled
|
||||
(let ([x (make-guardian #t)])
|
||||
(and (not (x))
|
||||
(begin (x (cons 'a 'b) 17) (not (x)))
|
||||
(begin (collect) (equal? (x) '17))
|
||||
(not (x)))))
|
||||
(equal?
|
||||
(with-interrupts-disabled
|
||||
(let ([g1 (make-guardian)] [g2 (make-guardian)])
|
||||
|
|
@ -3421,6 +3476,18 @@
|
|||
(collect 0 0)
|
||||
(list ((g1)) p)))))
|
||||
'((c d) (b)))
|
||||
;; same for ordered:
|
||||
(equal?
|
||||
(with-interrupts-disabled
|
||||
(let ([g1 (make-guardian #t)] [g2 (make-guardian #t)])
|
||||
(let ([p (list 'a 'b)])
|
||||
(g1 p g2)
|
||||
(g2 (list 'c 'd))
|
||||
(collect 0 0)
|
||||
(let ([p (cdr p)])
|
||||
(collect 0 0)
|
||||
(list ((g1)) p)))))
|
||||
'((c d) (b)))
|
||||
|
||||
(eq? (with-interrupts-disabled
|
||||
(let* ([g (make-guardian)] [x (list 'a 'b)])
|
||||
|
|
@ -3429,6 +3496,14 @@
|
|||
(#%$keep-live x)
|
||||
(g)))
|
||||
#f)
|
||||
;; same for ordered:
|
||||
(eq? (with-interrupts-disabled
|
||||
(let* ([g (make-guardian #t)] [x (list 'a 'b)])
|
||||
(g x)
|
||||
(collect 0 0)
|
||||
(#%$keep-live x)
|
||||
(g)))
|
||||
#f)
|
||||
|
||||
(or (not (threaded?))
|
||||
(equal?
|
||||
|
|
@ -3468,7 +3543,186 @@
|
|||
(error #f "no static-generation fraz in object-counts list"))
|
||||
(pretty-print (cons g x)) ; keep 'em live
|
||||
#t)
|
||||
)
|
||||
|
||||
(begin
|
||||
(define (measure-guardian-chain-time n get-key ordered?)
|
||||
;; Create a chain of guardians `n` long and
|
||||
;; report how long a collection takes averaged
|
||||
;; over `iters` tries
|
||||
(define iters 10)
|
||||
(let loop ([g #f] [accum 0] [j iters])
|
||||
(if (zero? j)
|
||||
(if (zero? accum)
|
||||
g
|
||||
(/ accum iters))
|
||||
(let ([g (let loop ([i n])
|
||||
(let ([g (make-guardian ordered?)])
|
||||
(if (zero? i)
|
||||
g
|
||||
(let ([next-g (loop (sub1 i))])
|
||||
(g (get-key next-g) next-g)
|
||||
g))))])
|
||||
(let ([start (current-time)])
|
||||
(collect (collect-maximum-generation))
|
||||
(let ([delta (time-difference (current-time) start)])
|
||||
(loop g
|
||||
(+ accum
|
||||
(* (time-second delta) 1e9)
|
||||
(time-nanosecond delta))
|
||||
(sub1 j))))))))
|
||||
|
||||
;; Make sure guardian chains imply GC times that
|
||||
;; look linear, as opposed to quadratic
|
||||
(define (ok-relative-guardian-chain-time? get-key ordered?)
|
||||
(let loop ([tries 3])
|
||||
(or (< (/ (measure-guardian-chain-time 10000 get-key ordered?)
|
||||
(measure-guardian-chain-time 1000 get-key ordered?))
|
||||
20)
|
||||
(and (positive? tries)
|
||||
(loop (sub1 tries))))))
|
||||
|
||||
(and (ok-relative-guardian-chain-time? values #f)
|
||||
(ok-relative-guardian-chain-time? values #t)
|
||||
(let ([obj (gensym)])
|
||||
(and
|
||||
(ok-relative-guardian-chain-time? (lambda (x) obj) #f)
|
||||
(ok-relative-guardian-chain-time? (lambda (x) obj) #t)))))
|
||||
|
||||
;; Ordered finalization as different from unordred:
|
||||
(with-interrupts-disabled
|
||||
(let ([g1 (make-guardian #t)]
|
||||
[g2 (make-guardian #t)]
|
||||
[s (gensym)])
|
||||
(g1 s)
|
||||
(g2 (list s)) ; delays readying `s` in `g1`
|
||||
(set! s #f)
|
||||
(collect 0 0)
|
||||
(and (list? (g2))
|
||||
(not (g1))
|
||||
(begin
|
||||
(collect 0 0)
|
||||
(and (symbol? (g1))
|
||||
(not (g2)))))))
|
||||
;; Unordered is different:
|
||||
(with-interrupts-disabled
|
||||
(let ([g1 (make-guardian #f)]
|
||||
[g2 (make-guardian #f)]
|
||||
[s (gensym)])
|
||||
(g1 s)
|
||||
(g2 (list s)) ; no delay
|
||||
(set! s #f)
|
||||
(collect 0 0)
|
||||
(and (list? (g2))
|
||||
(symbol? (g1))
|
||||
(begin
|
||||
(collect 0 0)
|
||||
(and (not (g1))
|
||||
(not (g2)))))))
|
||||
|
||||
;; cycle ok with unordered
|
||||
(let ([g (make-guardian)])
|
||||
(let ([s (gensym)])
|
||||
(g s (list s)))
|
||||
(collect)
|
||||
(list? (g)))
|
||||
;; cycle not ok with ordered
|
||||
(let ([g (make-guardian #t)])
|
||||
(let ([s (gensym)])
|
||||
(g s (list s)))
|
||||
(collect)
|
||||
(not (g)))
|
||||
;; self representative doesn't count as cycle
|
||||
(let ([g (make-guardian #t)])
|
||||
(let ([s (gensym)])
|
||||
(g s s))
|
||||
(collect)
|
||||
(symbol? (g)))
|
||||
;; try a longer cycle:
|
||||
(let ([g (make-guardian #t)])
|
||||
(let ([hd (cons 0 '())])
|
||||
(set-cdr! hd
|
||||
(let loop ([i 100])
|
||||
(if (zero? i)
|
||||
hd
|
||||
(let ([p (cons i (loop (sub1 i)))])
|
||||
(g p)
|
||||
p)))))
|
||||
(collect)
|
||||
(not (g)))
|
||||
|
||||
;; same object, ordered and unordered => ordered first
|
||||
(with-interrupts-disabled
|
||||
(let ([g1 (make-guardian)]
|
||||
[g2 (make-guardian #t)])
|
||||
(let ([s (gensym)])
|
||||
(g1 s)
|
||||
(g2 s))
|
||||
(collect 0 0)
|
||||
(collect 0 0)
|
||||
(and (not (g2))
|
||||
(symbol? (g1))
|
||||
(not (g2))
|
||||
(begin
|
||||
(collect 0 0)
|
||||
(and (symbol? (g2))
|
||||
(not (g1))
|
||||
(not (g2)))))))
|
||||
|
||||
;; same object, both ordered => available from both
|
||||
(with-interrupts-disabled
|
||||
(let ([g1 (make-guardian #t)]
|
||||
[g2 (make-guardian #t)])
|
||||
(let ([s (gensym)])
|
||||
(g1 s)
|
||||
(g2 s))
|
||||
(collect 0 0)
|
||||
(and (symbol? (g2))
|
||||
(symbol? (g1))
|
||||
(not (g1))
|
||||
(not (g2))
|
||||
(begin
|
||||
(collect 0 0)
|
||||
(and (not (g1))
|
||||
(not (g2)))))))
|
||||
|
||||
;; check ordered finalization on objects that immediately
|
||||
;; refer to themselves, which can create trouble for a naive
|
||||
;; approach to determining accessibility
|
||||
(begin
|
||||
(define (check-self-referencing p extract)
|
||||
(with-interrupts-disabled
|
||||
(let ([g (make-guardian #t)])
|
||||
(g p)
|
||||
(let ([wb (weak-cons p #f)])
|
||||
(set! p #f)
|
||||
(collect 0 0)
|
||||
(let ([p (car wb)])
|
||||
(and (not (g))
|
||||
(eq? p (extract p))))))))
|
||||
(let ([p (cons #f #f)])
|
||||
(set-car! p p)
|
||||
(check-self-referencing p car)))
|
||||
(let ([p (cons #f #f)])
|
||||
(set-cdr! p p)
|
||||
(check-self-referencing p cdr))
|
||||
(let ([p (cons #f #f)])
|
||||
(set-car! p p)
|
||||
(set-cdr! p p)
|
||||
(check-self-referencing p (lambda (p)
|
||||
(and (eq? (car p) (cdr p))
|
||||
(car p)))))
|
||||
(let ([b (box #f)])
|
||||
(set-box! b b)
|
||||
(check-self-referencing b unbox))
|
||||
(let ([f (letrec ([f (lambda () f)]) f)])
|
||||
(check-self-referencing f (lambda (f) (f))))
|
||||
(let ()
|
||||
(define-record-type self (fields (mutable v)))
|
||||
(let ([v (make-self #f)])
|
||||
(self-v-set! v v)
|
||||
(check-self-referencing v self-v)))
|
||||
)
|
||||
|
||||
|
||||
(mat weak-cons
|
||||
(procedure? weak-cons)
|
||||
|
|
|
|||
|
|
@ -58,6 +58,14 @@ Online versions of both books can be found at
|
|||
%-----------------------------------------------------------------------------
|
||||
\section{Functionality Changes}\label{section:functionality}
|
||||
|
||||
\subsection{Ordered guardians (9.5.1)}
|
||||
|
||||
The \scheme{make-guardian} function now accepts an optional argument to
|
||||
indicate whether the guardian is ordered or unordered. A guardian is
|
||||
unordered by default. An ordered guardian's objects are classified as
|
||||
inaccessible only when they are not reachable from the represetative
|
||||
of any inaccessible object in any other guardian.
|
||||
|
||||
\subsection{Procedure source location without inspector information (9.5.1)}
|
||||
|
||||
When \scheme{generate-inspector-information} is set to \scheme{#f} and
|
||||
|
|
|
|||
|
|
@ -1441,7 +1441,9 @@
|
|||
([ptr obj]
|
||||
[ptr rep]
|
||||
[ptr tconc]
|
||||
[ptr next]))
|
||||
[ptr next]
|
||||
[ptr ordered?] ; boolean to indicate finalization mode
|
||||
[ptr pending])) ; for the GC's use
|
||||
|
||||
;;; forwarding addresses are recorded with a single forward-marker
|
||||
;;; bit pattern (a special Scheme object) followed by the forwarding
|
||||
|
|
|
|||
84
s/cp0.ss
84
s/cp0.ss
|
|
@ -4374,44 +4374,56 @@
|
|||
[(?x) (mtp ctxt empty-env sc wd name moi #f 3)]
|
||||
[(?x ?p) (mtp ctxt empty-env sc wd name moi ?p 3)]))))
|
||||
|
||||
(define-inline 2 make-guardian
|
||||
[() (and likely-to-be-compiled?
|
||||
(let ()
|
||||
(define (build-make-guardian ordered-arg? ctxt empty-env sc wd name moi)
|
||||
(and likely-to-be-compiled?
|
||||
(cp0
|
||||
(let* ([tc (cp0-make-temp #t)] [ref-tc (build-ref tc)])
|
||||
(build-lambda '()
|
||||
(build-let (list tc)
|
||||
(list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
|
||||
(let ([zero `(quote 0)])
|
||||
(build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
|
||||
(build-primcall 3 'cons (list ref-x ref-x))))))
|
||||
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
|
||||
(list
|
||||
(list '()
|
||||
(let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
|
||||
(let ([y (cp0-make-temp #f)])
|
||||
(build-let (list x) (list (build-primcall 3 'car (list ref-tc)))
|
||||
`(if ,(build-primcall 3 'eq?
|
||||
(list ref-x
|
||||
(build-primcall 3 'cdr (list ref-tc))))
|
||||
,false-rec
|
||||
,(build-let (list y) (list (build-primcall 3 'car (list ref-x)))
|
||||
`(seq
|
||||
(seq
|
||||
(let* ([tc (cp0-make-temp #t)]
|
||||
[ref-tc (build-ref tc)]
|
||||
[ordered? (and ordered-arg? (cp0-make-temp #f))]
|
||||
[bool-ordered? (cp0-make-temp #t)]
|
||||
[bool-ordered?-ref (build-ref bool-ordered?)])
|
||||
(build-lambda (if ordered? (list ordered?) '())
|
||||
(build-let (list bool-ordered?)
|
||||
(list (if ordered?
|
||||
`(if ,(build-ref ordered?) ,true-rec ,false-rec)
|
||||
false-rec))
|
||||
(build-let (list tc)
|
||||
(list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
|
||||
(let ([zero `(quote 0)])
|
||||
(build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
|
||||
(build-primcall 3 'cons (list ref-x ref-x))))))
|
||||
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
|
||||
(list
|
||||
(list '()
|
||||
(let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
|
||||
(let ([y (cp0-make-temp #f)])
|
||||
(build-let (list x) (list (build-primcall 3 'car (list ref-tc)))
|
||||
`(if ,(build-primcall 3 'eq?
|
||||
(list ref-x
|
||||
(build-primcall 3 'cdr (list ref-tc))))
|
||||
,false-rec
|
||||
,(build-let (list y) (list (build-primcall 3 'car (list ref-x)))
|
||||
`(seq
|
||||
(seq
|
||||
,(build-primcall 3 'set-car! (list ref-tc
|
||||
(build-primcall 3 'cdr (list ref-x))))
|
||||
,(build-primcall 3 'set-car! (list ref-x false-rec)))
|
||||
,(build-primcall 3 'set-cdr! (list ref-x false-rec)))
|
||||
(ref #f ,y))))))))
|
||||
(let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
|
||||
(list (list obj)
|
||||
(build-primcall 3 '$install-guardian
|
||||
(list ref-obj ref-obj ref-tc))))
|
||||
(let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)])
|
||||
(list (list obj rep)
|
||||
(build-primcall 3 '$install-guardian
|
||||
(list (build-ref obj) (build-ref rep) ref-tc)))))))))
|
||||
ctxt empty-env sc wd name moi))]))
|
||||
(seq
|
||||
,(build-primcall 3 'set-car! (list ref-tc
|
||||
(build-primcall 3 'cdr (list ref-x))))
|
||||
,(build-primcall 3 'set-car! (list ref-x false-rec)))
|
||||
,(build-primcall 3 'set-cdr! (list ref-x false-rec)))
|
||||
(ref #f ,y))))))))
|
||||
(let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
|
||||
(list (list obj)
|
||||
(build-primcall 3 '$install-guardian
|
||||
(list ref-obj ref-obj ref-tc bool-ordered?-ref))))
|
||||
(let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)])
|
||||
(list (list obj rep)
|
||||
(build-primcall 3 '$install-guardian
|
||||
(list (build-ref obj) (build-ref rep) ref-tc bool-ordered?-ref))))))))))
|
||||
ctxt empty-env sc wd name moi)))
|
||||
(define-inline 2 make-guardian
|
||||
[() (build-make-guardian #f ctxt empty-env sc wd name moi)]
|
||||
[(?ordered?) (build-make-guardian #t ctxt empty-env sc wd name moi)])))
|
||||
) ; with-output-language
|
||||
|
||||
(define-pass cp0 : Lsrc (ir ctxt env sc wd name moi) -> Lsrc ()
|
||||
|
|
|
|||
|
|
@ -5375,14 +5375,16 @@
|
|||
)
|
||||
|
||||
(define-inline 3 $install-guardian
|
||||
[(e-obj e-rep e-tconc)
|
||||
(bind #f (e-obj e-rep e-tconc)
|
||||
[(e-obj e-rep e-tconc ordered?)
|
||||
(bind #f (e-obj e-rep e-tconc ordered?)
|
||||
(bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))])
|
||||
(%seq
|
||||
(set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj)
|
||||
(set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep)
|
||||
(set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc)
|
||||
(set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries))
|
||||
(set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,ordered?)
|
||||
(set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil))
|
||||
(set! ,(%tc-ref guardian-entries) ,t))))])
|
||||
|
||||
(define-inline 2 virtual-register-count
|
||||
|
|
|
|||
|
|
@ -929,11 +929,15 @@
|
|||
(defref GUARDIANREP guardian-entry rep)
|
||||
(defref GUARDIANTCONC guardian-entry tconc)
|
||||
(defref GUARDIANNEXT guardian-entry next)
|
||||
(defref GUARDIANORDERED guardian-entry ordered?)
|
||||
(defref GUARDIANPENDING guardian-entry pending)
|
||||
|
||||
(definit INITGUARDIANOBJ guardian-entry obj)
|
||||
(definit INITGUARDIANREP guardian-entry rep)
|
||||
(definit INITGUARDIANTCONC guardian-entry tconc)
|
||||
(definit INITGUARDIANNEXT guardian-entry next)
|
||||
(definit INITGUARDIANORDERED guardian-entry ordered?)
|
||||
(definit INITGUARDIANPENDING guardian-entry pending)
|
||||
|
||||
(defref FORWARDMARKER forward marker)
|
||||
(defref FORWARDADDRESS forward address)
|
||||
|
|
|
|||
|
|
@ -1429,7 +1429,7 @@
|
|||
(make-engine [sig [(procedure) -> (engine)]] [flags pure alloc])
|
||||
(make-format-condition [sig [() -> (condition)]] [flags pure unrestricted mifoldable discard])
|
||||
(make-fxvector [sig [(length) (length fixnum) -> (fxvector)]] [flags alloc])
|
||||
(make-guardian [sig [() -> (procedure)]] [flags alloc cp02])
|
||||
(make-guardian [sig [() (ptr) -> (procedure)]] [flags alloc cp02])
|
||||
(make-hash-table [sig [() (ptr) -> (old-hash-table)]] [flags unrestricted alloc])
|
||||
(make-input-port [sig [(procedure string) -> (textual-input-port)]] [flags alloc])
|
||||
(make-input/output-port [sig [(procedure string string) -> (textual-input/output-port)]] [flags alloc])
|
||||
|
|
|
|||
|
|
@ -1408,11 +1408,13 @@
|
|||
(foreign-procedure "(cs)locked_objectp" (scheme-object) boolean))
|
||||
|
||||
(define-who $install-guardian
|
||||
(lambda (obj rep tconc)
|
||||
(lambda (obj rep tconc ordered?)
|
||||
(unless (and (pair? tconc) (pair? (car tconc)) (pair? (cdr tconc))) ($oops who "~s is not a tconc" tconc))
|
||||
(#3%$install-guardian obj rep tconc)))
|
||||
(#3%$install-guardian obj rep tconc ordered?)))
|
||||
|
||||
(define make-guardian (lambda () (#2%make-guardian)))
|
||||
(define make-guardian (case-lambda
|
||||
[() (#2%make-guardian)]
|
||||
[(ordered?) (#2%make-guardian ordered?)]))
|
||||
|
||||
(define $address-in-heap?
|
||||
(foreign-procedure "(cs)s_addr_in_heap" (uptr) boolean))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user