Chez Scheme GC: internal parallelism by messages instead of locks

Change the internal parallelism strategy for the GC to record an owner
for each allocated segment of memory, and have the owner be solely
responsible for copying or marking objects of the segment. When
sweeping, a collecting thread handles references to objects that it
owns or that have been copied or marked already, and it asks another
collecting thread to resweep an object that refers to objects owned by
that that thread. At worst, an object ends up being swept by all
collecting threads, one at a time, but that's unlikely for a given
object.

The approach seems likely to scale better than a lock-based approach,
even the one that used a lightweight, CAS-based lock and retries on
lock failure.

.makefile

@@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
 
 # This branch name changes each time the pb boot files are updated:
-PB_BRANCH == circa-7.8.0.10-7
+PB_BRANCH == circa-7.8.0.10-11
 PB_REPO == https://github.com/racket/pb
 
 # Alternative source for Chez Scheme boot files, normally set by

Makefile

@@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
 RACKET =
 RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
-PB_BRANCH = circa-7.8.0.10-7
+PB_BRANCH = circa-7.8.0.10-11
 PB_REPO = https://github.com/racket/pb
 EXTRA_REPOS_BASE =
 CS_CROSS_SUFFIX =
@@ -306,14 +306,14 @@ maybe-fetch-pb-as-is:
 	echo done
 fetch-pb-from:
 	mkdir -p racket/src/ChezScheme/boot
-	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-7.8.0.10-7 https://github.com/racket/pb racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.8.0.10-7:remotes/origin/circa-7.8.0.10-7 ; fi
+	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-7.8.0.10-11 https://github.com/racket/pb racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.8.0.10-11:remotes/origin/circa-7.8.0.10-11 ; fi
-	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.8.0.10-7
+	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.8.0.10-11
 pb-stage:
-	cd racket/src/ChezScheme/boot/pb && git branch circa-7.8.0.10-7
+	cd racket/src/ChezScheme/boot/pb && git branch circa-7.8.0.10-11
-	cd racket/src/ChezScheme/boot/pb && git checkout circa-7.8.0.10-7
+	cd racket/src/ChezScheme/boot/pb && git checkout circa-7.8.0.10-11
 	cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
 pb-push:
-	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.8.0.10-7
+	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.8.0.10-11
 win-cs-base:
 	IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" GIT_CLONE_ARGS_qq="$(GIT_CLONE_ARGS_qq)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
 	IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" GIT_CLONE_ARGS_qq="$(GIT_CLONE_ARGS_qq)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

racket/src/ChezScheme/c/Mf-base

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

racket/src/ChezScheme/c/alloc.c

@@ -80,6 +80,9 @@ void S_alloc_init() {
         S_protect(&S_G.null_immutable_string);
         find_room(tc, space_new, 0, type_typed_object, size_string(0), S_G.null_immutable_string);
         STRTYPE(S_G.null_immutable_string) = (0 << string_length_offset) | type_string | string_immutable_flag;
+
+        S_protect(&S_G.zero_length_bignum);
+        S_G.zero_length_bignum = S_bignum(tc, 0, 0);
     }
 }
 

racket/src/ChezScheme/c/gcwrapper.c

@@ -15,6 +15,7 @@
  */
 
 #include "system.h"
+#include "popcount.h"
 
 /* locally defined functions */
 static void segment_tell PROTO((uptr seg));
@@ -545,6 +546,59 @@ void S_addr_tell(ptr p) {
   segment_tell(addr_get_segment(p));
 }
 
+static void check_pointer(ptr *pp, IBOOL address_is_meaningful, ptr base, uptr seg, ISPC s, IBOOL aftergc) {
+  ptr p = *pp;
+  if (!IMMEDIATE(p)) {
+    seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
+    if (psi != NULL) {
+      if ((psi->space == space_empty)
+          || psi->old_space
+          || (psi->marked_mask && !(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))
+              /* corner case: a continuation in space_count_pure can refer to code via CLOSENTRY
+                 where the entry point doesn't have a mark bit: */
+              && !((s == space_count_pure) && (psi->space == space_code)))) {
+        S_checkheap_errors += 1;
+        printf("!!! dangling reference at %s"PHtx" to "PHtx"%s\n",
+               (address_is_meaningful ? "" : "insideof "),
+               (ptrdiff_t)(address_is_meaningful ? pp : TO_VOIDP(base)),
+               (ptrdiff_t)p, (aftergc ? " after gc" : ""));
+        printf("from: "); segment_tell(seg);
+        printf("to:   "); segment_tell(ptr_get_segment(p));
+        {
+          ptr l;
+          for (l = S_G.locked_objects[psi->generation]; l != Snil; l = Scdr(l))
+            if (Scar(l) == p)
+              printf(" in locked\n");
+          for (l = S_G.unlocked_objects[psi->generation]; l != Snil; l = Scdr(l))
+            if (Scar(l) == p)
+              printf(" in unlocked\n");
+        }
+        abort(); // REMOVEME
+      }
+    }
+  }
+}
+
+static void check_bignum(ptr p) {
+  if (!Sbignump(p))
+    printf("!!! not a bignum %p\n", TO_VOIDP(p));
+}
+
+#include "heapcheck.inc"
+
+static ptr *find_nl(ptr *pp1, ptr *pp2, ISPC s, IGEN g) {
+  ptr *nl, ls;
+
+  for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
+    ptr t_tc = (ptr)THREADTC(Scar(ls));
+    nl = TO_VOIDP(NEXTLOC_AT(t_tc, s, g));
+    if (pp1 <= nl && nl < pp2)
+      return nl;
+  }
+
+  return NULL;
+}
+
 static void check_heap_dirty_msg(msg, x) char *msg; ptr *x; {
     INT d; seginfo *si;
 
@@ -577,6 +631,13 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
             printf("!!! inconsistent thread NEXT %p and BASE %p\n",
                    TO_VOIDP(NEXTLOC_AT(t_tc, s, g)), TO_VOIDP(BASELOC_AT(t_tc, s, g)));
           }
+          if ((REMOTERANGEEND(t_tc) != (ptr)0)
+              || (REMOTERANGESTART(t_tc) != (ptr)(uptr)-1)) {
+            S_checkheap_errors += 1;
+            printf("!!! nonempty thread REMOTERANGE %p-%p\n",
+                   TO_VOIDP(REMOTERANGESTART(t_tc)),
+                   TO_VOIDP(REMOTERANGEEND(t_tc)));
+          }
         }
       }
     }
@@ -669,25 +730,102 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
             printf("!!! unexpected generation %d segment "PHtx" in space_new\n", g, (ptrdiff_t)seg);
           }
         } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair || s == space_ephemeron
