Master merge for 20200605 (#11)

Author: Paulo Matos

.github/scripts/build.sh

@@ -1,15 +1,13 @@
 #!/bin/bash
 set -e -o pipefail
-echo 'travis_fold:start:build'
 echo Building Chez Scheme...
-./configure -m=$TARGET_MACHINE
+./configure -m=$MACH
 make
-case $TARGET_MACHINE in
+case $MACH in
   *a6nt)
     curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x64.dll > $TARGET_MACHINE/bin/$TARGET_MACHINE/iconv.dll
     ;;
   *i3nt)
     curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x86.dll > $TARGET_MACHINE/bin/$TARGET_MACHINE/iconv.dll
     ;;
 esac
-echo 'travis_fold:end:build'

.github/scripts/dobootfile.sh

@@ -10,12 +10,18 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        mach: ['ta6le'] 
+        mach: ['i3le', 'ti3le', 'a6le', 'ta6le'] 
 
     env:
-      TARGET_MACHINE: ${{ matrix.mach }}
+      MACH: ${{ matrix.mach }}
 
     steps:
+      - uses: Bogdanp/setup-racket@v0.8
+        with:
+          distribution: 'minimal'  # minimal is enough
+          variant: 'CS'            # lets dog-food CS
+          version: 'current'
+          packages: 'cs-bootstrap'
       - uses: actions/checkout@v2
         with:
           submodules: 'recursive'
@@ -33,7 +39,7 @@ jobs:
           sudo apt-get update
           sudo apt-get install -y libncurses5-dev uuid-dev libssl-dev
       - name: Build bootfiles
-        run: .github/scripts/dobootfile.sh
+        run: racket -l cs-bootstrap
       - name: Build Chez
         run: .github/scripts/build.sh
       - name: Test Chez

.github/scripts/test.sh

@@ -17,7 +17,7 @@ m = ti3osx
 Cpu = I386
 
 mdclib = -liconv -lm ${ncursesLib}
-C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
+C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -g -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
 o = o
 mdsrc = i3le.c
 mdobj = i3le.o

.github/workflows/build.yml

@@ -168,7 +168,7 @@ extern void S_immobilize_object PROTO((ptr v));
 extern void S_mobilize_object PROTO((ptr v));
 extern ptr S_unregister_guardian PROTO((ptr tconc));
 extern void S_compact_heap PROTO((void));
-extern void S_check_heap PROTO((IBOOL aftergc));
+extern void S_check_heap PROTO((IBOOL aftergc, IGEN target_gen));
 
 /* gc-ocd.c */
 extern ptr S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));

c/Mf-ti3osx

@@ -239,11 +239,11 @@ static ptr sweep_from;
 
 #if ptr_alignment == 2
 # define record_full_marked_mask 0x55
-# define record_high_marked_mask 0x40
+# define record_high_marked_bit  0x40
 # define mask_bits_to_list_bits_mask(m) ((m) | ((m) << 1))
 #elif ptr_alignment == 1
 # define record_full_marked_mask 0xFF
-# define record_high_marked_mask 0x80
+# define record_high_marked_bit  0x80
 # define mask_bits_to_list_bits_mask(m) (m)
 #endif
 
@@ -273,7 +273,7 @@ uptr list_length(ptr ls) {
 #define marked(si, p) (si->marked_mask && (si->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
 
 static void init_fully_marked_mask() {
-  init_mask(fully_marked_mask, 0, 0xFF);
+  init_mask(fully_marked_mask, target_generation, 0xFF);
 }
 
 #ifdef PRESERVE_FLONUM_EQ
@@ -287,11 +287,8 @@ static void flonum_set_forwarded(ptr p, seginfo *si) {
 static int flonum_is_forwarded_p(ptr p, seginfo *si) {
   if (!si->forwarded_flonums)
     return 0;
-  else {
-    uptr delta = (uptr)UNTYPE(p, type_flonum) - (uptr)build_ptr(si->number, 0);
-    delta >>= log2_ptr_bytes;
-    return si->forwarded_flonums[delta >> 3] & (1 << (delta & 0x7));
-  }
+  else
+    return si->forwarded_flonums[segment_bitmap_byte(p)] & segment_bitmap_bit(p);
 }
 
 # define FLONUM_FWDADDRESS(p) *(ptr*)(UNTYPE(p, type_flonum))
@@ -539,7 +536,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     }
 
    /* perform after ScanDirty */
-    if (S_checkheap) S_check_heap(0);
+    if (S_checkheap) S_check_heap(0, mcg);
 
 #ifdef DEBUG
 (void)printf("mcg = %x;  go? ", mcg); (void)fflush(stdout); (void)getc(stdin);
@@ -639,7 +636,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
          seginfo *si = SegInfo(ptr_get_segment(p));
          if (si->space == space_new) {
            if (!si->marked_mask)
-             init_mask(si->marked_mask, 0, 0);
+             init_mask(si->marked_mask, tg, 0);
            si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);
          }
        }
