From 8c5eebc51369fd1424d60bb3c3adaee456608e63 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Aug 2018 18:56:39 -0600 Subject: [PATCH] cs: fix races with places in the Rumble layer --- racket/src/cs/Makefile | 1 + racket/src/cs/demo/thread.ss | 2 +- racket/src/cs/rumble.sls | 7 +-- racket/src/cs/rumble/error.ss | 4 +- racket/src/cs/rumble/foreign.ss | 35 +++++++-------- racket/src/cs/rumble/hash-code.ss | 11 ++--- racket/src/cs/rumble/keyword.ss | 13 +++--- racket/src/cs/rumble/list.ss | 2 +- racket/src/cs/rumble/lock.ss | 38 ++++++++++++---- racket/src/cs/rumble/object-name.ss | 2 +- racket/src/cs/rumble/struct.ss | 64 ++++++++++++++------------- racket/src/cs/rumble/thread-local.ss | 22 +++++++++ racket/src/cs/rumble/will-executor.ss | 8 ++-- 13 files changed, 127 insertions(+), 82 deletions(-) create mode 100644 racket/src/cs/rumble/thread-local.ss diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile index 92da74c16f..3b413fae78 100644 --- a/racket/src/cs/Makefile +++ b/racket/src/cs/Makefile @@ -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 \ diff --git a/racket/src/cs/demo/thread.ss b/racket/src/cs/demo/thread.ss index 9098dc3f0f..7014f80075 100644 --- a/racket/src/cs/demo/thread.ss +++ b/racket/src/cs/demo/thread.ss @@ -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)) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index e6bffca1a5..0b2116b7b4 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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") diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index 793fee044e..9f32e2d10a 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -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 () diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index 545dabc8aa..fcdc07847b 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -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]))]))) ;; ---------------------------------------- diff --git a/racket/src/cs/rumble/hash-code.ss b/racket/src/cs/rumble/hash-code.ss index 26be95b83b..d91aeef20f 100644 --- a/racket/src/cs/rumble/hash-code.ss +++ b/racket/src/cs/rumble/hash-code.ss @@ -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 diff --git a/racket/src/cs/rumble/keyword.ss b/racket/src/cs/rumble/keyword.ss index 6038579d3a..16db4d5d96 100644 --- a/racket/src/cs/rumble/keyword.ss +++ b/racket/src/cs/rumble/keyword.ss @@ -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) diff --git a/racket/src/cs/rumble/list.ss b/racket/src/cs/rumble/list.ss index 799f011910..a0a4d917fa 100644 --- a/racket/src/cs/rumble/list.ss +++ b/racket/src/cs/rumble/list.ss @@ -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]) diff --git a/racket/src/cs/rumble/lock.ss b/racket/src/cs/rumble/lock.ss index 2da0efa930..0e7e2729cc 100644 --- a/racket/src/cs/rumble/lock.ss +++ b/racket/src/cs/rumble/lock.ss @@ -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))))]) diff --git a/racket/src/cs/rumble/object-name.ss b/racket/src/cs/rumble/object-name.ss index 42a1e47712..a8bef29e52 100644 --- a/racket/src/cs/rumble/object-name.ss +++ b/racket/src/cs/rumble/object-name.ss @@ -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))))) diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index ca795bd307..deb694a54f 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -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] diff --git a/racket/src/cs/rumble/thread-local.ss b/racket/src/cs/rumble/thread-local.ss new file mode 100644 index 0000000000..98b068a11b --- /dev/null +++ b/racket/src/cs/rumble/thread-local.ss @@ -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))))))) diff --git a/racket/src/cs/rumble/will-executor.ss b/racket/src/cs/rumble/will-executor.ss index 7946b33522..568c82f763 100644 --- a/racket/src/cs/rumble/will-executor.ss +++ b/racket/src/cs/rumble/will-executor.ss @@ -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))