cs: fix races with places in the Rumble layer

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 \

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))

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")

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 ()

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-thread-local 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-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
+  (with-global-lock
-   (mutex-acquire process-table-lock)
+   (cond
-   (let ([result (cond
+    [(not val)
-                  [(not val)
+     (hashtable-ref process-global-table key #f)]
-                   (hashtable-ref process-global-table key #f)]
+    [else
-                  [else
+     (let ([old-val (hashtable-ref process-global-table key #f)])
-                   (let ([old-val (hashtable-ref process-global-table key #f)])
+       (cond
-                     (cond
+        [(not old-val)
-                      [(not old-val)
+         (hashtable-set! process-global-table key val)
-                       (hashtable-set! process-global-table key val)
+         #f]
-                       #f]
+        [else old-val]))])))
-                      [else old-val]))])])
-     (mutex-release process-table-lock)
-     result)))
 
 ;; ----------------------------------------
 

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)
+    (with-global-lock
-        (let ([c (fx1+ counter)])
+     (or (eq-hashtable-ref codes x #f)
-          (set! counter c)
+         (let ([c (fx1+ counter)])
-          (eq-hashtable-set! codes x counter)
+           (set! counter c)
-          c))]))
+           (eq-hashtable-set! codes x counter)
+           c)))]))
 
 ;; Mostly copied from Chez Scheme's "newhash.ss":
 (define number-hash

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)])
+    (with-global-lock
-      (or (and e
+     (let ([e (eq-hashtable-ref keywords sym #f)])
-               (ephemeron-value e))
+       (or (and e
-          (let ([kw (make-keyword sym)])
+                (ephemeron-value e))
-            (eq-hashtable-set! keywords sym (make-ephemeron sym kw))
+           (let ([kw (make-keyword sym)])
-            kw)))))
+             (eq-hashtable-set! keywords sym (make-ephemeron sym kw))
+             kw))))))
 
 (define/who (keyword->string kw)
   (check who keyword? kw)

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])

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-acquire (lambda (l) (#%void)))
-(define scheduler-lock-release (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))))])

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)))))

racket/src/cs/rumble/struct.ss

@@ -92,9 +92,10 @@
                                  pv))
                            (do-fail fail v)))])]
                   [(v) (acc v default-fail)])])
-         (hashtable-set! property-accessors
+         (with-global-lock*
-                         acc
+          (hashtable-set! property-accessors
-                         (cons pred can-impersonate?))
+                          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)])
+          (let ([props (let ([props (append (map car props) parent-props)])
-                                          (if proc-spec
+                         (if proc-spec
-                                              (cons prop:procedure props)
+                             (cons prop:procedure props)
-                                              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
-   (and prefabs
+       (hash-ref prefabs prefab-key+count #f)))
-        (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)))
-          (unless prefabs (set! prefabs (make-weak-hash)))
+         (hash-set! prefabs prefab-key+count rtd)
-          (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]

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)))))))

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-thread-local the-will-guardian (make-guardian))
-(define the-stubborn-will-guardian (make-guardian #t))
+(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-thread-local the-will-stacks (make-weak-eq-hashtable))
-(define the-stubborn-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))