convert GC to "mkgc.ss" implementation

Replace repetitive C code in "gc.c" and "vfasl.c" with an
implementation using a little "Parenthe-C" language, which is a
somewhat declarative description of object tracing. From that
descrition, we generate different kinds of tracing functions, such as
the copy function or the sweep function.

The little language is still bascially C, just with parentheses and
parameterization that is much better than trying to use the C
preprocessor. (The "mkgc.ss" file includes the compiler from
Parenthe-C to C.)

Besides replacing existing code, we also generate a new traversal to
implement `compute-object-sizes`. Finally, the GC can now perform a
fused `collect` and `compute-object-sizes` in a single traversal.

Also improve the way that locked objects are detected during GC. This
can make a significant difference (on the order of 10-20% for a full
collection) when locked objects are long-lived.

original commit: de1f5c41d729ac75822a1f1e633ec6d042c883dc

c/Mf-base

@@ -69,6 +69,9 @@ ${kernelobj}: ${Include}/equates.h ${Include}/scheme.h
 ${mainobj}: ${Include}/scheme.h
 ${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep}
 gc-ocd.o gc-oce.o: gc.c
+gc-ocd.o: ${Include}/gc-ocd.inc
+gc-oce.o: ${Include}/gc-oce.inc
+vfasl.o: ${Include}/vfasl.inc
 
 ../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log
 

c/externs.h

@@ -139,8 +139,8 @@ extern void S_gc_init PROTO((void));
 extern void S_register_child_process PROTO((INT child));
 #endif /* WIN32 */
 extern void S_fixup_counts PROTO((ptr counts));
-extern void S_do_gc PROTO((IGEN g, IGEN gtarget));
+extern ptr S_do_gc PROTO((IGEN g, IGEN gtarget, ptr count_roots));
-extern void S_gc PROTO((ptr tc, IGEN mcg, IGEN tg));
+extern ptr S_gc PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
 extern void S_gc_init PROTO((void));
 extern void S_set_maxgen PROTO((IGEN g));
 extern IGEN S_maxgen PROTO((void));
@@ -155,17 +155,17 @@ extern ptr S_object_counts PROTO((void));
 extern IBOOL S_enable_object_backreferences PROTO((void));
 extern void S_set_enable_object_backreferences PROTO((IBOOL eoc));
 extern ptr S_object_backreferences PROTO((void));
-extern void S_do_gc PROTO((IGEN g, IGEN gtarget));
 extern ptr S_locked_objects PROTO((void));
 extern ptr S_unregister_guardian PROTO((ptr tconc));
 extern void S_compact_heap PROTO((void));
 extern void S_check_heap PROTO((IBOOL aftergc));
 
 /* gc-ocd.c */
-extern void S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg));
+extern ptr S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
 
 /* gc-oce.c */
-extern void S_gc_oce PROTO((ptr tc, IGEN mcg, IGEN tg));
+extern ptr S_gc_oce PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
+extern ptr S_count_size_increments PROTO((ptr ls, IGEN generation));
 
 /* intern.c */
 extern void S_intern_init PROTO((void));

c/gc-oce.c

@@ -17,4 +17,5 @@
 #define GCENTRY S_gc_oce
 #define ENABLE_OBJECT_COUNTS
 #define ENABLE_BACKREFERENCE
+#define ENABLE_MEASURE
 #include "gc.c"

c/gcwrapper.c

@@ -128,9 +128,11 @@ void S_gc_init() {
   INITVECTIT(S_G.countof_names, countof_oblist) = S_intern((const unsigned char *)"oblist");
     S_G.countof_size[countof_guardian] = 0;
   INITVECTIT(S_G.countof_names, countof_ephemeron) = S_intern((const unsigned char *)"ephemeron");
-    S_G.countof_size[countof_ephemeron] = 0;
+    S_G.countof_size[countof_ephemeron] = size_ephemeron;
   INITVECTIT(S_G.countof_names, countof_stencil_vector) = S_intern((const unsigned char *)"stencil-vector");
     S_G.countof_size[countof_stencil_vector] = 0;
+  INITVECTIT(S_G.countof_names, countof_record) = S_intern((const unsigned char *)"record");
+    S_G.countof_size[countof_record] = 0;
   for (i = 0; i < countof_types; i += 1) {
     if (Svector_ref(S_G.countof_names, i) == FIX(0)) {
       fprintf(stderr, "uninitialized countof_name at index %d\n", i);
@@ -351,29 +353,31 @@ ptr S_object_counts(void) {
 
  /* add primary types w/nonozero counts to the alist */
   for (i = 0 ; i < countof_types; i += 1) {
-    ptr inner_alist = Snil;
+    if (i != countof_record) { /* covered by rtd-specific counts */
-    for (g = 0; g <= static_generation; INCRGEN(g)) {
+      ptr inner_alist = Snil;
-      IGEN gcurrent = g;
+      for (g = 0; g <= static_generation; INCRGEN(g)) {
-      uptr count = S_G.countof[g][i];
+        IGEN gcurrent = g;
-      uptr bytes = S_G.bytesof[g][i];
+        uptr count = S_G.countof[g][i];
+        uptr bytes = S_G.bytesof[g][i];
 
-      if (g == S_G.new_max_nonstatic_generation) {
+        if (g == S_G.new_max_nonstatic_generation) {
-        while (g < S_G.max_nonstatic_generation) {
+          while (g < S_G.max_nonstatic_generation) {
-          g += 1;
+            g += 1;
-          /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */
+            /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */
-          /* coverity[overrun-buffer-val] */
+            /* coverity[overrun-buffer-val] */
-          count += S_G.countof[g][i];
+            count += S_G.countof[g][i];
-          /* coverity[overrun-buffer-val] */
+            /* coverity[overrun-buffer-val] */
-          bytes += S_G.bytesof[g][i];
+            bytes += S_G.bytesof[g][i];
+          }
+        }
+
+        if (count != 0) {
+          if (bytes == 0) bytes = count * S_G.countof_size[i];
+          inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist);
         }
       }
-
+      if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist);
-      if (count != 0) {
-        if (bytes == 0) bytes = count * S_G.countof_size[i];
-        inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist);
-      }
     }
-    if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist);
   }
 
   tc_mutex_release()
@@ -408,7 +412,7 @@ ptr S_object_backreferences(void) {
 void Scompact_heap() {
   ptr tc = get_thread_context();
   S_pants_down += 1;
-  S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation);
+  S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, Sfalse);
   S_pants_down -= 1;
 }
 
@@ -755,9 +759,9 @@ void S_fixup_counts(ptr counts) {
   RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0];
 }
 
-void S_do_gc(IGEN mcg, IGEN tg) {
+ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
   ptr tc = get_thread_context();
-  ptr code;
+  ptr code, result;
 
   code = CP(tc);
   if (Sprocedurep(code)) code = CLOSCODE(code);
@@ -777,7 +781,7 @@ void S_do_gc(IGEN mcg, IGEN tg) {
     new_g = S_G.new_max_nonstatic_generation;
     old_g = S_G.max_nonstatic_generation;
    /* first, collect everything to old_g */
-    S_gc(tc, old_g, old_g);
+    result = S_gc(tc, old_g, old_g, count_roots);
    /* now transfer old_g info to new_g, and clear old_g info */
     for (s = 0; s <= max_real_space; s += 1) {
       S_G.first_loc[s][new_g] = S_G.first_loc[s][old_g]; S_G.first_loc[s][old_g] = FIX(0);
@@ -859,7 +863,7 @@ void S_do_gc(IGEN mcg, IGEN tg) {
     S_G.min_free_gen = S_G.new_min_free_gen;
     S_G.max_nonstatic_generation = new_g;
   } else {
-    S_gc(tc, mcg, tg);
+    result = S_gc(tc, mcg, tg, count_roots);
   }
   S_pants_down -= 1;
 
@@ -869,12 +873,16 @@ void S_do_gc(IGEN mcg, IGEN tg) {
   S_reset_allocation_pointer(tc);
 
   Sunlock_object(code);
+
+  return result;
 }
 
 
-void S_gc(ptr tc, IGEN mcg, IGEN tg) {
+ptr S_gc(ptr tc, IGEN mcg, IGEN tg, ptr count_roots) {
-  if (tg == static_generation || S_G.enable_object_counts || S_G.enable_object_backreferences)
+  if (tg == static_generation
-    S_gc_oce(tc, mcg, tg);
+      || S_G.enable_object_counts || S_G.enable_object_backreferences
+      || (count_roots != Sfalse))
+    return S_gc_oce(tc, mcg, tg, count_roots);
   else
-    S_gc_ocd(tc, mcg, tg);
+    return S_gc_ocd(tc, mcg, tg, Sfalse);
 }

c/prim.c

@@ -177,6 +177,7 @@ void S_prim_init() {
     Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp);
     Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap);
     Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors);
+    Sforeign_symbol("(cs)count_size_increments", (void *)S_count_size_increments);
     Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry);
     Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object);
     Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry);

