Places: added shared-flvector and shared-byte string

collects/racket/flonum.rkt

@@ -10,7 +10,7 @@
          flvector? flvector make-flvector 
          flvector-length flvector-ref flvector-set!
          flreal-part flimag-part make-flrectangular
-         in-flvector for/flvector for*/flvector)
+         in-flvector for/flvector for*/flvector shared-flvector make-shared-flvector)
 
 (define (in-flvector* flv)
   (let ((n (flvector-length flv)))

collects/scribblings/places/info.rkt

@@ -1,3 +0,0 @@
-#lang setup/infotab
-
-(define scribblings '(("places.scrbl" (user-doc))))

collects/scribblings/reference/bytes.scrbl

@@ -171,6 +171,23 @@ string.
 
 @mz-examples[(list->bytes (list 65 112 112 108 101))]}
 
+@defproc[(make-shared-bytes [k exact-nonnegative-integer?] [b byte? 0])
+bytes?]{ Returns a new mutable byte string of length @scheme[k] where each
+position in the byte string is initialized with the byte @scheme[b].
+When @secref["places"] are enabled, the new byte string is allocated in the
+@tech{shared memory space}.
+
+@mz-examples[(make-shared-bytes 5 65)]}
+
+
+@defproc[(shared-bytes [b byte?] ...) bytes?]{ Returns a new mutable byte
+string whose length is the number of provided @scheme[b]s, and whose
+positions are initialized with the given @scheme[b]s.
+When @secref["places"] are enabled, the new byte string is allocated in the
+@tech{shared memory space}.
+
+@mz-examples[(shared-bytes 65 112 112 108 101)]}
+
 
 @; ----------------------------------------
 @section{Byte String Comparisons}

collects/scribblings/reference/concurrency.scrbl

@@ -17,3 +17,4 @@ to improve performance.
 @include-section["sync.scrbl"]
 @include-section["thread-local.scrbl"]
 @include-section["futures.scrbl"]
+@include-section["places.scrbl"]

collects/scribblings/reference/numbers.scrbl

@@ -1062,14 +1062,18 @@ Returns @racket[#t] if @racket[v] is a @tech{flvector}, @racket[#f] otherwise.}
 
 @defproc[(flvector [x inexact-real?] ...) flvector?]{
 
-Creates a @tech{flvector} containing the given inexact real numbers.}
+Creates a @tech{flvector} containing the given inexact real numbers.
+
+@mz-examples[(flvector 2.0 3.0 4.0 5.0)]}
 
 @defproc[(make-flvector [size exact-nonnegative-integer?]
                         [x inexact-real? 0.0]) 
          flvector?]{
 
 Creates a @tech{flvector} with @racket[size] elements, where every
-slot in the @tech{flvector} is filled with @racket[x].}
+slot in the @tech{flvector} is filled with @racket[x].
+
+@mz-examples[(make-flvector 4 3.0)]}
 
 @defproc[(flvector-length [vec flvector?]) exact-nonnegative-integer?]{
 
@@ -1108,6 +1112,25 @@ elements of @scheme[v] efficiently as in @scheme[in-list],
 Like @scheme[for/vector] or @scheme[for*/vector], but for
 @tech{flvector}s.}
 
+@defproc[(shared-flvector [x inexact-real?] ...) flvector?]{
+
+Creates a @tech{flvector} containing the given inexact real numbers.
+When @secref["places"] are enabled, the new @tech{flvector} is 
+allocated in the @tech{shared memory space}.
+
+@mz-examples[(shared-flvector 2.0 3.0 4.0 5.0)]}
+
+
+@defproc[(make-shared-flvector [size exact-nonnegative-integer?]
+                        [x inexact-real? 0.0]) 
+         flvector?]{
+
+Creates a @tech{flvector} with @racket[size] elements, where every
+slot in the @tech{flvector} is filled with @racket[x].
+When @secref["places"] are enabled, the new @tech{flvector} is 
+allocated in the @tech{shared memory space}.
+
+@mz-examples[(make-shared-flvector 4 3.0)]}
                        
 @section{Fixnum Operations}
 

collects/scribblings/reference/places.scrbl

@@ -1,6 +1,5 @@
 #lang scribble/doc
-
-@title{@bold{Places}: Coarse-grained Parallelism}
+@title[#:tag "places"]{@bold{places}: Coarse-grained Parallelism}
 
 @; ----------------------------------------------------------------------
 
@@ -10,7 +9,8 @@
           (for-label racket
                      racket/base
                      racket/contract
-                     racket/place))
+                     racket/place
+                     racket/flonum))
 
 @; ----------------------------------------------------------------------
 
