places: handle impersonated values by copying

Recognize vector, hash table, and prefab impersoantors/chaperones,
and allow them as place0channel messages by copying.

Closes #2001

pkgs/racket-doc/scribblings/reference/places.scrbl

@@ -372,10 +372,12 @@ messages:
  @item{@tech{pairs}, @tech{lists}, @tech{vectors}, and immutable
        @tech{prefab} structures containing message-allowed values,
        where a mutable vector is automatically replaced by an
-       immutable vector;}
+       immutable vector and where @tech{impersonators} or vectors and
+       @tech{prefab} structures are copied;}
 
  @item{@tech{hash tables} where mutable hash tables are automatically
-       replaced by immutable variants;}
+       replaced by immutable variants, and where an
+       hash table @tech{impersonator} is copied;}
 
  @item{@tech{place channels}, where a @tech{place descriptor} is
        automatically replaced by a plain place channel;}

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

@@ -102,6 +102,63 @@
   (test (not (place-enabled?)) place-message-allowed? (cons v 1))
   (test (not (place-enabled?)) place-message-allowed? (vector v)))
 
+;; ----------------------------------------
+;; Place messages and chaperones
+
+(test #t place-message-allowed? (chaperone-vector (vector 1 2) (lambda (v i e) e) (lambda (v i e) e)))
+(test #t place-message-allowed? (chaperone-hash (hasheq 1 2 3 4)
+                                                (lambda (ht k) (values k (lambda (ht k v) v)))
+                                                (lambda (ht k v) (values k v))
+                                                (lambda (ht k) k)
+                                                (lambda (ht k) k)))
+(test #t place-message-allowed? (chaperone-hash (make-hash)
+                                                (lambda (ht k) (values k (lambda (ht k v) v)))
+                                                (lambda (ht k v) (values k v))
+                                                (lambda (ht k) k)
+                                                (lambda (ht k) k)))
+(let ()
+  (struct posn (x y) #:prefab)
+  (test #t place-message-allowed? (chaperone-struct '#s(posn 1 2)
+                                                    posn-x (lambda (p x) x))))
+
+(let ()
+  (define-values (in out) (place-channel))
+
+  (place-channel-put out (impersonate-vector (vector 1 2) (lambda (v i e) (add1 e)) (lambda (v i e) e)))
+  (test '#(2 3) place-channel-get in)
+
+  (let ([ht (make-hash)])
+    (hash-set! ht 1 2)
+    (hash-set! ht 3 4)
+    (place-channel-put out (impersonate-hash ht
+                                             (lambda (ht k) (values k (lambda (ht k v) (add1 v))))
+                                             (lambda (ht k v) (values k v))
+                                             (lambda (ht k) k)
+                                             (lambda (ht k) k)))
+    (test '#hash((1 . 3) (3 . 5))
+          place-channel-get in))
+
+  (let ()
+    (struct posn (x y) #:prefab)
+    (place-channel-put out (chaperone-struct (posn 1 2)
+                                             posn-x (lambda (p x) x)))
+    (test (posn 1 2) place-channel-get in))
+
+  ;; MAke sure large values are handled correctly
+  (let ([v (for/list ([i 10000])
+             (impersonate-vector (vector i
+                                         (impersonate-vector (vector (- i))
+                                                             (lambda (v i e) (sub1 e))
+                                                             (lambda (v i e) e)))
+                                 (lambda (v i e) (list e))
+                                 (lambda (v i e) e)))])
+    (test #t 'allowed? (place-message-allowed? v))
+    (place-channel-put out v)
+    (test #t 'equal? (equal? v (place-channel-get in))))
+
+  (void))
+
+;; ----------------------------------------
 
 (require (submod "place-utils.rkt" place-test-submod))
 (test 0 p 0)

racket/src/racket/src/list.c

@@ -3633,7 +3633,9 @@ Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_
   return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null);
 }
 
-Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)
+
+Scheme_Object *scheme_chaperone_hash_table_filtered_copy(Scheme_Object *obj,
+                                                         Hash_Table_Element_Filter_Proc filter)
 {
   Scheme_Object *a[3], *v, *v2, *idx, *key, *val;
   int is_eq, is_eqv;
@@ -3644,14 +3646,14 @@ Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)
   is_eq = SCHEME_TRUEP(scheme_hash_eq_p(1, a));
   is_eqv = SCHEME_TRUEP(scheme_hash_eqv_p(1, a));
   
-  if (SCHEME_HASHTP(obj)) {
+  if (SCHEME_HASHTP(v)) {
     if (is_eq)
       v2 = make_hasheq(0, NULL);
     else if (is_eqv)
       v2 = make_hasheqv(0, NULL);
     else
       v2 = make_hash(0, NULL);
-  } else if (SCHEME_HASHTRP(obj)) {
+  } else if (SCHEME_HASHTRP(v)) {
     if (is_eq)
       v2 = scheme_make_immutable_hasheq(0, NULL);
     else if (is_eqv)
@@ -3674,6 +3676,7 @@ Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)
     key = scheme_hash_table_iterate_key(2, a);
 
     val = scheme_chaperone_hash_get(obj, key);
+    if (filter && val) val = filter(val);
     if (val) {
       a[0] = v2;
       a[1] = key;
@@ -3692,6 +3695,11 @@ Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)
   return v2;
 }
 
+Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)
+{
+  return scheme_chaperone_hash_table_filtered_copy(obj, NULL);
+}
+
 static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[])
 {
   intptr_t v;

racket/src/racket/src/place.c

@@ -88,9 +88,11 @@ static Scheme_Object *places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
 # define mzPDC_DIRECT_UNCOPY 3
 # define mzPDC_DESER 4
 # define mzPDC_CLEAN 5
+
+static Scheme_Object *strip_chaperones(Scheme_Object *so);
 #endif
 
-static void places_prepare_direct(Scheme_Object *so);
+static Scheme_Object *places_prepare_direct(Scheme_Object *so);
 static void log_place_event(const char *what, const char *tag, int has_amount, intptr_t amount);
 
 # ifdef MZ_PRECISE_GC
@@ -486,12 +488,21 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
     }
   }
   
