From 1f1a10db8725d37d5d85c91ef6dfc823de0a3a83 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Sep 2014 10:20:56 -0500 Subject: [PATCH] chaperones: allow struct chaperones that supply no redirections (as requested by Asumu) A witness accessor or mutator is still required to create a structure chaperone, but `#f` can be provided in place of a redirection, and then impersonator properties can be attached to the chaperone. At the same time, adjust `(chaperone-of? v1 v2)` so that `v1` as a chaperone is not required to preserve non-redirecting chaperones of `v2`. The overall consequence is that a redirection procedure can cooperate with a (suitably protected) impersonator property to override redirection behavior without running afoul of the chaperone invariant and without requiring O(N) space for O(N) overrides. For example, the contract system can implement the re-application of a contract with different blame information by overriding blame information as represented by properties, instead of adding a new chaperone layer every time that blame changes. ... and all the same for non-chaperone impersonators, of course. --- .../scribblings/reference/chaperones.scrbl | 64 +++++++++++--- .../racket-test/tests/racket/chaperone.rktl | 26 +++++- racket/src/racket/src/bool.c | 7 ++ racket/src/racket/src/schpriv.h | 2 + racket/src/racket/src/struct.c | 86 ++++++++++++++----- 5 files changed, 152 insertions(+), 33 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 22c3e8e22f..3eecb3f79c 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -89,12 +89,43 @@ impersonators to @racket[v2]. For values that include no impersonators, @racket[v1] and @racket[v2] can be considered impersonators of each other if they are @racket[equal?]. -Otherwise, all impersonators of @racket[v2] must be intact in @racket[v1], -in the sense that parts of @racket[v2] must be derived from -@racket[v1] through one of the impersonator constructors (e.g., -@racket[impersonate-procedure] or @racket[chaperone-procedure]). +Otherwise, impersonators within @racket[v2] must be intact within +@racket[v1]: -See also @racket[prop:impersonator-of].} +@itemlist[ + + @item{If a part of @racket[v2] is an impersonator created from one of + the impersonator constructors (e.g., + @racket[impersonate-procedure] or + @racket[chaperone-procedure]), and if the impersonator is + constructed with at least one redirection procedure (i.e., a + value other than @racket[#f] was supplied for a redirection + procedure), then the corresponding part of @racket[v1] must be + one of the following: + + @itemlist[ + + @item{the same value that is a part of @racket[v2];} + + @item{a value further derived from the part of @racket[v2] + value using an impersonator constructor; or} + + @item{a value with the @racket[prop:impersonator-of] property + whose procedure produces an impersonator of the value + that is a part of @racket[v2].} + + ]} + + @item{If a part of @racket[v2] is a structure impersonator that was + created with no redirection procedures (i.e, @racket[#f] in + place of all redirection procedures for specified operations), + then the impersonated value is considered in place of that part + of @racket[v2]. In other words, an impersonator construction + that does not redirect any access or mutation (but that + includes some @tech{impersonator properties}) need not be + preserved in @racket[v1].} + +]} @defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{ @@ -107,10 +138,11 @@ be considered chaperones of each other if they are @racket[equal?], except that the mutability of vectors and boxes with @racket[v1] and @racket[v2] must be the same. -Otherwise, all chaperones of @racket[v2] must be intact in -@racket[v1], in the sense that parts of @racket[v2] must be derived -from @racket[v1] through one of the chaperone constructors (e.g., -@racket[chaperone-procedure]).} +Otherwise, chaperones within @racket[v2] must be intact within +@racket[v1] analogous to way that @racket[impersonator-of?] requires +that impersonators are preserved, except that @racket[prop:impersonator-of] +has no analog for @racket[chaperone-of].} + @defproc[(impersonator-ephemeron [v any/c]) ephemeron?]{ @@ -183,7 +215,7 @@ of impersonators with respect to wrapping impersonators to be detected within [orig-proc (or/c struct-accessor-procedure? struct-mutator-procedure? struct-type-property-accessor-procedure?)] - [redirect-proc procedure?] ... ... + [redirect-proc (or/c procedure? #f)] ... ... [prop impersonator-property?] [prop-val any] ... ...) any/c]{ @@ -221,13 +253,21 @@ The protocol for a @racket[redirect-proc] depends on the corresponding ] +When a @racket[redirect-proc] is @racket[#f], the corresponding +@racket[orig-proc] is unaffected. Supplying @racket[#f] for a +@racket[redirect-proc] is useful to allow its @racket[orig-proc] to +act as a ``witness'' of @racket[v]'s representation and enable the +addition of @racket[prop]s. + Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to @racket[impersonate-struct] must be odd) add impersonator properties or override impersonator-property values of @racket[v]. Each @racket[orig-proc] must indicate a distinct operation. If no @racket[orig-proc]s are supplied, then no @racket[prop]s must be -supplied, and @racket[v] is returned unimpersonated. +supplied. If @racket[orig-proc]s are supplied only with @racket[#f] +@racket[redirect-proc]s and no @racket[prop]s are supplied, then +@racket[v] is returned unimpersonated. If any @racket[orig-proc] is itself an impersonator, then a use of the accessor or mutator that @racket[orig-proc] impersonates is redirected @@ -536,7 +576,7 @@ order of the supplied arguments' keywords.} struct-mutator-procedure? struct-type-property-accessor-procedure? (one-of/c struct-info))] - [redirect-proc procedure?] ... ... + [redirect-proc (or/c procedure? #f)] ... ... [prop impersonator-property?] [prop-val any] ... ...) any/c]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index f738146e19..2cb96f0fb9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -1449,6 +1449,8 @@ ;; ---------------------------------------- (let () + (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue)) + (define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate)) (define (a-impersonator-of v) (a-x v)) (define a-equal+hash (list (lambda (v1 v2 equal?) @@ -1459,7 +1461,8 @@ (hash (aa-y v2))))) (define (aa-y v) (if (a? v) (a-y v) (pre-a-y v))) (define-struct pre-a (x y) - #:property prop:equal+hash a-equal+hash) + #:property prop:equal+hash a-equal+hash + #:property prop:green 'color) (define-struct a (x y) #:property prop:impersonator-of a-impersonator-of #:property prop:equal+hash a-equal+hash) @@ -1492,6 +1495,27 @@ (err/rt-test (impersonator-of? (make-a-new-impersonator a1 1) a1)) (err/rt-test (impersonator-of? (make-a-new-equal a1 1) a1)) (err/rt-test (equal? (make-a-new-equal a1 1) a1)) + + (define a-pre-a (chaperone-struct (make-pre-a 17 1) pre-a-y (lambda (a v) v))) + (test 1 pre-a-y a-pre-a) + (test #t chaperone-of? a-pre-a a-pre-a) + (test #t chaperone-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color)) + (test #f chaperone-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color)) + (test #t chaperone-of? a-pre-a (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color)) + (test #t chaperone-of? (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color) a-pre-a) + (test #f chaperone-of? a-pre-a (chaperone-struct a-pre-a pre-a-y (lambda (a v) v) prop:blue 'color)) + (test #f chaperone-of? a-pre-a (chaperone-struct a-pre-a green-ref (lambda (a v) v))) + + (define (exn:second-time? e) (and (exn? e) (regexp-match? #rx"same value as" (exn-message e)))) + (err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y #f pre-a-y #f) exn:second-time?) + (err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y (lambda (a v) v) pre-a-y #f) exn:second-time?) + (err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y #f pre-a-y (lambda (a v) v)) exn:second-time?) + + (eq? a-pre-a (chaperone-struct a-pre-a pre-a-y #f)) + (eq? a-pre-a (chaperone-struct a-pre-a green-ref #f)) + + (test #t impersonator-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color)) + (test #f impersonator-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color)) (void))) ;; ---------------------------------------- diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index fbd653cf3b..3940dc32d6 100644 --- a/racket/src/racket/src/bool.c +++ b/racket/src/racket/src/bool.c @@ -564,6 +564,13 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (cmp > -1) return cmp; + if (eql->for_chaperone + && SCHEME_CHAPERONEP(obj2) + && scheme_is_noninterposing_chaperone(obj2)) { + obj2 = ((Scheme_Chaperone *)obj2)->prev; + goto top_after_next; + } + if (eql->for_chaperone && SCHEME_CHAPERONEP(obj1) && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR) diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 575d5ed4ca..9b9cd8cbc4 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1023,6 +1023,8 @@ void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_ Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val); +int scheme_is_noninterposing_chaperone(Scheme_Object *obj); + /*========================================================================*/ /* syntax objects */ /*========================================================================*/ diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 8af9585157..364f9fcfde 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -2197,9 +2197,9 @@ static void chaperone_struct_set(const char *who, Scheme_Object *prim, return; } } - } if (SCHEME_VECTORP(px->redirects) - && !(SCHEME_VEC_SIZE(px->redirects) & 1) - && SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) { + } else if (SCHEME_VECTORP(px->redirects) + && !(SCHEME_VEC_SIZE(px->redirects) & 1) + && SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) { /* chaperone on every field: check that current value is not undefined --- unless check is disabled by a mark (bit it's faster to check for `undefined` before checking the mark) */ @@ -2226,6 +2226,31 @@ void scheme_struct_set(Scheme_Object *sv, int pos, Scheme_Object *v) } } +int scheme_is_noninterposing_chaperone(Scheme_Object *o) +/* Checks whether the immediate impersonator layer for `o` is known to + interpose on no operations (i.e., it's for impersonator properties, + only) */ +{ + Scheme_Chaperone *px = (Scheme_Chaperone *)o; + int i; + + if (!SCHEME_VECTORP(px->redirects)) + return 0; + + if (SCHEME_VEC_SIZE(px->redirects) & 1) + return 0; + + if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0])) + return 0; + + for (i = SCHEME_VEC_SIZE(px->redirects); i-- > PRE_REDIRECTS; ) { + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[i])) + return 0; + } + + return 1; +} + static Scheme_Object **apply_guards(Scheme_Struct_Type *stype, int argc, Scheme_Object **args, int *_chaperone_undefined) { @@ -5714,8 +5739,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, Scheme_Object *a[1], *inspector, *getter_positions = scheme_null; int i, offset, arity, non_applicable_op, repeat_op; const char *kind; - Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL; + Scheme_Hash_Tree *props = NULL, *red_props = NULL, *empty_red_props = NULL, *setter_positions = NULL; intptr_t field_pos; + int empty_si_chaperone = 0, *empty_redirects = NULL; if (argc == 1) return argv[0]; @@ -5778,7 +5804,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, repeat_op = 0; if (offset == -2) { - if (SCHEME_TRUEP(si_chaperone)) + if (SCHEME_TRUEP(si_chaperone) || empty_si_chaperone) scheme_contract_error(name, "struct-info procedure supplied a second time", "procedure", 1, a[0], @@ -5804,10 +5830,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, non_applicable_op = 1; arity = 0; } else { - if (!red_props) - red_props = scheme_make_hash_tree(0); - - if (scheme_hash_tree_get(red_props, prop)) + if (red_props && scheme_hash_tree_get(red_props, prop)) + repeat_op = 1; + if (empty_red_props && scheme_hash_tree_get(empty_red_props, prop)) repeat_op = 1; arity = 2; @@ -5821,6 +5846,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, non_applicable_op = 1; else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos])) repeat_op = 1; + else if (empty_redirects && empty_redirects[offset + field_pos]) + repeat_op = 1; else { if (is_impersonator) { intptr_t loc_field_pos; @@ -5881,9 +5908,10 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, NULL); proc = argv[i]; - if (!scheme_check_proc_arity(NULL, arity, i, argc, argv)) { - char buf[32]; - sprintf(buf, "(procedure-arity-includes/c %d)", arity); + if (SCHEME_TRUEP(proc) + && !scheme_check_proc_arity(NULL, arity, i, argc, argv)) { + char buf[64]; + sprintf(buf, "(or/c (procedure-arity-includes/c %d) #f)", arity); scheme_contract_error(name, "operation's redirection procedure does not match the expected arity", "given", 1, proc, @@ -5894,8 +5922,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, } /* If the operation to chaperone was itself a chaperone, we need to - preserve and use he chaperoned variant of the operation. */ - if (SCHEME_CHAPERONEP(a[0])) { + preserve and use the chaperoned variant of the operation. */ + if (SCHEME_CHAPERONEP(a[0]) && SCHEME_TRUEP(proc)) { Scheme_Chaperone *ppx = (Scheme_Chaperone *)a[0]; if (!is_impersonator && (SCHEME_CHAPERONE_FLAGS(ppx) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) { @@ -5907,12 +5935,30 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, proc = scheme_make_pair(a[0], proc); } - if (prop) - red_props = scheme_hash_tree_set(red_props, prop, proc); - else if (st) - SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc; - else - si_chaperone = proc; + if (prop) { + if (SCHEME_TRUEP(prop)) { + if (!red_props) + red_props = scheme_make_hash_tree(0); + red_props = scheme_hash_tree_set(red_props, prop, proc); + } else { + if (!empty_red_props) + empty_red_props = scheme_make_hash_tree(0); + empty_red_props = scheme_hash_tree_set(empty_red_props, prop, proc); + } + } else if (st) { + if (SCHEME_TRUEP(proc)) + SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc; + else { + if (!empty_redirects) + empty_redirects = MALLOC_N_ATOMIC(int, 2 * stype->num_slots); + empty_redirects[offset + field_pos] = 1; + } + } else { + if (SCHEME_TRUEP(proc)) + si_chaperone = proc; + else + empty_si_chaperone = 1; + } } if (is_impersonator) {