diff --git a/LOG b/LOG index 41675d405a..6b8a941658 100644 --- a/LOG +++ b/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 diff --git a/c/gc.c b/c/gc.c index c65215d16a..498e6ad44d 100644 --- a/c/gc.c +++ b/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); } diff --git a/c/segment.c b/c/segment.c index b578889658..6cefcf4dda 100644 --- a/c/segment.c +++ b/c/segment.c @@ -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; { diff --git a/c/types.h b/c/types.h index ca4e582070..cfd53501ec 100644 --- a/c/types.h +++ b/c/types.h @@ -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; diff --git a/csug/smgmt.stex b/csug/smgmt.stex index 854129866e..7521396fd3 100644 --- a/csug/smgmt.stex +++ b/csug/smgmt.stex @@ -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 diff --git a/mats/4.ms b/mats/4.ms index 3d531e227f..8db8061d50 100644 --- a/mats/4.ms +++ b/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) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 0aea7d3242..8a9f33e8fe 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -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 diff --git a/s/cmacros.ss b/s/cmacros.ss index bd188e982a..b2153c8fb6 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -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 diff --git a/s/cp0.ss b/s/cp0.ss index fc599722b4..872ca270b2 100644 --- a/s/cp0.ss +++ b/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 () diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index ecd45d841e..5392e044bc 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -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 diff --git a/s/mkheader.ss b/s/mkheader.ss index e10453e9bc..8c71be462e 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -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) diff --git a/s/primdata.ss b/s/primdata.ss index 244c957bd3..fb29f5f161 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -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]) diff --git a/s/prims.ss b/s/prims.ss index a56fde1174..ecb8315f34 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -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))