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

cs: add lock on equal?-based weak hash table

Browse Source 
Also, repair a test that didn't properly retain weak-hash keys.
This commit is contained in:
Matthew Flatt 2018-03-14 14:37:41 -06:00
parent aad799f09e
commit 67a982ad6a
5 changed files with 137 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -2269,8 +2269,14 @@
(lambda (a hc) (lambda (a hc)
(hc (a-v a))))) (hc (a-v a)))))
(for ([i 1000]) (define all-save-keys (make-hasheq))
(hash-set! ht (a i) i))
(hash-set! all-save-keys
#f
(for/list ([i 1000])
(define k (a i))
(hash-set! ht k i)
k))
(define cht (chaperone-hash ht (define cht (chaperone-hash ht
(lambda (ht k) (values k (lambda (ht k v) v))) (lambda (ht k) (values k (lambda (ht k v) v)))
@ -2295,7 +2301,7 @@
(unless (equal? (hash-ref cht k #f) v) (unless (equal? (hash-ref cht k #f) v)
(error "oops"))) (error "oops")))
(semaphore-post done) (semaphore-post done)
save-keys)))) (hash-set! all-save-keys j save-keys)))))
(for-each sync ths) (for-each sync ths)

15
racket/src/cs/rumble/datum.ss
View File

@ -12,11 +12,12 @@
(char? v) (char? v)
(bytes? v) (bytes? v)
(intern-regexp? v)) (intern-regexp? v))
(or (weak-hash-ref-key datums v) (with-interrupts-disabled
(let ([v (cond (or (weak-hash-ref-key datums v)
[(string? v) (string->immutable-string v)] (let ([v (cond
[(bytes? v) (bytes->immutable-bytes v)] [(string? v) (string->immutable-string v)]
[else v])]) [(bytes? v) (bytes->immutable-bytes v)]
(hash-set! datums v #t) [else v])])
v))] (hash-set! datums v #t)
v)))]
[else v])) [else v]))

188
racket/src/cs/rumble/hash.ss
View File