c/types.h

@@ -114,6 +114,11 @@ typedef int IFASLCODE;      /* fasl type codes */
 #define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits)
 #define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits)
 
+#define segment_bitmap_bytes    (bytes_per_segment >> (log2_ptr_bytes+3))
+#define segment_bitmap_index(p) ((((uptr)p + (typemod-1)) & (bytes_per_segment - 1)) >> log2_ptr_bytes)
+#define segment_bitmap_byte(p)  (segment_bitmap_index(p) >> 3)
+#define segment_bitmap_bit(p)   ((uptr)1 << (segment_bitmap_index(p) & 0x7))
+
 #define SPACE(p) SegmentSpace(ptr_get_segment(p))
 #define GENERATION(p) SegmentGeneration(ptr_get_segment(p))
 
@@ -136,9 +141,12 @@ typedef struct _seginfo {
   ptr trigger_guardians;                    /* guardians to re-check if object in segment is copied out */
   ptr locked_objects;                       /* list of objects (including duplicates) for locked in this segment */
   ptr unlocked_objects;                     /* list of objects (no duplicates) for formerly locked */
+  octet *locked_mask;                       /* bitmap of locked objects, used only during GC */
 #ifdef PRESERVE_FLONUM_EQ
   octet *forwarded_flonums;                 /* bitmap of flonums whose payload is a forwarding pointer */
 #endif
+  octet *counting_mask;                     /* bitmap of counting roots during a GC */
+  octet *measured_mask;                     /* bitmap of objects that have been measured */
   octet dirty_bytes[cards_per_segment];     /* one dirty byte per card */
 } seginfo;
 
@@ -403,3 +411,8 @@ typedef struct {
 
 #define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
 #define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x))
+
+/* For `memcpy_aligned, that the first two arguments are word-aligned
+   and it would be ok to round up the length to a word size. But
+   probably the compiler does a fine job with plain old `mempcy`. */
+#define memcpy_aligned memcpy

c/vfasl.c

@@ -164,17 +164,16 @@ static uptr symbol_pos_to_offset(uptr sym_pos) {
 static ptr vfasl_copy_all(vfasl_info *vfi, ptr v);
 
 static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si);
-static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n);
-static uptr sweep_code_object(vfasl_info *vfi, ptr co);
-static uptr sweep_record(vfasl_info *vfi, ptr co);
 static uptr sweep(vfasl_info *vfi, ptr p);
 static int is_rtd(ptr tf, vfasl_info *vfi);
 
+static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj);
 static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static);
 static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets);
 
 static void vfasl_relocate(vfasl_info *vfi, ptr *ppp);
 static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp);
+static ptr vfasl_relocate_code(vfasl_info *vfi, ptr code);
 static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n);
 static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp);
 static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p);
@@ -182,6 +181,8 @@ static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int whi
 static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p);
 static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p);
 
+static iptr vfasl_symbol_to_index(vfasl_info *vfi, ptr pp);
+
 static void fasl_init_entry_tables();
 static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name);
 
