Chez Scheme: add support for nonatomic foreign arrays

A reference bytevector holds a mixture of addresses within GCable
objects and foreign addresses, where "address" corresponds to the
payload of a bytevector or flvector object. The GC knows to apply a
suitable offset to the reference, so that object counts as reachable
from a reference bytevector, and the reference bytevector is updated
if the object is relocated during a collection.

With this change, the restriction in Racket CS against passing
non-atomic memory to a foreign function can be lifted. For example,
`(_list i _string)` can be useful as the type of a foreign-call
argument.

Making reference bytevectors a subtype of bytevectors is not an
obvious choice, given that writing to a reference bytevector with
byte-level operations can easily corrupt it. But this choice makes
various things simpler and easier.

.makefile

@@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
 
 # This branch name changes each time the pb boot files are updated:
-PB_BRANCH == circa-8.1.0.4-1
+PB_BRANCH == circa-8.1.0.6-1
 PB_REPO = https://github.com/racket/pb
 
 # Set to empty for Git before v1.7.10:

Makefile

@@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
 RACKET =
 RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
-PB_BRANCH = circa-8.1.0.4-1
+PB_BRANCH = circa-8.1.0.6-1
 PB_REPO = https://github.com/racket/pb
 SINGLE_BRANCH_FLAG = --single-branch
 EXTRA_REPOS_BASE =
@@ -310,19 +310,19 @@ 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 $(SINGLE_BRANCH_FLAG) -b circa-8.1.0.4-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.1.0.4-1:remotes/origin/circa-8.1.0.4-1 ; fi
-	cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.1.0.4-1
-	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.1.0.4-1
+	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q $(SINGLE_BRANCH_FLAG) -b circa-8.1.0.6-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.1.0.6-1:remotes/origin/circa-8.1.0.6-1 ; fi
+	cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.1.0.6-1
+	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.1.0.6-1
 pb-fetch:
 	$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)" SINGLE_BRANCH_FLAG="$(SINGLE_BRANCH_FLAG)"
 pb-build:
 	cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
 pb-stage:
-	cd racket/src/ChezScheme/boot/pb && git branch circa-8.1.0.4-1
-	cd racket/src/ChezScheme/boot/pb && git checkout circa-8.1.0.4-1
+	cd racket/src/ChezScheme/boot/pb && git branch circa-8.1.0.6-1
+	cd racket/src/ChezScheme/boot/pb && git checkout circa-8.1.0.6-1
 	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-8.1.0.4-1
+	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.1.0.6-1
 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)" 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)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change only when
 ;; "racket_version.h" changes:
-(define version "8.1.0.5")
+(define version "8.1.0.6")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/foreign/pointers.scrbl