@ -656,7 +656,8 @@
;; Chez Scheme doesn't provide weak hash table with `equal?` comparisons, ;; Chez Scheme doesn't provide weak hash table with `equal?` comparisons,
;; so build our own ;; so build our own
(define-record weak-equal-hash (keys-ht ; integer[equal hash code] -> weak list of keys (define-record weak-equal-hash (lock
keys-ht ; integer[equal hash code] -> weak list of keys
vals-ht ; weak, eq?-based hash table: key -> value vals-ht ; weak, eq?-based hash table: key -> value
count ; number of items in the table (= sum of list lengths) count ; number of items in the table (= sum of list lengths)
prune-at ; count at which we should try to prune empty weak boxes prune-at ; count at which we should try to prune empty weak boxes
@ -664,35 +665,42 @@
(define make-weak-hash (define make-weak-hash
(case-lambda (case-lambda
[() (make-weak-equal-hash (hasheqv) (make-weak-eq-hashtable) 0 128 #f)] [() (make-weak-equal-hash (make-lock 'equal?) (hasheqv) (make-weak-eq-hashtable) 0 128 #f)]
[(alist) (fill-hash! 'make-weak-hash (make-weak-hash) alist)])) [(alist) (fill-hash! 'make-weak-hash (make-weak-hash) alist)]))
(define (weak-hash-copy ht) (define (weak-hash-copy ht)
(make-weak-equal-hash (weak-equal-hash-keys-ht ht) (lock-acquire (weak-equal-hash-lock ht))
(hashtable-copy (weak-equal-hash-vals-ht ht) #t) (let ([new-ht (make-weak-equal-hash (weak-equal-hash-keys-ht ht)
(weak-equal-hash-count ht) (hashtable-copy (weak-equal-hash-vals-ht ht) #t)
(weak-equal-hash-prune-at ht) (weak-equal-hash-count ht)
#f)) (weak-equal-hash-prune-at ht)
#f)])
(lock-release (weak-equal-hash-lock ht))
new-ht))
(define (weak-hash-ref t key fail) (define (weak-hash-ref t key fail)
(let* ([code (key-equal-hash-code key)] (let ([code (key-equal-hash-code key)])
[keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) (lock-acquire (weak-equal-hash-lock t))
(let loop ([keys keys]) (let ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())])
(cond (let loop ([keys keys])
[(null? keys) (cond
;; Not in the table: [(null? keys)
(if (procedure? fail) ;; Not in the table:
(|#%app| fail) (lock-release (weak-equal-hash-lock t))
fail)] (if (procedure? fail)
[(key-equal? (car keys) key) (|#%app| fail)
(let ([v (hashtable-ref (weak-equal-hash-vals-ht t) (car keys) none)]) fail)]
(if (eq? v none) [(key-equal? (car keys) key)
(if (procedure? fail) (let ([v (hashtable-ref (weak-equal-hash-vals-ht t) (car keys) none)])
(|#%app| fail) (lock-release (weak-equal-hash-lock t))
fail) (if (eq? v none)
v))] (if (procedure? fail)
[else (loop (cdr keys))])))) (|#%app| fail)
fail)
v))]
[else (loop (cdr keys))])))))
;; Only used in atomic mode:
(define (weak-hash-ref-key ht key) (define (weak-hash-ref-key ht key)
(let* ([code (key-equal-hash-code key)] (let* ([code (key-equal-hash-code key)]
[keys (intmap-ref (weak-equal-hash-keys-ht ht) code '())]) [keys (intmap-ref (weak-equal-hash-keys-ht ht) code '())])
@ -703,65 +711,72 @@
[else (loop (cdr keys))])))) [else (loop (cdr keys))]))))
(define (weak-hash-set! t k v) (define (weak-hash-set! t k v)
(let* ([code (key-equal-hash-code k)] (let ([code (key-equal-hash-code k)])
[keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) (lock-acquire (weak-equal-hash-lock t))
(let loop ([keys keys]) (let ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())])
(cond (let loop ([keys keys])
[(null? keys) (cond
;; Not in the table: [(null? keys)
(set-weak-equal-hash-keys! t #f) ;; Not in the table:
(when (= (weak-equal-hash-count t) (weak-equal-hash-prune-at t)) (set-weak-equal-hash-keys! t #f)
(prune-table! t)) (when (= (weak-equal-hash-count t) (weak-equal-hash-prune-at t))
(let* ([ht (weak-equal-hash-keys-ht t)]) (prune-table! t))
(set-weak-equal-hash-count! t (let* ([ht (weak-equal-hash-keys-ht t)])
(add1 (weak-equal-hash-count t))) (set-weak-equal-hash-count! t
(set-weak-equal-hash-keys-ht! t (add1 (weak-equal-hash-count t)))
(intmap-set ht code (set-weak-equal-hash-keys-ht! t
(weak/fl-cons k (intmap-set ht code
(intmap-ref ht code '())))) (weak/fl-cons k
(hashtable-set! (weak-equal-hash-vals-ht t) k v))] (intmap-ref ht code '()))))
[(key-equal? (car keys) k) (hashtable-set! (weak-equal-hash-vals-ht t) k v))
(hashtable-set! (weak-equal-hash-vals-ht t) (car keys) v)] (lock-release (weak-equal-hash-lock t))]
[else (loop (cdr keys))])))) [(key-equal? (car keys) k)
(hashtable-set! (weak-equal-hash-vals-ht t) (car keys) v)
(lock-release (weak-equal-hash-lock t))]
[else (loop (cdr keys))])))))
(define (weak-hash-remove! t k) (define (weak-hash-remove! t k)
(let* ([code (key-equal-hash-code k)] (let ([code (key-equal-hash-code k)])
[keys (intmap-ref (weak-equal-hash-keys-ht t) code '())] (lock-acquire (weak-equal-hash-lock t))
[keep-bwp? (let* ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]
;; If we have a `keys` array, then preserve the shape of [keep-bwp?
;; each key lst in `(weak-equal-hash-keys-ht t)` so that ;; If we have a `keys` array, then preserve the shape of
;; the `keys` array remains consistent with that shape ;; each key lst in `(weak-equal-hash-keys-ht t)` so that
(and (weak-equal-hash-keys t) #t)] ;; the `keys` array remains consistent with that shape
[new-keys (and (weak-equal-hash-keys t) #t)]
(let loop ([keys keys]) [new-keys
(cond (let loop ([keys keys])
[(null? keys) (cond
;; Not in the table [(null? keys)
#f] ;; Not in the table
[(key-equal? (car keys) k) #f]
(hashtable-delete! (weak-equal-hash-vals-ht t) (car keys)) [(key-equal? (car keys) k)
(if keep-bwp? (hashtable-delete! (weak-equal-hash-vals-ht t) (car keys))
(cons #!bwp keys) (if keep-bwp?
(cdr keys))] (cons #!bwp keys)
[else (cdr keys))]
(let ([new-keys (loop (cdr keys))]) [else
(and new-keys (let ([new-keys (loop (cdr keys))])
(if (and (not keep-bwp?) (and new-keys
(bwp-object? (car keys))) (if (and (not keep-bwp?)
new-keys (bwp-object? (car keys)))
(weak/fl-cons (car keys) new-keys))))]))]) new-keys
(when new-keys (weak/fl-cons (car keys) new-keys))))]))])
(set-weak-equal-hash-keys-ht! t (when new-keys
(if (null? new-keys) (set-weak-equal-hash-keys-ht! t
(intmap-remove (weak-equal-hash-keys-ht t) code) (if (null? new-keys)
(intmap-set (weak-equal-hash-keys-ht t) code new-keys)))))) (intmap-remove (weak-equal-hash-keys-ht t) code)
(intmap-set (weak-equal-hash-keys-ht t) code new-keys))))
(lock-release (weak-equal-hash-lock t)))))
(define (weak-hash-clear! t) (define (weak-hash-clear! t)
(lock-acquire (weak-equal-hash-lock t))
(set-weak-equal-hash-keys-ht! t (hasheqv)) (set-weak-equal-hash-keys-ht! t (hasheqv))
(hashtable-clear! (weak-equal-hash-vals-ht t)) (hashtable-clear! (weak-equal-hash-vals-ht t))
(set-weak-equal-hash-count! t 0) (set-weak-equal-hash-count! t 0)
(set-weak-equal-hash-prune-at! t 128) (set-weak-equal-hash-prune-at! t 128)
(set-weak-equal-hash-keys! t #f)) (set-weak-equal-hash-keys! t #f)
(lock-release (weak-equal-hash-lock t)))
(define (weak-hash-for-each t proc) (define (weak-hash-for-each t proc)
(let* ([ht (weak-equal-hash-vals-ht t)] (let* ([ht (weak-equal-hash-vals-ht t)]
@ -825,6 +840,7 @@
(weak-hash-iterate-next ht #f)) (weak-hash-iterate-next ht #f))
(define (weak-hash-iterate-next ht init-i) (define (weak-hash-iterate-next ht init-i)
(lock-acquire (weak-equal-hash-lock ht))
(let retry ([i (and init-i (add1 init-i))]) (let retry ([i (and init-i (add1 init-i))])
(let* ([vec (prepare-weak-iterate! ht i)] (let* ([vec (prepare-weak-iterate! ht i)]
[len (vector-length vec)]) [len (vector-length vec)])
@ -834,6 +850,7 @@
;; expand set of prepared keys ;; expand set of prepared keys
(retry i)] (retry i)]
[(> i len) [(> i len)
(lock-release (weak-equal-hash-lock ht))
(raise-arguments-error 'hash-iterate-next "no element at weak index" (raise-arguments-error 'hash-iterate-next "no element at weak index"
"index" init-i)] "index" init-i)]
[else [else
@ -841,14 +858,18 @@
(cond (cond
[(not p) [(not p)
;; no more keys available ;; no more keys available
(lock-release (weak-equal-hash-lock ht))
#f] #f]
[(bwp-object? (car p)) (loop (add1 i))] [(bwp-object? (car p)) (loop (add1 i))]
[(not (hashtable-contains? (weak-equal-hash-vals-ht ht) (car p))) [(not (hashtable-contains? (weak-equal-hash-vals-ht ht) (car p)))
;; key was removed from table after `keys` array was formed ;; key was removed from table after `keys` array was formed
(loop (add1 i))] (loop (add1 i))]
[else i]))]))))) [else
(lock-release (weak-equal-hash-lock ht))
i]))])))))
(define (do-weak-hash-iterate-key who ht i) (define (do-weak-hash-iterate-key who ht i release-lock?)
(lock-acquire (weak-equal-hash-lock ht))
(let* ([vec (weak-equal-hash-keys ht)] (let* ([vec (weak-equal-hash-keys ht)]
[p (and vec [p (and vec
(< i (vector-length vec)) (< i (vector-length vec))
@ -856,6 +877,8 @@
[k (if p [k (if p
(car p) (car p)
#!bwp)]) #!bwp)])
(when release-lock?
(lock-release (weak-equal-hash-lock ht)))
(cond (cond
[(bwp-object? k) [(bwp-object? k)
(raise-arguments-error who "no element at index" (raise-arguments-error who "no element at index"
@ -863,11 +886,12 @@
[else k]))) [else k])))
(define (weak-hash-iterate-key ht i) (define (weak-hash-iterate-key ht i)
(do-weak-hash-iterate-key 'hash-iterate-key ht i)) (do-weak-hash-iterate-key 'hash-iterate-key ht i #t))
(define (weak-hash-iterate-value ht i) (define (weak-hash-iterate-value ht i)
(let* ([key (do-weak-hash-iterate-key 'hash-iterate-value ht i)] (let* ([key (do-weak-hash-iterate-key 'hash-iterate-value ht i #f)]
[val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) [val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)])
(lock-release (weak-equal-hash-lock ht))
(if (eq? val none) (if (eq? val none)
(raise-arguments-error (raise-arguments-error
'weak-hash-iterate-value "no element at index" 'weak-hash-iterate-value "no element at index"
@ -875,9 +899,10 @@
val))) val)))
(define (weak-hash-iterate-key+value ht i) (define (weak-hash-iterate-key+value ht i)
(let ([key (do-weak-hash-iterate-key 'hash-iterate-key+value ht i)]) (let ([key (do-weak-hash-iterate-key 'hash-iterate-key+value ht i #f)])
(values key (values key
(let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)])
(lock-release (weak-equal-hash-lock ht))
(if (eq? val none) (if (eq? val none)
(raise-arguments-error (raise-arguments-error
'weak-hash-iterate-key+value "no element at index" 'weak-hash-iterate-key+value "no element at index"
@ -885,9 +910,10 @@
val))))) val)))))
(define (weak-hash-iterate-pair ht i) (define (weak-hash-iterate-pair ht i)
(let ([key (do-weak-hash-iterate-key 'hash-iterate-pair ht i)]) (let ([key (do-weak-hash-iterate-key 'hash-iterate-pair ht i #f)])
(cons key (cons key
(let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)])
(lock-release (weak-equal-hash-lock ht))
(if (eq? val none) (if (eq? val none)
(raise-arguments-error (raise-arguments-error
'weak-hash-iterate-paur "no element at index" 'weak-hash-iterate-paur "no element at index"

3
racket/src/cs/rumble/lock.ss
View File

@ -76,12 +76,14 @@
(case-lambda (case-lambda
[(lock) [(lock)
(cond (cond
[(not lock) (void)]
[(spinlock? lock) [(spinlock? lock)
(spinlock-acquire lock)] (spinlock-acquire lock)]
[else [else
(scheduler-lock-acquire lock)])] (scheduler-lock-acquire lock)])]
[(lock block?) [(lock block?)
(cond (cond
[(not lock) (void)]
[(spinlock? lock) [(spinlock? lock)
(spinlock-acquire lock block?)] (spinlock-acquire lock block?)]
[else [else
@ -89,6 +91,7 @@
(define (lock-release lock) (define (lock-release lock)
(cond (cond
[(not lock) (void)]
[(spinlock? lock) [(spinlock? lock)
(spinlock-release lock)] (spinlock-release lock)]
[else [else

16
racket/src/cs/rumble/struct.ss
View File

@ -547,10 +547,14 @@
(record-type-uid (record-type-uid
(prefab-key+count->rtd (cons prefab-key total*-count))))) (prefab-key+count->rtd (cons prefab-key total*-count)))))
(define (prefab-ref prefab-key+count)
(with-interrupts-disabled ; atomic access of `prefabs`
(and prefabs
(hash-ref prefabs prefab-key+count #f))))
(define (prefab-key+count->rtd prefab-key+count) (define (prefab-key+count->rtd prefab-key+count)
(cond (cond
[(and prefabs [(prefab-ref prefab-key+count)
(hash-ref prefabs prefab-key+count #f))
=> (lambda (rtd) rtd)] => (lambda (rtd) rtd)]
[else [else
(let* ([prefab-key (car prefab-key+count)] (let* ([prefab-key (car prefab-key+count)]
@ -573,14 +577,14 @@
[mutables (prefab-key-mutables prefab-key)]) [mutables (prefab-key-mutables prefab-key)])
(with-interrupts-disabled (with-interrupts-disabled
(cond (cond
[(and prefabs [(prefab-ref prefab-key+count)
(hash-ref prefabs prefab-key+count #f))
;; rtd was created concurrently ;; rtd was created concurrently
=> (lambda (rtd) rtd)] => (lambda (rtd) rtd)]
[else [else
(putprop uid 'prefab-key+count prefab-key+count) (putprop uid 'prefab-key+count prefab-key+count)
(unless prefabs (set! prefabs (make-weak-hash))) (with-interrupts-disabled ; atomic use of `prefabs` table
(hash-set! prefabs prefab-key+count rtd) (unless prefabs (set! prefabs (make-weak-hash)))
(hash-set! prefabs prefab-key+count rtd))
(unless parent-rtd (unless parent-rtd
(record-type-equal-procedure rtd default-struct-equal?) (record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash)) (record-type-hash-procedure rtd default-struct-hash))