-                   || s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure) {
+                   || s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure
-          /* doesn't handle: space_port, space_continuation, space_code, space_pure_typed_object,
+                   || s == space_pure_typed_object || s == space_continuation || s == space_port || s == space_code
-                             space_impure_record, or impure_typed_object */
+                   || s == space_impure_record || s == space_impure_typed_object) {
+          ptr start;
+          
           /* check for dangling references */
           pp1 = TO_VOIDP(build_ptr(seg, 0));
           pp2 = TO_VOIDP(build_ptr(seg + 1, 0));
 
-          nl = NULL;
+          nl = find_nl(pp1, pp2, s, g);
-          {
-            ptr ls;
-            for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
-              ptr t_tc = (ptr)THREADTC(Scar(ls));
-              nl = TO_VOIDP(NEXTLOC_AT(t_tc, s, g));
-              if (pp1 <= nl && nl < pp2)
-                break;
-            }
-          }
           if (pp1 <= nl && nl < pp2) pp2 = nl;
 
+          if (s == space_pure_typed_object || s == space_port || s == space_code
+              || s == space_impure_record || s == space_impure_typed_object) {
+            if (si->marked_mask) {
+              /* not implemented */
+            } else {
+              /* only check this segment for objects that start on it */
+              uptr before_seg = seg;
+
+              /* Back up over segments for the same space and generation: */
+              while (1) {
+                seginfo *before_si = MaybeSegInfo(before_seg-1);
+                if (!before_si
+                    || (before_si->space != si->space)
+                    || (before_si->generation != si->generation)
+                    || ((before_si->marked_mask == NULL) != (si->marked_mask == NULL)))
+                  break;
+                before_seg--;
+              }
+
+              /* Move forward to reach `seg` again: */
+              start = build_ptr(before_seg, 0);
+              while (before_seg != seg) {
+                ptr *before_pp2, *before_nl;
+
+                before_pp2 = TO_VOIDP(build_ptr(before_seg + 1, 0));
+                if ((ptr *)TO_VOIDP(start) > before_pp2) {
+                  /* skipped to a further segment */
+                  before_seg++;
+                } else {
+                  before_nl = find_nl(TO_VOIDP(start), before_pp2, s, g);
+                  if (((ptr*)TO_VOIDP(start)) <= before_nl && before_nl < before_pp2) {
+                    /* this segment ends, so move to next segment */
+                    before_seg++;
+                    if (s == space_code) {
+                      /* in the case of code, it's possible for a whole segment to
+                         go unused if a large code object didn't fit; give up, just in case */
+                      start = build_ptr(seg+1, 0);
+                    } else {
+                      start = build_ptr(before_seg, 0);
+                    }
+                  } else {
+                    while (((ptr *)TO_VOIDP(start)) < before_pp2) {
+                      if (*(ptr *)TO_VOIDP(start) == forward_marker) {
+                        /* this segment ends, so move to next segment */
+                        if (s == space_code) {
+                          start = build_ptr(seg+1, 0);
+                        } else {
+                          start = build_ptr(before_seg+1, 0);
+                        }
+                      } else {
+                        start = (ptr)((uptr)start + size_object(TYPE(start, type_typed_object)));
+                      }
+                    }
+                    before_seg++;
+                  }
+                }
+              }
+
+              if (((ptr *)TO_VOIDP(start)) >= pp2) {
+                /* previous object extended past the segment */
+              }  else {
+                pp1 = TO_VOIDP(start);
+                while (pp1 < pp2) {
+                  if (*pp1 == forward_marker)
+                    break;
+                  else {
+                    p = TYPE(TO_PTR(pp1), type_typed_object);
+                    check_object(p, seg, s, aftergc);
+                    pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_object(p)));
+                  }
+                }
+              }
+            }
+          } else if (s == space_continuation) {
+            while (pp1 < pp2) {
+              if (*pp1 == forward_marker)
+                break;
+              if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) {
+                p = TYPE(TO_PTR(pp1), type_closure);
+                check_object(p, seg, s, aftergc);
+              }
+              pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_continuation));
+            }
+          } else {
             while (pp1 < pp2) {
               if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) {
                 int a;
@@ -700,30 +838,8 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
                     if (!si->marked_mask && (p == forward_marker)) {
                       pp1 = pp2; /* break out of outer loop */
                       break;
-                  } else if (!IMMEDIATE(p)) {
+                    } else {
-                    seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
+                      check_pointer(pp1, 1, (ptr)0, seg, s, aftergc);
-                    if (psi != NULL) {
-                      if ((psi->space == space_empty)
-                          || psi->old_space
-                          || (psi->marked_mask && !(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))
-                              /* corner case: a continuation in space_count_pure can refer to code via CLOSENTRY
-                                 where the entry point doesn't have a mark bit: */
-                              && !((s == space_count_pure) && (psi->space == space_code)))) {
-                        S_checkheap_errors += 1;
-                        printf("!!! dangling reference at "PHtx" to "PHtx"%s\n", (ptrdiff_t)pp1, (ptrdiff_t)p, (aftergc ? " after gc" : ""));
-                        printf("from: "); segment_tell(seg);
-                        printf("to:   "); segment_tell(ptr_get_segment(p));
-                        {
-                          ptr l;
-                          for (l = S_G.locked_objects[psi->generation]; l != Snil; l = Scdr(l))
-                            if (Scar(l) == p)
-                              printf(" in locked\n");
-                          for (l = S_G.unlocked_objects[psi->generation]; l != Snil; l = Scdr(l))
-                            if (Scar(l) == p)
-                              printf(" in unlocked\n");
-                        }
-                      }
-                    }
                     }
                   }
                   pp1 += 1;
@@ -731,6 +847,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
               } else
                 pp1 += ptr_alignment;
             }
+          }
 
           /* verify that dirty bits are set appropriately */
           /* out of date: doesn't handle space_impure_record, space_port, and maybe others */

racket/src/ChezScheme/c/globals.h

@@ -117,6 +117,7 @@ EXTERN struct S_G_struct {
     ptr null_immutable_vector;
     ptr null_immutable_fxvector;
     ptr null_immutable_bytevector;
+    ptr zero_length_bignum;
     seginfo *dirty_segments[DIRTY_SEGMENT_LISTS];
 
   /* schsig.c */

racket/src/ChezScheme/c/scheme.c

@@ -330,6 +330,13 @@ static void idiot_checks() {
     oops = 1;
   }
 
+  if ((((code_flag_continuation << code_flags_offset) | (code_flag_mutable_closure << code_flags_offset))
+       & (uptr)forward_marker) != 0) {
+    /* parallel GC relies on not confusing a forward marker with code flags */
+    fprintf(stderr, "code flags overlap with forwadr_marker\n");
+    oops = 1;
+  } 
+
   if (oops) S_abnormal_exit();
 }
 

racket/src/ChezScheme/c/segment.c