@@ -64,7 +64,7 @@ hardware threads.
   Returns an immutable message received on channel @racket[ch].
 }
 
-@section[#:tag "example"]{Basic Example?}
+@section[#:tag "example"]{Basic Example}
 
 This code launches two places, echos a message to them and then waits for the places to complete and return.
 
@@ -97,15 +97,33 @@ to send a value through the channel.
 
 @section[#:tag "messagepassingparallelism"]{Message Passing Parallelism}
 
-Places can only communicate by passing immutable messages on place-channels.
-Only immutable pairs, vectors, and structs can be communicated across places channels.
+Places communicate by passing messages on place-channels.
+Only atomic values, immutable pairs, vectors, and structs can be 
+communicated across places channels.
 
 @section[#:tag "places-architecture"]{Architecture and Garbage Collection}
 
-Immutable messages communicated on place-channels are first copied to a shared
-garbage collector called the master.  Places are allowed to garbage collect
-independently of one another.  The master collector, however, has to pause all
-mutators before it can collect garbage.
+Places enables a @deftech{shared memory space} between all places.
+References from the @tech{shared memory space} back into a places memory space.
+The invariant of allowing no backpointers is enforced by only allowing immutable
+datastructures to be deep copied into the @tech{shared memory space}.
+
+However, mutation of atomic values in
+the @tech{shared memory space} is permitted to improve performace of 
+shared-memory parallel programs. 
+
+Special functions such as @racket[shared-flvector] and @racket[shared-bytes] allocate 
+vectors of mutable atomic values into the @tech{shared memory space}.  
+
+Parallel mutation of these atomic values
+can possibly lead to data races, but will not cause @exec{racket} to
+crash.  In practice however, parallel tasks usually write to disjoint 
+partitions of a shared vector.
+}
+
+Places are allowed to garbage collect independently of one another.
+The shared-memory collector, however, has to pause all
+places before it can collect garbage.
 
 @section[#:tag "enabling-places"]{Enabling Places in Racket Builds}
 

collects/tests/racket/place-channel.rktl

@@ -1,5 +1,6 @@
 (load-relative "loadtest.rktl")
 (Section 'place-channel)
+(require racket/flonum)
 
 (define (splat txt fn)
   (call-with-output-file fn #:exists 'replace
@@ -10,7 +11,7 @@
 #<<END
 (module pct1 scheme
   (provide place-main)
-
+  (require racket/flonum)
 
   (define-syntax (pcrs stx)
     (syntax-case stx ()
@@ -31,10 +32,18 @@
       (list (car x) 'b (cadr x))
       (vector (vector-ref x 0) 'b (vector-ref x 1))
       #s((abuilding 1 building 2) 6 'utah 'no))
+
     (define pc1 (place-channel-recv ch))
     (pcrss pc1 (string-append x "-ok"))
+
     (define pc3 (first (place-channel-recv ch)))
-    (pcrss pc3 (string-append x "-ok3")))
+    (pcrss pc3 (string-append x "-ok3"))
+
+    (pcrss ch (begin (flvector-set! x 2 5.0) "Ready1"))
+    (pcrss ch (begin (flvector-set! x 2 6.0) "Ready2"))
+    (pcrss ch (begin (bytes-set! x 2 67) "Ready3"))
+    (pcrss ch (begin (bytes-set! x 2 67) "Ready4"))
+  )
 )
 END
 "pct1.ss")
@@ -47,6 +56,11 @@ END
 (define-struct (house building) (occupied ) #:prefab)
 (define h1 (make-house 5 'factory 'yes))
 
+(define flv1 (shared-flvector 0.0 1.0 2.0 3.0))
+(define flv2 (make-shared-flvector 4 3.0))
+
+(define b1 (shared-bytes 66 66 66 66))
+(define b2 (make-shared-bytes 4 65))
 
 (let ([pl (place "pct1.ss" 'place-main)])
   (pc-send-recv-test pl
@@ -56,12 +70,27 @@ END
     ((list 'a 'a) (list 'a 'b 'a))
     (#(a a) #(a b a))
     (h1 #s((abuilding 1 building 2) 6 'utah 'no)))
+
   (define-values (pc1 pc2) (place-channel))
   (place-channel-send pl pc2)
   (test "Testing-ok" place-channel-send/recv pc1 "Testing")
+
   (define-values (pc3 pc4) (place-channel))
   (place-channel-send pl (list pc4))
   (test "Testing-ok3" place-channel-send/recv pc3 "Testing")
+
+  (test "Ready1" place-channel-send/recv pl flv1)
+  (test 5.0 flvector-ref flv1 2)
+
+  (test "Ready2" place-channel-send/recv pl flv2)
+  (test 6.0 flvector-ref flv2 2)
+
+  (test "Ready3" place-channel-send/recv pl b1)
+  (test 67 bytes-ref b1 2)
+
+  (test "Ready4" place-channel-send/recv pl b2)
+  (test 67 bytes-ref b2 2)
+
+
   (place-wait pl)
 )
-

src/racket/include/scheme.h

@@ -302,8 +302,14 @@ typedef struct Scheme_Vector {
   Scheme_Object *els[1];
 } Scheme_Vector;
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+# define SHARED_ALLOCATED 0x2
+# define SHARED_ALLOCATEDP(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) & SHARED_ALLOCATED)
+# define SHARED_ALLOCATED_SET(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) |= SHARED_ALLOCATED)
+#endif
+
 typedef struct Scheme_Double_Vector {
-  Scheme_Object so;
+  Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
   long size;
   double els[1];
 } Scheme_Double_Vector;

src/racket/src/number.c

@@ -96,6 +96,10 @@ static Scheme_Object *flvector (int argc, Scheme_Object *argv[]);
 static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]);
 static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]);
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+static Scheme_Object *shared_flvector (int argc, Scheme_Object *argv[]);
+static Scheme_Object *make_shared_flvector (int argc, Scheme_Object *argv[]);
+#endif
 
 static Scheme_Object *integer_to_fl (int argc, Scheme_Object *argv[]);
 static Scheme_Object *fl_to_integer (int argc, Scheme_Object *argv[]);
@@ -549,6 +553,14 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
                                                     1, 2),
 			     env);
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  GLOBAL_PRIM_W_ARITY("shared-flvector", shared_flvector, 0, -1, env);
+  GLOBAL_PRIM_W_ARITY("make-shared-flvector", make_shared_flvector, 1, 2, env);
+#else
+  GLOBAL_PRIM_W_ARITY("shared-flvector", flvector, 0, -1, env); 
+  GLOBAL_PRIM_W_ARITY("make-shared-flvector", make_flvector, 1, 2, env);
+#endif
+
   p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("flvector-length", p, env);
@@ -3139,19 +3151,39 @@ long scheme_integer_length(Scheme_Object *n)
 /*                             flvectors                               */
 /************************************************************************/
 
-static Scheme_Double_Vector *alloc_flvector(long size)
+Scheme_Double_Vector *scheme_alloc_flvector(long size)
 {
   Scheme_Double_Vector *vec;
 
   vec = (Scheme_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged, 
                                                       sizeof(Scheme_Double_Vector) 
                                                       + ((size - 1) * sizeof(double)));
-  vec->so.type = scheme_flvector_type;
+  vec->iso.so.type = scheme_flvector_type;
   vec->size = size;
 
   return vec;
 }
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+static Scheme_Double_Vector *alloc_shared_flvector(long size)
+{
+  Scheme_Double_Vector *vec;
+  void *original_gc;
+
+  original_gc = GC_switch_to_master_gc();
+  vec = (Scheme_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged, 
+                                                      sizeof(Scheme_Double_Vector) 
+                                                      + ((size - 1) * sizeof(double)));
+  GC_switch_back_from_master(original_gc);
+
+  vec->iso.so.type = scheme_flvector_type;
+  SHARED_ALLOCATED_SET(vec);
+  vec->size = size;
+
+  return vec;
+}
+#endif
+
 static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
 {
   int i;
@@ -3164,7 +3196,7 @@ static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
     }
   }
 
-  vec = alloc_flvector(argc);
+  vec = scheme_alloc_flvector(argc);
 
   for (i = 0; i < argc; i++) {
     vec->els[i] = SCHEME_FLOAT_VAL(argv[i]);
@@ -3173,6 +3205,28 @@ static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
   return (Scheme_Object *)vec;
 }
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+static Scheme_Object *shared_flvector (int argc, Scheme_Object *argv[])
+{
+  int i;
+  Scheme_Double_Vector *vec;
+
+  for (i = 0; i < argc; i++) {
+    if (!SCHEME_FLOATP(argv[i])) {
+      scheme_wrong_type("flvector", "inexact real", i, argc, argv);
+      return NULL;
+    }
+  }
+
+  vec = alloc_shared_flvector(argc);
+
+  for (i = 0; i < argc; i++) {
+    vec->els[i] = SCHEME_FLOAT_VAL(argv[i]);
+  }
+
+  return (Scheme_Object *)vec;
+}
+#endif
 
 static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[])
 {
@@ -3206,7 +3260,7 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
       scheme_wrong_type("make-flvector", "inexact real", 1, argc, argv);
   }
 
-  vec = alloc_flvector(size);
+  vec = scheme_alloc_flvector(size);
 
   if (argc > 1) {
     int i;
@@ -3219,6 +3273,45 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
   return (Scheme_Object *)vec;
 }
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+static Scheme_Object *make_shared_flvector (int argc, Scheme_Object *argv[])
+{
+  Scheme_Double_Vector *vec;
+  long size;
+
+  if (SCHEME_INTP(argv[0]))
+    size = SCHEME_INT_VAL(argv[0]);
+  else if (SCHEME_BIGNUMP(argv[0])) {
+    if (SCHEME_BIGPOS(argv[0])) {
+      scheme_raise_out_of_memory("make-flvector", NULL);
+      return NULL;
+    } else
+      size = -1;
+  } else
+    size = -1;
+
+  if (size < 0)
+    scheme_wrong_type("make-flvector", "exact non-negative integer", 0, argc, argv);
+
+  if (argc > 1) {
+    if (!SCHEME_FLOATP(argv[1]))
+      scheme_wrong_type("make-flvector", "inexact real", 1, argc, argv);
+  }
+
+  vec = alloc_shared_flvector(size);
+
+  if (argc > 1) {
+    int i;
+    double d = SCHEME_FLOAT_VAL(argv[1]);
+    for (i = 0; i < size; i++) {
+      vec->els[i] = d;
+    }
+  }
+
+  return (Scheme_Object *)vec;
+}
+#endif
+
 Scheme_Object *scheme_flvector_length(Scheme_Object *vec)
 {
   if (!SCHEME_FLVECTORP(vec))

src/racket/src/places.c

@@ -33,7 +33,10 @@ static int scheme_place_channel_ready(Scheme_Object *so);
 
 static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
 static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch);
+
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
 static Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht);
+#endif
 
 # ifdef MZ_PRECISE_GC
 static void register_traversers(void);
@@ -661,6 +664,7 @@ static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[])
 }
 
 Scheme_Object *scheme_places_deep_copy(Scheme_Object *so) {
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
   Scheme_Object *new_so = so;
   if (SCHEME_INTP(so)) {
     return so;
@@ -682,8 +686,12 @@ Scheme_Object *scheme_places_deep_copy(Scheme_Object *so) {
       break;
   }
   return new_so;
+#else
+  return so;
+#endif
 }
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
 Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
 {
   Scheme_Object *new_so = so;
@@ -740,7 +748,12 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
       new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
       break;
     case scheme_byte_string_type:
-      new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
+      if (SHARED_ALLOCATEDP(so)) {
+        new_so = so;
+      }
+      else {
+        new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
+      }
       break;
     case scheme_unix_path_type:
       new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
@@ -783,7 +796,22 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
         new_so = vec;
       }
       break;
+    case scheme_flvector_type:
+      if (SHARED_ALLOCATEDP(so)) {
+        new_so = so;
+      }
+      else {
+        Scheme_Double_Vector *vec;
+        long i;
+        long size = SCHEME_FLVEC_SIZE(so);
+        vec = scheme_alloc_flvector(size);
 
+        for (i = 0; i < size; i++) {
+          SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i];
+        }
+        new_so = (Scheme_Object *) vec;
+      }
+      break;
     case scheme_structure_type:
       {
         Scheme_Structure *st = (Scheme_Structure*)so;
@@ -849,6 +877,7 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
   }
   return new_so;
 }
+#endif
 
 Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base,
 					Scheme_Object *parent,
@@ -1085,6 +1114,7 @@ void force_hash_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
     case scheme_unix_path_type:
     case scheme_symbol_type:
     case scheme_place_bi_channel_type:
+    case scheme_flvector_type:
       break;
     case scheme_pair_type:
       {

src/racket/src/schminc.h

@@ -13,9 +13,9 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1000
+#define EXPECTED_PRIM_COUNT 1002
 #define EXPECTED_UNSAFE_COUNT 69
-#define EXPECTED_FLFXNUM_COUNT 58
+#define EXPECTED_FLFXNUM_COUNT 60
 #define EXPECTED_FUTURES_COUNT 5
 
 #ifdef MZSCHEME_SOMETHING_OMITTED

src/racket/src/schpriv.h

@@ -3441,6 +3441,7 @@ Scheme_Object *scheme_checked_byte_string_ref(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_byte_string_set(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_vector_length(Scheme_Object *v);
+Scheme_Double_Vector *scheme_alloc_flvector(long size);
 Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_flvector_length(Scheme_Object *v);

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.0.1.3"
+#define MZSCHEME_VERSION "5.0.1.4"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 1
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/racket/src/string.c

@@ -262,6 +262,11 @@ static Scheme_Object *string_normalize_kc (int argc, Scheme_Object *argv[]);
 static Scheme_Object *string_normalize_d (int argc, Scheme_Object *argv[]);
 static Scheme_Object *string_normalize_kd (int argc, Scheme_Object *argv[]);
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+static Scheme_Object *make_shared_byte_string (int argc, Scheme_Object *argv[]);
+static Scheme_Object *shared_byte_string (int argc, Scheme_Object *argv[]);
+#endif
+
 static Scheme_Object *make_byte_string (int argc, Scheme_Object *argv[]);
 static Scheme_Object *byte_string (int argc, Scheme_Object *argv[]);
 static Scheme_Object *byte_p (int argc, Scheme_Object *argv[]);
@@ -685,6 +690,15 @@ scheme_init_string (Scheme_Env *env)
 						    "bytes",
 						    0, -1),
 			     env);
+
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
+  GLOBAL_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env);
+  GLOBAL_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env);
+#else
+  GLOBAL_PRIM_W_ARITY("make-shared-bytes", make_byte_string, 1, 2, env);
+  GLOBAL_PRIM_W_ARITY("shared-bytes", byte_string, 0, -1, env);
+#endif
+
   scheme_add_global_constant("bytes-length",
 			     scheme_make_folding_prim(byte_string_length,
 						      "bytes-length",
@@ -1140,7 +1154,9 @@ byte_p(int argc, Scheme_Object *argv[])
 #define CHAR_STR BYTE_STR
 #define MAKE_CHAR(x) scheme_make_integer_value(x)
 #define xstrlen strlen
+#define GENERATING_BYTE
 #include "strops.inc"
+#undef GENERATING_BYTE
 
 /* comparisons */
 

src/racket/src/strops.inc

@@ -87,6 +87,43 @@ X(scheme_alloc, _string)(long size, Xchar fill)
   return str;
 }
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) && defined(GENERATING_BYTE)
+Scheme_Object *
+X(scheme_alloc_shared, _string)(long size, Xchar fill)
+{
+  Scheme_Object *str;
+  Xchar *s;
+  long i;
+  void *original_gc;
+  
+  if (size < 0) {
+    str = scheme_make_integer(size);
+    scheme_wrong_type("make-" XSTRINGSTR, "non-negative exact integer",
+		      -1, 0, &str);
+  }
+
+  original_gc = GC_switch_to_master_gc();
+  str = scheme_alloc_object();
+  str->type = scheme_x_string_type;
+  SHARED_ALLOCATED_SET(str);
+
+  if (size < 100)
+    s = (Xchar *)scheme_malloc_atomic(sizeof(Xchar)*(size + 1));
+  else
+    s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1));
+  GC_switch_back_from_master(original_gc);
+
+  for (i = size; i--; ) {
+    s[i] = fill;
+  }
+  s[size] = 0;
+  SCHEME_X_STR_VAL(str) = s;
+  SCHEME_X_STRTAG_VAL(str) = size;
+
+  return str;
+}
+#endif
+
 /**********************************************************************/
 /*                          string procs                              */
 /**********************************************************************/
@@ -139,6 +176,50 @@ X__(string) (int argc, Scheme_Object *argv[])
   return str;
 }
 
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) && defined(GENERATING_BYTE)
+static Scheme_Object *
+X_(make_shared, string) (int argc, Scheme_Object *argv[])
+{
+  long len;
+  Xchar fill;
+  Scheme_Object *str;
+
+  len = scheme_extract_index("make-" XSTRINGSTR, 0, argc, argv, -1, 0);
+
+  if (argc == 2) {
+    if (!CHARP(argv[1]))
+      scheme_wrong_type("make-" XSTRINGSTR, CHAR_STR, 1, argc, argv);
+    fill = (Xchar)CHAR_VAL(argv[1]);
+  } else
+    fill = 0;
+
+  if (len == -1) {
+    scheme_raise_out_of_memory("make-" XSTRINGSTR, "making " XSTR "string of length %s",
+			       scheme_make_provided_string(argv[0], 0, NULL));
+  }
+
+  str = X(scheme_alloc_shared, _string)(len, fill);
+  return str;
+}
+
+static Scheme_Object *
+X_(shared, string) (int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *str;
+  int i;
+
+  str = X(scheme_alloc_shared, _string)(argc, 0);
+
+  for ( i=0 ; i<argc ; ++i ) {
+    if (!CHARP(argv[i]))
+      scheme_wrong_type(XSTRINGSTR, CHAR_STR, i, argc, argv);
+    SCHEME_X_STR_VAL(str)[i] = (Xchar)CHAR_VAL(argv[i]);
+  }
+
+  return str;
+}
+#endif
+
 static Scheme_Object *
 X__(string_length) (int argc, Scheme_Object *argv[])
 {