@@ -992,198 +993,7 @@ static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) {
 
 #define FIND_ROOM(vfi, s, t, n, p) p = vfasl_find_room(vfi, s, t, n)
 
-#define copy_ptrs(ty, p1, p2, n) {\
+#include "vfasl.inc"
-  ptr *Q1, *Q2, *Q1END;\
-  Q1 = (ptr *)UNTYPE((p1),ty);\
-  Q2 = (ptr *)UNTYPE((p2),ty);\
-  Q1END = (ptr *)((uptr)Q1 + n);\
-  while (Q1 != Q1END) *Q1++ = *Q2++;}
-
-static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) {
-    ptr p, tf; ITYPE t;
-
-    if ((t = TYPEBITS(pp)) == type_typed_object) {
-      tf = TYPEFIELD(pp);
-      if (TYPEP(tf, mask_record, type_record)) {
-          ptr rtd; iptr n; int s;
-
-          rtd = tf;
-
-          if (is_rtd(tf, vfi)) {
-            if (pp != S_G.base_rtd) {
-              /* make sure rtd's type is registered first */
-              (void)vfasl_relocate_help(vfi, rtd);
-            }
-            /* need parent before child */
-            vfasl_relocate_parents(vfi, RECORDDESCPARENT(pp));
-
-            s = vspace_rtd;
-          } else {
-            /* See gc.c for original rationale, but the fine-grained
-               choices only matter when loading into the static
-               generation, so we make */
-            s = (RECORDDESCMPM(rtd) == FIX(0)
-                 ? vspace_pure_typed
-                 : vspace_impure_record);
-          }
-
-          n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
-
-          FIND_ROOM(vfi, s, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-
-          if (pp == S_G.base_rtd)
-            vfi->base_rtd = p;
-
-          /* pad if necessary */
-          {
-            iptr m = unaligned_size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
-            if (m != n)
-              *((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0);
-          }
-      } else if (TYPEP(tf, mask_vector, type_vector)) {
-          iptr len, n;
-          len = Svector_length(pp);
-          n = size_vector(len);
-          FIND_ROOM(vfi, vspace_impure, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-          /* pad if necessary */
-          if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0);
-      } else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) {
-          iptr len, n;
-          len = Sstencil_vector_length(pp);
-          n = size_stencil_vector(len);
-          FIND_ROOM(vfi, vspace_impure, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-          /* pad if necessary */
-          if ((len & 1) == 0) INITSTENVECTIT(p, len) = FIX(0);
-      } else if (TYPEP(tf, mask_string, type_string)) {
-          iptr n;
-          n = size_string(Sstring_length(pp));
-          FIND_ROOM(vfi, vspace_data, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-      } else if (TYPEP(tf, mask_fxvector, type_fxvector)) {
-          iptr n;
-          n = size_fxvector(Sfxvector_length(pp));
-          FIND_ROOM(vfi, vspace_data, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-      } else if (TYPEP(tf, mask_bytevector, type_bytevector)) {
-          iptr n;
-          n = size_bytevector(Sbytevector_length(pp));
-          FIND_ROOM(vfi, vspace_data, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-      } else if ((iptr)tf == type_tlc) {
-          vfasl_fail(vfi, "tlc");
-          return (ptr)0;
-      } else if (TYPEP(tf, mask_box, type_box)) {
-          FIND_ROOM(vfi, vspace_impure, type_typed_object, size_box, p);
-          BOXTYPE(p) = (iptr)tf;
-          INITBOXREF(p) = Sunbox(pp);
-      } else if ((iptr)tf == type_ratnum) {
-        /* note: vspace_impure is suboptimal for loading into static
-           generation, but these will be rare in boot code */
-          FIND_ROOM(vfi, vspace_impure, type_typed_object, size_ratnum, p);
-          RATTYPE(p) = type_ratnum;
-          RATNUM(p) = RATNUM(pp);
-          RATDEN(p) = RATDEN(pp);
-          /* pad */
-          ((void **)UNTYPE(p, type_typed_object))[3] = (ptr)0;
-      } else if ((iptr)tf == type_exactnum) {
-        /* note: vspace_impure is suboptimal for loading into static
-           generation, but these will be rare in boot code */
-          FIND_ROOM(vfi, vspace_impure, type_typed_object, size_exactnum, p);
-          EXACTNUM_TYPE(p) = type_exactnum;
-          EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp);
-          EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp);
-          /* pad */
-          ((void **)UNTYPE(p, type_typed_object))[3] = (ptr)0;
-      } else if ((iptr)tf == type_inexactnum) {
-          FIND_ROOM(vfi, vspace_data, type_typed_object, size_inexactnum, p);
-          INEXACTNUM_TYPE(p) = type_inexactnum;
-          INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp);
-          INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp);
-      } else if (TYPEP(tf, mask_bignum, type_bignum)) {
-          iptr n;
-          n = size_bignum(BIGLEN(pp));
-          FIND_ROOM(vfi, vspace_data, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-      } else if (TYPEP(tf, mask_port, type_port)) {
-          vfasl_fail(vfi, "port");
-          return (ptr)0;
-      } else if (TYPEP(tf, mask_code, type_code)) {
-          iptr n;
-          n = size_code(CODELEN(pp));
-          FIND_ROOM(vfi, vspace_code, type_typed_object, n, p);
-          copy_ptrs(type_typed_object, p, pp, n);
-          if (CODERELOC(pp) == (ptr)0)
-            vfasl_fail(vfi, "code without relocation");
-      } else if ((iptr)tf == type_rtd_counts) {
-        /* prune counts, since GC will recreate as needed */
-          return Sfalse;
-      } else if ((iptr)tf == type_thread) {
-          vfasl_fail(vfi, "thread");
-          return (ptr)0;
-      } else {
-          S_error_abort("vfasl: illegal type");
-          return (ptr)0 /* not reached */;
-      }
-    } else if (t == type_pair) {
-      if (si->space == space_ephemeron) {
-        vfasl_fail(vfi, "emphemeron");
-        return (ptr)0;
-      } else if (si->space == space_weakpair) {
-        vfasl_fail(vfi, "weakpair");
-        return (ptr)0;
-      } else {
-        FIND_ROOM(vfi, vspace_impure, type_pair, size_pair, p);
-      }
-      INITCAR(p) = Scar(pp);
-      INITCDR(p) = Scdr(pp);
-    } else if (t == type_closure) {
-        ptr code;
-        code = CLOSCODE(pp);
-        if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) {
-          vfasl_fail(vfi, "continuation");
-          return (ptr)0;
-        } else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
-          vfasl_fail(vfi, "mutable closure");
-          return (ptr)0;
-        } else {
-            iptr len, n;
-            len = CLOSLEN(pp);
-            n = size_closure(len);
-            FIND_ROOM(vfi, vspace_closure, type_closure, n, p);
-            copy_ptrs(type_closure, p, pp, n);
-            /* pad if necessary */
-            if ((len & 1) == 0) CLOSIT(p, len) = FIX(0);
-        }
-    } else if (t == type_symbol) {
-        iptr pos = vfi->sym_count++;
-        ptr name = SYMNAME(pp);
-        if (Sstringp(name))
-          vfasl_check_install_library_entry(vfi, name);
-        else if (!Spairp(name) || (Scar(name) == Sfalse))
-          vfasl_fail(vfi, "gensym without unique name");
-        FIND_ROOM(vfi, vspace_symbol, type_symbol, size_symbol, p);
-        INITSYMVAL(p) = FIX(pos);   /* stores symbol index for now; will get reset on load */
-        INITSYMPVAL(p) = Snil;      /* will get reset on load */
-        INITSYMPLIST(p) = Snil;
-        INITSYMSPLIST(p) = Snil;
-        INITSYMNAME(p) = name;
-        INITSYMHASH(p) = SYMHASH(pp);
-    } else if (t == type_flonum) {
-        FIND_ROOM(vfi, vspace_data, type_flonum, size_flonum, p);
-        FLODAT(p) = FLODAT(pp);
-        /* note: unlike GC, sharing flonums */
-    } else {
-      S_error_abort("copy(gc): illegal type");
-      return (ptr)0 /* not reached */;
-    }
-
-    vfasl_register_forward(vfi, pp, p);
-
-    return p;
-}
 
 static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp) {
   ptr fpp;
@@ -1225,133 +1035,10 @@ static void vfasl_relocate(vfasl_info *vfi, ptr *ppp) {
   }
 }
 
