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

allow hash-table chaperones to support efficient hash-clear[!]

Browse Source
This commit is contained in:
Matthew Flatt 2013-08-22 07:49:59 -06:00
parent 9f68533f82
commit d901504174
8 changed files with 1127 additions and 989 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -285,15 +285,17 @@ or override impersonator-property values of @racket[box].}
[set-proc (hash? any/c any/c . -> . (values any/c any/c))]
[remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)]
[clear-proc (or/c #f (hash? . -> . any)) #f]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c hash? impersonator?)]{
Returns an impersonator of @racket[hash], which redirects the
@racket[hash-ref], @racket[hash-set!] or @racket[hash-set] (as
applicable), and @racket[hash-remove] or @racket[hash-remove!] (as
applicable) operations. When
@racket[hash-set] or @racket[hash-remove] is used on an impersonator of a hash
applicable), @racket[hash-remove] or @racket[hash-remove!] (as
applicable), @racket[hash-clear] or @racket[hash-clear!] (as
applicable and if @racket[clear-proc] is not @racket[#f]) operations. When
@racket[hash-set], @racket[hash-remove] or @racket[hash-clear] is used on an impersonator of a hash
table, the result is an impersonator with the same redirecting procedures.
In addition, operations like
@racket[hash-iterate-key] or @racket[hash-map], which extract
@ -329,6 +331,14 @@ other operations that use @racket[hash-iterate-key] internally); it
must produce a replacement for the key, which is then reported as a
key extracted from the table.
If @racket[clear-proc] is not @racket[#f], it must accept
@racket[hash] as an argument, and its result is ignored. The fact that
@racket[clear-proc] returns (as opposed to raising an exception or
otherwise escaping) grants the capability to remove all keys from @racket[hash].
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!].
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
@ -565,6 +575,7 @@ the same value or a chaperone of the value that it is given. The
[set-proc (hash? any/c any/c . -> . (values any/c any/c))]
[remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)]
[clear-proc (or/c #f (hash? . -> . any)) #f]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c hash? chaperone?)]{

58
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -668,6 +668,21 @@
(lambda () #hash()) (lambda () #hasheq()) (lambda () #hasheqv())
make-weak-hash make-weak-hasheq make-weak-hasheqv))
(let ([mk (lambda clear-proc+more
(apply chaperone-hash (make-hash)
(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)
clear-proc+more))])
(test #t chaperone? (mk))
(test #t chaperone? (mk #f))
(test #t chaperone? (mk (lambda (ht) (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)))
(for-each
(lambda (make-hash)
(let ([h (impersonate-hash (make-hash)
@ -684,10 +699,10 @@
(for-each
(lambda (make-hash)
(err/rt-test
(impersonator-hash (make-hash)
(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))))
(impersonate-hash (make-hash)
(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))))
(list (lambda () #hash()) (lambda () #hasheq()) (lambda () #hasheqv())))
(as-chaperone-or-impersonator
@ -850,6 +865,41 @@
(test (void) hash-clear! ht)
(test 0 hash-count ht))))
(as-chaperone-or-impersonator
([chaperone-hash impersonate-hash]
[chaperone-procedure impersonate-procedure]
[sub1 add1])
(define hit? #f)
(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)
(lambda (h)
(set! hit? #t)
(test #t hash? h))))
(let* ([ht (make-hash)]
[ht2 (mk ht)])
(hash-set! ht2 'a 1)
(hash-set! ht2 'b 2)
(test #f values hit?)
(test (void) hash-clear! ht2)
(test #t values hit?)
(test 0 hash-count ht)
(test 0 hash-count ht2))
(when (negative? (sub1 0))
(let* ([ht (hash 'a 1)]
[ht2 (mk ht)])
(define ht3 (hash-set ht2 'b 2))
(set! hit? #f)
(define ht4 (hash-clear ht2))
(test #t values hit?)
(test 0 hash-count ht4))))
;; ----------------------------------------
;; Check broken key impersonator:

4
racket/collects/racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
Version 5.90.0.9
Allow hash table chaperones and impersonators to Support efficient
hash-clear and hash-clear!
Version 5.90.0.6
Added path<?, symbol<?
Added hash-copy-clear

17
racket/collects/racket/private/hash.rkt
View File

@ -49,7 +49,7 @@
(define (hash-copy-clear table)
(unless (hash? table)
(raise-argument-error 'hash-clear "hash?" table))
(raise-argument-error 'hash-copy-clear "hash?" table))
(cond
[(immutable? table)
(cond
@ -67,20 +67,6 @@
[(hash-eqv? table) (make-hasheqv)]
[(hash-eq? table) (make-hasheq)])]))
(define (hash-clear table)
(unless (and (hash? table) (immutable? table))
(raise-argument-error 'hash-clear "(and/c hash? immutable?)" table))
(if (not (impersonator? table))
;; Can just make a new one:
(cond
[(hash-equal? table) (hash)]
[(hash-eqv? table) (hasheqv)]
[(hash-eq? table) (hasheq)])
;; To preserve chaperones, need to remove
;; each individual key:
(for/fold ([table table]) ([k (in-hash-keys table)])
(hash-remove table k))))
(define (hash-empty? table)
(unless (hash? table)
(raise-argument-error 'hash-empty? "hash?" table))
@ -93,5 +79,4 @@
hash-set*
hash-set*!
hash-empty?
hash-clear
hash-copy-clear))

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

File diff suppressed because it is too large Load Diff

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

@ -123,6 +123,7 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_clear_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_clear(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_map(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_for_each(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_start(int argc, Scheme_Object *argv[]);
@ -171,6 +172,7 @@ static Scheme_Object *unsafe_set_box_star (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key);
static Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val);
static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table);
#define BOX "box"
#define BOXP "box?"
@ -587,6 +589,11 @@ scheme_init_list (Scheme_Env *env)
"hash-clear!",
1, 1),
env);
scheme_add_global_constant("hash-clear",
scheme_make_noncm_prim(hash_table_clear,
"hash-clear",
1, 1),
env);
scheme_add_global_constant("hash-map",
scheme_make_noncm_prim(hash_table_map,
"hash-map",
@ -2433,24 +2440,33 @@ static Scheme_Object *hash_table_clear_bang(int argc, Scheme_Object *argv[])
if (!(SCHEME_HASHTP(v2) && SCHEME_MUTABLEP(v2)) && !SCHEME_BUCKTP(v2))
scheme_wrong_contract("hash-clear!", "(and/c hash? (not/c immutable?))", 0, argc, argv);
if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v)))) {
/* Implement `(hash-clear! ht)' as `(hash-for-each ht (lambda (k) (hash-remove! ht k)))'
to allow chaperones to interpose. */
Scheme_Object *i, *a[2], *key;
a[0] = v;
while (1) {
i = scheme_hash_table_iterate_start(1, a);
if (SCHEME_FALSEP(i))
break;
if (SCHEME_NP_CHAPERONEP(v)) {
if (chaperone_hash_clear("hash-clear!", v)) {
/* A non-NULL result means that there were `hash-clear' implementations
in the chaperone and all checking passed. */
v = v2; /* and perform clear below */
} else {
/* Implement `(hash-clear! ht)' as `(hash-for-each ht (lambda (k) (hash-remove! ht k)))'
to allow chaperones to interpose. */
Scheme_Object *i, *a[2], *key;
a[0] = v;
while (1) {
i = scheme_hash_table_iterate_start(1, a);
if (SCHEME_FALSEP(i))
break;
a[1] = i;
key = scheme_hash_table_iterate_key(2, a);
a[1] = key;
hash_table_remove_bang(2, a);
}
a[1] = i;
key = scheme_hash_table_iterate_key(2, a);
a[1] = key;
hash_table_remove_bang(2, a);
return scheme_void;
}
} else if (SCHEME_BUCKTP(v)) {
}
if (SCHEME_BUCKTP(v)) {
scheme_clear_bucket_table((Scheme_Bucket_Table *)v);
} else{
scheme_clear_hash_table((Scheme_Hash_Table *)v);
@ -2459,6 +2475,42 @@ static Scheme_Object *hash_table_clear_bang(int argc, Scheme_Object *argv[])
return scheme_void;
}
static Scheme_Object *hash_table_clear(int argc, Scheme_Object *argv[])
{
Scheme_Object *v, *v2;
v = argv[0];
v2 = (SCHEME_NP_CHAPERONEP(v) ? SCHEME_CHAPERONE_VAL(v) : v);
if (!SCHEME_HASHTRP(v2))
scheme_wrong_contract("hash-clear", "(and/c hash? immutable?)", 0, argc, argv);
if (SCHEME_NP_CHAPERONEP(v)) {
v2 = chaperone_hash_clear("hash-clear", v);
if (v2)
return v2;
else {
/* NULL result means that a `hash-clear' implementation was not
available, so we need to fold a remove over all keys: */
Scheme_Object *i, *a[2], *key;
while (1) {
a[0] = v;
i = scheme_hash_table_iterate_start(1, a);
if (SCHEME_FALSEP(i))
return v;
a[1] = i;
key = scheme_hash_table_iterate_key(2, a);
a[1] = key;
v = hash_table_remove_bang(2, a);
}
}
} else
return (Scheme_Object *)scheme_make_hash_tree(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)v) & 0x3);
}
static void no_post_key(const char *name, Scheme_Object *key, int chap)
{
scheme_contract_error(name,
@ -2832,8 +2884,9 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Object *redirects, *clear;
Scheme_Hash_Tree *props;
int start_props = 5;
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
@ -2847,14 +2900,22 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i
scheme_check_proc_arity(name, 2, 3, argc, argv); /* remove */
scheme_check_proc_arity(name, 2, 4, argc, argv); /* key */
redirects = scheme_make_vector(4, NULL);
if ((argc > 5) && (SCHEME_FALSEP(argv[5]) || SCHEME_PROCP(argv[5]))) {
scheme_check_proc_arity2(name, 1, 5, argc, argv, 1); /* clear */
clear = argv[5];
start_props++;
} else
clear = scheme_false;
redirects = scheme_make_vector(5, 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;
redirects = scheme_box(redirects); /* so it doesn't look like a struct chaperone */
props = scheme_parse_chaperone_props(name, 5, argc, argv);
props = scheme_parse_chaperone_props(name, start_props, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
@ -2973,8 +3034,20 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
} else
scheme_add_to_table((Scheme_Bucket_Table *)o, (const char *)k, v, 0);
return scheme_void;
} else
} else if (mode == 3)
return k;
else {
/* mode == 4, hash-clear */
if (SCHEME_HASHTRP(o)) {
o = (Scheme_Object *)scheme_make_hash_tree(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x3);
while (wraps) {
o = transfer_chaperone(SCHEME_CAR(wraps), o);
wraps = SCHEME_CDR(wraps);
}
return o;
} else
return scheme_void;
}
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red, *orig;
@ -2994,6 +3067,8 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
k = orig;
} else if (mode == 2)
orig = k;
else if (mode == 4)
orig = scheme_void;
else
orig = v;
@ -3004,6 +3079,9 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
red = SCHEME_BOX_VAL(px->redirects);
red = SCHEME_VEC_ELS(red)[mode];
if ((mode == 4) && SCHEME_FALSEP(red))
return NULL; /* => fall back to a sequence of removes */
a[0] = px->prev;
a[1] = k;
a[2] = orig;
@ -3066,8 +3144,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
what = "result";
} else
what = "value";
} else if (mode == 4) {
/* hash-clear */
(void)_scheme_apply_multi(red, 1, a);
o = scheme_void;
what = "void";
} else {
/* hash-remove! and key extraction */
/* hash-remove and key extraction */
o = _scheme_apply(red, 2, a);
what = "key";
}
@ -3112,6 +3195,11 @@ static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table,
return chaperone_hash_op(name, table, key, NULL, 3);
}
static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table)
{
return chaperone_hash_op(name, table, NULL, NULL, 4);
}
Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key,
Scheme_Object **alt_key)
{

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1113
#define EXPECTED_PRIM_COUNT 1114
#define EXPECTED_UNSAFE_COUNT 100
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.90.0.8"
#define MZSCHEME_VERSION "5.90.0.9"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 90
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)