places: handle impersonated values by copying
Recognize vector, hash table, and prefab impersoantors/chaperones, and allow them as place0channel messages by copying. Closes #2001
This commit is contained in:
Matthew Flatt
parent
f4db704b5b
commit
b0424737a7
|
|
@ -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;}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -485,13 +487,22 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
|
|||
place_data->err = rw[5];
|
||||
}
|
||||
}
|
||||
|
||||
places_prepare_direct(place_data->current_library_collection_paths);
|
||||
places_prepare_direct(place_data->current_library_collection_links);
|
||||
places_prepare_direct(place_data->compiled_roots);
|
||||
places_prepare_direct(place_data->channel);
|
||||
places_prepare_direct(place_data->module);
|
||||
places_prepare_direct(place_data->function);
|
||||
|
||||
{
|
||||
Scheme_Object *tmp;
|
||||
tmp = places_prepare_direct(place_data->current_library_collection_paths);
|
||||
place_data->current_library_collection_paths = tmp;
|
||||
tmp = places_prepare_direct(place_data->current_library_collection_links);
|
||||
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;
|
||||
|
||||
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;
|
||||
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,11 +2574,20 @@ 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;
|
||||
|
||||
if (places_deep_copy_worker(args[0], &ht, mzPDC_CHECK, 1, 0, NULL, NULL))
|
||||
Scheme_Object *v, *invalid_object = 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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user