@@ -235,7 +235,6 @@ static void initialize_seginfo(seginfo *si, NO_THREADS_UNUSED ptr tc, ISPC s, IG
   si->use_marks = 0;
   si->must_mark = 0;
 #ifdef PTHREADS
-  si->lock = 0;
   si->creator_tc = tc;
 #endif
   si->list_bits = NULL;

racket/src/ChezScheme/c/thread.c

@@ -142,7 +142,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
   LZ4OUTBUFFER(tc) = 0;
 
   SWEEPER(tc) = -1;
-  LOCKSTATUS(tc) = Strue;
+  REMOTERANGESTART(tc) = (ptr)(uptr)-1;
+  REMOTERANGEEND(tc) = (ptr)0;
 
   tc_mutex_release();
 

racket/src/ChezScheme/c/types.h

@@ -158,8 +158,7 @@ typedef struct _seginfo {
   octet *list_bits;                         /* for `$list-bits-ref` and `$list-bits-set!` */
   uptr number;                              /* the segment number */
 #ifdef PTHREADS
-  ptr lock;                                 /* for parallel GC */
+  ptr creator_tc;                           /* for GC parallelism heuristic; might not match an active thread unless old_space */
-  ptr creator_tc;                           /* for parallelism heuristic; might not match an active thread */
 #endif
   struct _chunkinfo *chunk;                 /* the chunk this segment belongs to */
   struct _seginfo *next;                    /* pointer to the next seginfo (used in occupied_segments and unused_segs) */

racket/src/ChezScheme/c/vfasl.c

@@ -1151,10 +1151,20 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets
     t = CODERELOC(co);
     t = ptr_add(vspaces[vspace_reloc], (uptr)t - vspace_offsets[vspace_reloc]);
 
-    if (to_static && !S_G.retain_static_relocation
+    if (to_static && !S_G.retain_static_relocation) {
-        && ((CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0))
+      if ((CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0)
         CODERELOC(co) = (ptr)0;
       else {
+        ptr tc = get_thread_context();
+        iptr sz = size_reloc_table(RELOCSIZE(t));
+        ptr new_t;
+        find_room(tc, space_data, static_generation, typemod, ptr_align(sz), new_t);
+        memcpy(TO_VOIDP(new_t), TO_VOIDP(t), sz);
+        t = new_t;
+        CODERELOC(co) = t;
+        RELOCCODE(t) = co;
+      }
+    } else {
       CODERELOC(co) = t;
       RELOCCODE(t) = co;
     }

racket/src/ChezScheme/rktboot/make-boot.rkt

@@ -401,7 +401,9 @@
       (status "Generate GC")
       (eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc"))))
       (eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc"))))
+      (eval `(mkgc-par.inc ,(path->string (build-path out-subdir "gc-par.inc"))))
       (eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc"))))
+      (eval `(mkheapcheck.inc ,(path->string (build-path out-subdir "heapcheck.inc"))))
       (plumber-flush-all (current-plumber))))
 
   (when (getenv "MAKE_BOOT_FOR_CROSS")

racket/src/ChezScheme/s/Mf-base

@@ -114,7 +114,9 @@ Cheader = ../boot/$m/scheme.h
 Cequates = ../boot/$m/equates.h
 Cgcocd = ../boot/$m/gc-ocd.inc
 Cgcoce = ../boot/$m/gc-oce.inc
+Cgcpar = ../boot/$m/gc-par.inc
 Cvfasl = ../boot/$m/vfasl.inc
+Cheapcheck = ../boot/$m/heapcheck.inc
 Revision = ../boot/$m/revision
 
 # The following controls the patch files loaded before compiling, typically used only
@@ -171,11 +173,11 @@ allsrc =\
  np-languages.ss fxmap.ss
 
 # doit uses a different Scheme process to compile each target
-doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
+doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${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} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
+all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${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.
@@ -362,7 +364,7 @@ resetbootlinks:
              | ${Scheme} -q
 
 keepbootfiles:
-	for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc vfasl.inc` ; do\
+	for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc gc-par.inc vfasl.inc heapcheck.inc` ; do\
           if [ ! -h ../boot/$(m)/$$x ] ; then \
             mv -f ../boot/$(m)/$$x ../../boot/$(m)/$$x ;\
           elif [ "${upupupbootdir}" != "../../.." ] ; then \
@@ -633,6 +635,15 @@ ${Cgcoce}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.s
           then mv -f ${Cgcoce}.bak ${Cgcoce};\
           else rm -f ${Cgcoce}.bak; fi)
 
+${Cgcpar}: 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 ${Cgcpar} ]; then mv -f ${Cgcpar} ${Cgcpar}.bak; fi)
+	echo '(reset-handler abort)'\
+             '(mkgc-par.inc "${Cgcpar}")' |\
+         ${Scheme} -q ${macroobj} mkheader.so mkgc.so
+	(if `cmp -s ${Cgcpar} ${Cgcpar}.bak`;\
+          then mv -f ${Cgcpar}.bak ${Cgcpar};\
+          else rm -f ${Cgcpar}.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)'\
@@ -642,6 +653,15 @@ ${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.s
           then mv -f ${Cvfasl}.bak ${Cvfasl};\
           else rm -f ${Cvfasl}.bak; fi)
 
+${Cheapcheck}: 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 ${Cheapcheck} ]; then mv -f ${Cheapcheck} ${Cheapcheck}.bak; fi)
+	echo '(reset-handler abort)'\
+             '(mkheapcheck.inc "${Cheapcheck}")' |\
+         ${Scheme} -q ${macroobj} mkheader.so mkgc.so
+	(if `cmp -s ${Cheapcheck} ${Cheapcheck}.bak`;\
+          then mv -f ${Cheapcheck}.bak ${Cheapcheck};\
+          else rm -f ${Cheapcheck}.bak; fi)
+
 .PHONY: ${Revision}
 ${Revision}: update-revision
 	@./update-revision > ${Revision}
@@ -664,7 +684,9 @@ reset:
 	$(MAKE) reset-one FILE=scheme.h
 	$(MAKE) reset-one FILE=gc-oce.inc
 	$(MAKE) reset-one FILE=gc-ocd.inc
+	$(MAKE) reset-one FILE=gc-par.inc
 	$(MAKE) reset-one FILE=vfasl.inc
+	$(MAKE) reset-one FILE=heapcheck.inc
 
 .PHONY: reset-one
 reset-one:

racket/src/ChezScheme/s/cmacros.ss

@@ -855,6 +855,8 @@
 ;; ---------------------------------------------------------------------
 ;; Bit and byte offsets for different types of objects:
 
