From 567679bf0a5dbe52fc718ad7c6242da0e46a8492 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 31 Dec 2015 09:21:11 -0700 Subject: [PATCH] {impersonate,chaperone}-hash: add `equal-key-proc` wrapper The optional `equal-key-proc` wrapper effectively interposes on calls to `equal?` and `equal-hash-code` for hash-table keys. --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/chaperones.scrbl | 28 ++- .../tests/racket/chaperone.rktl | 127 +++++++++++- racket/src/racket/src/hash.c | 193 ++++++++++++++---- racket/src/racket/src/list.c | 66 ++++-- racket/src/racket/src/schpriv.h | 16 ++ racket/src/racket/src/schvers.h | 4 +- 7 files changed, 364 insertions(+), 72 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 61f22b809d..34e6cdefb2 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.3.0.10") +(define version "6.3.0.11") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl index ec16c2cbbf..a846c478a3 100644 --- a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -446,6 +446,7 @@ or override impersonator-property values of @racket[box].} [remove-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)] [clear-proc (or/c #f (hash? . -> . any)) #f] + [equal-key-proc (or/c #f (hash? any/c . -> . any/c)) #f] [prop impersonator-property?] [prop-val any] ... ...) (and/c hash? impersonator?)]{ @@ -499,6 +500,19 @@ If @racket[clear-proc] is @racket[#f], then @racket[hash-clear] or @racket[hash-clear!] on the impersonator is implemented using @racket[hash-iterate-key] and @racket[hash-remove] or @racket[hash-remove!]. +If @racket[equal-key-proc] is not @racket[#f], it effectively +interposes on calls to @racket[equal?], @racket[equal-hash-code], and +@racket[equal-secondary-hash-code] for the keys of @racket[hash]. The +@racket[equal-key-proc] must accept as its arguments @racket[hash] and +a key that is either mapped by @racket[hash] or passed to +@racket[hash-ref], etc., where the latter has potentially been +adjusted by the corresponding @racket[ref-proc], etc@|.__| The result +is a value that is passed to @racket[equal?], +@racket[equal-hash-code], and @racket[equal-secondary-hash-code] as +needed to hash and compare keys. In the case of @racket[hash-set!] or +@racket[hash-set], the key that is passed to @racket[equal-key-proc] +is the one stored in the hash table for future lookup. + The @racket[hash-iterate-value], @racket[hash-map], or @racket[hash-for-each] functions use a combination of @racket[hash-iterate-key] and @racket[hash-ref]. If a key @@ -507,7 +521,10 @@ produced by @racket[key-proc] does not yield a value through Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to @racket[impersonate-hash] must be odd) add impersonator properties -or override impersonator-property values of @racket[hash].} +or override impersonator-property values of @racket[hash]. + +@history[#:changed "6.3.0.11" @elem{Added the @racket[equal-key-proc] + argument.}]} @defproc[(impersonate-channel [channel channel?] @@ -802,6 +819,7 @@ the same value or a chaperone of the value that it is given. The [remove-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)] [clear-proc (or/c #f (hash? . -> . any)) #f] + [equal-key-proc (or/c #f (hash? any/c . -> . any/c)) #f] [prop impersonator-property?] [prop-val any] ... ...) (and/c hash? chaperone?)]{ @@ -811,8 +829,12 @@ and support for immutable hashes. The @racket[ref-proc] procedure must return a found value or a chaperone of the value. The @racket[set-proc] procedure must produce two values: the key that it is given or a chaperone of the key and the value that it is given or a -chaperone of the value. The @racket[remove-proc] and @racket[key-proc] -procedures must produce the given key or a chaperone of the key.} +chaperone of the value. The @racket[remove-proc], @racket[key-proc], +and @racket[equal-key-proc] +procedures must produce the given key or a chaperone of the key. + +@history[#:changed "6.3.0.11" @elem{Added the @racket[equal-key-proc] + argument.}]} @defproc[(chaperone-struct-type [struct-type struct-type?] [struct-info-proc procedure?] diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index ddee10417e..8275f6468e 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -1202,11 +1202,15 @@ (test #t chaperone? (mk)) (test #t chaperone? (mk #f)) (test #t chaperone? (mk (lambda (ht) (void)))) + (test #t chaperone? (mk (lambda (ht) (void)) (lambda (ht k) (void)))) + (test #t chaperone? (mk #f (lambda (ht k) (void)))) (err/rt-test (mk (lambda (a b) (void)))) (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue)) (test #t chaperone? (mk prop:blue 'ok)) (test #t chaperone? (mk #f prop:blue 'ok)) - (err/rt-test (mk (lambda (a b) (void)) prop:blue 'ok))) + (test #t chaperone? (mk #f #f prop:blue 'ok)) + (err/rt-test (mk (lambda (a b) (void)) prop:blue 'ok)) + (err/rt-test (mk #f (lambda (a) (void)) prop:blue 'ok))) (for-each (lambda (make-hash) @@ -1470,7 +1474,124 @@ (define ht4 (hash-clear ht2)) (test #t values hit?) (test 0 hash-count ht4)))) - + +;; Check use of equal-key-proc argument: +(as-chaperone-or-impersonator + ([chaperone-hash impersonate-hash] + [chaperone-procedure impersonate-procedure]) + (define saw null) + (define (mk ht) + (chaperone-hash ht + (lambda (h k) + (values k + (lambda (h k v) v))) + (lambda (h k v) + (values k v)) + (lambda (h k) k) + (lambda (h k) k) + #f + (lambda (h k) (set! saw (cons k saw)) k))) + (for ([make-hash (in-list (list make-hash make-weak-hash))]) + (set! saw null) + (define ht (make-hash)) + (define cht (mk ht)) + (hash-set! cht "x" 1) + (test '("x") values saw) + (define new-x (make-string 1 #\x)) + (void (hash-ref cht new-x)) + (test '("x" "x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (hash-set! cht new-x 5) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (hash-remove! cht new-x) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t))) + (unless (eq? chaperone-hash impersonate-hash) + (for ([hash (in-list (list hash))]) + (set! saw null) + (define ht (mk (hash))) + (define ht1 (hash-set ht "x" 1)) + (test '("x") values saw) + (define new-x (make-string 1 #\x)) + (void (hash-ref ht1 new-x)) + (test '("x" "x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (void (hash-set ht1 new-x 5)) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (void (hash-remove ht1 new-x)) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t))))) + +;; Check that hash table stores given key while +;; coercing key for hashing and equality: +(let () + (define (mk ht) + (impersonate-hash ht + (lambda (h k) + (values k + (lambda (h k v) v))) + (lambda (h k v) + (values k v)) + (lambda (h k) k) + (lambda (h k) k) + #f + (lambda (h k) (inexact->exact (floor k))))) + (for ([make-hash (in-list (list make-hash make-weak-hash))]) + (define ht (make-hash)) + (define cht (mk ht)) + (hash-set! cht 1.2 'one) + (test 'one hash-ref cht 1.3 #f) + (test #f hash-ref ht 1.3 #f) + ;; Trying to find 1.2 in `ht` likely won't work, because the hash code was mangled + (test '(1.2) hash-keys ht) + (test '(1.2) hash-keys cht) + (hash-set! cht 1.3 'two) + (test 'two hash-ref cht 1.2 #f)) + (let-values ([(prop:blue blue? blue-ref) (make-impersonator-property 'blue)]) + (define (mk ht) + (chaperone-hash ht + (lambda (h k) + (values k + (lambda (h k v) v))) + (lambda (h k v) + (values k v)) + (lambda (h k) k) + (lambda (h k) k) + #f + (lambda (h k) (chaperone-vector k + (lambda (vec i v) + (if (= i 1) + (error "ONE") + v)) + (lambda (vec i v) v))))) + (define (one-exn? s) (regexp-match? #rx"ONE" (exn-message s))) + (let () + (define cht (mk (hash))) + (err/rt-test (hash-set cht (vector 1 2) 'vec) one-exn?) + (define ht1 (hash-set cht (vector 1) 'vec)) + (test 'vec hash-ref ht1 (vector 1) #f) + (test #f hash-ref ht1 (vector 2) #f)) + (for ([make-hash (in-list (list make-hash make-weak-hash))]) + (define ht (make-hash)) + (define cht (mk ht)) + (define key (vector 1 2)) + (define key7 (vector 7)) + (hash-set! cht key7 'vec7) + (test 'vec7 hash-ref cht (vector 7) #f) + (test 'vec7 hash-ref ht (vector 7) #f) + (hash-set! ht key 'vec2) + (test 'vec2 hash-ref ht (vector 1 2)) + (err/rt-test (hash-ref cht (vector 1 2) #f) one-exn?) + (test 2 length (hash-keys cht)) ; can extract keys without hashing or comparing + (test 'vec2 hash-ref ht key) + (test 'vec7 hash-ref ht key7)))) + ;; ---------------------------------------- ;; Check broken key impersonator: @@ -2062,7 +2183,7 @@ #:a "x")) ;; ---------------------------------------- -;; Check that importantor transformations are applied for printing: +;; Check that impersonator transformations are applied for printing: (let () (define ht diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index ab9d0fd289..8bc1043062 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -164,6 +164,49 @@ static void string_hash_indices(void *_key, intptr_t *_h, intptr_t *_h2) *_h2 = to_signed_hash(h2); } +/*========================================================================*/ +/* equality with wraps */ +/*========================================================================*/ + +static Scheme_Object *apply_equal_key_wraps(Scheme_Object *key, Scheme_Object *key_wraps) +{ + if (key_wraps) { + GC_CAN_IGNORE const char *who = (const char *)SCHEME_CAR(key_wraps); + Scheme_Chaperone *px; + Scheme_Object *a[2], *red; + + key_wraps = SCHEME_CDR(key_wraps); + while (!SCHEME_NULLP(key_wraps)) { + px = (Scheme_Chaperone *)SCHEME_CAR(key_wraps); + + red = SCHEME_BOX_VAL(px->redirects); + red = SCHEME_VEC_ELS(red)[5]; + + a[0] = px->prev; + a[1] = key; + key = _scheme_apply(red, 2, a); + + if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR) + && !scheme_chaperone_of(key, a[1])) { + scheme_wrong_chaperoned(who, "key", a[1], key); + return 0; + } + + key_wraps = SCHEME_CDR(key_wraps); + } + } + + return key; +} + +static int equal_w_key_wraps(Scheme_Object *ekey, Scheme_Object *tkey, Scheme_Object *key_wraps) +{ + if (key_wraps) + tkey = apply_equal_key_wraps(tkey, key_wraps); + + return scheme_equal(ekey, tkey); +} + /*========================================================================*/ /* normal hash table */ /*========================================================================*/ @@ -201,9 +244,10 @@ void scheme_clear_hash_table(Scheme_Hash_Table *ht) ht->mcount = 0; } -static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val) +static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val, + Scheme_Object *key_wraps) { - Scheme_Object *tkey, **keys; + Scheme_Object *tkey, *ekey, **keys; intptr_t hx, h2x; hash_v_t h, h2, useme = 0; uintptr_t mask; @@ -214,8 +258,12 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int if (table->make_hash_indices) { if (table->compare == scheme_compare_equal) { + if (key_wraps) + ekey = apply_equal_key_wraps(key, key_wraps); + else + ekey = key; h2 = 0; - hx = scheme_equal_hash_key(key); + hx = scheme_equal_hash_key(ekey); h = to_unsigned_hash(hx) & mask; } else { GC_CAN_IGNORE intptr_t *_h2x; @@ -240,7 +288,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int if (table->compare) { if (table->compare == scheme_compare_equal) { - /* Direct calls can be significant faster than indirect */ + /* Direct calls can be significantly faster than indirect */ scheme_hash_request_count++; while ((tkey = keys[HASH_TO_ARRAY_INDEX(h, mask)])) { if (SAME_PTR(tkey, GONE)) { @@ -248,7 +296,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int useme = h; set = 1; } - } else if (scheme_equal(tkey, key)) { + } else if (equal_w_key_wraps(ekey, tkey, key_wraps)) { if (set) { table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val; if (!val) { @@ -261,7 +309,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int } scheme_hash_iteration_count++; if (!h2) { - h2x = scheme_equal_hash_key2(key); + h2x = scheme_equal_hash_key2(ekey); h2 = (to_unsigned_hash(h2x) & (table->size - 1)) | 1; } h = (h + h2) & mask; @@ -346,7 +394,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int table->mcount = 0; for (i = 0; i < oldsize; i++) { if (oldkeys[i] && !SAME_PTR(oldkeys[i], GONE)) - do_hash(table, oldkeys[i], 2, oldvals[i]); + do_hash(table, oldkeys[i], 2, oldvals[i], key_wraps); } goto rehash_key; @@ -405,7 +453,7 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, h = useme; else if (table->mcount * FILL_FACTOR >= table->size) { /* Use slow path to grow table: */ - return do_hash(table, key, 2, val); + return do_hash(table, key, 2, val, NULL); } else { table->mcount++; } @@ -446,7 +494,8 @@ XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Schem return NULL; } -void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val) +void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps) { if (!table->vals) { Scheme_Object **ba; @@ -460,21 +509,32 @@ void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object } if (table->make_hash_indices) - do_hash(table, key, 2, val); + do_hash(table, key, 2, val, key_wraps); else do_hash_set(table, key, val); } -Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key) +void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val) +{ + scheme_hash_set_w_key_wraps(table, key, val, NULL); +} + +Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, + Scheme_Object *key_wraps) { if (!table->vals) return NULL; else if (table->make_hash_indices) - return do_hash(table, key, 0, NULL); + return do_hash(table, key, 0, NULL, key_wraps); else return do_hash_get(table, key); } +Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key) +{ + return scheme_hash_get_w_key_wraps(table, key, NULL); +} + Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key) /* Specialized to allow XFORM_NONGCING */ { @@ -692,10 +752,12 @@ allocate_bucket (Scheme_Bucket_Table *table, const char *key, void *val) } static Scheme_Bucket * -get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b) +get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b, + Scheme_Object *key_wraps) { intptr_t hx, h2x; hash_v_t h, h2; + void *ekey; Scheme_Bucket *bucket; Compare_Proc compare = table->compare; uintptr_t mask; @@ -705,7 +767,11 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket mask = table->size - 1; if (table->make_hash_indices) { - table->make_hash_indices((void *)key, &hx, &h2x); + if (key_wraps) + ekey = apply_equal_key_wraps((Scheme_Object *)key, key_wraps); + else + ekey = (void *)key; + table->make_hash_indices(ekey, &hx, &h2x); h = to_unsigned_hash(hx) & mask; h2 = to_unsigned_hash(h2x) & mask; } else { @@ -728,7 +794,10 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket reuse_bucket = h + 1; } else if (SAME_PTR(hk, key)) return bucket; - else if (compare && !compare((void *)hk, (void *)key)) + else if (key_wraps) { + if (equal_w_key_wraps((Scheme_Object *)ekey, (Scheme_Object *)hk, key_wraps)) + return bucket; + } else if (compare && !compare((void *)hk, ekey)) return bucket; } else if (add) break; @@ -747,7 +816,10 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket while ((bucket = table->buckets[HASH_TO_ARRAY_INDEX(h, mask)])) { if (SAME_PTR(bucket->key, key)) return bucket; - else if (compare && !compare((void *)bucket->key, (void *)key)) + else if (key_wraps) { + if (equal_w_key_wraps((Scheme_Object *)ekey, (Scheme_Object *)bucket->key, key_wraps)) + return bucket; + } else if (compare && !compare((void *)bucket->key, (void *)key)) return bucket; scheme_hash_iteration_count++; h = (h + h2) & mask; @@ -800,12 +872,12 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket if (table->weak) { for (i = 0; i < oldsize; i++) { if (old[i] && old[i]->key && HT_EXTRACT_WEAK(old[i]->key)) - get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i]); + get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i], key_wraps); } } else { for (i = 0; i < oldsize; i++) { if (old[i] && old[i]->key) - get_bucket(table, old[i]->key, 1, old[i]); + get_bucket(table, old[i]->key, 1, old[i], key_wraps); } } @@ -825,28 +897,35 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket } Scheme_Bucket * -scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add) +scheme_bucket_or_null_from_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, int add, + Scheme_Object *key_wraps) { Scheme_Bucket *b; - b = get_bucket(table, key, add, NULL); + b = get_bucket(table, key, add, NULL, key_wraps); return b; } +Scheme_Bucket * +scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add) +{ + return scheme_bucket_or_null_from_table_w_key_wraps(table, key, add, NULL); +} + Scheme_Bucket * scheme_bucket_from_table (Scheme_Bucket_Table *table, const char *key) { - return scheme_bucket_or_null_from_table(table, key, 1); + return scheme_bucket_or_null_from_table_w_key_wraps(table, key, 1, NULL); } void -scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, - int constant) +scheme_add_to_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, void *val, + int constant, Scheme_Object *key_wraps) { Scheme_Bucket *b; - b = get_bucket(table, key, 1, NULL); + b = get_bucket(table, key, 1, NULL, key_wraps); if (val) b->val = val; @@ -854,17 +933,25 @@ scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_CONST; } +void +scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, + int constant) +{ + scheme_add_to_table_w_key_wraps(table, key, val, constant, NULL); +} + void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b) { - get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b); + get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b, NULL); } void * -scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key) +scheme_lookup_in_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, + Scheme_Object *key_wraps) { Scheme_Bucket *bucket; - bucket = get_bucket(table, key, 0, NULL); + bucket = get_bucket(table, key, 0, NULL, key_wraps); if (bucket) return bucket->val; @@ -872,12 +959,18 @@ scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key) return NULL; } +void * +scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key) +{ + return scheme_lookup_in_table_w_key_wraps(table, key, NULL); +} + void scheme_change_in_table (Scheme_Bucket_Table *table, const char *key, void *naya) { Scheme_Bucket *bucket; - bucket = get_bucket(table, key, 0, NULL); + bucket = get_bucket(table, key, 0, NULL, NULL); if (bucket) bucket->val = naya; @@ -2607,7 +2700,8 @@ int scheme_hash_tree_index(Scheme_Hash_Tree *ht, mzlonglong pos, Scheme_Object * } static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Scheme_Object *key, - GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code) + GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code, + Scheme_Object *key_wraps) /* in the case of hash collisions, we put the colliding elements in a tree that uses integers as keys; we have to search through the tree for keys, but the advatange of using a HAMT (instead of a list) is @@ -2624,7 +2718,7 @@ static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Sche return found_val; } } else if (stype == scheme_hash_tree_type) { - if (scheme_equal(key, found_key)) { + if (equal_w_key_wraps(key, found_key, key_wraps)) { if (_i) *_i = i; return found_val; } @@ -2779,7 +2873,8 @@ Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *ke return NULL; } -Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) +Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, + Scheme_Object *key_wraps) { uintptr_t h; int stype, pos; @@ -2789,9 +2884,11 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) if (stype == scheme_eq_hash_tree_type) return scheme_eq_hash_tree_get(tree, key); - else if (stype == scheme_hash_tree_type) + else if (stype == scheme_hash_tree_type) { + if (key_wraps) + key = apply_equal_key_wraps(key, key_wraps); h = to_unsigned_hash(scheme_equal_hash_key(key)); - else + } else h = to_unsigned_hash(scheme_eqv_hash_key(key)); tree = hamt_assoc(tree, h, &pos, 0); @@ -2801,10 +2898,10 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) if (HASHTR_COLLISIONP(tree->els[pos])) { /* hash collision; linear search in subtree */ uintptr_t code; - return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code); + return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code, key_wraps); } else { if (stype == scheme_hash_tree_type) { - if (scheme_equal(key, tree->els[pos])) + if (equal_w_key_wraps(key, tree->els[pos], key_wraps)) return mzHAMT_VAL(tree, pos); } else { if (scheme_eqv(key, tree->els[pos])) @@ -2815,20 +2912,29 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) return NULL; } -Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val) +Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) +{ + return scheme_hash_tree_get_w_key_wraps(tree, key, NULL); +} + +Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps) /* val == NULL => remove */ { uintptr_t h; Scheme_Hash_Tree *in_tree; + Scheme_Object *ekey = key; int stype, pos; stype = SCHEME_TYPE(resolve_placeholder(tree)); if (stype == scheme_eq_hash_tree_type) h = PTR_TO_LONG((Scheme_Object *)key); - else if (stype == scheme_hash_tree_type) - h = to_unsigned_hash(scheme_equal_hash_key(key)); - else + else if (stype == scheme_hash_tree_type) { + if (key_wraps) + ekey = apply_equal_key_wraps(ekey, key_wraps); + h = to_unsigned_hash(scheme_equal_hash_key(ekey)); + } else h = to_unsigned_hash(scheme_eqv_hash_key(key)); in_tree = hamt_assoc(resolve_placeholder(tree), h, &pos, 0); @@ -2847,7 +2953,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke int i, inc; uintptr_t code; in_tree = (Scheme_Hash_Tree *)in_tree->els[pos]; - if (hamt_linear_search(in_tree, stype, key, &i, &code)) { + if (hamt_linear_search(in_tree, stype, key, &i, &code, key_wraps)) { /* key is part of the current collision */ if (!val) { if (in_tree->count == 2) { @@ -2885,7 +2991,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke if (stype == scheme_eq_hash_tree_type) same = SAME_OBJ(key, in_tree->els[pos]); else if (stype == scheme_hash_tree_type) - same = scheme_equal(key, in_tree->els[pos]); + same = equal_w_key_wraps(ekey, in_tree->els[pos], key_wraps); else same = scheme_eqv(key, in_tree->els[pos]); @@ -2921,6 +3027,11 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke } } +Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val) +{ + return scheme_hash_tree_set_w_key_wraps(tree, key, val, NULL); +} + static int hamt_equal_entries(int stype, void *eql_data, Scheme_Object *k1, Scheme_Object *v1, Scheme_Object *k2, Scheme_Object *v2) diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index d253e78449..ad9f007de0 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -2944,7 +2944,7 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i { Scheme_Chaperone *px; Scheme_Object *val = argv[0]; - Scheme_Object *redirects, *clear; + Scheme_Object *redirects, *clear, *equal_key_wrap; Scheme_Hash_Tree *props; int start_props = 5; @@ -2967,15 +2967,23 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i } else clear = scheme_false; + if ((argc > 6) && (SCHEME_FALSEP(argv[6]) || SCHEME_PROCP(argv[6]))) { + scheme_check_proc_arity2(name, 2, 6, argc, argv, 1); /* clear */ + equal_key_wrap = argv[6]; + start_props++; + } else + equal_key_wrap = scheme_false; + /* The allocation of this vector is used to detect when two chaperoned immutable hash tables can be `{chaperone,impersonator}-of?` when they're not eq. */ - redirects = scheme_make_vector(5, NULL); + redirects = scheme_make_vector(6, NULL); SCHEME_VEC_ELS(redirects)[0] = argv[1]; SCHEME_VEC_ELS(redirects)[1] = argv[2]; SCHEME_VEC_ELS(redirects)[2] = argv[3]; SCHEME_VEC_ELS(redirects)[3] = argv[4]; SCHEME_VEC_ELS(redirects)[4] = clear; + SCHEME_VEC_ELS(redirects)[5] = equal_key_wrap; redirects = scheme_box(redirects); /* so it doesn't look like a struct chaperone */ props = scheme_parse_chaperone_props(name, start_props, argc, argv); @@ -3019,7 +3027,7 @@ static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object } static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k, - Scheme_Object *v, int mode); + Scheme_Object *v, int mode, Scheme_Object *key_wraps); static Scheme_Object *chaperone_hash_op_k(void) { @@ -3028,13 +3036,15 @@ static Scheme_Object *chaperone_hash_op_k(void) Scheme_Object *k = (Scheme_Object *)p->ku.k.p2; Scheme_Object *v = (Scheme_Object *)p->ku.k.p3; const char *who = (const char *)p->ku.k.p4; + Scheme_Object *key_wraps = (Scheme_Object *)p->ku.k.p5; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; + p->ku.k.p5 = NULL; - o = chaperone_hash_op(who, o, k, v, p->ku.k.i1); + o = chaperone_hash_op(who, o, k, v, p->ku.k.i1, key_wraps); if (!o) return scheme_false; @@ -3043,7 +3053,7 @@ static Scheme_Object *chaperone_hash_op_k(void) } static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object *o, Scheme_Object *k, - Scheme_Object *v, int mode) + Scheme_Object *v, int mode, Scheme_Object *key_wraps) { Scheme_Thread *p = scheme_current_thread; @@ -3052,6 +3062,7 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object p->ku.k.p3 = (void *)v; p->ku.k.p4 = (void *)who; p->ku.k.i1 = mode; + p->ku.k.p5 = (void *)key_wraps; o = scheme_handle_stack_overflow(chaperone_hash_op_k); @@ -3062,26 +3073,30 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object } static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k, - Scheme_Object *v, int mode) + Scheme_Object *v, int mode, Scheme_Object *key_wraps) { Scheme_Object *wraps = NULL; while (1) { if (!SCHEME_NP_CHAPERONEP(o)) { + if (SCHEME_NULLP(key_wraps)) + key_wraps = NULL; + else + key_wraps = scheme_make_raw_pair((Scheme_Object *)who, key_wraps); if (mode == 0) { /* hash-ref */ if (SCHEME_HASHTP(o)) - return scheme_hash_get((Scheme_Hash_Table *)o, k); + return scheme_hash_get_w_key_wraps((Scheme_Hash_Table *)o, k, key_wraps); else if (SCHEME_HASHTRP(o)) - return scheme_hash_tree_get((Scheme_Hash_Tree *)o, k); + return scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps); else - return scheme_lookup_in_table((Scheme_Bucket_Table *)o, (const char *)k); + return scheme_lookup_in_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, key_wraps); } else if ((mode == 1) || (mode == 2)) { /* hash-set! or hash-remove! */ if (SCHEME_HASHTP(o)) - scheme_hash_set((Scheme_Hash_Table *)o, k, v); + scheme_hash_set_w_key_wraps((Scheme_Hash_Table *)o, k, v, key_wraps); else if (SCHEME_HASHTRP(o)) { - o = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)o, k, v); + o = (Scheme_Object *)scheme_hash_tree_set_w_key_wraps((Scheme_Hash_Tree *)o, k, v, key_wraps); while (wraps) { o = transfer_chaperone(SCHEME_CAR(wraps), o); wraps = SCHEME_CDR(wraps); @@ -3089,13 +3104,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem return o; } else if (!v) { Scheme_Bucket *b; - b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)o, (char *)k, 0); + b = scheme_bucket_or_null_from_table_w_key_wraps((Scheme_Bucket_Table *)o, (char *)k, 0, key_wraps); if (b) { HT_EXTRACT_WEAK(b->key) = NULL; b->val = NULL; } } else - scheme_add_to_table((Scheme_Bucket_Table *)o, (const char *)k, v, 0); + scheme_add_to_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, v, 0, key_wraps); return scheme_void; } else if (mode == 3) return k; @@ -3119,14 +3134,21 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem #ifdef DO_STACK_CHECK { # include "mzstkchk.h" - return chaperone_hash_op_overflow(who, o, k, v, mode); + return chaperone_hash_op_overflow(who, o, k, v, mode, key_wraps); } #endif + if ((mode != 3) && (mode != 4)) { + red = SCHEME_BOX_VAL(px->redirects); + red = SCHEME_VEC_ELS(red)[5]; + if (!SCHEME_FALSEP(red)) + key_wraps = scheme_make_pair((Scheme_Object *)px, key_wraps); + } + if (mode == 0) orig = NULL; else if (mode == 3) { - orig = chaperone_hash_op(who, px->prev, k, v, mode); + orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps); k = orig; } else if (mode == 2) orig = k; @@ -3196,7 +3218,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem who, red); - orig = chaperone_hash_op(who, px->prev, k, v, mode); + orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps); if (!orig) return NULL; /* hash-ref */ @@ -3240,27 +3262,27 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key) { - return chaperone_hash_op("hash-ref", table, key, NULL, 0); + return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null); } void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val) { - (void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2); + (void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2, scheme_null); } Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val) { - return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2); + return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2, scheme_null); } static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key) { - return chaperone_hash_op(name, table, key, NULL, 3); + return chaperone_hash_op(name, table, key, NULL, 3, scheme_null); } static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table) { - return chaperone_hash_op(name, table, NULL, NULL, 4); + return chaperone_hash_op(name, table, NULL, NULL, 4, scheme_null); } Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key, @@ -3268,7 +3290,7 @@ Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_ { key = chaperone_hash_key("hash-table-iterate-key", table, key); *alt_key = key; - return chaperone_hash_op("hash-ref", table, key, NULL, 0); + return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null); } Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj) diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index b536986f5d..17b13f9bc5 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -597,6 +597,22 @@ Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, + Scheme_Object *key_wraps); +void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps); +Scheme_Bucket *scheme_bucket_or_null_from_table_w_key_wraps(Scheme_Bucket_Table *table, + const char *key, int add, + Scheme_Object *key_wraps); +void scheme_add_to_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, void *val, + int constant, Scheme_Object *key_wraps); +void *scheme_lookup_in_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, + Scheme_Object *key_wraps); +Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, + Scheme_Object *key_wraps); +Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps); + /*========================================================================*/ /* thread state and maintenance */ /*========================================================================*/ diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 7224f9d8be..b7a833417f 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.3.0.10" +#define MZSCHEME_VERSION "6.3.0.11" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 10 +#define MZSCHEME_VERSION_W 11 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)