-  places_prepare_direct(place_data->current_library_collection_paths);
+  {
-  places_prepare_direct(place_data->current_library_collection_links);
+    Scheme_Object *tmp;
-  places_prepare_direct(place_data->compiled_roots);
+    tmp = places_prepare_direct(place_data->current_library_collection_paths);
-  places_prepare_direct(place_data->channel);
+    place_data->current_library_collection_paths = tmp;
-  places_prepare_direct(place_data->module);
+    tmp = places_prepare_direct(place_data->current_library_collection_links);
-  places_prepare_direct(place_data->function);
+    place_data->current_library_collection_links = tmp;
+    tmp = places_prepare_direct(place_data->compiled_roots);
+    place_data->compiled_roots = tmp;
+    tmp = places_prepare_direct(place_data->channel);
+    place_data->channel = tmp;
+    tmp = places_prepare_direct(place_data->module);
+    place_data->module = tmp;
+    tmp = places_prepare_direct(place_data->function);
+    place_data->function = tmp;
+  }
   
   /* create new place */
   proc_thread = mz_proc_thread_create(place_start_proc, place_data);
@@ -775,8 +786,10 @@ static Scheme_Object *do_places_deep_copy(Scheme_Object *so, int mode, int gcabl
 #endif
 }
 
-static void places_prepare_direct(Scheme_Object *so) {
+static Scheme_Object *places_prepare_direct(Scheme_Object *so) {
+  so = strip_chaperones(so);
   (void)do_places_deep_copy(so, mzPDC_CHECK, 1, NULL, NULL);
+  return so;
 }
 
 static Scheme_Object *places_deep_direct_uncopy(Scheme_Object *so) {
@@ -1931,6 +1944,79 @@ DEEP_DONE_L:
 
 }
 
+static Scheme_Object *strip_chaperones_k(void);
+
+/* Recognizes the same shapes as places_deep_copy_worker, but also
+   allows chaperones and impersonators. The result is an
+   impersonator-free copy of `so`. */
+static Scheme_Object *strip_chaperones(Scheme_Object *so)
+{
+  Scheme_Object *o;
+
+#ifdef DO_STACK_CHECK
+  {
+# include "mzstkchk.h"
+    {
+      Scheme_Thread *p = scheme_current_thread;
+      p->ku.k.p1 = (void *)so;
+      return scheme_handle_stack_overflow(strip_chaperones_k);
+    }
+  }
+#endif
+
+  if (SCHEME_CHAPERONEP(so))
+    o = SCHEME_CHAPERONE_VAL(so);
+  else
+    o = so;
+
+  if (SCHEME_PAIRP(o)) {
+    return scheme_make_pair(strip_chaperones(SCHEME_CAR(o)),
+                            strip_chaperones(SCHEME_CDR(o)));
+  } else if (SCHEME_VECTORP(o)) {
+    Scheme_Object *v, *e;
+    intptr_t len = SCHEME_VEC_SIZE(o), i;
+    v = scheme_make_vector(len, NULL);
+    for (i = 0; i < len; i++) {
+      if (SAME_OBJ(o, so))
+        e = SCHEME_VEC_ELS(so)[i];
+      else
+        e = scheme_chaperone_vector_ref(so, i);
+      e = strip_chaperones(e);
+      SCHEME_VEC_ELS(v)[i] = e;
+    }
+    return v;
+  } else if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o)) {
+    return scheme_chaperone_hash_table_filtered_copy(so, strip_chaperones);
+  } else if (SCHEME_STRUCTP(o)) {
+    Scheme_Structure *s = (Scheme_Structure *)(o), *s2;
+    Scheme_Object *e;
+    intptr_t i, len = s->stype->num_slots;
+    if (!s->stype->prefab_key)
+      return NULL;
+    s2 = (Scheme_Structure *)scheme_make_blank_prefab_struct_instance(s->stype);
+    for (i = 0; i < len; i++) {
+      if (SAME_OBJ(o, so))
+        e = s->slots[i];
+      else
+        e = scheme_struct_ref(so, i);
+      e = strip_chaperones(e);
+      s2->slots[i] = e;
+    }
+    return (Scheme_Object *)s2;
+  } else
+    return so;
+}
+
+static Scheme_Object *strip_chaperones_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object *so = (Scheme_Object *)p->ku.k.p1;
+
+  p->ku.k.p1 = NULL;
+
+  return strip_chaperones(so);
+}
+
 #if 0
 /* unused code, may be useful when/if we revive shared symbol and prefab key tables */
 Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base,