+;; Flags that matter to the GC must apply only to static-generation
+;; objects, and they must not overlap with `forward-marker`
 (define-constant code-flag-system           #b0000001)
 (define-constant code-flag-continuation     #b0000010)
 (define-constant code-flag-template         #b0000100)
@@ -1389,7 +1391,8 @@
 (define-primitive-structure-disps ratnum type-typed-object
   ([iptr type]
    [ptr numerator]
-   [ptr denominator]))
+   [ptr denominator]
+   [iptr pad])) ; for alignment
 
 (define-primitive-structure-disps vector type-typed-object
   ([iptr type]
@@ -1433,7 +1436,8 @@
 (define-primitive-structure-disps exactnum type-typed-object
   ([iptr type]
    [ptr real]
-   [ptr imag]))
+   [ptr imag]
+   [iptr pad])) ; for alignment
 
 (define-primitive-structure-disps closure type-closure
   ([ptr code]
@@ -1495,8 +1499,9 @@
 (define-constant virtual-register-count 16)
 (define-constant static-generation 7)
 (define-constant num-generations (fx+ (constant static-generation) 1))
-(define-constant num-thread-local-allocation-segments (fx* (fx+ 1 (constant static-generation))
+(define-constant num-spaces (fx+ (constant max-real-space) 1))
-                                                           (fx+ 1 (constant max-real-space))))
+(define-constant num-thread-local-allocation-segments (fx* (constant num-generations)
+                                                           (constant num-spaces)))
 (define-constant maximum-parallel-collect-threads 8)
 
 ;;; make sure gc sweeps all ptrs
@@ -1577,6 +1582,7 @@
    [xptr base-loc (constant num-thread-local-allocation-segments)]
    [xptr next-loc (constant num-thread-local-allocation-segments)]
    [iptr bytes-left (constant num-thread-local-allocation-segments)]
+   [xptr orig-next-loc (constant num-spaces)]
    [xptr sweep-loc (constant num-thread-local-allocation-segments)]
    [xptr sweep-next (constant num-thread-local-allocation-segments)]
    [xptr pending-ephemerons]
@@ -1585,7 +1591,9 @@
    [xptr sweep-stack-start]
    [xptr sweep-stack-limit]
    [iptr sweep-change]
-   [xptr lock-status]
+   [iptr remote-sweeper]
+   [xptr remote-range-start]
+   [xptr remote-range-end]
    [iptr bitmask-overhead (constant num-generations)]))
 
 (define tc-field-list

racket/src/ChezScheme/s/mkgc.ss

@@ -13,7 +13,9 @@
 (disable-unbound-warning
  mkgc-ocd.inc
  mkgc-oce.inc
- mkvfasl.inc)
+ mkgc-par.inc
+ mkvfasl.inc
+ mkheapcheck.inc)
 
 ;; Currently supported traversal modes:
 ;;   - copy
@@ -25,6 +27,7 @@
 ;;   - measure     : recurs for reachable size
 ;;   - vfasl-copy
 ;;   - vfasl-sweep
+;;   - check
 
 ;; For the specification, there are a few declaration forms described
 ;; below, such as `trace` to declare a pointer-valued field within an
@@ -83,6 +86,7 @@
 ;;  - (trace-early <field>) : relocate for sweep, copy, and mark; recur otherwise; implies pure
 ;;  - (trace-now <field>) : direct recur; implies pure
 ;;  - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd; implies pure
+;;  - (trace-pure-code <field>) : like `trace-pure`, but special handling in parallel mode
 ;;  - (trace-ptrs <field> <count>) : trace an array of pointerrs
 ;;  - (trace-pure-ptrs <field> <count>) : pure analog of `trace-ptrs`
 ;;  - (copy <field>) : copy for copy, ignore otherwise
@@ -96,8 +100,6 @@
 ;;  - (as-mark-end <statment> ...) : declares that <statement>s implement counting,
 ;;       which means that it's included for mark mode
 ;;  - (skip-forwarding) : disable forward-pointer installation in copy mode
-;;  - (check-lock-failed) : bail out if a lock aquire failed; use this before dereferencing
-;;                          an object reference that might not have been relocated
 ;;  - (assert <expr>) : assertion
 ;;
 ;; In the above declarations, nonterminals like <space> can be
@@ -150,6 +152,7 @@
 ;; Built-in variables:
 ;;  - _                 : object being copied, swept, etc.
 ;;  - _copy_            : target in copy or vfasl mode, same as _ otherwise
+;;  - _size_            : size of the current object, but only in parallel mode
 ;;  - _tf_              : type word
 ;;  - _tg_              : target generation
 ;;  - _backreferences?_ : dynamic flag indicating whether backreferences are on
@@ -173,6 +176,9 @@
        [(copy)
         (set! (ephemeron-prev-ref _copy_) 0)
         (set! (ephemeron-next _copy_) 0)]
+       [(check)
+        (trace pair-car)
+        (trace pair-cdr)]
        [else])
       (add-ephemeron-to-pending)
       (mark one-bit no-sweep)
@@ -181,6 +187,9 @@
      [space-weakpair
       (space space-weakpair)
       (vfasl-fail "weakpair")
+      (case-mode
+       [(check) (trace pair-car)]
+       [else])
       (try-double-pair copy pair-car
                        trace pair-cdr
                        countof-weakpair)]
@@ -193,7 +202,10 @@
 
    [closure
     (define code : ptr (CLOSCODE _))
-    (trace-code-early code)
+    (trace-code-early code) ; not traced in parallel mode
+    ;; In parallel mode, don't use any fields of `code` until the
+    ;; second on after the type, because the type and first field may
+    ;; be overwritten with forwarding information
     (cond
       [(and-not-as-dirty
         (or-assume-continuation
@@ -221,12 +233,23 @@
             (case-mode
              [(sweep)
               (define stk : ptr (continuation-stack _))
-              (when (&& (!= stk (cast ptr 0)) (OLDSPACE stk))
+              (define s_si : seginfo* NULL)
+              (when (&& (!= stk (cast ptr 0))
+                        (begin
+                          (set! s_si (SegInfo (ptr_get_segment stk)))
+                          (-> s_si old_space)))
+                (cond
+                  [(! (SEGMENT_IS_LOCAL s_si stk))
+                   ;; A stack segment has a single owner, so it's ok for us
+                   ;; to sweep the stack content, even though it's on a
+                   ;; remote segment relative to the current sweeper.
+                   (RECORD_REMOTE_RANGE _tc_ _ _size_ s_si)]
+                  [else
                    (set! (continuation-stack _)
                          (copy_stack _tc_
                                      (continuation-stack _)
                                      (& (continuation-stack-length _))
-                                  (continuation-stack-clength _))))]
+                                     (continuation-stack-clength _)))]))]
              [else])
             (count countof-stack (continuation-stack-length _) 1 [measure])
             (trace-pure continuation-link)
@@ -250,9 +273,15 @@
           [else
            (cond
              [(& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
+              ;; in parallel mode, assume that code pointer is static and doesn't need to be swept
               space-impure]
              [else
-              space-pure])]))
+              (case-flag parallel?
+                [on
+                 ;; use space-closure so code reference (not a regular ptr) is swept correctly
+                 space-closure]
+                [off
+                 space-pure])])]))
        (vspace vspace_closure)
        (when-vfasl
         (when (& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
@@ -286,7 +315,7 @@
     (size size-symbol)
     (mark one-bit)
     (trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _)))
-    (trace-symcode symbol-pvalue val)
+    (trace-local-symcode symbol-pvalue val)
     (trace-nonself/vfasl-as-nil symbol-plist)
     (trace-nonself symbol-name)
     (trace-nonself/vfasl-as-nil symbol-splist)
@@ -463,37 +492,33 @@
       (count countof-box)]
 
      [ratnum
-      (space space-data)
+      (space (case-flag parallel?
+               [on space-pure]
+               [off space-data]))
       (vspace vspace_impure) ; would be better if we had pure, but these are rare
       (size size-ratnum)
       (copy-type ratnum-type)
-      (trace-now ratnum-numerator)
+      (trace-nonparallel-now ratnum-numerator)
-      (trace-now ratnum-denominator)
+      (trace-nonparallel-now ratnum-denominator)
-      (case-mode
+      (case-flag parallel?
-       [(copy) (when (CHECK_LOCK_FAILED _tc_)
+        [on (pad (set! (ratnum-pad _copy_) 0))]
-                 ;; create failed relocates so that the heap checker isn't unhappy
+        [off])
-                 (set! (ratnum-numerator _copy_) (cast ptr 0))
-                 (set! (ratnum-denominator _copy_) (cast ptr 0)))]
-       [(mark) (check-lock-failed)]
-       [else])
       (mark)
       (vfasl-pad-word)
       (count countof-ratnum)]
 
      [exactnum
-      (space space-data)
+      (space (case-flag parallel?
+               [on space-pure]
+               [off space-data]))
       (vspace vspace_impure) ; same rationale as ratnum
       (size size-exactnum)
       (copy-type exactnum-type)
-      (trace-now exactnum-real)
+      (trace-nonparallel-now exactnum-real)
-      (trace-now exactnum-imag)
+      (trace-nonparallel-now exactnum-imag)
-      (case-mode
+      (case-flag parallel?
-       [(copy) (when (CHECK_LOCK_FAILED _tc_)
+        [on (pad (set! (exactnum-pad _copy_) 0))]
-                 ;; create failed relocates so that the heap checker isn't unhappy
+        [off])
-                 (set! (exactnum-real _copy_) (cast ptr 0))
-                 (set! (exactnum-imag _copy_) (cast ptr 0)))]
-       [(mark) (check-lock-failed)]
-       [else])
       (mark)
       (vfasl-pad-word)
       (count countof-exactnum)]