-static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n) {
+static ptr vfasl_relocate_code(vfasl_info *vfi, ptr code) {
-  ptr *end = pp + n;
+  /* We don't want to register `code` as a pointer, since it is
-
+     treated more directly */
-  while (pp != end) {
+  return vfasl_relocate_help(vfi, code);
-    vfasl_relocate(vfi, pp);
-    pp += 1;
-  }
-}
-
-static uptr sweep(vfasl_info *vfi, ptr p) {
-  ptr tf; ITYPE t;
-
-  t = TYPEBITS(p);
-  if (t == type_closure) {
-    uptr len;
-    ptr code;
-
-    len = CLOSLEN(p);
-    sweep_ptrs(vfi, &CLOSIT(p, 0), len);
-
-    /* To code-entry pointer looks like an immediate to
-       sweep, so relocate the code directly, and also make it
-       relative to the base address. */
-    code = vfasl_relocate_help(vfi, CLOSCODE(p));
-    code = (ptr)ptr_diff(code, vfi->base_addr);
-    SETCLOSCODE(p,code);
-
-    return size_closure(len);
-  } else if (t == type_symbol) {
-    vfasl_relocate(vfi, &INITSYMNAME(p));
-      /* other parts are replaced on load */
-    return size_symbol;
-  } else if (t == type_flonum) {
-    /* nothing to sweep */;
-    return size_flonum;
- /* typed objects */
-  } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) {
-    uptr len = Svector_length(p);
-    sweep_ptrs(vfi, &INITVECTIT(p, 0), len);
-    return size_vector(len);
-  } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_stencil_vector, type_stencil_vector)) {
-    uptr len = Sstencil_vector_length(p);
-    sweep_ptrs(vfi, &INITSTENVECTIT(p, 0), len);
-    return size_stencil_vector(len);
-  } else if (TYPEP(tf, mask_record, type_record)) {
-    return sweep_record(vfi, p);
-  } else if (TYPEP(tf, mask_box, type_box)) {
-    vfasl_relocate(vfi, &INITBOXREF(p));
-    return size_box;
-  } else if ((iptr)tf == type_ratnum) {
-    vfasl_relocate(vfi, &RATNUM(p));
-    vfasl_relocate(vfi, &RATDEN(p));
-    return size_ratnum;
-  } else if ((iptr)tf == type_exactnum) {
-    vfasl_relocate(vfi, &EXACTNUM_REAL_PART(p));
-    vfasl_relocate(vfi, &EXACTNUM_IMAG_PART(p));
-    return size_exactnum;
-  } else if (TYPEP(tf, mask_code, type_code)) {
-    return sweep_code_object(vfi, p);
-  } else {
-    S_error_abort("vfasl_sweep: illegal type");
-    return 0;
-  }
-}
-
-static uptr sweep_record(vfasl_info *vfi, ptr x)
-{
-    ptr *pp; ptr num; ptr rtd;
-
-    rtd = RECORDINSTTYPE(x);
-
-    if (x == vfi->base_rtd) {
-      /* Don't need to save fields of base-rtd */
-      ptr *pp = &RECORDINSTIT(x,0);
-      ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1;
-      while (pp < ppend) {
-        *pp = Snil;
-        pp += 1;
-      }
-      return size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
-    }
-
-    vfasl_relocate(vfi, &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) {
-            vfasl_relocate(vfi, pp);
-            pp += 1;
-          }
-        } else {
-          while (mask != 0) {
-            if (mask & 1) vfasl_relocate(vfi, pp);
-            mask >>= 1;
-            pp += 1;
-          }
-        }
-    } else {
-      iptr index; bigit mask; INT bits;
-
-      /* bignum pointer mask */
-      num = RECORDDESCPM(rtd);
-      vfasl_relocate(vfi, &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) vfasl_relocate(vfi, pp);
-          mask >>= 1;
-          pp += 1;
-        } while (--bits > 0);
-        if (index-- == 0) break;
-        mask = BIGIT(num,index);
-        bits = bigit_bits;
-      }
-    }
-
-    return size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
 }
 
 static int is_rtd(ptr tf, vfasl_info *vfi)
@@ -1389,70 +1076,34 @@ static int is_rtd(ptr tf, vfasl_info *vfi)
 #define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1))
 #define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS)
 
-static uptr sweep_code_object(vfasl_info *vfi, ptr co) {
+static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj) {
-    ptr t, oldco, oldt; iptr a, m, n;
+  ptr pos;
+  int which_singleton;
+  
+  if ((which_singleton = detect_singleton(obj))) {
+    obj = FIX(VFASL_RELOC_SINGLETON(which_singleton));
+  } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) {
+    if ((uptr)pos == CENTRY_install_library_entry)
+      vfi->installs_library_entry = 1;
+    obj = FIX(VFASL_RELOC_C_ENTRY(pos));
+  } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) {
+    obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos));
+  } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) {
+    obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos));
+  } else if (Ssymbolp(obj)) {
+    obj = vfasl_relocate_help(vfi, obj);
+    obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj))));
+  } else if (IMMEDIATE(obj)) {
+    /* as-is */
+    if (Sfixnump(obj))
+      if (obj != FIX(0)) /* allow 0 for fcallable cookie */
+        S_error("vfasl", "unexpected fixnum in relocation");
+  } else {
+    obj = vfasl_relocate_help(vfi, obj);
+    obj = (ptr)ptr_diff(obj, vfi->base_addr);
+  }
 
