From d9015041743a853bf7beccde5686c410ddf07579 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 22 Aug 2013 07:49:59 -0600 Subject: [PATCH] allow hash-table chaperones to support efficient `hash-clear[!]` --- .../scribblings/reference/chaperones.scrbl | 17 +- .../racket-test/tests/racket/chaperone.rktl | 58 +- racket/collects/racket/HISTORY.txt | 4 + racket/collects/racket/private/hash.rkt | 17 +- racket/src/racket/src/cstartup.inc | 1884 ++++++++--------- racket/src/racket/src/list.c | 130 +- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 4 +- 8 files changed, 1127 insertions(+), 989 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl index df1fa9f167..39cfe26853 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -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?)]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index b2590e08ff..4707899d83 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -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: diff --git a/racket/collects/racket/HISTORY.txt b/racket/collects/racket/HISTORY.txt index 6c6996b568..952edc2c67 100644 --- a/racket/collects/racket/HISTORY.txt +++ b/racket/collects/racket/HISTORY.txt @@ -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 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) { diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index d4131b167d..1732cd5684 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -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 diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 2c7f218ceb..61dcf3a450 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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)