add internal unsafe-impersonate-hash

Unlike `impersonate-hash`, `unsafe-impersonate-hash` works on
immutable hash tables. As a result, interposition procedures on hash
table operations can implement a custom hashing strategy. It's unsafe
because impersonating an immutable data structure can be misleading,
and the new operation is intended for use only when the impersonated
hash table is not itself visible. For now, this function is "internal"
in the sense that it's not documented and it's exported only by the
predefined `#%unsafe` module; it may change or go away in future
versions.

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change exactly when
 ;; "racket_version.h" changes:
-(define version "8.13.0.1")
+(define version "8.13.0.2")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

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

@@ -7,7 +7,9 @@
                   unsafe-chaperone-vector
                   unsafe-impersonate-vector
                   unsafe-impersonate-procedure
-                  unsafe-chaperone-procedure))
+                  unsafe-chaperone-procedure)
+         (only-in '#%unsafe
+                  unsafe-impersonate-hash))
 
 (define secondary-hash-unused? (eq? 'cs (system-type 'gc)))
 
@@ -2131,94 +2133,100 @@
    make-weak-hash make-weak-hasheq make-weak-hasheqv make-weak-hashalw
    make-ephemeron-hash make-ephemeron-hasheq make-ephemeron-hasheqv make-ephemeron-hashalw)))
 