-    vfasl_relocate(vfi, &CODENAME(co));
+  return obj;
-    vfasl_relocate(vfi, &CODEARITYMASK(co));
-    vfasl_relocate(vfi, &CODEINFO(co));
-    vfasl_relocate(vfi, &CODEPINFOS(co));
-
-    oldt = CODERELOC(co);
-
-    n = size_reloc_table(RELOCSIZE(oldt));
-    t = vfasl_find_room(vfi, vspace_reloc, typemod, n);
-    copy_ptrs(typemod, t, oldt, n);
-
-    m = RELOCSIZE(t);
-    oldco = RELOCCODE(t);
-    a = 0;
-    n = 0;
-    while (n < m) {
-        uptr entry, item_off, code_off; ptr obj, pos;
-        int which_singleton;
- 
-        entry = RELOCIT(t, n); n += 1;
-        if (RELOC_EXTENDED_FORMAT(entry)) {
-            item_off = RELOCIT(t, n); n += 1;
-            code_off = RELOCIT(t, n); n += 1;
-        } else {
-            item_off = RELOC_ITEM_OFFSET(entry);
-            code_off = RELOC_CODE_OFFSET(entry);
-        }
-        a += code_off;
-        obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off);
-
-        if ((which_singleton = detect_singleton(obj))) {
-          obj = FIX(VFASL_RELOC_SINGLETON(which_singleton));
-        } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) {
-          if ((uptr)pos == CENTRY_install_library_entry)
-            vfi->installs_library_entry = 1;
-          obj = FIX(VFASL_RELOC_C_ENTRY(pos));
-        } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) {
-          obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos));
-        } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) {
-          obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos));
-        } else if (Ssymbolp(obj)) {
-          obj = vfasl_relocate_help(vfi, obj);
-          obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj))));
-        } else if (IMMEDIATE(obj)) {
-          /* as-is */
-          if (Sfixnump(obj))
-            if (obj != FIX(0)) /* allow 0 for fcallable cookie */
-              S_error("vfasl", "unexpected fixnum in relocation");
-        } else {
-          obj = vfasl_relocate_help(vfi, obj);
-          obj = (ptr)ptr_diff(obj, vfi->base_addr);
-        }
-
-        S_set_code_obj("vfasl", reloc_abs, co, a, obj, item_off);
-    }
-
-    RELOCCODE(t) = (ptr)ptr_diff(co, vfi->base_addr);
-    CODERELOC(co) = (ptr)ptr_diff(t, vfi->base_addr);
-    /* no vfasl_register_pointer, since relink_code can handle it */
-
-    return size_code(CODELEN(co));
 }
 
 static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static) {
@@ -1553,6 +1204,20 @@ static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offse
   return TYPE(ptr_add(vspaces[s], p_off - vspace_offsets[s]), t);
 }
 
+/*************************************************************/
+/* Symbol names                                              */
+
+static iptr vfasl_symbol_to_index(vfasl_info *vfi, ptr pp)
+{
+  uptr pos = vfi->sym_count++;
+  ptr name = SYMNAME(pp);
+  if (Sstringp(name))
+    vfasl_check_install_library_entry(vfi, name);
+  else if (!Spairp(name) || (Scar(name) == Sfalse))
+    vfasl_fail(vfi, "gensym without unique name");
+  return pos;
+}
+
 /*************************************************************/
 /* C and library entries                                     */
 

csug/smgmt.stex

@@ -128,7 +128,8 @@ storage management for dynamically typed languages''~\cite{Dybvig:sm}.
 \formdef{collect}{\categoryprocedure}{(collect)}
 \formdef{collect}{\categoryprocedure}{(collect \var{g})}
 \formdef{collect}{\categoryprocedure}{(collect \var{g} \var{tg})}
-\returns unspecified
+\formdef{collect}{\categoryprocedure}{(collect \var{g} \var{tg} \var{objs})}
+\returns a list if \var{objs} is a list, unspecified otherwise
 \listlibraries
 \endentryheader
 
@@ -141,6 +142,7 @@ If \var{g} is the maximum nonstatic generation,
 \scheme{static}.
 Otherwise, \var{tg} must be a fixnum equal to or one
 greater than \var{g}.