@@ -613,6 +638,11 @@
    [else
     (trace-nonself field)]))
 
+(define-trace-macro (trace-nonparallel-now field)
+  (case-flag parallel?
+    [on (trace-pure field)]
+    [off (trace-now field)]))
+
 (define-trace-macro (try-double-pair do-car pair-car
                                      do-cdr pair-cdr
                                      count-pair)
@@ -680,7 +710,16 @@
      ;; Special relocation handling for code in a closure:
      (set! code (vfasl_relocate_code vfi code))]
     [else
-     (trace-early (just code))])))
+     ;; In parallel mode, the `code` pointer may or may not have been
+     ;; forwarded. In that case, we may misinterpret the forward mmarker
+     ;; as a code type with flags, but it's ok, because the flags will
+     ;; only be set for static-generation objects
+     (case-flag parallel?
+       [on (case-mode
+            [(sweep sweep-in-old)
+             (trace-pure-code (just code))]
+            [else])]
+       [off (trace-early (just code))])])))
 
 (define-trace-macro (copy-clos-code code)
   (case-mode
@@ -718,7 +757,6 @@
     (trace ref)]
    [(sweep sweep-in-old)
     (trace ref) ; can't trace `val` directly, because we need an impure relocate
-    (check-lock-failed)
     (define val : ptr (ref _))]
    [vfasl-copy
     (set! (ref _copy_) vfasl-val)]
@@ -733,7 +771,6 @@
     (case-flag as-dirty?
        [on (trace (just code))]
        [off (trace-pure (just code))])
-    (check-lock-failed)
     (INITSYMCODE _ code)]
    [measure]
    [vfasl-copy
@@ -741,6 +778,27 @@
    [else
     (copy symbol-pvalue)]))
 
+(define-trace-macro (trace-local-symcode symbol-pvalue val)
+  (case-mode
+   [(sweep)
+    (case-flag parallel?
+      [on
+       (define v_si : seginfo* (cond
+                                 [(Sprocedurep val) (SegInfo (ptr_get_segment val))]
+                                 [else NULL]))
+       (cond
+         [(\|\|
+           (\|\|
+            (== v_si NULL)
+            (! (-> v_si old_space)))
+           (SEGMENT_IS_LOCAL v_si val))
+          (trace-symcode symbol-pvalue val)]
+         [else
+          (RECORD_REMOTE_RANGE _tc_ _ _size_ v_si)])]
+      [off (trace-symcode symbol-pvalue val)])]
+   [else
+    (trace-symcode symbol-pvalue val)]))
+
 (define-trace-macro (trace-tlc tlc-next tlc-keyval)
   (case-mode
    [(copy mark)
@@ -800,11 +858,24 @@
           [on]
           [off
            (case-mode
-            [(sweep sweep-in-old self-test)
+            [(sweep)
-             ;; Bignum pointer mask may need forwarding
+             (case-flag parallel?
-             (trace-pure (record-type-pm rtd))
+               [on
-             (check-lock-failed)
+                (define pm_si : seginfo* (SegInfo (ptr_get_segment num)))
-             (set! num (record-type-pm rtd))]
+                (cond
+                  [(\|\|
+                    (! (-> pm_si old_space))
+                    (SEGMENT_IS_LOCAL pm_si num))
+                   (trace-record-type-pm num rtd)]
+                  [else
+                   ;; Try again in the bignum's sweeper
+                   (RECORD_REMOTE_RANGE _tc_ _ _size_ pm_si)
+                   (set! num S_G.zero_length_bignum)])]
+               [off
+                (trace-record-type-pm num rtd)])]
+            [(sweep-in-old self-test)
+             (trace-record-type-pm num rtd)]
+            [(check) (check-bignum num)]
             [else])])
          (let* ([index : iptr (- (BIGLEN num) 1)]
                 ;; Ignore bit for already forwarded rtd
@@ -825,6 +896,11 @@
             (set! mask (bignum-data num index))
             (set! bits bigit_bits)))]))]))
 
+(define-trace-macro (trace-record-type-pm num rtd)
+  ;; Bignum pointer mask may need forwarding
+  (trace-pure (record-type-pm rtd))
+  (set! num (record-type-pm rtd)))
+
 (define-trace-macro (vfasl-check-parent-rtd rtd)
   (case-mode
    [(vfasl-copy)
@@ -917,7 +993,7 @@
                           (cast iptr (port-buffer _))))
       (trace port-buffer)
       (set! (port-last _) (cast ptr (+ (cast iptr (port-buffer _)) n))))]