@@ -2393,10 +2479,21 @@ static Scheme_Object *places_serialize(Scheme_Object *so, void **msg_memory, Sch
   new_so = trivial_copy(so, NULL);
   if (new_so) return new_so;
 
+  while (1) {
     GC_create_message_allocator();
     new_so = do_places_deep_copy(so, mzPDC_COPY, 0, master_chain, invalid_object);
     tmp = GC_finish_message_allocator();
     (*msg_memory) = tmp;
+
+    if (!new_so && SCHEME_CHAPERONEP(*invalid_object)) {
+      /* try again after removing chaperones */
+      so = strip_chaperones(so);
+      if (!so)
+        break;
+    } else
+      break;
+  }
+  
   return new_so;
 #else
   return so;
@@ -2477,12 +2574,21 @@ Scheme_Object *place_receive(int argc, Scheme_Object *args[]) {
 static Scheme_Object* place_allowed_p(int argc, Scheme_Object *args[])
 {
   Scheme_Hash_Table *ht = NULL;
+  Scheme_Object *v, *invalid_object = NULL;
 
-  if (places_deep_copy_worker(args[0], &ht, mzPDC_CHECK, 1, 0, NULL, NULL))
+  v = args[0];
+
+  if (places_deep_copy_worker(v, &ht, mzPDC_CHECK, 1, 0, NULL, &invalid_object))
     return scheme_true;
-  else
+  else {
+    if (invalid_object && SCHEME_CHAPERONEP(invalid_object)) {
+      v = strip_chaperones(v);
+      if (v && places_deep_copy_worker(v, &ht, mzPDC_CHECK, 1, 0, NULL, NULL))
+        return scheme_true;
+    }
     return scheme_false;
   }
+}
 
 # ifdef MZ_PRECISE_GC
 void scheme_spawn_master_place() {

racket/src/racket/src/schpriv.h

@@ -3746,6 +3746,10 @@ Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[
 Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *obj);
 Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj);
 
+typedef Scheme_Object *(*Hash_Table_Element_Filter_Proc)(Scheme_Object *);
+Scheme_Object *scheme_chaperone_hash_table_filtered_copy(Scheme_Object *obj,
+                                                         Hash_Table_Element_Filter_Proc filter);
+
 void scheme_bad_vec_index(char *name, Scheme_Object *i, 
                           const char *what, Scheme_Object *vec, 
                           intptr_t bottom, intptr_t len);