suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add ordered guardians

Browse Source 
Also, avoid quadratic time in GC for guardian chains.

original commit: 4f8c9d31395637557eec41e4fcb16ff71c6618da
This commit is contained in:
Matthew Flatt 2017-07-07 10:36:10 -06:00
parent fd7606ca05
commit 9144829de9
13 changed files with 476 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
LOG
View File

@ -529,3 +529,7 @@
bytevector.ms, root-experr*
- fixed typo in S_abnormal_exit
schsig.c
- 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

189
c/gc.c
View File

@ -49,9 +49,11 @@ 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 +74,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 +202,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 +231,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 +467,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;
@ -880,14 +898,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 +945,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(tc, rep, 1);
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 +1003,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 +1021,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 +1077,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);
}
}
}
@ -2028,6 +2123,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`. */
@ -2078,6 +2192,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;
@ -2160,15 +2275,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);
}

3
c/segment.c
View File

@ -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; {

4
c/types.h
View File

@ -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;

28
csug/smgmt.stex
View File

@ -532,7 +532,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
@ -618,10 +619,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:
@ -638,7 +655,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

220
mats/4.ms
View File

@ -3187,6 +3187,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...
@ -3198,6 +3205,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)])
@ -3212,24 +3231,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)])
@ -3241,6 +3296,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)])
@ -3249,6 +3316,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?
@ -3288,7 +3363,150 @@
(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)))))))
)
(mat weak-cons
(procedure? weak-cons)

8
release_notes/release_notes.stex
View File

@ -78,6 +78,14 @@ procedures.
Immutable boxes are created via \scheme{box-immutable}.
Any attempt to modify an immutable object causes an exception to be raised.
\subsection{Ordered guardians (9.4.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{Optional timeout for \protect\scheme{condition-wait} (9.4.1)}
The \scheme{condition-wait} procedure now takes an optional

4
s/cmacros.ss
View File

@ -1433,7 +1433,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
View File

@ -4349,44 +4349,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 ()

6
s/cpnanopass.ss
View File

@ -5281,14 +5281,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

4
s/mkheader.ss
View File

@ -919,11 +919,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)

2
s/primdata.ss
View File

@ -1415,7 +1415,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])

8
s/prims.ss
View File

@ -1398,11 +1398,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))