@@ -1207,7 +1204,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
     S_flush_instruction_cache(tc);
 
-    if (S_checkheap) S_check_heap(1);
+    if (S_checkheap) S_check_heap(1, mcg);
 
    /* post-collection rehashing of tlcs.
       must come after any use of relocate.
@@ -1659,7 +1656,7 @@ static void sweep_dirty(void) {
                           if (si->marked_mask[byte-1] == record_full_marked_mask) {
                             /* next byte is full, so keep looking */
                             byte--;
-                          } else if (si->marked_mask[byte-1] & record_high_marked_mask) {
+                          } else if (si->marked_mask[byte-1] & record_high_marked_bit) {
                             /* next byte continues, but is not full, so we can start
                                there */
                             if (at_seg != seg) {
@@ -1671,6 +1668,7 @@ static void sweep_dirty(void) {
                               si = SegInfo(at_seg);
                             } else {
                               byte--;
+                              bit = record_high_marked_bit;
                               /* find bit contiguous with highest bit */
                               while (si->marked_mask[byte] & (bit >> ptr_alignment))
                                 bit >>= ptr_alignment;
@@ -2080,14 +2078,14 @@ void copy_and_clear_list_bits(seginfo *oldspacesegments, IGEN tg) {
       } else {
         if (si->marked_mask) {
           /* Besides marking or copying `si->list_bits`, clear bits
-             where there's no corresopnding mark bit, so we don't try to
+             where there's no corresponding mark bit, so we don't try to
              check forwarding in a future GC */
           seginfo *bits_si = SegInfo(ptr_get_segment((ptr)si->list_bits));
 
           if (bits_si->old_space) {
             if (bits_si->use_marks) {
               if (!bits_si->marked_mask)
-                init_mask(bits_si->marked_mask, 0, 0);
+                init_mask(bits_si->marked_mask, tg, 0);
               bits_si->marked_mask[segment_bitmap_byte((ptr)si->list_bits)] |= segment_bitmap_bit((ptr)si->list_bits);
             } else {
               octet *copied_bits;

c/externs.h

@@ -22,6 +22,7 @@ static void check_heap_dirty_msg PROTO((char *msg, ptr *x));
 static IBOOL dirty_listedp PROTO((seginfo *x, IGEN from_g, IGEN to_g));
 static void check_dirty_space PROTO((ISPC s));
 static void check_dirty PROTO((void));
+static void check_locked_object PROTO((ptr p, IBOOL locked, IGEN g, IBOOL aftergc, IGEN mcg));
 
 static IBOOL checkheap_noisy;
 
@@ -510,6 +511,8 @@ static void segment_tell(seg) uptr seg; {
     else {
       printf(" space-%s", spacename[s1]);
       if (si->old_space) printf(" oldspace");
+      if (si->must_mark) printf(" mustmark");
+      if (si->marked_mask) printf(" marked");
     }
     printf("\n");
   }
@@ -534,7 +537,7 @@ static void check_heap_dirty_msg(msg, x) char *msg; ptr *x; {
     printf("to   "); segment_tell(addr_get_segment(*x));
 }
 
-void S_check_heap(aftergc) IBOOL aftergc; {
+void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
   uptr seg; INT d; ISPC s; IGEN g; IDIRTYBYTE dirty; IBOOL found_eos; IGEN pg;
   ptr p, *pp1, *pp2, *nl;
   iptr i;
@@ -573,6 +576,10 @@ void S_check_heap(aftergc) IBOOL aftergc; {
     seginfo *si;
     for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
       for (si = S_G.occupied_segments[s][g]; si != NULL; si = si->next) {
+        if (si->generation != g) {
+          S_checkheap_errors += 1;
+          printf("!!! segment in wrong occupied_segments list\n");
+        }
         nonstatic_segments += 1;
       }
     }
@@ -619,8 +626,11 @@ void S_check_heap(aftergc) IBOOL aftergc; {
         s = si->space;
         g = si->generation;
 
+        if (si->use_marks)
+          printf("!!! use_marks set on generation %d segment %#tx\n", g, (ptrdiff_t)seg);
+
         if (s == space_new) {
-          if (g != 0) {
+          if (g != 0 && !si->marked_mask) {
             S_checkheap_errors += 1;
             printf("!!! unexpected generation %d segment %#tx in space_new\n", g, (ptrdiff_t)seg);
           }
@@ -654,9 +664,18 @@ void S_check_heap(aftergc) IBOOL aftergc; {
                           || psi->old_space
                           || (psi->marked_mask && !(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))) {
                         S_checkheap_errors += 1;
-                        printf("!!! dangling reference at %#tx to %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)p);
+                        printf("!!! dangling reference at %#tx to %#tx%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");
+                        }
                       }
                     }
                   }
@@ -745,8 +764,9 @@ void S_check_heap(aftergc) IBOOL aftergc; {
         if (aftergc
             && (s != space_empty)
             && (g == 0
-                || (s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron
-                    && s != space_impure_record && s != space_immobile_impure && s != space_count_impure && s != space_closure))) {
+                || (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron
+                    && s != space_impure_record && s != space_impure_typed_object
+                    && s != space_immobile_impure && s != space_count_impure && s != space_closure))) {
           for (d = 0; d < cards_per_segment; d += 1) {
             if (si->dirty_bytes[d] != 0xff) {
               S_checkheap_errors += 1;
@@ -760,6 +780,21 @@ void S_check_heap(aftergc) IBOOL aftergc; {
       chunk = chunk->next;
     }
   }
+
+  {
+    for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
+      ptr l;
+      for (l = S_G.locked_objects[g]; l != Snil; l = Scdr(l))
+        check_locked_object(Scar(l), 1, g, aftergc, mcg);
+      for (l = S_G.unlocked_objects[g]; l != Snil; l = Scdr(l))
+        check_locked_object(Scar(l), 0, g, aftergc, mcg);
+    }
+  }
+
+  if (S_checkheap_errors) {
+    printf("heap check failed%s\n", (aftergc ? " after gc" : ""));
+    exit(1);
+  }
 }
 
 static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g) {
@@ -826,7 +861,9 @@ static void check_dirty() {
             S_checkheap_errors += 1;
             printf("!!! (check_dirty): dirty byte = %d for segment %#tx in %d -> %d dirty list\n", mingval, (ptrdiff_t)(si->number), from_g, to_g);
           }
-          if (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_impure_record && s != space_weakpair && s != space_ephemeron) {
+          if (s != space_new && s != space_impure && s != space_symbol && s != space_port
+              && s != space_impure_record && s != space_impure_typed_object && s != space_immobile_impure 
+              && s != space_weakpair && s != space_ephemeron) {
             S_checkheap_errors += 1;
             printf("!!! (check_dirty): unexpected space %d for dirty segment %#tx\n", s, (ptrdiff_t)(si->number));
           }
@@ -842,10 +879,40 @@ static void check_dirty() {
   check_dirty_space(space_impure_record);
   check_dirty_space(space_weakpair);
   check_dirty_space(space_ephemeron);
+  check_dirty_space(space_immobile_impure);
 
   fflush(stdout);
 }
 
+static void check_locked_object(ptr p, IBOOL locked, IGEN g, IBOOL aftergc, IGEN mcg)
+{
+  const char *what = (locked ? "locked" : "unlocked");
+  seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
+  if (!psi) {
+    S_checkheap_errors += 1;
+    printf("!!! generation %d %s object has no segment: %p\n", g, what, p);
+  } else {
+    if (psi->generation != g) {
+      S_checkheap_errors += 1;
+      printf("!!! generation %d %s object in generation %d segment: %p\n", g, what, psi->generation, p);
+    }
+    if (!psi->must_mark && locked) {
+      S_checkheap_errors += 1;
+      printf("!!! generation %d %s object not on must-mark page: %p\n", g, what, p);
+    }
+    if (!psi->marked_mask) {
+      if (aftergc && (psi->generation <= mcg)) {
+        S_checkheap_errors += 1;
+        printf("!!! %s object not in marked segment: %p\n", what, p);
+        printf(" in: "); segment_tell(psi->number);
+      }
+    } else if (!(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) {
+      S_checkheap_errors += 1;
+      printf("!!! generation %d %s object not marked: %p\n", g, what, p);
+    }
+  }
+}
+
 void S_fixup_counts(ptr counts) {
   IGEN g; U64 timestamp;
 

c/gc.c

@@ -150,7 +150,8 @@ static void create_c_entry_vector() {
 
     for (i = 0; i < c_entry_vector_size; i++) {
 #ifndef PTHREADS
-      if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex
+      if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_collect_thread0_cond
+          || i == CENTRY_raw_tc_mutex
           || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
           || i == CENTRY_unactivate_thread)
         continue;

c/gcwrapper.c

@@ -222,6 +222,11 @@ static ptr s_make_immobile_vector(uptr len, ptr fill) {
   for (i = 0; i < len; i++)
     INITVECTIT(v, i) = fill;
 
+  if (!(len & 0x1)) {
+    /* pad, since we're not going to copy on a GC */
+    INITVECTIT(v, len) = FIX(0);
+  }
+
   return v;
 }