+\var{objs} must be either \scheme{#f} or a list.
 
 This procedure causes the storage manager to perform a garbage collection.
 \scheme{collect} is invoked periodically via the collect-request
@@ -152,6 +154,18 @@ In the threaded versions of {\ChezScheme}, the thread that invokes
 The system determines which generations to collect, based on \var{g} and
 \var{tg} if provided, as described in the lead-in to this section.
 
+If \var{objs} is a list, the collection is combined with counting as
+in \scheme{compute-size-increments}. Counting looks through all
+generations, as when \scheme{'static} is the second argument to
+\scheme{compute-size-increments}, but the returned sizes from
+\scheme{collect} do not include any objects in a generation older than
+\var{g}. Another difference is that an object later in \var{objs} are
+treated as unreachable by earlier objects in \var{objs} only when the
+later object is a record, thread, or procedure (including
+continuations). Finally, if an object is included in \var{objs} using
+a weak pair, then the object's result size is 0 unless it is reachable
+from earlier objects; if the object is not reachable at all, it can be
+collected.
 
 %----------------------------------------------------------------------------
 \entryheader

mats/misc.ms

@@ -1057,6 +1057,7 @@
   (error? (compute-size-increments (list 0) '()))
   (begin
     (define pair-size (compute-size (cons 1 2)))
+    (define ephemeron-size (compute-size (ephemeron-cons 1 2)))
     #t)
   (equal? (list pair-size pair-size)
           (compute-size-increments (list (cons 1 2) (cons 3 4))))
@@ -1070,25 +1071,25 @@
     (equal? (compute-size-increments ls)
             (reverse (compute-size-increments (reverse ls)))))
   ;; Ephemeron(s) found before key:
-  (equal? (list pair-size (* 2 pair-size))
+  (equal? (list ephemeron-size (* 2 pair-size))
           (compute-size-increments (let* ([p (cons 0 0)]
                                           [e (ephemeron-cons p (cons 0 0))])
                                      (list e p))))
-  (equal? (list pair-size (* 3 pair-size))
+  (equal? (list ephemeron-size (* 3 pair-size))
           (let* ([v (cons 1 2)]
                  [e (ephemeron-cons v (cons 3 4))])
             (compute-size-increments (list e (cons v #f)))))
-  (equal? (list (* 4 pair-size) (* 4 pair-size))
+  (equal? (list (* 2 (+ ephemeron-size pair-size)) (* 4 pair-size))
           (let* ([v (cons 1 2)]
                  [e* (list (ephemeron-cons v (cons 3 4))
                            (ephemeron-cons v (cons 5 6)))])
             (compute-size-increments (list e* (cons v #f)))))
   ;; Key found before ephemeron(s):
-  (equal? (list (* 2 pair-size) (* 2 pair-size))
+  (equal? (list (* 2 pair-size) (+ ephemeron-size pair-size))
           (let* ([v (cons 1 2)]
                  [e (ephemeron-cons v (cons 3 4))])
             (compute-size-increments (list (cons v #f) e))))
-  (equal? (list (* 2 pair-size) (* 6 pair-size))
+  (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size)))
           (let* ([v (cons 1 2)]
                  [e* (list (ephemeron-cons v (cons 3 4))
                            (ephemeron-cons v (cons 5 6)))])
@@ -1150,6 +1151,79 @@
             (or (eq? (current-eval) interpret) ; interpreter continuaton is not precise enough
                 (and (> (car pre-sizes) N)
                      (< (car post-sizes) N)))))))
+  )
+
+(mat collect+compute-size-increments
+  (eq? (void) (collect 0 0 #f))
+  (eq? '() (collect 0 0 '()))
+
+  (error? (collect 0 0 'not-a-list))
+  (error? (collect 0 0 0))
+  (error? (collect 'not-a-generation 0 '()))
+  (error? (collect 0 'not-a-generation '()))
+  (error? (collect 1 0 '()))
+  
+  (begin
+    (define-record-type count-wrap (fields val))
+    (collect 0 0 (list (make-count-wrap 0))) ; take care of one-time initialization costs
+    (define wrap-size (car (collect 0 0 (list (make-count-wrap 0))))) ; includes rtd
+    (define just-wrap-size (cadr (collect 0 0 (list (make-count-wrap 0) (make-count-wrap 1)))))
+    (define pair-size (compute-size (cons 1 2)))
+    (define ephemeron-size (compute-size (ephemeron-cons 1 2)))
+    #t)
+  (equal? (list pair-size pair-size)
+          (collect 0 0 (list (cons 1 2) (cons 3 4))))
+  (equal? (list (* 3 pair-size) pair-size)
+          (let ([l (list 1 2)])
+            (collect 0 0 (list (cons 3 l) (cons 4 l)))))
+  (equal? (list pair-size)
+          (collect 0 0 (list (weak-cons (make-bytevector 100) #f))))
+  ;; Ephemeron(s) found before key:
+  (equal? (list ephemeron-size (+ (* 2 pair-size) wrap-size))
+          (collect 0 0 (let* ([p (make-count-wrap (cons 0 0))]
+                              [e (ephemeron-cons p (cons 0 0))])
+                         (list e p))))
+  (equal? (list ephemeron-size (+ (* 3 pair-size) wrap-size))
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [e (ephemeron-cons v (cons 3 4))])
+            (collect 0 0 (list e (cons v #f)))))
+  (equal? (list (* 2 (+ ephemeron-size pair-size)) (+ (* 4 pair-size) wrap-size))
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [e* (list (ephemeron-cons v (cons 3 4))
+                           (ephemeron-cons v (cons 5 6)))])
+            (collect 0 0 (list e* (cons v #f)))))
+  ;; Key found before ephemeron(s):
+  (equal? (list (+ (* 2 pair-size) wrap-size) (+ ephemeron-size pair-size))
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [e (ephemeron-cons v (cons 3 4))])
+            (collect 0 0 (list (cons v #f) e))))
+  (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size)))
+          (let* ([v (cons 1 2)]
+                 [e* (list (ephemeron-cons v (cons 3 4))
+                           (ephemeron-cons v (cons 5 6)))])
+            (collect 0 0 (list (cons v #f) e*))))
+  ;; Weakly held objects:
+  (equal? '(0)
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [ls (weak-cons v '())])
+            (collect 0 0 ls)))
+  (equal? (list wrap-size pair-size (+ just-wrap-size pair-size))
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [ls (cons* (make-count-wrap 0) (cons v 1) (weak-cons v '()))])
+            (collect 0 0 ls)))
+  (equal? (list 0 (+ wrap-size (* 2 pair-size)))
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [ls (weak-cons v (cons (cons v 1) '()))])
+            (collect 0 0 ls)))
+  (equal? #!bwp
+          (let* ([v (make-count-wrap (cons 1 2))]
+                 [ls (weak-cons v '())])
+            (collect 0 0 ls)
+            (car ls)))
+  ;; These calls will encounter many kinds of objects, just to make
+  ;; sure they don't fail:
+  (list? (collect 0 0 (list (call/cc values))))
+  (list? (collect (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values))))
 )
 
 (mat compute-composition

mats/thread.ms

@@ -1553,7 +1553,8 @@
         (unless (= i 0)
           (fork-thread (lambda () (let loop ()
                                     (unless (with-mutex m
-                                               (condition-wait c m)
+                                               (unless done?
+                                                 (condition-wait c m))
                                                done?)
                                       (collect-rendezvous)
                                       (loop)))))

s/7.ss

@@ -754,12 +754,12 @@
   (define gc-count 0)
   (define start-bytes 0)
   (define docollect
-    (let ([do-gc (foreign-procedure "(cs)do_gc" (int int) void)])
+    (let ([do-gc (foreign-procedure "(cs)do_gc" (int int ptr) ptr)])
       (lambda (p)
         (with-tc-mutex
           (unless (= $active-threads 1)
             ($oops 'collect "cannot collect when multiple threads are active"))
-          (let-values ([(trip g gtarget) (p gc-trip)])
+          (let-values ([(trip g gtarget count-roots) (p gc-trip)])
             (set! gc-trip trip)
             (let ([cpu (current-time 'time-thread)] [real (current-time 'time-monotonic)])
               (set! gc-bytes (+ gc-bytes (bytes-allocated)))
@@ -770,17 +770,18 @@
                 (flush-output-port (console-output-port)))
               (when (eqv? g (collect-maximum-generation))
                 ($clear-source-lines-cache))
-              (do-gc g gtarget)
+              (let ([gc-result (do-gc g gtarget count-roots)])
-              ($close-resurrected-files)
+                ($close-resurrected-files)
-              (when-feature pthreads
+                (when-feature pthreads
-                ($close-resurrected-mutexes&conditions))
+                  ($close-resurrected-mutexes&conditions))
-              (when (collect-notify)
+                (when (collect-notify)
-                (fprintf (console-output-port) "done]~%")
+                  (fprintf (console-output-port) "done]~%")
-                (flush-output-port (console-output-port)))
+                  (flush-output-port (console-output-port)))
-              (set! gc-bytes (- gc-bytes (bytes-allocated)))
+                (set! gc-bytes (- gc-bytes (bytes-allocated)))
-              (set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu)))
+                (set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu)))
-              (set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real)))
+                (set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real)))
-              (set! gc-count (1+ gc-count))))))))
+                (set! gc-count (1+ gc-count))
+                gc-result)))))))
   (define collect-init
     (lambda ()
       (set! gc-trip 0)
@@ -815,11 +816,11 @@
               (let loop ([g (collect-maximum-generation)])
                 (if (= (modulo gct (expt (collect-generation-radix) g)) 0)
                     (if (fx= g (collect-maximum-generation))
-                        (values 0 g g)
+                        (values 0 g g #f)
-                        (values gct g (fx+ g 1)))
+                        (values gct g (fx+ g 1) #f))
                     (loop (fx- g 1)))))))))
     (define collect2
-      (lambda (g gtarget)
+      (lambda (g gtarget count-roots)
         (docollect
           (lambda (gct)
             (values 
@@ -833,21 +834,24 @@
                         (+ gct (modulo (- n gct) n))))
                     (let ([next (trip g)] [limit (trip (fx+ g 1))])
                       (if (< next limit) next (- limit 1)))))
-              g gtarget)))))
+              g gtarget count-roots)))))
     (case-lambda
       [() (collect0)]
       [(g)
        (unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))
          ($oops who "invalid generation ~s" g))
-       (collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)))]
+       (collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)) #f)]
-      [(g gtarget)
+      [(g gtarget) (collect g gtarget #f)]
+      [(g gtarget count-roots)
        (unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))
          ($oops who "invalid generation ~s" g))
        (unless (if (fx= g (collect-maximum-generation))
                    (or (eqv? gtarget g) (eq? gtarget 'static))
                    (or (eqv? gtarget g) (eqv? gtarget (fx+ g 1))))
          ($oops who "invalid target generation ~s for generation ~s" gtarget g))
-       (collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))])))
+       (unless (or (not count-roots) (list? count-roots))
+         ($oops who "invalid counting-roots list ~s" count-roots))
+       (collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget) count-roots)])))
 
 (set! collect-rendezvous
   (let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)])

s/Mf-base

@@ -108,6 +108,9 @@ PetiteBoot = ../boot/$m/petite.boot
 SchemeBoot = ../boot/$m/scheme.boot
 Cheader = ../boot/$m/scheme.h
 Cequates = ../boot/$m/equates.h
+Cgcocd = ../boot/$m/gc-ocd.inc
+Cgcoce = ../boot/$m/gc-oce.inc
+Cvfasl = ../boot/$m/vfasl.inc
 Revision = ../boot/$m/revision
 
 # The following controls the patch files loaded before compiling, typically used only
@@ -164,11 +167,11 @@ allsrc =\
  np-languages.ss bitset.ss fxmap.ss
 
 # doit uses a different Scheme process to compile each target
-doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Revision}
+doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
 
 # all uses a single Scheme process to compile all targets.  this is typically
 # faster when most of the targets need to be recompiled.
-all: bootall ${Cheader} ${Cequates} ${Revision}
+all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
 
 # allx runs all up to three times and checks to see if the new boot file is the
 # same as the last, i.e., the system is properly bootstrapped.
@@ -194,7 +197,7 @@ bootstrap: ${allsrc} | ${Revision}
 	touch bootstrap
 
 # source eagerly creates links to most of the files that might be needed
-source: ${allsrc} mkheader.ss script.all
+source: ${allsrc} mkheader.ss mkgc.ss script.all
 
 # profiled goes through the involved process of building a profile-optimized boot file
 profiled:
@@ -414,6 +417,21 @@ mkheader.so: mkheader.ss cmacros.so primvars.so env.so
              '(compile-file "$*.ss" "$*.so")'\
              | ${Scheme} -q cmacros.so priminfo.so primvars.so env.so
 
+mkgc.so: mkgc.ss mkheader.so cmacros.so primvars.so env.so
+	echo '(reset-handler abort)'\
+             '(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
+             '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
+             '(optimize-level 0)'\
+             '(debug-level $d)'\
+             '(commonization-level $(cl))'\
+             '(compile-compressed #$(cc))'\
+             '(compress-format $(xf))'\
+             '(compress-level $(xl))'\
+             '(generate-inspector-information #$i)'\
+             '(subset-mode (quote system))'\
+             '(compile-file "$*.ss" "$*.so")'\
+             | ${Scheme} -q cmacros.so priminfo.so primvars.so env.so mkheader.so
+
 nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss
 	echo '(reset-handler abort)'\
              '(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
@@ -582,6 +600,33 @@ ${Cequates}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss pri
           then mv -f ${Cequates}.bak ${Cequates};\
           else rm -f ${Cequates}.bak; fi)
 
+${Cgcocd}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
+	(if [ -r ${Cgcocd} ]; then mv -f ${Cgcocd} ${Cgcocd}.bak; fi)
+	echo '(reset-handler abort)'\
+             '(mkgc-ocd.inc "${Cgcocd}")' |\
+         ${Scheme} -q ${macroobj} mkheader.so mkgc.so
+	(if `cmp -s ${Cgcocd} ${Cgcocd}.bak`;\
+          then mv -f ${Cgcocd}.bak ${Cgcocd};\
+          else rm -f ${Cgcocd}.bak; fi)
+
+${Cgcoce}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
+	(if [ -r ${Cgcoce} ]; then mv -f ${Cgcoce} ${Cgcoce}.bak; fi)
+	echo '(reset-handler abort)'\
+             '(mkgc-oce.inc "${Cgcoce}")' |\
+         ${Scheme} -q ${macroobj} mkheader.so mkgc.so
+	(if `cmp -s ${Cgcoce} ${Cgcoce}.bak`;\
+          then mv -f ${Cgcoce}.bak ${Cgcoce};\
+          else rm -f ${Cgcoce}.bak; fi)
+
+${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
+	(if [ -r ${Cvfasl} ]; then mv -f ${Cvfasl} ${Cvfasl}.bak; fi)
+	echo '(reset-handler abort)'\
+             '(mkvfasl.inc "${Cvfasl}")' |\
+         ${Scheme} -q ${macroobj} mkheader.so mkgc.so
+	(if `cmp -s ${Cvfasl} ${Cvfasl}.bak`;\
+          then mv -f ${Cvfasl}.bak ${Cvfasl};\
+          else rm -f ${Cvfasl}.bak; fi)
+
 .PHONY: ${Revision}
 ${Revision}: update-revision
 	@./update-revision > ${Revision}

s/cmacros.ss

@@ -662,11 +662,13 @@
       (pure-typed-object "p-tobj" #\r 9) ;
       (impure-record "ip-rec" #\s 10)    ;
       (impure-typed-object "ip-tobj" #\t 11) ; as needed (instead of impure) for backtraces
-      (closure "closure" #\l 12))        ; as needed (instead of pure/impure) for backtraces
+      (closure "closure" #\l 12)         ; as needed (instead of pure/impure) for backtraces
+      (count-pure "count-pure" #\y 13)     ; like pure, but delayed for counting from roots
+      (count-impure "count-impure" #\z 14)); like impure-typed-object, but delayed for counting from roots
     (unswept
-      (data "data" #\d 13)))             ; unswept objects allocated here
+      (data "data" #\d 15)))             ; unswept objects allocated here
   (unreal
-    (empty "empty" #\e 14)))             ; available segments
+    (empty "empty" #\e 16)))             ; available segments
 
 ;;; enumeration of types for which gc tracks object counts
 ;;; also update gc.c
@@ -698,7 +700,8 @@
 (define-constant countof-oblist 24)
 (define-constant countof-ephemeron 25)
 (define-constant countof-stencil-vector 26)
-(define-constant countof-types 27)
+(define-constant countof-record 27)
+(define-constant countof-types 28)
 
 ;;; type-fixnum is assumed to be all zeros by at least by vector, fxvector,
 ;;; and bytevector index checks
@@ -1367,7 +1370,7 @@
    [ptr data 0]))
 
 (define-primitive-structure-disps thread type-typed-object
-  ([ptr type] [uptr tc]))
+  ([iptr type] [uptr tc]))
 
 (define-constant virtual-register-count 16)
 

s/inspect.ss

@@ -2604,24 +2604,27 @@
                    [(and (eqv? space (constant space-weakpair))
                          (not single-inspect-mode?))
                     (fx+ (constant size-pair) (compute-size (cdr x)))]
-                   [(and (eqv? space (constant space-ephemeron))
+                   [(eqv? space (constant space-ephemeron))
-                         (not single-inspect-mode?)
+                    (cond
-                         (let ([a (car x)])
+                      [(and (not single-inspect-mode?)
-                           (not (or ($immediate? a)
+                            (let ([a (car x)])
-                                    (let ([g ($generation a)])
+                              (not (or ($immediate? a)
-                                      (or (not g) (fx> g maxgen)))
+                                       (let ([g ($generation a)])
-                                    (and (eq-bitset-member? size-ht-or-bitset a)
+                                         (or (not g) (fx> g maxgen)))
-                                         (not (eq-hashtable-ref ephemeron-non-keys a #f)))))))
+                                       (and (eq-bitset-member? size-ht-or-bitset a)
-                    (let ([d (cdr x)])
+                                            (not (eq-hashtable-ref ephemeron-non-keys a #f)))))))
-                      (unless ($immediate? d)
+                       (let ([d (cdr x)])
-                        (unless ephemeron-triggers-bitset
+                         (unless ($immediate? d)
-                          (set! ephemeron-triggers-bitset (make-eq-bitset))
+                           (unless ephemeron-triggers-bitset
-                          (set! ephemeron-triggers (make-eq-hashtable)))
+                             (set! ephemeron-triggers-bitset (make-eq-bitset))
-                        (let ([v (car x)])
+                             (set! ephemeron-triggers (make-eq-hashtable)))
-                          (eq-bitset-add! ephemeron-triggers-bitset v)
+                           (let ([v (car x)])
-                          (let ([a (eq-hashtable-cell ephemeron-triggers v '())])
+                             (eq-bitset-add! ephemeron-triggers-bitset v)
-                            (set-cdr! a (cons d (cdr a)))))))
+                             (let ([a (eq-hashtable-cell ephemeron-triggers v '())])
-                    (constant size-pair)]
+                               (set-cdr! a (cons d (cdr a)))))))
+                       (constant size-ephemeron)]
+                      [else
+                       (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))])]
                    [else
                     (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]))]
                [(symbol? x)

s/mkheader.ss

@@ -76,6 +76,9 @@
          (lambda (a)
            (apply
              (lambda (field type disp len)
+               (putprop (string->symbol (format "~a-~a" struct field)) '*c-ref* (if len
+                                                                                    (cons name len)
+                                                                                    name))
                (if len
                    (def (format "~s(x,i)" name)
                         (format (if (eq? ref &ref) "(~a+i)" "(~a[i])")
@@ -170,7 +173,9 @@
 
   (set-who! mkscheme.h
     (lambda (ofn target-machine)
-      (fluid-let ([op (open-output-file ofn 'replace)])
+      (fluid-let ([op (if (output-port? ofn)
+                          ofn
+                          (open-output-file ofn 'replace))])
         (comment "scheme.h for Chez Scheme Version ~a (~a)" scheme-version target-machine)
   
         (nl)
@@ -706,7 +711,9 @@
 
   (set! mkequates.h
     (lambda (ofn)
-      (fluid-let ([op (open-output-file ofn 'replace)])
+      (fluid-let ([op (if (output-port? ofn)
+                          ofn
+                          (open-output-file ofn 'replace))])
         (comment "equates.h for Chez Scheme Version ~a" scheme-version)
   
         (nl)
@@ -736,8 +743,10 @@
             (cond
               [(getprop x '*constant* #f) =>
                (lambda (k)
-                 (let ([type (getprop x '*constant-ctype* #f)])
+                 (let ([type (getprop x '*constant-ctype* #f)]
-                   (def (sanitize x)
+                       [c-name (sanitize x)])
+                   (putprop x '*c-name* c-name)
+                   (def c-name
                      (if (or (fixnum? k) (bignum? k))
                          (if (< k 0)
                              (if (or (not type) (eq? type 'int))
@@ -994,6 +1003,7 @@
 
         (nl)
         (comment "threads")
+        (defref THREADTYPE thread type)
         (defref THREADTC thread tc)
 
         (nl)

s/primdata.ss

@@ -1220,7 +1220,7 @@
   (chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags])
   (clear-input-port [sig [() (input-port) -> (void)]] [flags true])
   (clear-output-port [sig [() (output-port) -> (void)]] [flags true])
-  (collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) -> (void)]] [flags true])
+  (collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) (sub-ufixnum ptr ptr) -> (void/list)]] [flags true])
   (collect-rendezvous [sig [() -> (void)]] [flags])
   (collections [sig [() -> (uint)]] [flags unrestricted alloc])
   (compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags])

workarea

@@ -182,6 +182,8 @@ workdir $W/boot
 workdir $W/boot/$M
 (cd $W/boot/$M; workln ../../../boot/$M/scheme.h scheme.h)
 (cd $W/boot/$M; workln ../../../boot/$M/equates.h equates.h)
+(cd $W/boot/$M; workln ../../../boot/$M/gc-ocd.inc gc-ocd.inc)
+(cd $W/boot/$M; workln ../../../boot/$M/gc-oce.inc gc-oce.inc)
 (cd $W/boot/$M; workln ../../../boot/$M/petite.boot petite.boot)
 (cd $W/boot/$M; workln ../../../boot/$M/scheme.boot scheme.boot)
 (cd $W/boot/$M; workln ../../../boot/$M/def.so def.so)