suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add hash-keys-subset?

Browse Source 
This function exposes the fast subset operation that is built in for
immutable hash tables (and used by the set-of-scopes implementation).

Also, make the space optimization implicit for `eq?`-based hash tables
that contain only #t values (instead of explicit and only available
internally). It turns out to be easy and efficient to make the
representation automatic, because the HAMT implementation can support
a mixture of nodes with some containing explicit values and some
containing implicit #t values.
This commit is contained in:
Matthew Flatt 2016-06-30 05:40:51 -06:00
parent 8ae013cdb1
commit 3fbb384604
18 changed files with 1140 additions and 972 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.5.0.7") (define version "6.5.0.8")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

13
pkgs/racket-doc/scribblings/reference/hashes.scrbl
View File

@ -414,6 +414,19 @@ Returns a list of the key--value pairs of @racket[hash] in an unspecified order.
See @racket[hash-map] for information about modifying @racket[hash] See @racket[hash-map] for information about modifying @racket[hash]
during @racket[hash->list]. @see-also-concurrency-caveat[]} during @racket[hash->list]. @see-also-concurrency-caveat[]}
@defproc[(hash-keys-subset? [hash1 hash?] [hash2 hash?])
boolean?]{
Returns @racket[#t] if the keys of @racket[hash1] are a subset of or
the same as the keys of @racket[hash2]. The hash tables must both use
the same key-comparison function (@racket[equal?], @racket[eqv?], or
@racket[eq?]), otherwise the @exnraise[exn:fail:contract].
Using @racket[hash-keys-subset?] on immutable hash tables can be much
faster than iterating through the keys of @racket[hash1] to make sure
that each is in @racket[hash2].
@history[#:added "6.5.0.8"]}
@defproc[(hash-for-each [hash hash?] @defproc[(hash-for-each [hash hash?]
[proc (any/c any/c . -> . any)] [proc (any/c any/c . -> . any)]
[try-order? any/c #f]) [try-order? any/c #f])

53
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -2126,7 +2126,8 @@
hash-iterate-value hash-iterate-key hash-iterate-value hash-iterate-key
hash-copy hash-copy
hash-clear! hash-clear hash-clear! hash-clear
hash-empty?) hash-empty?
hash-keys-subset?)
(define-struct ax (b c)) ; opaque (define-struct ax (b c)) ; opaque
(define-struct a (b c) #:inspector (make-inspector)) (define-struct a (b c) #:inspector (make-inspector))
@ -2271,6 +2272,7 @@
(define (check-tables-equal mode t1 t2 weak?) (define (check-tables-equal mode t1 t2 weak?)
(test #t equal? t1 t2) (test #t equal? t1 t2)
(test #t hash-keys-subset? t1 t2)
(test (equal-hash-code t1) equal-hash-code t2) (test (equal-hash-code t1) equal-hash-code t2)
(test #t equal? t1 (hash-copy t1)) (test #t equal? t1 (hash-copy t1))
(let ([again (if weak? (make-weak-hash) (make-hash))]) (let ([again (if weak? (make-weak-hash) (make-hash))])
@ -2338,7 +2340,8 @@
hash-iterate-value hash-iterate-key hash-iterate-value hash-iterate-key
hash-copy hash-copy
hash-clear! hash-clear hash-clear! hash-clear
hash-empty?) hash-empty?
hash-keys-subset?)
(let ([ub-wrap (lambda (proc) (let ([ub-wrap (lambda (proc)
(lambda (ht . args) (lambda (ht . args)
(apply proc (unbox ht) args)))]) (apply proc (unbox ht) args)))])
@ -2364,7 +2367,9 @@
(lambda (ht) (box (unbox ht))) (lambda (ht) (box (unbox ht)))
(lambda (ht) (set-box! ht (hash-clear (unbox ht)))) (lambda (ht) (set-box! ht (hash-clear (unbox ht))))
#f #f
(ub-wrap hash-empty?))) (ub-wrap hash-empty?)
(lambda (ht1 ht2)
(hash-keys-subset? (unbox ht1) (unbox ht2)))))
(test #f hash? 5) (test #f hash? 5)
(test #t hash? (make-hasheq)) (test #t hash? (make-hasheq))
@ -2465,6 +2470,48 @@
(test #f equal? (mk make-immutable-hash) (mk make-immutable-hasheqv)) (test #f equal? (mk make-immutable-hash) (mk make-immutable-hasheqv))
(test #f equal? (mk make-immutable-hasheq) (mk make-immutable-hasheqv))) (test #f equal? (mk make-immutable-hasheq) (mk make-immutable-hasheqv)))
(let ([check-subset (lambda (mk1 mk2 [v2 2] #:k1 [k1 'a] #:k2 [k2 'a])
(define h1 (mk1 k1 #t 'b v2))
(define h2 (mk2 k2 #t))
(test #t hash-keys-subset? h2 h1)
(test #f hash-keys-subset? h1 h2)
(define h3 (mk2 k2 'something-else))
(test #t hash-keys-subset? h3 h1)
(test #t hash-keys-subset? h3 h2))]
[make-make-hash (lambda (mk)
(lambda args
(define ht (mk))
(let loop ([args args])
(cond
[(null? args) (void)]
[else
(hash-set! ht (car args) (cadr args))
(loop (cddr args))]))
ht))])
(check-subset hasheq hasheq #t)
(check-subset hasheq hasheq)
(check-subset hasheqv hasheqv)
(check-subset hasheqv hasheqv #:k1 (expt 2 70) #:k2 (expt 2 70))
(check-subset hash hash)
(check-subset hash hash #:k1 (cons 1 2) #:k2 (cons 1 2))
(check-subset hasheq (make-make-hash make-hasheq))
(check-subset hasheq (make-make-hash make-weak-hasheq))
(check-subset hasheqv (make-make-hash make-hasheqv))
(check-subset hasheqv (make-make-hash make-weak-hasheqv))
(check-subset hash (make-make-hash make-hash))
(check-subset hash (make-make-hash make-weak-hash))
(check-subset (make-make-hash make-hash) (make-make-hash make-weak-hash))
(check-subset hash (make-make-hash make-hash) #:k1 (expt 2 70) #:k2 (expt 2 70)))
(let ([not-same-comparison? (lambda (x)
(regexp-match? #rx"do not use the same key comparison" (exn-message x)))])
(err/rt-test (hash-keys-subset? #hash() #hasheq()) not-same-comparison?)
(err/rt-test (hash-keys-subset? #hash() #hasheqv()) not-same-comparison?)
(err/rt-test (hash-keys-subset? #hasheq() #hasheqv()) not-same-comparison?)
(err/rt-test (hash-keys-subset? (make-hasheq #hasheqv()) not-same-comparison?))
(err/rt-test (hash-keys-subset? (make-weak-hasheq #hasheqv()) not-same-comparison?)))
(define im-t (make-immutable-hasheq null)) (define im-t (make-immutable-hasheq null))
(test #t hash? im-t) (test #t hash? im-t)
(test #t hash-eq? im-t) (test #t hash-eq? im-t)

1
racket/src/racket/include/mzwin.def
View File

@ -258,7 +258,6 @@ EXPORTS
scheme_hash_table_index scheme_hash_table_index
scheme_hash_table_next scheme_hash_table_next
scheme_make_hash_tree scheme_make_hash_tree
scheme_make_hash_tree_set
scheme_hash_tree_set scheme_hash_tree_set
scheme_hash_tree_get scheme_hash_tree_get
scheme_eq_hash_tree_get scheme_eq_hash_tree_get

1
racket/src/racket/include/mzwin3m.def
View File

@ -272,7 +272,6 @@ EXPORTS
scheme_hash_table_index scheme_hash_table_index
scheme_hash_table_next scheme_hash_table_next
scheme_make_hash_tree scheme_make_hash_tree
scheme_make_hash_tree_set
scheme_hash_tree_set scheme_hash_tree_set
scheme_hash_tree_get scheme_hash_tree_get
scheme_eq_hash_tree_get scheme_eq_hash_tree_get

1
racket/src/racket/include/racket.exp
View File

@ -274,7 +274,6 @@ scheme_clear_hash_table
scheme_hash_table_index scheme_hash_table_index
scheme_hash_table_next scheme_hash_table_next
scheme_make_hash_tree scheme_make_hash_tree
scheme_make_hash_tree_set
scheme_hash_tree_set scheme_hash_tree_set
scheme_hash_tree_get scheme_hash_tree_get
scheme_eq_hash_tree_get scheme_eq_hash_tree_get

1
racket/src/racket/include/racket3m.exp
View File

@ -279,7 +279,6 @@ scheme_clear_hash_table
scheme_hash_table_index scheme_hash_table_index
scheme_hash_table_next scheme_hash_table_next
scheme_make_hash_tree scheme_make_hash_tree
scheme_make_hash_tree_set
scheme_hash_tree_set scheme_hash_tree_set
scheme_hash_tree_get scheme_hash_tree_get
scheme_eq_hash_tree_get scheme_eq_hash_tree_get

1848
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

88
racket/src/racket/src/hash.c
View File

@ -2412,6 +2412,10 @@ intptr_t scheme_eqv_hash_key2(Scheme_Object *o)
#define HASHTR_HAS_VAL 0x1 #define HASHTR_HAS_VAL 0x1
#define HASHTR_HAS_CODE 0x2 #define HASHTR_HAS_CODE 0x2
/* In a hash tree without HASHTR_HAS_VAL, all values are `#t`; we nodes without
HASHTR_HAS_VAL to nodes with it on demand, but we don't go the other way */
#define NOT_IMPLICIT_VALUE(v) (!SAME_OBJ(v, scheme_true))
#define HASHTR_SUBTREEP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_hash_tree_subtree_type) #define HASHTR_SUBTREEP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_hash_tree_subtree_type)
#define HASHTR_COLLISIONP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_hash_tree_collision_type) #define HASHTR_COLLISIONP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_hash_tree_collision_type)
@ -2475,7 +2479,7 @@ XFORM_NONGCING static hash_tree_bitmap_t hamt_bit(int index)
XFORM_NONGCING Scheme_Object *_mzHAMT_VAL(Scheme_Hash_Tree *ht, int pos, int popcount) XFORM_NONGCING Scheme_Object *_mzHAMT_VAL(Scheme_Hash_Tree *ht, int pos, int popcount)
{ {
return ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) ? (ht)->els[(popcount)+(pos)] : (ht)->els[pos]); return ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) ? (ht)->els[(popcount)+(pos)] : scheme_true);
} }
XFORM_NONGCING uintptr_t mzHAMT_KEY_CODE(Scheme_Object *o) XFORM_NONGCING uintptr_t mzHAMT_KEY_CODE(Scheme_Object *o)
@ -2513,6 +2517,11 @@ XFORM_NONGCING static void hamt_content_copy(Scheme_Hash_Tree *dest, Scheme_Hash
if (SCHEME_HASHTR_FLAGS(src) & HASHTR_HAS_CODE) { if (SCHEME_HASHTR_FLAGS(src) & HASHTR_HAS_CODE) {
memcpy(dest->els+2*dest_popcount+dest_start, src->els+2*src_popcount+src_start, len*sizeof(Scheme_Object*)); memcpy(dest->els+2*dest_popcount+dest_start, src->els+2*src_popcount+src_start, len*sizeof(Scheme_Object*));
} }
} else if (SCHEME_HASHTR_FLAGS(dest) & HASHTR_HAS_VAL) {
/* make source's implicit `#t` values explicit in dest */
while (len--) {
_mzHAMT_SET_VAL(dest, dest_start+len, scheme_true, dest_popcount);
}
} }
} }
@ -2547,15 +2556,24 @@ static Scheme_Hash_Tree *hamt_alloc(int kind, int popcount)
return (Scheme_Hash_Tree *)scheme_malloc_small_tagged(HASH_TREE_RECORD_SIZE(kind, popcount)); return (Scheme_Hash_Tree *)scheme_malloc_small_tagged(HASH_TREE_RECORD_SIZE(kind, popcount));
} }
static Scheme_Hash_Tree *hamt_dup(Scheme_Hash_Tree *ht, int popcount) static Scheme_Hash_Tree *hamt_dup(Scheme_Hash_Tree *ht, int popcount, int need_value)
{ {
Scheme_Hash_Tree *new_ht; Scheme_Hash_Tree *new_ht;
int kind; int kind;
kind = SCHEME_HASHTR_KIND(ht); kind = SCHEME_HASHTR_KIND(ht);
new_ht = hamt_alloc(kind, popcount); new_ht = hamt_alloc(kind | (need_value ? HASHTR_HAS_VAL : 0), popcount);
memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(kind, popcount)); memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(kind, popcount));
if (!(kind & HASHTR_HAS_VAL) && need_value) {
/* make original's implicit `#t` values explicit in the copy */
int i;
SCHEME_HASHTR_FLAGS(new_ht) |= HASHTR_HAS_VAL;
for (i = popcount; i--; ) {
_mzHAMT_SET_VAL(new_ht, i, scheme_true, popcount);
}
}
return new_ht; return new_ht;
} }
@ -2595,6 +2613,7 @@ static Scheme_Hash_Tree *hamt_make2(int kind, int shift,
code2, key2, val2); code2, key2, val2);
return hamt_make1(new_ht, index1); return hamt_make1(new_ht, index1);
} else { } else {
kind = kind | ((NOT_IMPLICIT_VALUE(val1) || NOT_IMPLICIT_VALUE(val2)) ? HASHTR_HAS_VAL : 0);
new_ht = hamt_alloc(kind, 2); new_ht = hamt_alloc(kind, 2);
new_ht->iso.so.type = scheme_hash_tree_subtree_type; new_ht->iso.so.type = scheme_hash_tree_subtree_type;
SCHEME_HASHTR_FLAGS(new_ht) = kind; SCHEME_HASHTR_FLAGS(new_ht) = kind;
@ -2639,7 +2658,7 @@ static Scheme_Hash_Tree *hamt_set(Scheme_Hash_Tree *ht, uintptr_t code, int shif
if (ht->bitmap & hamt_bit(index)) { if (ht->bitmap & hamt_bit(index)) {
/* Replacing: */ /* Replacing: */
new_ht = hamt_dup(ht, popcount); new_ht = hamt_dup(ht, popcount, NOT_IMPLICIT_VALUE(val));
if (HASHTR_SUBTREEP(ht->els[pos])) { if (HASHTR_SUBTREEP(ht->els[pos])) {
ht = (Scheme_Hash_Tree *)ht->els[pos]; ht = (Scheme_Hash_Tree *)ht->els[pos];
ht = hamt_set(ht, code, shift + mzHAMT_LOG_WORD_SIZE, key, val, inc); ht = hamt_set(ht, code, shift + mzHAMT_LOG_WORD_SIZE, key, val, inc);
@ -2648,7 +2667,7 @@ static Scheme_Hash_Tree *hamt_set(Scheme_Hash_Tree *ht, uintptr_t code, int shif
} else { } else {
if (code == _mzHAMT_CODE(new_ht, pos, popcount)) { if (code == _mzHAMT_CODE(new_ht, pos, popcount)) {
new_ht->els[pos] = key; new_ht->els[pos] = key;
if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) if (SCHEME_HASHTR_FLAGS(new_ht) & HASHTR_HAS_VAL)
_mzHAMT_SET_VAL(new_ht, pos, val, popcount); _mzHAMT_SET_VAL(new_ht, pos, val, popcount);
new_ht->count += inc; new_ht->count += inc;
} else { } else {
@ -2657,23 +2676,25 @@ static Scheme_Hash_Tree *hamt_set(Scheme_Hash_Tree *ht, uintptr_t code, int shif
_mzHAMT_CODE(new_ht, pos, popcount), new_ht->els[pos], _mzHAMT_VAL(new_ht, pos, popcount), _mzHAMT_CODE(new_ht, pos, popcount), new_ht->els[pos], _mzHAMT_VAL(new_ht, pos, popcount),
code, key, val); code, key, val);
new_ht->els[pos] = (Scheme_Object *)ht; new_ht->els[pos] = (Scheme_Object *)ht;
if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) if (SCHEME_HASHTR_FLAGS(new_ht) & HASHTR_HAS_VAL)
_mzHAMT_SET_VAL(new_ht, pos, NULL, popcount); _mzHAMT_SET_VAL(new_ht, pos, NULL, popcount);
new_ht->count += inc; new_ht->count += inc;
} }
} }
} else { } else {
new_ht = hamt_alloc(SCHEME_HASHTR_KIND(ht), popcount+1); int kind = SCHEME_HASHTR_KIND(ht) | (NOT_IMPLICIT_VALUE(val) ? HASHTR_HAS_VAL : 0);
memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(new_ht), 0)); new_ht = hamt_alloc(kind, popcount+1);
memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(ht), 0));
SCHEME_HASHTR_FLAGS(new_ht) |= kind;
hamt_content_copy(new_ht, ht, popcount+1, popcount, 0, 0, pos); hamt_content_copy(new_ht, ht, popcount+1, popcount, 0, 0, pos);
if (pos < popcount) if (pos < popcount)
hamt_content_copy(new_ht, ht, popcount+1, popcount, pos+1, pos, popcount-pos); hamt_content_copy(new_ht, ht, popcount+1, popcount, pos+1, pos, popcount-pos);
new_ht->bitmap |= hamt_bit(index); new_ht->bitmap |= hamt_bit(index);
new_ht->count += inc; new_ht->count += inc;
new_ht->els[pos] = key; new_ht->els[pos] = key;
if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) { if (SCHEME_HASHTR_FLAGS(new_ht) & HASHTR_HAS_VAL) {
_mzHAMT_SET_VAL(new_ht, pos, val, popcount+1); _mzHAMT_SET_VAL(new_ht, pos, val, popcount+1);
if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_CODE) if (SCHEME_HASHTR_FLAGS(new_ht) & HASHTR_HAS_CODE)
_mzHAMT_SET_CODE(new_ht, pos, code, popcount+1); _mzHAMT_SET_CODE(new_ht, pos, code, popcount+1);
} }
} }
@ -2690,7 +2711,7 @@ static Scheme_Hash_Tree *hamt_contract(Scheme_Hash_Tree *ht, int popcount, int i
return NULL; return NULL;
new_ht = hamt_alloc(SCHEME_HASHTR_KIND(ht), popcount-1); new_ht = hamt_alloc(SCHEME_HASHTR_KIND(ht), popcount-1);
memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(new_ht), 0)); memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(ht), 0));
hamt_content_copy(new_ht, ht, popcount-1, popcount, 0, 0, pos); hamt_content_copy(new_ht, ht, popcount-1, popcount, 0, 0, pos);
if (pos < popcount-1) if (pos < popcount-1)
hamt_content_copy(new_ht, ht, popcount-1, popcount, pos, pos+1, popcount-pos-1); hamt_content_copy(new_ht, ht, popcount-1, popcount, pos, pos+1, popcount-pos-1);
@ -2717,13 +2738,15 @@ static Scheme_Hash_Tree *hamt_remove(Scheme_Hash_Tree *ht, uintptr_t code, int s
if (!SAME_OBJ((Scheme_Object *)sub_ht, ht->els[pos])) { if (!SAME_OBJ((Scheme_Object *)sub_ht, ht->els[pos])) {
if (!sub_ht) if (!sub_ht)
return hamt_contract(ht, popcount, index, pos); return hamt_contract(ht, popcount, index, pos);
ht = hamt_dup(ht, popcount); ht = hamt_dup(ht, popcount, 0);
ht->count -= 1; ht->count -= 1;
if (((sub_ht->count == 1) && !HASHTR_SUBTREEP(sub_ht->els[0])) if (((sub_ht->count == 1) && !HASHTR_SUBTREEP(sub_ht->els[0]))
|| (HASHTR_COLLISIONP(sub_ht->els[0]) || (HASHTR_COLLISIONP(sub_ht->els[0])
&& (sub_ht->count == ((Scheme_Hash_Tree *)sub_ht->els[0])->count))) { && (sub_ht->count == ((Scheme_Hash_Tree *)sub_ht->els[0])->count))) {
/* drop extra layer that has 1 immediate entry */ /* drop extra layer that has 1 immediate entry */
ht->els[pos] = sub_ht->els[0]; ht->els[pos] = sub_ht->els[0];
if (!(SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) && (SCHEME_HASHTR_FLAGS(sub_ht) & HASHTR_HAS_VAL))
ht = hamt_dup(ht, popcount, 1);
if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) { if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) {
_mzHAMT_SET_VAL(ht, pos, _mzHAMT_VAL(sub_ht, 0, 1), popcount); _mzHAMT_SET_VAL(ht, pos, _mzHAMT_VAL(sub_ht, 0, 1), popcount);
if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_CODE) if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_CODE)
@ -2867,11 +2890,7 @@ XFORM_NONGCING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_O
XFORM_NONGCING Scheme_Object *scheme_unsafe_hash_tree_access(Scheme_Hash_Tree *subtree, int i) XFORM_NONGCING Scheme_Object *scheme_unsafe_hash_tree_access(Scheme_Hash_Tree *subtree, int i)
{ {
int popcount; return _mzHAMT_VAL(subtree, i, hamt_popcount(subtree->bitmap));
popcount = hamt_popcount(subtree->bitmap);
return subtree->els[i+popcount];
} }
/* args is a (cons subtree (cons subtree-index stack-of-parents)) /* args is a (cons subtree (cons subtree-index stack-of-parents))
@ -3092,10 +3111,10 @@ XFORM_NONGCING static uintptr_t hamt_find_free_code(Scheme_Hash_Tree *tree, int
shift + mzHAMT_LOG_WORD_SIZE); shift + mzHAMT_LOG_WORD_SIZE);
} }
static Scheme_Hash_Tree *make_hash_tree(int eql_kind, int val_kind, int popcount) static Scheme_Hash_Tree *make_hash_tree(int eql_kind, int popcount)
{ {
Scheme_Hash_Tree *ht; Scheme_Hash_Tree *ht;
int kind = val_kind | (eql_kind ? (HASHTR_HAS_CODE | HASHTR_HAS_VAL) : 0); int kind = (eql_kind ? (HASHTR_HAS_CODE | HASHTR_HAS_VAL) : 0);
ht = hamt_alloc(kind, popcount); ht = hamt_alloc(kind, popcount);
@ -3111,12 +3130,7 @@ static Scheme_Hash_Tree *make_hash_tree(int eql_kind, int val_kind, int popcount
Scheme_Hash_Tree *scheme_make_hash_tree(int eql_kind) Scheme_Hash_Tree *scheme_make_hash_tree(int eql_kind)
{ {
return make_hash_tree(eql_kind, HASHTR_HAS_VAL, 0); return make_hash_tree(eql_kind, 0);
}
Scheme_Hash_Tree *scheme_make_hash_tree_set(int eql_kind)
{
return make_hash_tree(eql_kind, 0, 0);
} }
Scheme_Hash_Tree *scheme_make_hash_tree_of_type(Scheme_Type stype) Scheme_Hash_Tree *scheme_make_hash_tree_of_type(Scheme_Type stype)
@ -3136,12 +3150,12 @@ Scheme_Hash_Tree *scheme_make_hash_tree_placeholder(int eql_kind)
{ {
Scheme_Hash_Tree *ht, *sub; Scheme_Hash_Tree *ht, *sub;
ht = make_hash_tree(eql_kind, 0, 1); ht = make_hash_tree(eql_kind, 1);
ht->iso.so.type = scheme_hash_tree_indirection_type; ht->iso.so.type = scheme_hash_tree_indirection_type;
ht->count = 0; ht->count = 0;
ht->bitmap = 1; ht->bitmap = 1;
sub = make_hash_tree(eql_kind, HASHTR_HAS_VAL, 0); sub = make_hash_tree(eql_kind, 0);
ht->els[0] = (Scheme_Object *)sub; ht->els[0] = (Scheme_Object *)sub;
return ht; return ht;
@ -3354,11 +3368,18 @@ static int hamt_equal_entries(int stype, void *eql_data,
return SAME_OBJ(v1, v2); return SAME_OBJ(v1, v2);
} }
} else if (stype == scheme_hash_tree_type) { } else if (stype == scheme_hash_tree_type) {
if (eql_data) {
if (scheme_recur_equal(k1, k2, eql_data)) if (scheme_recur_equal(k1, k2, eql_data))
return scheme_recur_equal(v1, v2, eql_data); return scheme_recur_equal(v1, v2, eql_data);
} else
return scheme_equal(k1, k2);
} else { } else {
if (scheme_eqv(k1, k2)) if (scheme_eqv(k1, k2)) {
if (eql_data)
return scheme_recur_equal(v1, v2, eql_data); return scheme_recur_equal(v1, v2, eql_data);
else
return 1;
}
} }
return 0; return 0;
} }
@ -3472,6 +3493,17 @@ int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2)
return hamt_eq_subset_of(t1, t2, 0, scheme_eq_hash_tree_type, NULL); return hamt_eq_subset_of(t1, t2, 0, scheme_eq_hash_tree_type, NULL);
} }
int scheme_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2)
{
t1 = resolve_placeholder(t1);
t2 = resolve_placeholder(t2);
if (t1->count > t2->count)
return 0;
return hamt_subset_of(t1, t2, 0, SCHEME_TYPE(t1), NULL);
}
int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2) int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2)
/* assumes that `t1` and `t2` are sets, as opposed to maps */ /* assumes that `t1` and `t2` are sets, as opposed to maps */
{ {

83
racket/src/racket/src/list.c
View File

@ -139,6 +139,7 @@ Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_keys_subset_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]); static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]); static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]); static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]);
@ -685,6 +686,12 @@ scheme_init_list (Scheme_Env *env)
2, 2, 2, 2), 2, 2, 2, 2),
env); env);
scheme_add_global_constant("hash-keys-subset?",
scheme_make_immed_prim(hash_keys_subset_p,
"hash-keys-subset?",
2, 2),
env);
scheme_add_global_constant("chaperone-hash", scheme_add_global_constant("chaperone-hash",
scheme_make_prim_w_arity(chaperone_hash, scheme_make_prim_w_arity(chaperone_hash,
"chaperone-hash", "chaperone-hash",
@ -3087,6 +3094,82 @@ Scheme_Object *scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv
return NULL; return NULL;
} }
static Scheme_Object *hash_keys_subset_p_slow(int argc, Scheme_Object *argv[])
{
Scheme_Object *b[2], *i1, *c2;
int kind1, kind2;
if (SCHEME_HASHTRP(argv[0]) && SCHEME_HASHTRP(argv[1])) {
if (SAME_TYPE(SCHEME_HASHTR_TYPE(argv[0]), SCHEME_HASHTR_TYPE(argv[1])))
return (scheme_hash_tree_subset_of((Scheme_Hash_Tree *)argv[0], (Scheme_Hash_Tree *)argv[1])
? scheme_true
: scheme_false);
}
b[0] = argv[1];
if (!SCHEME_TRUEP(hash_p(1, argv)))
scheme_wrong_type("hash-keys-subset?", "hash?", 0 , argc, argv);
if (!SCHEME_TRUEP(hash_p(1, b)))
scheme_wrong_type("hash-keys-subset?", "hash?", 1, argc, argv);
if (SCHEME_TRUEP(scheme_hash_eq_p(1, argv)))
kind1 = 0;
else if (SCHEME_TRUEP(scheme_hash_equal_p(1, argv)))
kind1 = 1;
else
kind1 = 2;
if (SCHEME_TRUEP(scheme_hash_eq_p(1, b)))
kind2 = 0;
else if (SCHEME_TRUEP(scheme_hash_equal_p(1, b)))
kind2 = 1;
else
kind2 = 2;
if (kind1 != kind2) {
scheme_contract_error("hash-keys-subset?",
"given hash tables do not use the same key comparison",
"first table", 1, argv[0],
"second table", 1, argv[1],
NULL);
return NULL;
}
i1 = hash_table_count(1, argv);
c2 = hash_table_count(1, b);
if (SCHEME_INT_VAL(i1) > SCHEME_INT_VAL(c2))
return scheme_false;
i1 = scheme_hash_table_iterate_start(1, argv);
b[0] = argv[0];
while (!SCHEME_FALSEP(i1)) {
b[1] = i1;
c2 = scheme_hash_table_iterate_key(2, b);
if (!scheme_chaperone_hash_get(argv[1], c2))
return scheme_false;
i1 = scheme_hash_table_iterate_next(2, b);
}
return scheme_true;
}
static Scheme_Object *hash_keys_subset_p(int argc, Scheme_Object *argv[]) XFORM_ASSERT_NO_CONVERSION
{
if (SCHEME_HASHTRP(argv[0])
&& SCHEME_HASHTRP(argv[1])
&& SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0]))
&& SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[1]))) {
if (scheme_eq_hash_tree_subset_of((Scheme_Hash_Tree *)argv[0], (Scheme_Hash_Tree *)argv[1]))
return scheme_true;
else
return scheme_false;
} else
return hash_keys_subset_p_slow(argc, argv);
}
static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;

1
racket/src/racket/src/schemef.h
View File

@ -518,7 +518,6 @@ XFORM_NONGCING_NONALIASING MZ_EXTERN int scheme_hash_table_index(Scheme_Hash_Tab
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_hash_table_next(Scheme_Hash_Table *hash, mzlonglong start); XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_hash_table_next(Scheme_Hash_Table *hash, mzlonglong start);
MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree(int kind); MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree(int kind);
MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree_set(int kind);
MZ_EXTERN Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val); MZ_EXTERN Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key); MZ_EXTERN Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key); XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);

1
racket/src/racket/src/schemex.h
View File

@ -409,7 +409,6 @@ void (*scheme_clear_hash_table)(Scheme_Hash_Table *ht);
int (*scheme_hash_table_index)(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val); int (*scheme_hash_table_index)(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
Scheme_Object *(*scheme_hash_table_next)(Scheme_Hash_Table *hash, mzlonglong start); Scheme_Object *(*scheme_hash_table_next)(Scheme_Hash_Table *hash, mzlonglong start);
Scheme_Hash_Tree *(*scheme_make_hash_tree)(int kind); Scheme_Hash_Tree *(*scheme_make_hash_tree)(int kind);
Scheme_Hash_Tree *(*scheme_make_hash_tree_set)(int kind);
Scheme_Hash_Tree *(*scheme_hash_tree_set)(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val); 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); Scheme_Object *(*scheme_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key);
Scheme_Object *(*scheme_eq_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key); Scheme_Object *(*scheme_eq_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key);

1
racket/src/racket/src/schemex.inc
View File

@ -305,7 +305,6 @@
scheme_extension_table->scheme_hash_table_index = scheme_hash_table_index; scheme_extension_table->scheme_hash_table_index = scheme_hash_table_index;
scheme_extension_table->scheme_hash_table_next = scheme_hash_table_next; scheme_extension_table->scheme_hash_table_next = scheme_hash_table_next;
scheme_extension_table->scheme_make_hash_tree = scheme_make_hash_tree; scheme_extension_table->scheme_make_hash_tree = scheme_make_hash_tree;
scheme_extension_table->scheme_make_hash_tree_set = scheme_make_hash_tree_set;
scheme_extension_table->scheme_hash_tree_set = scheme_hash_tree_set; scheme_extension_table->scheme_hash_tree_set = scheme_hash_tree_set;
scheme_extension_table->scheme_hash_tree_get = scheme_hash_tree_get; scheme_extension_table->scheme_hash_tree_get = scheme_hash_tree_get;
scheme_extension_table->scheme_eq_hash_tree_get = scheme_eq_hash_tree_get; scheme_extension_table->scheme_eq_hash_tree_get = scheme_eq_hash_tree_get;

1
racket/src/racket/src/schemexm.h
View File

@ -305,7 +305,6 @@
#define scheme_hash_table_index (scheme_extension_table->scheme_hash_table_index) #define scheme_hash_table_index (scheme_extension_table->scheme_hash_table_index)
#define scheme_hash_table_next (scheme_extension_table->scheme_hash_table_next) #define scheme_hash_table_next (scheme_extension_table->scheme_hash_table_next)
#define scheme_make_hash_tree (scheme_extension_table->scheme_make_hash_tree) #define scheme_make_hash_tree (scheme_extension_table->scheme_make_hash_tree)
#define scheme_make_hash_tree_set (scheme_extension_table->scheme_make_hash_tree_set)
#define scheme_hash_tree_set (scheme_extension_table->scheme_hash_tree_set) #define scheme_hash_tree_set (scheme_extension_table->scheme_hash_tree_set)
#define scheme_hash_tree_get (scheme_extension_table->scheme_hash_tree_get) #define scheme_hash_tree_get (scheme_extension_table->scheme_hash_tree_get)
#define scheme_eq_hash_tree_get (scheme_extension_table->scheme_eq_hash_tree_get) #define scheme_eq_hash_tree_get (scheme_extension_table->scheme_eq_hash_tree_get)

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1150 #define EXPECTED_PRIM_COUNT 1151
#define EXPECTED_UNSAFE_COUNT 126 #define EXPECTED_UNSAFE_COUNT 126
#define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_EXTFL_COUNT 45

1
racket/src/racket/src/schpriv.h
View File

@ -4450,6 +4450,7 @@ Scheme_Hash_Tree *scheme_make_hash_tree_placeholder(int kind);
void scheme_hash_tree_tie_placeholder(Scheme_Hash_Tree *t, Scheme_Hash_Tree *base); void scheme_hash_tree_tie_placeholder(Scheme_Hash_Tree *t, Scheme_Hash_Tree *base);
XFORM_NONGCING Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t); XFORM_NONGCING Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t);
int scheme_hash_tree_kind(Scheme_Hash_Tree *t); int scheme_hash_tree_kind(Scheme_Hash_Tree *t);
int scheme_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
XFORM_NONGCING int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); XFORM_NONGCING int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
XFORM_NONGCING int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); XFORM_NONGCING int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *t1); intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *t1);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.5.0.7" #define MZSCHEME_VERSION "6.5.0.8"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 5 #define MZSCHEME_VERSION_Y 5
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 7 #define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

2
racket/src/racket/src/syntax.c
View File

@ -312,7 +312,7 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(empty_propagate_table); REGISTER_SO(empty_propagate_table);
REGISTER_SO(empty_scope_set); REGISTER_SO(empty_scope_set);
empty_hash_tree = scheme_make_hash_tree(0); empty_hash_tree = scheme_make_hash_tree(0);
empty_scope_set = (Scheme_Scope_Set *)scheme_make_hash_tree_set(0); empty_scope_set = (Scheme_Scope_Set *)scheme_make_hash_tree(0);
empty_scope_table = MALLOC_ONE_TAGGED(Scheme_Scope_Table); empty_scope_table = MALLOC_ONE_TAGGED(Scheme_Scope_Table);
empty_scope_table->so.type = scheme_scope_table_type; empty_scope_table->so.type = scheme_scope_table_type;
empty_scope_table->simple_scopes = empty_scope_set; empty_scope_table->simple_scopes = empty_scope_set;