diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index 2ca274891e..f18cd8f702 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -2214,11 +2214,61 @@ (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)))) - + (test 'vec7 hash-ref ht key7) + (err/rt-test (hash-ref cht (vector 1 2) #f) one-exn?)))) + +;; ---------------------------------------- +;; Make sure chaperoned hash tables use a lock + +(for ([make-hash (list make-hash make-weak-hash)]) + (define ht (make-hash)) + + (struct a (v) + #:property + prop:equal+hash + (list (lambda (a b eql?) + (when (zero? (random 20)) (sleep)) + (eql? (a-v a) (a-v b))) + (lambda (a hc) + (when (zero? (random 20)) (sleep)) + (hc (a-v a))) + (lambda (a hc) + (hc (a-v a))))) + + (for ([i 1000]) + (hash-set! ht (a i) i)) + + (define cht (chaperone-hash ht + (lambda (ht k) (values k (lambda (ht k v) v))) + (lambda (ht k v) (values k v)) + (lambda (ht k) k) + (lambda (ht k) k))) + + (define done (make-semaphore)) + + (define ths + (for/list ([j 4]) + (thread + (lambda () + (for ([i 1000]) + (define v (random 100000)) + (define k (a v)) + (hash-set! cht k v) + ;; Make sure the addition didn't get lost, which + ;; can happen when a lock is missing: + (unless (equal? (hash-ref cht k #f) v) + (error "oops"))) + (semaphore-post done))))) + + (for-each sync ths) + + (test #t + 'threads-finished + (for/and ([t ths]) + (semaphore-try-wait? done)))) + ;; ---------------------------------------- ;; Check broken key impersonator: diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index 41c0ec739b..e26103c513 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -3317,17 +3317,28 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem key_wraps = scheme_make_raw_pair((Scheme_Object *)who, key_wraps); if (mode == 0) { /* hash-ref */ - if (SCHEME_HASHTP(o)) - return scheme_hash_get_w_key_wraps((Scheme_Hash_Table *)o, k, key_wraps); - else if (SCHEME_HASHTRP(o)) - return scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps); - else - return scheme_lookup_in_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, key_wraps); + if (SCHEME_HASHTP(o)) { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)o; + if (t->mutex) scheme_wait_sema(t->mutex, 0); + v = scheme_hash_get_w_key_wraps(t, k, key_wraps); + if (t->mutex) scheme_post_sema(t->mutex); + } else if (SCHEME_HASHTRP(o)) + v = scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps); + else { + Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)o; + if (t->mutex) scheme_wait_sema(t->mutex, 0); + v = scheme_lookup_in_table_w_key_wraps(t, (const char *)k, key_wraps); + if (t->mutex) scheme_post_sema(t->mutex); + } + return v; } else if ((mode == 1) || (mode == 2)) { /* hash-set! or hash-remove! */ - if (SCHEME_HASHTP(o)) - scheme_hash_set_w_key_wraps((Scheme_Hash_Table *)o, k, v, key_wraps); - else if (SCHEME_HASHTRP(o)) { + if (SCHEME_HASHTP(o)) { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)o; + if (t->mutex) scheme_wait_sema(t->mutex, 0); + scheme_hash_set_w_key_wraps(t, k, v, key_wraps); + if (t->mutex) scheme_post_sema(t->mutex); + } else if (SCHEME_HASHTRP(o)) { 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); @@ -3335,14 +3346,21 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem } return o; } else if (!v) { + Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)o; Scheme_Bucket *b; - b = scheme_bucket_or_null_from_table_w_key_wraps((Scheme_Bucket_Table *)o, (char *)k, 0, key_wraps); + if (t->mutex) scheme_wait_sema(t->mutex, 0); + b = scheme_bucket_or_null_from_table_w_key_wraps(t, (char *)k, 0, key_wraps); + if (t->mutex) scheme_post_sema(t->mutex); if (b) { HT_EXTRACT_WEAK(b->key) = NULL; b->val = NULL; } - } else - scheme_add_to_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, v, 0, key_wraps); + } else { + Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)o; + if (t->mutex) scheme_wait_sema(t->mutex, 0); + scheme_add_to_table_w_key_wraps(t, (const char *)k, v, 0, key_wraps); + if (t->mutex) scheme_post_sema(t->mutex); + } return scheme_void; } else if (mode == 3) return k;