-   [sweep-in-old
+   [(sweep-in-old check)
     (when (& (cast uptr _tf_) flag)
       (trace port-buffer))]
    [else
@@ -1024,10 +1100,19 @@
                (trace-pure (* pp)))
              (set! mask >>= 1)))]
          [else
+          (case-mode
+           [(check) (check-bignum num)]
+           [else
+            (define n_si : seginfo* (SegInfo (ptr_get_segment num)))
+            (cond
+              [(! (-> n_si old_space))]
+              [(SEGMENT_IS_LOCAL n_si num)
                (trace-pure (* (ENTRYNONCOMPACTLIVEMASKADDR oldret)))
-          (check-lock-failed)
+               (set! num  (ENTRYLIVEMASK oldret))]
-          (let* ([num : ptr (ENTRYLIVEMASK oldret)]
+              [else
-                 [index : iptr (BIGLEN num)])
+               (RECORD_REMOTE_RANGE _tc_ _ _size_ n_si)
+               (set! num S_G.zero_length_bignum)])])
+          (let* ([index : iptr (BIGLEN num)])
             (while
              :? (!= index 0)
              (set! index -= 1)
@@ -1055,11 +1140,10 @@
    [(sweep sweep-in-old)
     (define x_si : seginfo* (SegInfo (ptr_get_segment c_p)))
     (when (-> x_si old_space)
-      (relocate_code c_p x_si)
+      (relocate_code c_p x_si _ _size_)
       (case-mode
        [sweep-in-old]
        [else
-        (check-lock-failed)
         (set! field (cast ptr (+ (cast uptr c_p) co)))]))]
    [else
     (trace-pure (just c_p))]))
@@ -1116,7 +1200,6 @@
 
     (case-mode
      [sweep
-      (check-lock-failed)
       (cond
         [(&& (== from_g static_generation)
              (&& (! S_G.retain_static_relocation)
@@ -1126,21 +1209,20 @@
          (let* ([t_si : seginfo* (SegInfo (ptr_get_segment t))])
            (when (-> t_si old_space)
              (cond
-               [(SEGMENT_LOCK_ACQUIRE t_si)
+               [(SEGMENT_IS_LOCAL t_si t)
                 (set! n (size_reloc_table (reloc-table-size t)))
                 (count countof-relocation-table (just n) 1 sweep)
                 (cond
                   [(-> t_si use_marks)
-                   ;; Assert: (! (marked t_si t))
+                   (cond
-                   (mark_typemod_data_object _tc_ t n t_si)]
+                     [(! (marked t_si t))
+                      (mark_typemod_data_object _tc_ t n t_si)])]
                   [else
                    (let* ([oldt : ptr t])
                      (find_room _tc_ space_data from_g typemod n t)
-                     (memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])
+                     (memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])]
-                (SEGMENT_LOCK_RELEASE t_si)]
                [else
-                (RECORD_LOCK_FAILED _tc_ t_si)
+                (RECORD_REMOTE_RANGE _tc_ _ _size_ t_si)])))
-                (check-lock-failed)])))
          (set! (reloc-table-code t) _)
          (set! (code-reloc _) t)])
       (S_record_code_mod tc_in (cast uptr (TO_PTR (& (code-data _ 0)))) (cast uptr (code-length _)))]
@@ -1150,6 +1232,10 @@
       (set! (code-reloc _) (cast ptr (ptr_diff t (-> vfi base_addr))))]
      [else])]))
 