@@ -61,13 +61,9 @@ memory that is (assumed to be) managed by the garbage collector,
 @racket[#f] otherwise.
 
 For a pointer based on @racket[_gcpointer] as a result type,
-@racket[cpointer-gcable?] will return @racket[#t]. In the @BC[]
-implementation of Racket, @racket[cpointer-gcable?] will return
-@racket[#f] for a pointer based on @racket[_pointer] as a result type.
-The @CS[] implementation is mostly the same, except that if a pointer is
-extracted using the @racket[_pointer] type from memory allocated as
-@racket['nonatomic], @racket[cpointer-gcable?] will report @racket[#t]
-for the extracted pointer.}
+@racket[cpointer-gcable?] will return @racket[#t]. For a pointer based
+on @racket[_pointer] as a result type, @racket[cpointer-gcable?] will
+return @racket[#f].}
 
 
 @; ----------------------------------------------------------------------
@@ -268,22 +264,22 @@ specification is required at minimum:
      @item{@indexed-racket['nonatomic] --- Allocates memory that can
        be reclaimed by the garbage collector, is treated by the
        garbage collector as holding only pointers, and is initially
-       filled with zeros.
+       filled with zeros. The memory is allowed to contain a mixture of
+       references to objects managed by the garbage collector and
+       addresses that are outside the garbage collector's space.
 
        For the @BC[] Racket implementation, this allocation mode corresponds
-       to @cpp{scheme_malloc} in the C API.
-
-       For the @CS[] Racket implementation, this mode is of limited use,
-       because a pointer allocated this way cannot be passed to
-       foreign functions that expect a pointer to pointers. The result
-       can only be used with functions like @racket[ptr-set!] and
-       @racket[ptr-ref].}
+       to @cpp{scheme_malloc} in the C API.}
 
      @item{@indexed-racket['atomic-interior] --- Like
        @racket['atomic], but the allocated object will not be moved by
        the garbage collector as long as the allocated object is
        retained.
 
+       A better name for this allocation mode would be
+       @racket['atomic-immobile], but it's @racket['atomic-interior]
+       for historical reasons.
+
        For the @BC[] Racket implementation, a reference can point
        to the interior of the object, instead of its starting address.
        This allocation mode corresponds to
@@ -294,6 +290,10 @@ specification is required at minimum:
        by the garbage collector as long as the allocated object is
        retained.
 
+       A better name for this allocation mode would be
+       @racket['nonatomic-immobile], but it's @racket['interior] for
+       historical reasons.
+
        For the @BC[] Racket implementation, a reference can point
        to the interior of the object, instead of its starting address.
        This allocation mode corresponds to
@@ -339,7 +339,10 @@ when the type is a @racket[_gcpointer]- or @racket[_scheme]-based
 type, and @racket['atomic] allocation is used otherwise.
 
 @history[#:changed "6.4.0.10" @elem{Added the @racket['tagged] allocation mode.}
-         #:changed "8.0.0.13" @elem{Changed CS to support the @racket['interior] allocation mode.}]}
+         #:changed "8.0.0.13" @elem{Changed CS to support the @racket['interior] allocation mode.}
+         #:changed "8.1.0.6" @elem{Changed CS to remove constraints on the use of memory allocated
+                                   with the @racket['nonatomic] and @racket['interior] allocation
+                                   modes.}]}
 
 
 @defproc[(free [cptr cpointer?]) void]{

pkgs/racket-doc/scribblings/foreign/types.scrbl

@@ -1125,11 +1125,6 @@ allocated using @racket[(malloc type-expr)] if
 @racket[maybe-malloc-mode] is not specified or if it is @racket[#f],
 @racket[(malloc type-expr '@#,racket[maybe-malloc-mode])] otherwise.
 
-Note that in the @CS[] implementation of Racket, a @racket[(_ptr i
-__ctype)] argument will trigger an error if @racket[__ctype] indicates
-values that are managed by the garbage collector, since pointers to
-non-atomic memory cannot be passed to foreign functions.
-
 @history[#:changed "7.7.0.6" @elem{The modes @racket[i], @racket[o],
                                    and @racket[io] match as symbols
                                    instead of free identifiers.}
@@ -1200,12 +1195,6 @@ return two values, the vector and the boolean.
       -> (values vec res))
 ]
 
-Note that in the @CS[] implementation of Racket, a @racket[(_list i
-__ctype)] argument will trigger an error if @racket[__ctype] indicates
-values that are managed by the garbage collector, since pointers to
-non-atomic memory cannot be passed to foreign functions. See also
-@racketmodname[ffi/unsafe/string-list].
-
 @history[#:changed "7.7.0.2" @elem{Added @racket[maybe-mode].}]
          #:changed "7.7.0.6" @elem{The modes @racket[i], @racket[o],
                                    and @racket[io] match as symbols

pkgs/racket-test-core/tests/racket/foreign-test.c

@@ -76,6 +76,22 @@ X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); }
 
 X int grab7th(void *p) { return ((char *)p)[7]; }
 
+X char *second_string(char **x) { return x[1]; }
+
+X void reverse_strings(char **x) {
+  while (*x) {
+    int i, len;
+    char *s;
+    for (len = 0; (*x)[len] != 0; len++);
+    s = malloc(len + 1);
+    for (i = 0; i < len; i++)
+      s[i] = (*x)[len - i - 1];
+    s[len] = 0;
+    *x = s;
+    x++;
+  }
+}
+
 X int vec4(int x[]) { return x[0]+x[1]+x[2]+x[3]; }
 
 typedef struct _char_int { unsigned char a; int b; } char_int;

pkgs/racket-test-core/tests/racket/foreign-test.rktl

@@ -361,12 +361,16 @@
       (with-keeper b)
       (set-box! b #f)))
   ;; ---
-  ;; test error reported when trying to pass non-atomic on CS
-  (when (eq? 'chez-scheme (system-type 'vm))
-    (err/rt-test ((ffi 'grab7th (_fun (_list i _string) -> _int ))
-                  (list "hello"))
-                 exn:fail?
-                 "non-atomic"))
+  ;; test passing an array of strings
+  (test "world"
+        (ffi 'second_string (_fun (_list i _string) -> _string))
+        (list "hello" "world" "!"))
+  ;; check that an io array of strings can have GC_allocated strings get replaced
+  ;; by foreign addresses
+  (test '("olleh" "dlrow" "?!" #f)
+        (ffi 'reverse_strings (_fun (lst : (_list io _string 4)) -> _void -> lst))
+        (list "hello" "world" "!?" #f #f))
+
   ;; ---
   ;; test exposing internal mzscheme functionality
   (when (eq? 'racket (system-type 'vm))
@@ -1152,7 +1156,6 @@
       (check-equal? (array-ref (MISCPTR-as d) i) s)
       (check-equal? (array-ref (MISCPTR-ab d) i) b)))
 
-
   ;; --- simple failing tests
   (define-serializable-cstruct _F4 ([a _int]) #:malloc-mode 'abc)
   (define-serializable-cstruct _F40 ([a _fpointer]))

racket/src/ChezScheme/c/alloc.c

@@ -727,10 +727,10 @@ ptr S_flvector(n) iptr n; {
 }
 
 ptr S_bytevector(n) iptr n; {
-  return S_bytevector2(get_thread_context(), n, 0);
+  return S_bytevector2(get_thread_context(), n, space_new);
 }
 
-ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; {
+ptr S_bytevector2(tc, n, spc) ptr tc; iptr n; ISPC spc; {
     ptr p; iptr d;
 
     if (n == 0) return S_G.null_bytevector;
@@ -739,8 +739,8 @@ ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; {
         S_error("", "invalid bytevector size request");
 
     d = size_bytevector(n);
-    if (immobile)
-      find_room(tc, space_immobile_data, 0, type_typed_object, d, p);
+    if (spc != space_new)
+      find_room(tc, spc, 0, type_typed_object, d, p);
     else
       newspace_find_room(tc, type_typed_object, d, p);
     BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector;

racket/src/ChezScheme/c/externs.h

@@ -89,7 +89,7 @@ extern ptr S_vector PROTO((iptr n));
 extern ptr S_fxvector PROTO((iptr n));
 extern ptr S_flvector PROTO((iptr n));
 extern ptr S_bytevector PROTO((iptr n));
-extern ptr S_bytevector2 PROTO((ptr tc, iptr n, IBOOL immobile));
+extern ptr S_bytevector2 PROTO((ptr tc, iptr n, ISPC spc));
 extern ptr S_null_immutable_vector PROTO((void));
 extern ptr S_null_immutable_fxvector PROTO((void));
 extern ptr S_null_immutable_bytevector PROTO((void));

racket/src/ChezScheme/c/fasl.c

@@ -1569,7 +1569,10 @@ static void pb_set_abs(void *address, uptr item) {
   int dest_reg = ((U32 *)address)[1] & DEST_REG_MASK;
 #endif
 
-  ((U32 *)address)[0] = (pb_mov16_pb_zero_bits_pb_shift0 | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
+  /* pb_link is the same as pb_mov16_pb_zero_bits_pb_shift0, but with
+     a promise of the subsequent instructions to load a full word */
+
+  ((U32 *)address)[0] = (pb_link | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
   ((U32 *)address)[1] = (pb_mov16_pb_keep_bits_pb_shift1 | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
 #if ptr_bytes == 8  
   ((U32 *)address)[2] = (pb_mov16_pb_keep_bits_pb_shift2 | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));

racket/src/ChezScheme/c/flushcache.c

@@ -30,7 +30,7 @@ static uptr max_gap;
 static ptr make_mod_range PROTO((ptr tc, uptr start, uptr end));
 
 static ptr make_mod_range(ptr tc, uptr start, uptr end) {
-  ptr bv = S_bytevector2(tc, sizeof(mod_range), 0);
+  ptr bv = S_bytevector2(tc, sizeof(mod_range), space_new);
   mod_range_start(bv) = start;
   mod_range_end(bv) = end;
   return bv;

racket/src/ChezScheme/c/gc.c

@@ -697,6 +697,24 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
     }                                                                   \
   } while (0)
 
+#define relocate_reference(ppp, from_g) do {                    \
+    ptr* rPPP = ppp; ptr rPP = *rPPP;                           \
+    if (!FOREIGN_REFERENCEP(rPP)) {                             \
+      *rPPP = S_reference_to_object(rPP);                       \
+      relocate_impure(rPPP, from_g);                            \
+      *rPPP = S_object_to_reference(*rPPP);                     \
+    }                                                           \
+  } while (0)
+
+#define relocate_reference_dirty(ppp, YOUNGEST) do {            \
+    ptr* rPPP = ppp;                                            \
+    if (!FOREIGN_REFERENCEP(*rPPP)) {                           \
+      *rPPP = S_reference_to_object(*rPPP);                     \
+      relocate_dirty(rPPP, YOUNGEST);                           \
+      *rPPP = S_object_to_reference(*rPPP);                     \
+    }                                                           \
+  } while (0)
+
 #ifdef ENABLE_OBJECT_COUNTS
 # define is_counting_root(si, p) (si->counting_mask && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
 #endif
@@ -706,6 +724,14 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
     relocate_pure(&_P);            \
   } while (0)
 
+# define relocate_reference_indirect(p) do {   \
+    ptr _P = p;                                \
+    if (!FOREIGN_REFERENCEP(_P)) {             \
+      _P = S_reference_to_object(_P);          \
+      relocate_pure(&_P);                      \
+    }                                          \
+  } while (0)
+
 FORCEINLINE void check_triggers(thread_gc *tgc, seginfo *si) {
   /* Registering ephemerons and guardians to recheck at the
      granularity of a segment means that the worst-case complexity of
@@ -1914,7 +1940,7 @@ static iptr sweep_generation_pass(thread_gc *tgc) {
           ppn = pp + 1;
           p = *ppn;
           relocate_impure_help(ppn, p, from_g);
-          FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair));
+          FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); /* can always treat as a pair to sweep words */
           pp = ppn + 1;
         });
       SET_BACKREFERENCE(Sfalse);
@@ -1996,6 +2022,12 @@ static iptr sweep_generation_pass(thread_gc *tgc) {
           sweep(tgc, p, from_g);
           pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p));
         });
+
+      sweep_space(space_reference_array, from_g, {
+          p = TYPE(TO_PTR(pp), type_typed_object);
+          pp = TO_VOIDP((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g));
+        });
+
     }
 
     /* May add to the sweep stack: */
@@ -2448,6 +2480,33 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) {
                       youngest = check_dirty_ephemeron(tgc, p, youngest);
                     pp += size_ephemeron / sizeof(ptr);
                   }
+                } else if (s == space_reference_array) {
+                  /* the same as space_impure and others above, but for object references */
+                  if (dirty_si->marked_mask) {
+                    while (pp < ppend) {
+                      /* handle two pointers at a time */
+                      if (marked(dirty_si, TO_PTR(pp))) {
+                        FLUSH_REMOTE_BLOCK
+                        relocate_reference_dirty(pp, youngest);
+                        ppn = pp + 1;
+                        relocate_reference_dirty(ppn, youngest);
+                        FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); /* can treat as a pair for resweep */
+                        pp = ppn + 1;
+                      } else {
+                        pp += 2;
+                      }
+                    }
+                  } else {
+                    while (pp < ppend && *pp != forward_marker) {
+                      /* handle two pointers at a time */
+                      FLUSH_REMOTE_BLOCK
+                      relocate_reference_dirty(pp, youngest);
+                      ppn = pp + 1;
+                      relocate_reference_dirty(ppn, youngest);
+                      FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair));
+                      pp = ppn + 1;
+                    }
+                  }
                 } else {
                   S_error_abort("sweep_dirty(gc): unexpected space");
                 }