Merge branch 'orderfnl' of github.com:mflatt/ChezScheme

original commit: abb84eb7b0dbb9824d0b32407143589ff309a0fb

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

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) {
+FORCEINLINE void check_triggers(seginfo *si) {
-  /* Registering ephemerons to recheck at the granularity of a segment
+  /* Registering ephemerons and guardians to recheck at the
-     means that the worst-case complexity of GC is quadratic in the
+     granularity of a segment means that the worst-case complexity of
-     number of objects that fit into a segment (but that only happens
+     GC is quadratic in the number of objects that fit into a segment
-     if the objects are ephemeron keys that are reachable just through
+     (but that only happens if the objects are ephemeron keys that are
-     a chain via the value field of the same ephemerons). */
+     reachable just through a chain via the value field of the same
-  if (si->trigger_ephemerons) {
+     ephemerons). */
-    add_trigger_ephemerons_to_repending(si->trigger_ephemerons);
+  if (si->has_triggers) {
-    si->trigger_ephemerons = NULL;
+    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_final_ls    if obj not accessible and tconc not accessible
-        pend_hold_ls = final_ls = pend_final_ls = Snil;
+       * 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 */
+                /* if tconc was old it's been forwarded */
-                tconc = GUARDIANTCONC(ls);
+                  tconc = GUARDIANTCONC(ls);
-
+                  
-                old_end = Scdr(tconc);
+                  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);
+                  SETCAR(old_end,rep);
-                SETCDR(old_end,new_end);
+                  SETCDR(old_end,new_end);
-                SETCDR(tconc,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;
+                            INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_HOLD);
-                            pend_hold_ls = ls;
+                            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 */
+           *   pend_final_ls    if tconc not forwarded
-            ls = pend_final_ls; final_ls = pend_final_ls = Snil;
+           * 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;
+                    INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_FINAL);
-                    pend_final_ls = ls;
+                    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 */
+#define check_self(pp) if (*(pp) == x) return 1;
-    rtd = RECORDINSTTYPE(x);
-    num = RECORDDESCPM(rtd);
-    pp = &RECORDINSTIT(x,0);
 
-  /* sweep cells for which bit in pm is set; quit when pm == 0. */
+static int scan_record_for_self(x) ptr x; {
-    if (Sfixnump(num)) {
+  sweep_or_check_record(x, check_self)
-       /* ignore bit for already forwarded rtd */
+  return 0;
-        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 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);
   }

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

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;
 

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

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)

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

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

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
+      (let ()
-        [() (and likely-to-be-compiled?
+        (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)])
+                  (let* ([tc (cp0-make-temp #t)]
-                     (build-lambda '()
+                         [ref-tc (build-ref tc)]
-                       (build-let (list tc)
+                         [ordered? (and ordered-arg? (cp0-make-temp #f))]
-                         (list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
+                         [bool-ordered? (cp0-make-temp #t)]
-                                 (let ([zero `(quote 0)])
+                         [bool-ordered?-ref (build-ref bool-ordered?)])
-                                   (build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
+                     (build-lambda (if ordered? (list ordered?) '())
-                                     (build-primcall 3 'cons (list ref-x ref-x))))))
+                       (build-let (list bool-ordered?)
-                         (build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
+                         (list (if ordered?
-                           (list
+                                   `(if ,(build-ref ordered?) ,true-rec ,false-rec)
-                             (list '()
+                                   false-rec))
-                               (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
+                         (build-let (list tc)
-                                 (let ([y (cp0-make-temp #f)])
+                           (list (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
-                                   (build-let (list x) (list (build-primcall 3 'car (list ref-tc)))
+                                   (let ([zero `(quote 0)])
-                                     `(if ,(build-primcall 3 'eq?
+                                     (build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
-                                             (list ref-x
+                                       (build-primcall 3 'cons (list ref-x ref-x))))))
-                                               (build-primcall 3 'cdr (list ref-tc))))
+                           (build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
-                                          ,false-rec
+                             (list
-                                          ,(build-let (list y) (list (build-primcall 3 'car (list ref-x)))
+                               (list '()
-                                             `(seq
+                                 (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
-                                                (seq
+                                   (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
+                                                    (seq
-                                                                                       (build-primcall 3 'cdr (list ref-x))))
+                                                      ,(build-primcall 3 'set-car! (list ref-tc
-                                                    ,(build-primcall 3 'set-car! (list ref-x false-rec)))
+                                                                                         (build-primcall 3 'cdr (list ref-x))))
-                                                  ,(build-primcall 3 'set-cdr! (list ref-x false-rec)))
+                                                      ,(build-primcall 3 'set-car! (list ref-x false-rec)))
-                                                (ref #f ,y))))))))
+                                                    ,(build-primcall 3 'set-cdr! (list ref-x false-rec)))
-                             (let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
+                                                  (ref #f ,y))))))))
-                               (list (list obj)
+                               (let* ([obj (cp0-make-temp #t)] [ref-obj (build-ref obj)])
-                                 (build-primcall 3 '$install-guardian
+                                 (list (list obj)
-                                   (list ref-obj ref-obj ref-tc))))
+                                   (build-primcall 3 '$install-guardian
-                             (let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)])
+                                     (list ref-obj ref-obj ref-tc bool-ordered?-ref))))
-                               (list (list obj rep)
+                               (let ([obj (cp0-make-temp #f)] [rep (cp0-make-temp #f)])
-                                 (build-primcall 3 '$install-guardian
+                                 (list (list obj rep)
-                                   (list (build-ref obj) (build-ref rep) ref-tc)))))))))
+                                   (build-primcall 3 '$install-guardian
-                   ctxt empty-env sc wd name moi))]))
+                                     (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 ()

s/cpnanopass.ss

@@ -5375,14 +5375,16 @@
           )
 
         (define-inline 3 $install-guardian
-          [(e-obj e-rep e-tconc)
+          [(e-obj e-rep e-tconc ordered?)
-           (bind #f (e-obj e-rep e-tconc)
+           (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

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)

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])

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))