-(for-each
- (lambda (h1)   
-   (let* ([get-k #f]
-          [get-v #f]
-          [set-k #f]
-          [set-v #f]
-          [remove-k #f]
-          [access-k #f]
-          [h2 (chaperone-hash h1
-                              (lambda (h k) 
-                                (set! get-k k)
-                                (values k
-                                        (lambda (h k v)
-                                          (set! get-v v)
-                                          v)))
-                              (lambda (h k v) 
-                                (set! set-k k)
-                                (set! set-v v)
-                                (values k v))
-                              (lambda (h k) 
-                                (set! remove-k k)
-                                k) 
-                              (lambda (h k) 
-                                (set! access-k k)
-                                k))]
-          [test (lambda (val proc . args)
-                  ;; Avoid printing hash-table argument, which implicitly uses `ref':
-                  (let ([got (apply proc args)])
-                    (test #t (format "~s ~s ~s" proc val got) (equal? val got))))])
-     (test #f hash-ref h1 'key #f)
-     (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
-     (test 'nope hash-ref h2 'key 'nope)
-     (test '(key #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
-     (let ([h2 (hash-set h2 'key 'val)])
-       (test '(key #f key val #f #f) list get-k get-v set-k set-v remove-k access-k)
-       (test 'val hash-ref h2 'key #f)
-       (test '(key val key val #f #f) list get-k get-v set-k set-v remove-k access-k)
-       (let ([h2 (hash-set h2 'key2 'val2)])
-         (test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
-         (test 'val2 hash-ref h2 'key2 #f)
-         (test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
-         (test 'key2 hash-ref-key h2 'key2)
-         (test '(key2 val2 key2 val2 #f key2) list get-k get-v set-k set-v remove-k access-k)
-         (let ([h2 (hash-remove h2 'key3)])
-           (test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
-           (test 'val2 hash-ref h2 'key2)
-           (test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
-           (let ([h2 (hash-remove h2 'key2)])
-             (test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
-             (test #f hash-ref h2 'key2 #f)
-             (test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
-             (hash-for-each h2 void)
-             (test '(mid key val key2 val2 key2 key) list 'mid get-k get-v set-k set-v remove-k access-k)
-             (set! get-k #f)
-             (set! get-v #f)
-             (void (equal-hash-code h2))
-             (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
-             (unless secondary-hash-unused?
-               (set! get-k #f)
-               (set! get-v #f)
-               (void (equal-secondary-hash-code h2)))
-             (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
-             (set! get-k #f)
-             (set! get-v #f)
-             (test #t values (equal? h2 (hash-set h1 'key 'val)))
-             (test '(equal?2 key val key2 val2 key2 key) list 'equal?2 get-k get-v set-k set-v remove-k access-k)
-             (void))))))
-   ;; Check that `hash-set` propagates in a way that allows
-   ;; `chaperone-of?` to work recursively:
-   (let ()
-     (define proc (lambda (x) (add1 x)))
-     (define h2 (hash-set h1 1 proc))
-     (define (add-chap h2)
-       (chaperone-hash h2
-                       (λ (h k) (values k (λ (h k v) v)))
-                       (λ (h k v) (values k v))
-                       (λ _ #f)
-                       (λ (h k) k)))
-     (define h3 (add-chap h2))
-     (test #t chaperone-of? h3 h2)
-     (test #f chaperone-of? h3 (add-chap h2))
-     (define h4 (hash-set h3 1 proc))
-     (test #t chaperone-of? h4 h3)
-     (define h5 (hash-set h3 1 (chaperone-procedure proc void)))
-     (test #t chaperone-of? h5 h3)
-     (test #f chaperone-of? (hash-set h3 1 sub1) h3)
-     (test #f chaperone-of? (hash-set h3 2 sub1) h3)))
- (list #hash() #hasheq() #hasheqv() #hashalw()))
+(define (unsafe-impersonate-hash* ht ref set remove key)
+  (unsafe-impersonate-hash #f ht ref set remove key))
+
+(as-chaperone-or-impersonator
+ ([chaperone-hash unsafe-impersonate-hash*]
+  [chaperone-of? impersonator-of?])
+ (for-each
+  (lambda (h1)
+    (let* ([get-k #f]
+           [get-v #f]
+           [set-k #f]
+           [set-v #f]
+           [remove-k #f]
+           [access-k #f]
+           [h2 (chaperone-hash h1
+                               (lambda (h k)
+                                 (set! get-k k)
+                                 (values k
+                                         (lambda (h k v)
+                                           (set! get-v v)
+                                           v)))
+                               (lambda (h k v)
+                                 (set! set-k k)
+                                 (set! set-v v)
+                                 (values k v))
+                               (lambda (h k)
+                                 (set! remove-k k)
+                                 k) 
+                               (lambda (h k)
+                                 (set! access-k k)
+                                 k))]
+           [test (lambda (val proc . args)
+                   ;; Avoid printing hash-table argument, which implicitly uses `ref':
+                   (let ([got (apply proc args)])
+                     (test #t (format "~s ~s ~s" proc val got) (equal? val got))))])
+      (test #f hash-ref h1 'key #f)
+      (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
+      (test 'nope hash-ref h2 'key 'nope)
+      (test '(key #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
+      (let ([h2 (hash-set h2 'key 'val)])
+        (test '(key #f key val #f #f) list get-k get-v set-k set-v remove-k access-k)
+        (test 'val hash-ref h2 'key #f)
+        (test '(key val key val #f #f) list get-k get-v set-k set-v remove-k access-k)
+        (let ([h2 (hash-set h2 'key2 'val2)])
+          (test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
+          (test 'val2 hash-ref h2 'key2 #f)
+          (test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
+          (test 'key2 hash-ref-key h2 'key2)
+          (test '(key2 val2 key2 val2 #f key2) list get-k get-v set-k set-v remove-k access-k)
+          (let ([h2 (hash-remove h2 'key3)])
+            (test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
+            (test 'val2 hash-ref h2 'key2)
+            (test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
+            (let ([h2 (hash-remove h2 'key2)])
+              (test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
+              (test #f hash-ref h2 'key2 #f)
+              (test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
+              (hash-for-each h2 void)
+              (test '(mid key val key2 val2 key2 key) list 'mid get-k get-v set-k set-v remove-k access-k)
+              (set! get-k #f)
+              (set! get-v #f)
+              (void (equal-hash-code h2))
+              (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
+              (unless secondary-hash-unused?
+                (set! get-k #f)
+                (set! get-v #f)
+                (void (equal-secondary-hash-code h2)))
+              (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
+              (set! get-k #f)
+              (set! get-v #f)
+              (test #t values (equal? h2 (hash-set h1 'key 'val)))
+              (test '(equal?2 key val key2 val2 key2 key) list 'equal?2 get-k get-v set-k set-v remove-k access-k)
+              (void))))))
+    ;; Check that `hash-set` propagates in a way that allows
+    ;; `chaperone-of?` to work recursively:
+    (let ()
+      (define proc (lambda (x) (add1 x)))
+      (define h2 (hash-set h1 1 proc))
+      (define (add-chap h2)
+        (chaperone-hash h2
+                        (λ (h k) (values k (λ (h k v) v)))
+                        (λ (h k v) (values k v))
+                        (λ _ #f)
+                        (λ (h k) k)))
+      (define h3 (add-chap h2))
+      (test #t chaperone-of? h3 h2)
+      (test #f chaperone-of? h3 (add-chap h2))
+      (define h4 (hash-set h3 1 proc))
+      (test #t chaperone-of? h4 h3)
+      (define h5 (hash-set h3 1 (chaperone-procedure proc void)))
+      (test #t chaperone-of? h5 h3)
+      (test #f chaperone-of? (hash-set h3 1 sub1) h3)
+      (test #f chaperone-of? (hash-set h3 2 sub1) h3)))
+  (list #hash() #hasheq() #hasheqv() #hashalw())))
 
 ;; Make sure that multiple chaperone/impersonator layers
 ;; are allowed by `chaperone-of?` and `impersonator-of?`

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

@@ -3,7 +3,8 @@
 
 (Section 'hash)
 
-(require racket/hash)
+(require racket/hash
+         (only-in '#%unsafe unsafe-impersonate-hash))
 
 ;; ----------------------------------------
 ;; Hash-key sorting:
@@ -326,6 +327,14 @@
               (lambda (h k v) values k v) ; set-proc
               (lambda (h k) k) ; remove-proc
               (lambda (h k) k))) ; key-proc
+          (define fake-ht/immut-unsafe
+            (unsafe-impersonate-hash
+                #f
+                ht/immut
+              (lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
+              (lambda (h k v) values k v) ; set-proc
+              (lambda (h k) k) ; remove-proc
+              (lambda (h k) k))) ; key-proc
           (define fake-ht/mut
             (impersonate-hash
                 ht/mut
@@ -371,6 +380,7 @@
            (for/sum ([(k v) (-in-weak-hash ht/weak)]) (+ k v))
            (for/sum ([(k v) (-in-ephemeron-hash ht/ephemeron)]) (+ k v))
            (for/sum ([(k v) (-in-immut-hash fake-ht/immut)]) (+ k v))
+           (for/sum ([(k v) (-in-immut-hash fake-ht/immut-unsafe)]) (+ k v))
            (for/sum ([(k v) (-in-mut-hash fake-ht/mut)]) (+ k v))
            (for/sum ([(k v) (-in-weak-hash fake-ht/weak)]) (+ k v))
            (for/sum ([(k v) (-in-ephemeron-hash fake-ht/ephemeron)]) (+ k v))
@@ -388,6 +398,8 @@
              (+ (car k+v) (cdr k+v)))
            (for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut)])
              (+ (car k+v) (cdr k+v)))
+           (for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut-unsafe)])
+             (+ (car k+v) (cdr k+v)))
            (for/sum ([k+v (-in-mut-hash-pairs fake-ht/mut)])
              (+ (car k+v) (cdr k+v)))
            (for/sum ([k+v (-in-weak-hash-pairs fake-ht/weak)])
@@ -408,6 +420,8 @@
               (for/sum ([v (-in-ephemeron-hash-values ht/ephemeron)]) v))
            (+ (for/sum ([k (-in-immut-hash-keys fake-ht/immut)]) k)
               (for/sum ([v (-in-immut-hash-values fake-ht/immut)]) v))
+           (+ (for/sum ([k (-in-immut-hash-keys fake-ht/immut-unsafe)]) k)
+              (for/sum ([v (-in-immut-hash-values fake-ht/immut-unsafe)]) v))
            (+ (for/sum ([k (-in-mut-hash-keys fake-ht/mut)]) k)
               (for/sum ([v (-in-mut-hash-values fake-ht/mut)]) v))
            (+ (for/sum ([k (-in-weak-hash-keys fake-ht/weak)]) k)
@@ -429,6 +443,7 @@
            (for/sum ([(k v) (-in-weak-hash ht/weak)]) k)
            (for/sum ([(k v) (-in-ephemeron-hash ht/ephemeron)]) k)
            (for/sum ([(k v) (-in-immut-hash fake-ht/immut)]) k)
+           (for/sum ([(k v) (-in-immut-hash fake-ht/immut-unsafe)]) k)
            (for/sum ([(k v) (-in-mut-hash fake-ht/mut)]) k)
            (for/sum ([(k v) (-in-weak-hash fake-ht/weak)]) k)
            (for/sum ([(k v) (-in-ephemeron-hash fake-ht/ephemeron)]) k)
@@ -441,6 +456,7 @@
            (for/sum ([k+v (-in-weak-hash-pairs ht/weak)]) (car k+v))
            (for/sum ([k+v (-in-ephemeron-hash-pairs ht/ephemeron)]) (car k+v))
            (for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut)]) (car k+v))
+           (for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut-unsafe)]) (car k+v))
            (for/sum ([k+v (-in-mut-hash-pairs fake-ht/mut)]) (car k+v))
            (for/sum ([k+v (-in-weak-hash-pairs fake-ht/weak)]) (car k+v))
            (for/sum ([k+v (-in-ephemeron-hash-pairs fake-ht/ephemeron)]) (car k+v))
@@ -453,6 +469,7 @@
            (for/sum ([k (-in-weak-hash-keys ht/weak)]) k)
            (for/sum ([k (-in-ephemeron-hash-keys ht/ephemeron)]) k)
            (for/sum ([k (-in-immut-hash-keys fake-ht/immut)]) k)
+           (for/sum ([k (-in-immut-hash-keys fake-ht/immut-unsafe)]) k)
            (for/sum ([k (-in-mut-hash-keys fake-ht/mut)]) k)
            (for/sum ([k (-in-weak-hash-keys fake-ht/weak)]) k)
            (for/sum ([k (-in-ephemeron-hash-keys fake-ht/ephemeron)]) k)
@@ -467,6 +484,7 @@
            (for/sum ([(k v) (-in-weak-hash ht/weak)]) v)
            (for/sum ([(k v) (-in-ephemeron-hash ht/ephemeron)]) v)
            (for/sum ([(k v) (-in-immut-hash fake-ht/immut)]) v)
+           (for/sum ([(k v) (-in-immut-hash fake-ht/immut-unsafe)]) v)
            (for/sum ([(k v) (-in-mut-hash fake-ht/mut)]) v)
            (for/sum ([(k v) (-in-weak-hash fake-ht/weak)]) v)
            (for/sum ([(k v) (-in-ephemeron-hash fake-ht/ephemeron)]) v)
@@ -479,6 +497,7 @@
            (for/sum ([k+v (-in-weak-hash-pairs ht/weak)]) (cdr k+v))
            (for/sum ([k+v (-in-ephemeron-hash-pairs ht/ephemeron)]) (cdr k+v))
            (for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut)]) (cdr k+v))
+           (for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut-unsafe)]) (cdr k+v))
            (for/sum ([k+v (-in-mut-hash-pairs fake-ht/mut)]) (cdr k+v))
            (for/sum ([k+v (-in-weak-hash-pairs fake-ht/weak)]) (cdr k+v))
            (for/sum ([k+v (-in-ephemeron-hash-pairs fake-ht/ephemeron)]) (cdr k+v))
@@ -491,6 +510,7 @@
            (for/sum ([v (-in-weak-hash-values ht/weak)]) v)
            (for/sum ([v (-in-ephemeron-hash-values ht/ephemeron)]) v)
            (for/sum ([v (-in-immut-hash-values fake-ht/immut)]) v)
+           (for/sum ([v (-in-immut-hash-values fake-ht/immut-unsafe)]) v)
            (for/sum ([v (-in-mut-hash-values fake-ht/mut)]) v)
            (for/sum ([v (-in-weak-hash-values fake-ht/weak)]) v)
            (for/sum ([v (-in-ephemeron-hash-values fake-ht/ephemeron)]) v)

racket/collects/racket/unsafe/ops.rkt

@@ -12,6 +12,7 @@
                      chaperone-struct-unsafe-undefined
                      unsafe-chaperone-procedure
                      unsafe-impersonate-procedure
+                     unsafe-impersonate-hash
                      unsafe-start-atomic unsafe-end-atomic
                      unsafe-start-breakable-atomic unsafe-end-breakable-atomic
                      unsafe-in-atomic?

racket/src/bc/src/hash.c

@@ -230,6 +230,24 @@ static int equal_always_w_key_wraps(Scheme_Object *ekey, Scheme_Object *tkey, Sc
   return scheme_equal_always(ekey, tkey);
 }
 
+XFORM_NONGCING static int same_kind_via_impersonator(Scheme_Object *orig_t1,
+                                                     Scheme_Object *orig_t2)
+{
+  Scheme_Object *v, *v2;
+
+  if (SCHEME_NP_CHAPERONEP(orig_t1))
+    v = scheme_chaperone_props_get(((Scheme_Chaperone *)orig_t1)->props, scheme_hash_kind_key);
+  else
+    v = NULL;
+
+  if (SCHEME_NP_CHAPERONEP(orig_t2))
+    v2 = scheme_chaperone_props_get(((Scheme_Chaperone *)orig_t2)->props, scheme_hash_kind_key);
+  else
+    v2 = NULL;
+
+  return SAME_OBJ(v, v2);
+}
+
 /*========================================================================*/
 /*                      normal mutable hash table                         */
 /*========================================================================*/
@@ -634,6 +652,9 @@ int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Object *orig_t1,
       || (t1->make_hash_indices != t2->make_hash_indices)
       || (t1->compare != t2->compare))
     return 0;
+
+  if (!same_kind_via_impersonator(orig_t1, orig_t2))
+    return 0;
 
   keys = t1->keys;
   vals = t1->vals;
@@ -1119,6 +1140,9 @@ int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Object *orig_t
       || (t1->make_hash_indices != t2->make_hash_indices)
       || (t1->compare != t2->compare))
     return 0;
+
+  if (!same_kind_via_impersonator(orig_t1, orig_t2))
+    return 0;
 
   buckets = t1->buckets;
   weak = t1->weak;
@@ -4009,7 +4033,10 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1,
   if (SAME_OBJ((Scheme_Object *)t1, orig_t1)
       && SAME_OBJ((Scheme_Object *)t2, orig_t2))
     return hamt_subset_of(t1, t2, 0, SCHEME_TYPE(t1), eql);
-
+
+  if (!same_kind_via_impersonator(orig_t1, orig_t2))
+    return 0;
+
   for (i = scheme_hash_tree_next(t1, -1); i != -1; i = scheme_hash_tree_next(t1, i)) {
     scheme_hash_tree_index(t1, i, &k, &v);