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

cs: fix races with places in the Rumble layer

Browse Source
This commit is contained in:
Matthew Flatt 2018-08-29 18:56:39 -06:00
parent 8b4a17e33e
commit 8c5eebc513
13 changed files with 127 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/src/cs/Makefile
View File

@ -240,6 +240,7 @@ RUMBLE_SRCS = rumble/define.ss \
rumble/hash.ss \
rumble/datum.ss \
rumble/lock.ss \
rumble/thread-local.ss \
rumble/thread-cell.ss \
rumble/parameter.ss \
rumble/begin0.ss \

2
racket/src/cs/demo/thread.ss
View File

@ -32,7 +32,7 @@
(define-syntax define
(syntax-rules ()
[(_ id rhs) (set! id rhs)]))
(check #t (thread? (current-thread)))
(check #t (evt? (current-thread)))
(define s (make-semaphore))

7
racket/src/cs/rumble.sls
View File

@ -687,8 +687,11 @@
(include "rumble/define.ss")
(include "rumble/virtual-register.ss")
(include "rumble/version.ss")
(include "rumble/begin0.ss")
(include "rumble/syntax-rule.ss")
(include "rumble/lock.ss")
(include "rumble/thread-local.ss")
(include "rumble/version.ss")
(include "rumble/check.ss")
(include "rumble/constant.ss")
(include "rumble/hash-code.ss")
@ -702,11 +705,9 @@
(include "rumble/object-name.ss")
(include "rumble/arity.ss")
(include "rumble/intmap.ss")
(include "rumble/lock.ss")
(include "rumble/hash.ss")
(include "rumble/datum.ss")
(include "rumble/thread-cell.ss")
(include "rumble/begin0.ss")
(include "rumble/pthread.ss")
(include "rumble/control.ss")
(include "rumble/interrupt.ss")

4
racket/src/cs/rumble/error.ss
View File

@ -440,7 +440,7 @@
;; In case the escape handler doesn't escape:
(default-error-escape-handler)))
(define link-instantiate-continuations (make-ephemeron-eq-hashtable))
(define-thread-local link-instantiate-continuations (make-ephemeron-eq-hashtable))
;; For `instantiate-linklet` to help report which linklet is being run:
(define (register-linklet-instantiate-continuation! k name)
@ -450,7 +450,7 @@
;; Convert a contination to a list of function-name and
;; source information. Cache the result half-way up the
;; traversal, so that it's amortized constant time.
(define cached-traces (make-ephemeron-eq-hashtable))
(define-thread-local cached-traces (make-ephemeron-eq-hashtable))
(define (continuation->trace k)
(call-with-values
(lambda ()

35
racket/src/cs/rumble/foreign.ss
View File

@ -1270,7 +1270,8 @@
(define the-foreign-guardian (make-guardian))
;; Can be called in any host thread
;; Can be called in any host thread, but all other
;; threads are stopped
(define (poll-foreign-guardian)
(let ([v (the-foreign-guardian)])
(when v
@ -1287,8 +1288,8 @@
(set! eval/foreign proc))
;; Cache generated code for an underlying foreign call or callable shape:
(define ffi-expr->code (make-weak-hash)) ; expr to weak cell of code
(define ffi-code->expr (make-weak-eq-hashtable)) ; keep exprs alive as long as code lives
(define-thread-local ffi-expr->code (make-weak-hash)) ; expr to weak cell of code
(define-thread-local ffi-code->expr (make-weak-eq-hashtable)) ; keep exprs alive as long as code lives
(define/who ffi-call
(case-lambda
@ -1659,7 +1660,7 @@
(let* ([code (make-code proc)]
[cb (create-callback code)])
(lock-object code)
(the-foreign-guardian cb (lambda () (unlock-object code)))
(with-global-lock (the-foreign-guardian cb (lambda () (unlock-object code))))
cb)))]))
;; ----------------------------------------
@ -1714,23 +1715,19 @@
;; ----------------------------------------
(define process-global-table (make-hashtable equal-hash-code equal?))
(define process-table-lock (make-mutex))
(define (unsafe-register-process-global key val)
(with-interrupts-disabled
(mutex-acquire process-table-lock)
(let ([result (cond
[(not val)
(hashtable-ref process-global-table key #f)]
[else
(let ([old-val (hashtable-ref process-global-table key #f)])
(cond
[(not old-val)
(hashtable-set! process-global-table key val)
#f]
[else old-val]))])])
(mutex-release process-table-lock)
result)))
(with-global-lock
(cond
[(not val)
(hashtable-ref process-global-table key #f)]
[else
(let ([old-val (hashtable-ref process-global-table key #f)])
(cond
[(not old-val)
(hashtable-set! process-global-table key val)
#f]
[else old-val]))])))
;; ----------------------------------------

11
racket/src/cs/rumble/hash-code.ss
View File

@ -29,11 +29,12 @@
[(number? x) (number-hash x)]
[(char? x) (char->integer x)]
[else
(or (eq-hashtable-ref codes x #f)
(let ([c (fx1+ counter)])
(set! counter c)
(eq-hashtable-set! codes x counter)
c))]))
(with-global-lock
(or (eq-hashtable-ref codes x #f)
(let ([c (fx1+ counter)])
(set! counter c)
(eq-hashtable-set! codes x counter)
c)))]))
;; Mostly copied from Chez Scheme's "newhash.ss":
(define number-hash

13
racket/src/cs/rumble/keyword.ss
View File

@ -8,12 +8,13 @@
(define/who (string->keyword s)
(check who string? s)
(let ([sym (string->symbol s)])
(let ([e (eq-hashtable-ref keywords sym #f)])
(or (and e
(ephemeron-value e))
(let ([kw (make-keyword sym)])
(eq-hashtable-set! keywords sym (make-ephemeron sym kw))
kw)))))
(with-global-lock
(let ([e (eq-hashtable-ref keywords sym #f)])
(or (and e
(ephemeron-value e))
(let ([kw (make-keyword sym)])
(eq-hashtable-set! keywords sym (make-ephemeron sym kw))
kw))))))
(define/who (keyword->string kw)
(check who keyword? kw)

2
racket/src/cs/rumble/list.ss
View File

@ -6,7 +6,7 @@
;; Detect cycles using the same `slow` tortoise that is used for
;; caching.
(define lists (make-weak-eq-hashtable))
(define-thread-local lists (make-weak-eq-hashtable))
(define (list? v)
(let loop ([v v] [depth 0])

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

@ -1,8 +1,8 @@
;; locking code for hash.ss
(define make-scheduler-lock (lambda () #f))
(define scheduler-lock-acquire (lambda (l) (void)))
(define scheduler-lock-release (lambda (l) (void)))
(define scheduler-lock-acquire (lambda (l) (#%void)))
(define scheduler-lock-release (lambda (l) (#%void)))
(define (set-scheduler-lock-callbacks! make acquire release)
(set! make-scheduler-lock make)
@ -37,7 +37,17 @@
(define (lock-release lock)
(when lock
(scheduler-lock-release lock)))]
(scheduler-lock-release lock)))
;; Use `with-global-lock*` when no lock is needed absent threads
(define-syntax-rule (with-global-lock* e ...)
(begin e ...))
;; Use `with-global-lock` when a lock is needed to prevent
;; engine-based concurrency
(define-syntax-rule (with-global-lock e ...)
(with-interrupts-disabled
e))]
[else
;; Using a Chez Scheme build with thread support; make hash-table
;; access thread-safe at that level for `eq?`- and `eqv?`-based
@ -49,7 +59,7 @@
;; Assume low contention on `eq?`- and `eqv?`-based tables across
;; Chez Scheme threads, in which case a compare-and-set spinlock is
;; good enough.
;; Taking a lock disables interrupts, whcih ensures that the GC
;; Taking a lock disables interrupts, which ensures that the GC
;; callback or other atomic actions can use hash tables without
;; deadlocking.
(define (make-spinlock) (box #f))
@ -63,7 +73,7 @@
(define (spinlock-release q)
(#%set-box! q #f)
(enable-interrupts)
(void))
(#%void))
(define (make-lock for-kind)
(cond
@ -76,14 +86,14 @@
(case-lambda
[(lock)
(cond
[(not lock) (void)]
[(not lock) (#%void)]
[(spinlock? lock)
(spinlock-acquire lock)]
[else
(scheduler-lock-acquire lock)])]
[(lock block?)
(cond
[(not lock) (void)]
[(not lock) (#%void)]
[(spinlock? lock)
(spinlock-acquire lock block?)]
[else
@ -91,8 +101,18 @@
(define (lock-release lock)
(cond
[(not lock) (void)]
[(not lock) (#%void)]
[(spinlock? lock)
(spinlock-release lock)]
[else
(scheduler-lock-release lock)]))])
(scheduler-lock-release lock)]))
(define global-lock (make-spinlock))
(define-syntax-rule (with-global-lock* e ...)
(with-global-lock e ...))
(define-syntax-rule (with-global-lock e ...)
(begin
(spinlock-acquire global-lock)
(begin0
(begin e ...)
(spinlock-release global-lock))))])

2
racket/src/cs/rumble/object-name.ss
View File

@ -58,5 +58,5 @@
(and
;; Having an entry in `rtd-props` is a sign that
;; this structure type was created with `make-struct-type`:
(hashtable-contains? rtd-props rtd)
(with-global-lock* (hashtable-contains? rtd-props rtd))
(object-name (record-rtd v)))))

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

@ -92,9 +92,10 @@
pv))
(do-fail fail v)))])]
[(v) (acc v default-fail)])])
(hashtable-set! property-accessors
acc
(cons pred can-impersonate?))
(with-global-lock*
(hashtable-set! property-accessors
acc
(cons pred can-impersonate?)))
(values st
pred
acc)))]))
@ -102,14 +103,14 @@
(define (struct-type-property-accessor-procedure? v)
(and (procedure? v)
(let ([v (strip-impersonator v)])
(hashtable-ref property-accessors v #f))
(with-global-lock* (hashtable-ref property-accessors v #f)))
#t))
(define (struct-type-property-accessor-procedure-pred v)
(car (hashtable-ref property-accessors v #f)))
(car (with-global-lock (hashtable-ref property-accessors v #f))))
(define (struct-type-property-accessor-procedure-can-impersonate? v)
(cdr (hashtable-ref property-accessors v #f)))
(cdr (with-global-lock* (hashtable-ref property-accessors v #f))))
(define (struct-property-ref prop rtd default)
(getprop (record-type-uid rtd) prop default))
@ -360,44 +361,46 @@
(define struct-field-mutators (make-ephemeron-eq-hashtable))
(define (register-struct-constructor! p)
(hashtable-set! struct-constructors p #t))
(with-global-lock* (hashtable-set! struct-constructors p #t)))
(define (register-struct-predicate! p)
(hashtable-set! struct-predicates p #t))
(with-global-lock* (hashtable-set! struct-predicates p #t)))
(define (register-struct-field-accessor! p rtd pos)
(hashtable-set! struct-field-accessors p (cons rtd pos)))
(with-global-lock* (hashtable-set! struct-field-accessors p (cons rtd pos))))
(define (register-struct-field-mutator! p rtd pos)
(hashtable-set! struct-field-mutators p (cons rtd pos)))
(with-global-lock* (hashtable-set! struct-field-mutators p (cons rtd pos))))
(define (struct-constructor-procedure? v)
(and (procedure? v)
(hashtable-ref struct-constructors (strip-impersonator v) #f)))
(let ([v (strip-impersonator v)])
(with-global-lock* (hashtable-ref struct-constructors v #f)))))
(define (struct-predicate-procedure? v)
(and (procedure? v)
(hashtable-ref struct-predicates (strip-impersonator v) #f)))
(let ([v (strip-impersonator v)])
(with-global-lock* (hashtable-ref struct-predicates v #f)))))
(define (struct-accessor-procedure? v)
(and (procedure? v)
(let ([v (strip-impersonator v)])
(or (position-based-accessor? v)
(hashtable-ref struct-field-accessors v #f)))
(with-global-lock* (hashtable-ref struct-field-accessors v #f))))
#t))
(define (struct-mutator-procedure? v)
(and (procedure? v)
(let ([v (strip-impersonator v)])
(or (position-based-mutator? v)
(hashtable-ref struct-field-mutators v #f)))
(with-global-lock* (hashtable-ref struct-field-mutators v #f))))
#t))
(define (struct-accessor-procedure-rtd+pos v)
(hashtable-ref struct-field-accessors v #f))
(with-global-lock* (hashtable-ref struct-field-accessors v #f)))
(define (struct-mutator-procedure-rtd+pos v)
(hashtable-ref struct-field-mutators v #f))
(with-global-lock* (hashtable-ref struct-field-mutators v #f)))
;; ----------------------------------------
@ -498,7 +501,7 @@
(let* ([parent-rtd* (strip-impersonator parent-rtd)]
[parent-props
(if parent-rtd*
(hashtable-ref rtd-props parent-rtd* '())
(with-global-lock* (hashtable-ref rtd-props parent-rtd* '()))
'())]
[all-immutables (if (integer? proc-spec)
(cons proc-spec immutables)
@ -508,12 +511,13 @@
(record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash))
;; Record properties implemented by this type:
(hashtable-set! rtd-props rtd (let ([props (append (map car props) parent-props)])
(if proc-spec
(cons prop:procedure props)
props)))
(let ([props (let ([props (append (map car props) parent-props)])
(if proc-spec
(cons prop:procedure props)
props))])
(with-global-lock* (hashtable-set! rtd-props rtd props)))
(unless (equal? '#() mutables)
(hashtable-set! rtd-mutables rtd mutables))
(with-global-lock* (hashtable-set! rtd-mutables rtd mutables)))
;; Copy parent properties for this type:
(for-each (lambda (prop)
(let loop ([prop prop])
@ -548,9 +552,8 @@
(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))))
(and prefabs
(hash-ref prefabs prefab-key+count #f)))
(define (prefab-key+count->rtd prefab-key+count)
(cond
@ -575,16 +578,15 @@
uid #f #f
(make-fields total-count))]
[mutables (prefab-key-mutables prefab-key)])
(with-interrupts-disabled
(with-global-lock
(cond
[(prefab-ref prefab-key+count)
;; rtd was created concurrently
=> (lambda (rtd) rtd)]
[else
(putprop uid 'prefab-key+count prefab-key+count)
(with-interrupts-disabled ; atomic use of `prefabs` table
(unless prefabs (set! prefabs (make-weak-hash)))
(hash-set! prefabs prefab-key+count rtd))
(unless prefabs (set! prefabs (make-weak-hash)))
(hash-set! prefabs prefab-key+count rtd)
(unless parent-rtd
(record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash))
@ -722,7 +724,7 @@
auto-count
(make-position-based-accessor rtd* parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd* parent-total*-count (+ init-count auto-count))
(mutables->immutables (hashtable-ref rtd-mutables rtd* '#()) init-count)
(mutables->immutables (with-global-lock* (hashtable-ref rtd-mutables rtd* '#())) init-count)
next-rtd*
skipped?))])
(cond
@ -884,7 +886,7 @@
;; ----------------------------------------
(define (struct-type-field-mutable? rtd pos)
(let ([mutables (hashtable-ref rtd-mutables rtd '#())])
(let ([mutables (with-global-lock* (hashtable-ref rtd-mutables rtd '#()))])
(let loop ([j (#%vector-length mutables)])
(cond
[(fx= j 0) #f]

22
racket/src/cs/rumble/thread-local.ss Normal file
View File

@ -0,0 +1,22 @@
;; Use `define-thread-local` for an immutable variable containing a
;; mutable value where the value can be created lazily and isn't #f
(define-syntax-rule (define-thread-local id rhs)
(begin
(define cell (make-thread-parameter #f))
(define (init) rhs)
(define-syntax (id stx)
(...
(syntax-case stx ()
[(id arg ...) #'((thread-local-ref cell init) arg ...)]
[_ #'(thread-local-ref cell init)])))))
(define (thread-local-ref c init)
(let ([v (c)])
(or v
(with-interrupts-disabled
(let ([v (c)])
(or v
(let ([v (init)])
(c v)
v)))))))

8
racket/src/cs/rumble/will-executor.ss
View File

@ -2,16 +2,16 @@
;; Implements a variant of will executors with polling and a callback
;; for when a will becomes ready
(define the-will-guardian (make-guardian))
(define the-stubborn-will-guardian (make-guardian #t))
(define-thread-local the-will-guardian (make-guardian))
(define-thread-local the-stubborn-will-guardian (make-guardian #t))
;; Guardian callbacks are called fifo, but will executors are called
;; lifo. The `will-stacks` tables map a finalized value to a list
;; of finalizers, where each finalizer is an ephemeron pairing a will
;; executor with a will function (so that the function is not retained
;; if the will executor is dropped)
(define the-will-stacks (make-weak-eq-hashtable))
(define the-stubborn-will-stacks (make-weak-eq-hashtable))
(define-thread-local the-will-stacks (make-weak-eq-hashtable))
(define-thread-local the-stubborn-will-stacks (make-weak-eq-hashtable))
(define-record-type (will-executor create-will-executor will-executor?)
(fields guardian will-stacks (mutable ready) notify))