+(define-trace-macro (check-bignum var)
+  (trace (just var))
+  (check_bignum var))
+
 (define-trace-macro (unless-code-relocated stmt)
   (case-flag code-relocated?
    [on]
@@ -1389,6 +1475,7 @@
                   [(lookup 'as-dirty? config #f) ", IGEN youngest"]
                   [(lookup 'no-from-g? config #f) ""]
                   [else ", IGEN from_g"])]
+               [(check) ", uptr seg, ISPC s_in, IBOOL aftergc"]
                [else ""]))
      (let ([body
             (lambda ()
@@ -1417,14 +1504,11 @@
        (case (lookup 'mode config)
          [(copy)
           (code-block
-           "ENABLE_LOCK_ACQUIRE"
-           "if (CHECK_LOCK_FAILED(tc_in)) return 0xff;"
            "check_triggers(tc_in, si);"
            (code-block
             "ptr new_p;"
             "IGEN tg = TARGET_GENERATION(si);"
             (body)
-            "if (CHECK_LOCK_FAILED(tc_in)) return 0xff;"
             "SWEEPCHANGE(tc_in) = SWEEP_CHANGE_PROGRESS;"
             "FWDMARKER(p) = forward_marker;"
             "FWDADDRESS(p) = new_p;"
@@ -1434,17 +1518,14 @@
             "return tg;"))]
          [(mark)
           (code-block
-           "ENABLE_LOCK_ACQUIRE"
-           "if (CHECK_LOCK_FAILED(tc_in)) return 0xff;"
            "check_triggers(tc_in, si);"
-           (ensure-segment-mark-mask "si" "" '())
+           (ensure-segment-mark-mask "si" "")
            (body)
            "SWEEPCHANGE(tc_in) = SWEEP_CHANGE_PROGRESS;"
            "ADD_BACKREFERENCE(p, si->generation);"
            "return si->generation;")]
          [(sweep)
           (code-block
-           "ENABLE_LOCK_ACQUIRE"
            (and (lookup 'maybe-backreferences? config #f)
                 "PUSH_BACKREFERENCE(p)")
            (body)
@@ -1453,9 +1534,7 @@
            (and (lookup 'as-dirty? config #f)
                 "return youngest;"))]
          [(sweep-in-old)
-          (code-block
+          (body)]
-           "ENABLE_LOCK_ACQUIRE"
-           (body))]
          [(measure)
           (body)]
          [(self-test)
@@ -1579,8 +1658,8 @@
                         (code
                          "/* Do not inspect the type or first field of the rtd, because"
                          "   it may have been overwritten for forwarding. */")])]
-                    [(measure sweep sweep-in-old)
+                    [(measure sweep sweep-in-old check)
-                     (statements `((trace-early ,field)) config)]
+                     (statements `((trace-early ,field)) (cons `(early-rtd? #t) config))]
                     [else #f])
                   (statements (cdr l) (cons `(copy-extra-rtd ,field) config)))]
            [`(trace ,field)
@@ -1590,9 +1669,12 @@
             (code (and (not (lookup 'as-dirty? config #f))
                        (trace-statement field config #f 'pure))
                   (statements (cdr l) config))]
+           [`(trace-pure-code ,field)
+            (code (and (not (lookup 'as-dirty? config #f))
+                       (trace-statement field (cons `(early-code? #t) config) #f 'pure))
+                  (statements (cdr l) config))]
            [`(trace-early ,field)
             (code (trace-statement field config #t 'pure)
-                  (check-lock-failure-statement config)
                   (statements (cdr l) (if (symbol? field)
                                           (cons `(copy-extra ,field) config)
                                           config)))]
@@ -1680,7 +1762,7 @@
                (statements (cons `(copy-bytes ,offset (* ptr_bytes ,len))
                                  (cdr l))
                            config)]
-              [(sweep measure sweep-in-old vfasl-sweep)
+              [(sweep measure sweep-in-old vfasl-sweep check)
                (code
                 (loop-over-pointers
                  (field-expression offset config "p" #t)
@@ -1855,10 +1937,6 @@
                   (statements (list count-stmt) config)))]
               [else
                (statements (cdr l) config)])]
-           [`(check-lock-failed)
-            (code
-             (check-lock-failure-statement config)
-             (statements (cdr l) config))]
            [`(define ,id : ,type ,rhs)
             (let* ([used (lookup 'used config)]
                    [prev-used? (hashtable-ref used id #f)])
@@ -1981,6 +2059,12 @@
         [`_copy_ (case (lookup 'mode config)
                    [(copy vfasl-copy) "new_p"]
                    [else "p"])]
+        [`_size_
+         (cond
+           [(lookup 'parallel? config #f)
+            (hashtable-set! (lookup 'used config) 'p_sz #t)
+            "p_sz"]
+           [else "SIZE"])]
         [`_tf_
          (lookup 'tf config "TYPEFIELD(p)")]
         [`_tg_
@@ -2052,6 +2136,8 @@
                  (expression (car (apply-macro m (list a))) config protect? multiline?))]
            [else
             (protect (format "~a(~a)" op (expression a config #t)))])]
+        [`(begin ,a ,b)
+         (format "(~a, ~a)" (expression a config #t) (expression b config #t))]
         [`(,op ,a ,b)
          (cond
            [(memq op '(& && \|\| == != + - * < > <= >= << >> ->))
@@ -2118,23 +2204,38 @@
        (measure-statement (field-expression field config "p" #f))]
       [(eq? mode 'self-test)
        (format "if (p == ~a) return 1;" (field-expression field config "p" #f))]
+      [(eq? mode 'check)
+       (format "check_pointer(&(~a), ~a, ~a, seg, s_in, aftergc);"
+               (field-expression field config "p" #f)
+               (match field
+                 [`(just ,_) "0"]
+                 [else "1"])
+               (expression '_ config))]
       [else #f]))
 
   (define (relocate-statement purity e config)
     (define mode (lookup 'mode config))
+    (define (get-start) (expression '_ config))
+    (define (get-size) (cond
+                         [(lookup 'early-rtd? config #f)
+                          (expression '(size_record_inst (UNFIX (record-type-size (record-type _)))) config)]
+                         [(lookup 'early-code? config #f)
+                          (expression '(size_closure (CODEFREE (CLOSCODE _))) config)]
+                         [else
+                          (expression '_size_ config)]))
     (case mode
       [(vfasl-sweep)
        (format "vfasl_relocate(vfi, &~a);" e)]
       [(sweep-in-old)
        (if (eq? purity 'pure)
-           (format "relocate_pure(&~a);" e)
+           (format "relocate_pure(&~a, ~a, ~a);" e (get-start) (get-size))
-           (format "relocate_indirect(~a);" e))]
+           (format "relocate_indirect(~a, ~a, ~a);" e (get-start) (get-size)))]
       [else
        (if (lookup 'as-dirty? config #f)
            (begin
              (when (eq? purity 'pure) (error 'relocate-statement "pure as dirty?"))
-             (format "relocate_dirty(&~a, youngest);" e))
+             (format "relocate_dirty(&~a, youngest, ~a, ~a);" e (get-start) (get-size)))
-           (format "relocate_~a(&~a~a);" purity e (if (eq? purity 'impure) ", from_g" "")))]))
+           (format "relocate_~a(&~a~a, ~a, ~a);" purity e (if (eq? purity 'impure) ", from_g" "") (get-start) (get-size)))]))
 
   (define (measure-statement e)
     (code
@@ -2243,26 +2344,19 @@
                "  seginfo *mark_si; IGEN g;"
                "  si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr;"
                "  seg++;"
-               "  /* Note: taking a sequence of locks for a span of segments */"
                "  while (seg < end_seg) {"
-               "    ENABLE_LOCK_ACQUIRE"
                "    mark_si = SegInfo(seg);"
-               "    SEGMENT_LOCK_MUST_ACQUIRE(mark_si);"
                "    g = mark_si->generation;"
                "    if (!fully_marked_mask[g]) init_fully_marked_mask(tc_in, g);"
                "    mark_si->marked_mask = fully_marked_mask[g];"
                "    mark_si->marked_count = bytes_per_segment;"
-               "    SEGMENT_LOCK_RELEASE(mark_si);"
                "    seg++;"
                "  }"
                "  mark_si = SegInfo(end_seg);"
                "  {"
-               "    ENABLE_LOCK_ACQUIRE"
+               (ensure-segment-mark-mask "mark_si" "    ")
-               "    SEGMENT_LOCK_MUST_ACQUIRE(mark_si);"
-               (ensure-segment-mark-mask "mark_si" "    " '())
                "    /* no need to set a bit: it's enough to have made `marked_mask` non-NULL */"
                "    mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0);"
-               "    SEGMENT_LOCK_RELEASE(mark_si);"
                "  }"
                "}")]))]
          [within-segment?
@@ -2294,13 +2388,11 @@
              "else"
              (within-loop-statement (code
                                      "  seginfo *mark_si = SegInfo(ptr_get_segment(mark_p));"
-                                     "  ENABLE_LOCK_ACQUIRE"
+                                     (ensure-segment-mark-mask "mark_si" "  "))
-                                     "  SEGMENT_LOCK_MUST_ACQUIRE(mark_si);"
-                                     (ensure-segment-mark-mask "mark_si" "  " '()))
                                     "mark_si"
                                     step
                                     #t
-                                    "  SEGMENT_LOCK_RELEASE(mark_si);")))])
+                                    #f)))])
        (cond
          [no-sweep? #f]
          [else
@@ -2312,20 +2404,6 @@
                      (code-block push))]
               [else push]))]))))
 
-  (define (check-lock-failure-statement config)
-    (let ([mode (lookup 'mode config)])
-      (case mode
-        [(copy mark sweep)
-         (code
-          "if (CHECK_LOCK_FAILED(tc_in))"
-          (case mode
-            [(copy mark) (code-block "return 0xff;")]
-            [(sweep sweep-in-old)
-             (if (lookup 'as-dirty? config #f)
-                 (code-block "return 0xff;")
-                 (code-block "return;"))]))]
-        [else #f])))
-
   (define (field-expression field config arg protect?)
     (if (symbol? field)
         (cond
@@ -2359,15 +2437,11 @@
            (error 'field-ref "index not allowed for non-array field ~s" acc-name))
          (format "~a(~a)" c-ref obj)])))
   
-  (define (ensure-segment-mark-mask si inset flags)
+  (define (ensure-segment-mark-mask si inset)
     (code
      (format "~aif (!~a->marked_mask) {" inset si)
-     (format "~a  find_room_voidp(tc_in, space_data, ~a->generation, ptr_align(segment_bitmap_bytes), ~a->marked_mask);"
+     (format "~a  init_mask(tc_in, ~a->marked_mask, ~a->generation, 0);"
              inset si si)
-     (if (memq 'no-clear flags)
-         (format "~a  /* no clearing needed */" inset)
-         (format "~a  memset(~a->marked_mask, 0, segment_bitmap_bytes);" inset si))
-     (format "~a  S_G.bitmask_overhead[~a->generation] += ptr_align(segment_bitmap_bytes);" inset si)
      (format "~a}" inset)))
 
   (define (just-mark-bit-space? sp)
@@ -2534,25 +2608,29 @@
                                   (loop (cdr l))))]
          [else (cons (car l) (loop (cdr l)))]))))
 
-  (define (gen-gc ofn count? measure?)
+  (define (gen-gc ofn count? measure? parallel?)
     (guard
      (x [#t (raise x)])
      (parameterize ([current-output-port (open-output-file ofn 'replace)])
        (print-code (generate "copy"
                              `((mode copy)
                                (maybe-backreferences? ,count?)
-                               (counts? ,count?))))
+                               (counts? ,count?)
+                               (parallel? ,parallel?))))
        (print-code (generate "sweep"
                              `((mode sweep)
                                (maybe-backreferences? ,count?)
-                               (counts? ,count?))))
+                               (counts? ,count?)
+                               (parallel? ,parallel?))))
        (print-code (generate "sweep_object_in_old"
                              `((mode sweep-in-old)
-                               (maybe-backreferences? ,count?))))
+                               (maybe-backreferences? ,count?)
+                               (parallel? ,parallel?))))
        (print-code (generate "sweep_dirty_object"
                              `((mode sweep)
                                (maybe-backreferences? ,count?)
                                (counts? ,count?)
+                               (parallel? ,parallel?)
                                (as-dirty? #t))))
        (letrec ([sweep1
                  (case-lambda
@@ -2566,26 +2644,32 @@
                                             (known-types (,type))
                                             (maybe-backreferences? ,count?)
                                             (counts? ,count?)))))])])
-         (sweep1 'record "sweep_record" '())
+         (sweep1 'record "sweep_record" `((parallel? ,parallel?)))
-         (sweep1 'record "sweep_dirty_record" '((as-dirty? #t)))
+         (sweep1 'record "sweep_dirty_record" `((as-dirty? #t)
-         (sweep1 'symbol)
+                                                (parallel? ,parallel?)))
-         (sweep1 'symbol "sweep_dirty_symbol" '((as-dirty? #t)))
+         (sweep1 'symbol "sweep_symbol" `((parallel? ,parallel?)))
-         (sweep1 'thread "sweep_thread" '((no-from-g? #t)))
+         (sweep1 'symbol "sweep_dirty_symbol" `((as-dirty? #t)
-         (sweep1 'port)
+                                                (parallel? ,parallel?)))
-         (sweep1 'port "sweep_dirty_port" '((as-dirty? #t)))
+         (sweep1 'thread "sweep_thread" `((no-from-g? #t)
-         (sweep1 'closure "sweep_continuation" '((code-relocated? #t)
+                                          (parallel? ,parallel?)))
-                                                 (assume-continuation? #t)))
+         (sweep1 'port "sweep_port" `((parallel? ,parallel?)))
-         (sweep1 'code "sweep_code_object"))
+         (sweep1 'port "sweep_dirty_port" `((as-dirty? #t)
+                                            (parallel? ,parallel?)))
+         (sweep1 'closure "sweep_continuation" `((code-relocated? #t)
+                                                 (assume-continuation? #t)
+                                                 (parallel? ,parallel?)))
+         (sweep1 'code "sweep_code_object" `((parallel? ,parallel?))))
        (print-code (generate "size_object"
                              `((mode size))))
        (print-code (generate "mark_object"
                              `((mode mark)
-                               (counts? ,count?))))
+                               (counts? ,count?)
+                               (parallel? ,parallel?))))
        (print-code (generate "object_directly_refers_to_self"
                              `((mode self-test))))
        (print-code (code "static void mark_typemod_data_object(ptr tc_in, ptr p, uptr p_sz, seginfo *si)"
                          (code-block
-                          (ensure-segment-mark-mask "si" "" '())
+                          (ensure-segment-mark-mask "si" "")
                           (mark-statement '(one-bit no-sweep)
                                           (cons
                                            (list 'used (make-eq-hashtable))
@@ -2603,11 +2687,22 @@
                              `((mode vfasl-sweep)
                                (return-size? #t)))))))
 
+  (define (gen-heapcheck ofn)
+    (guard
+     (x [#t (raise x)])
+     (parameterize ([current-output-port (open-output-file ofn 'replace)])
+       (print-code (generate "check_object"
+                             `((mode check))))
+       (print-code (generate "size_object"
+                             `((mode size)))))))
+
   ;; Render via mkequates to record a mapping from selectors to C
   ;; macros:
   (let-values ([(op get) (open-bytevector-output-port (native-transcoder))])
     (mkequates.h op))
   
-  (set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f)))
+  (set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f #f)))
-  (set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t)))
+  (set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t #f)))
-  (set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn))))
+  (set! mkgc-par.inc (lambda (ofn) (gen-gc ofn #f #f #t)))
+  (set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn)))
+  (set! mkheapcheck.inc (lambda (ofn) (gen-heapcheck ofn))))

racket/src/ChezScheme/s/mkheader.ss

@@ -1006,10 +1006,12 @@
         (defref EXACTNUM_TYPE exactnum type)
         (defref EXACTNUM_REAL_PART exactnum real)
         (defref EXACTNUM_IMAG_PART exactnum imag)
+        (defref EXACTNUM_PAD exactnum pad)
 
         (defref RATTYPE ratnum type)
         (defref RATNUM ratnum numerator)
         (defref RATDEN ratnum denominator)
+        (defref RATPAD ratnum pad)
 
         (defref CLOSENTRY closure code)
         (defref CLOSIT closure data)

racket/src/ChezScheme/workarea

@@ -285,7 +285,9 @@ workdir $W/boot/$M
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/equates.h equates.h)
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/gc-ocd.inc gc-ocd.inc)
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/gc-oce.inc gc-oce.inc)
+(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/gc-par.inc gc-par.inc)
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/vfasl.inc vfasl.inc)
+(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/heapcheck.inc heapcheck.inc)
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/petite.boot petite.boot)
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/scheme.boot scheme.boot)
 (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/def.so def.so)

racket/src/cs/c/check_boot.sh

@@ -24,7 +24,9 @@ check_pb scheme.h
 check_pb equates.h
 check_pb gc-ocd.inc
 check_pb gc-oce.inc
+check_pb gc-par.inc
 check_pb vfasl.inc
+check_pb heapcheck.inc
 
 check_mach()
 {
@@ -43,4 +45,6 @@ check_mach scheme.h
 check_mach equates.h
 check_mach gc-ocd.inc
 check_mach gc-oce.inc
+check_mach gc-par.inc
 check_mach vfasl.inc
+check_mach heapcheck.inc

racket/src/cs/c/ready_boot.sh

@@ -22,6 +22,8 @@ ready_mach scheme.h
 ready_mach equates.h
 ready_mach gc-ocd.inc
 ready_mach gc-oce.inc
+ready_mach gc-par.inc
 ready_mach vfasl.inc
+ready_mach heapcheck.inc
 
 rm -f boot_pending

racket/src/cs/c/reset_boot.sh

@@ -22,4 +22,5 @@ ready_mach scheme.h
 ready_mach equates.h
 ready_mach gc-ocd.inc
 ready_mach gc-oce.inc
+ready_mach gc-par.inc
 ready_mach vfasl.inc