expander: avoid race on multi-scope -> scope table

Although extremely unlikely, it was possible for multiple Racket
threads operating on the same scopes to race on a multi-scope's table
mapping phase levels to scopes.

Also, for some some mutable hash tables that will be shared across
places as read-only in Racket CS, make sure they are definitely set up
for iteration.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.4.0.13")
+(define version "7.4.0.14")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

racket/src/cs/expander.sls

@@ -66,6 +66,7 @@
          (let ([ht (make-hasheq)])
            (hash-set! ht 'prim prim)
            ...
+           (unsafe-hash-seal! ht)
            ht))]))
 
   (include "primitive/kernel.ss")

racket/src/cs/linklet.sls

@@ -243,6 +243,7 @@
      (lambda (table)
        (hash-for-each (cdr table) (lambda (k v) (hash-set! primitives k v))))
      tables)
+    (unsafe-hash-seal! primitives)
     ;; prropagate table to the rumble layer
     (install-primitives-table! primitives))
   

racket/src/cs/rumble.sls

@@ -270,6 +270,7 @@
           unsafe-weak-hash-iterate-first unsafe-weak-hash-iterate-next
           unsafe-weak-hash-iterate-key unsafe-weak-hash-iterate-value
           unsafe-weak-hash-iterate-key+value unsafe-weak-hash-iterate-pair
+          unsafe-hash-seal!    ; not exported to racket
 
           hash? hash-eq? hash-equal? hash-eqv? hash-weak? immutable-hash?
           hash-count

racket/src/cs/rumble/hash.ss

@@ -238,6 +238,11 @@
                 ht))))]
    [else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)]))
 
+(define/who (unsafe-hash-seal! ht)
+  (check who eq-mutable-hash? ht)
+  (prepare-iterate! ht (hash-count ht))
+  (set-locked-iterable-hash-lock! ht #f))
+
 (define (hash-eq? ht)
   (cond
    [(mutable-hash? ht) (eq-mutable-hash? ht)]

racket/src/cs/rumble/lock.ss

@@ -57,13 +57,11 @@
     (make-scheduler-lock)]
    [else #f]))
 
-(define lock-acquire
-  (case-lambda
-   [(lock)
-    (cond
-     [(not lock) (disable-interrupts)]
-     [else
-      (scheduler-lock-acquire lock)])]))
+(define (lock-acquire lock)
+  (cond
+   [(not lock) (disable-interrupts)]
+   [else
+    (scheduler-lock-acquire lock)]))
 
 (define (lock-release lock)
   (cond

racket/src/expander/syntax/scope.rkt

@@ -163,7 +163,7 @@
 ;; be small.
 (struct multi-scope (id       ; identity
                      name     ; for debugging
-                     scopes   ; phase -> representative-scope
+                     scopes   ; box of table: phase -> representative-scope
                      shifted  ; box of table: interned shifted-multi-scopes for non-label phases
                      label-shifted) ; box of table: interned shifted-multi-scopes for label phases
   #:authentic
@@ -174,10 +174,9 @@
     ;; Prune to reachable representative scopes
     (define multi-scope-tables (serialize-state-multi-scope-tables state))
     (ser-push! (or (hash-ref multi-scope-tables (multi-scope-scopes ms) #f)
-                   (let ([ht (make-hasheqv)])
-                     (for ([(phase sc) (in-hash (multi-scope-scopes ms))])
-                       (when (set-member? (serialize-state-reachable-scopes state) sc)
-                         (hash-set! ht phase sc)))
+                   (let ([ht (for/hasheqv ([(phase sc) (in-hash (unbox (multi-scope-scopes ms)))]
+                                           #:when (set-member? (serialize-state-reachable-scopes state) sc))
+                               (values phase sc))])
                      (hash-set! multi-scope-tables (multi-scope-scopes ms) ht)
                      ht))))
   #:property prop:reach-scopes
@@ -199,12 +198,12 @@
     ;; To make that work, `binding-table-register-reachable`
     ;; needs to recognize representative scopes and treat
     ;; them differently, hence `prop:implicitly-reachable`.
-    (for ([sc (in-hash-values (multi-scope-scopes ms))])
+    (for ([sc (in-hash-values (unbox (multi-scope-scopes ms)))])
       (unless (binding-table-empty? (scope-binding-table sc))
         (reach sc)))))
 
 (define (deserialize-multi-scope name scopes)
-  (multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash))))
+  (multi-scope (new-deserialize-scope-id!) name (box scopes) (box (hasheqv)) (box (hash))))
 
 (struct representative-scope scope (owner   ; a multi-scope for which this one is a phase-specific identity
                                     phase)  ; phase of this scope
@@ -340,19 +339,21 @@
            (ephemeron-value new))))))
 
 (define (new-multi-scope [name #f])
-  (intern-shifted-multi-scope 0 (multi-scope (new-scope-id!) name (make-hasheqv) (box (hasheqv)) (box (hash)))))
+  (intern-shifted-multi-scope 0 (multi-scope (new-scope-id!) name (box (hasheqv)) (box (hasheqv)) (box (hash)))))
 
 (define (multi-scope-to-scope-at-phase ms phase)
   ;; Get the identity of `ms` at phase`
-  (or (hash-ref (multi-scope-scopes ms) phase #f)
-      (let ([s (representative-scope (if (deserialized-scope-id? (multi-scope-id ms))
-                                         (new-deserialize-scope-id!)
-                                         (new-scope-id!))
-                                     'module
-                                     empty-binding-table
-                                     ms phase)])
-        (hash-set! (multi-scope-scopes ms) phase s)
-        s)))
+  (let ([scopes (unbox (multi-scope-scopes ms))])
+    (or (hash-ref scopes phase #f)
+        (let ([s (representative-scope (if (deserialized-scope-id? (multi-scope-id ms))
+                                           (new-deserialize-scope-id!)
+                                           (new-scope-id!))
+                                       'module
+                                       empty-binding-table
+                                       ms phase)])
+          (if (box-cas! (multi-scope-scopes ms) scopes (hash-set scopes phase s))
+              s
+              (multi-scope-to-scope-at-phase ms phase))))))
 
 (define (scope>? sc1 sc2)
   ((scope-id sc1) . > . (scope-id sc2)))

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 4
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 13
+#define MZSCHEME_VERSION_W 14
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x

racket/src/racket/src/startup.inc

@@ -8684,7 +8684,7 @@ static const char *startup_source =
 " prop:scope-with-bindings"
 "(lambda(ms_0 get-reachable-scopes_0 reach_0 register-trigger_0)"
 "(begin"
-"(let-values(((ht_0)(multi-scope-scopes ms_0)))"
+"(let-values(((ht_0)(unbox(multi-scope-scopes ms_0))))"
 "(begin"
 "(if(variable-reference-from-unsafe?(#%variable-reference))"
 "(void)"
@@ -8727,45 +8727,54 @@ static const char *startup_source =
 "(let-values(((or-part_0)(hash-ref multi-scope-tables_0(multi-scope-scopes ms_0) #f)))"
 "(if or-part_0"
 " or-part_0"
-"(let-values(((ht_0)(make-hasheqv)))"
-"(begin"
-"(let-values(((ht_1)(multi-scope-scopes ms_0)))"
+"(let-values(((ht_0)"
+"(let-values(((ht_0)(unbox(multi-scope-scopes ms_0))))"
 "(begin"
 "(if(variable-reference-from-unsafe?(#%variable-reference))"
 "(void)"
-"(let-values()(check-in-hash ht_1)))"
+"(let-values()(check-in-hash ht_0)))"
 "((letrec-values(((for-loop_0)"
-"(lambda(i_0)"
+"(lambda(table_0 i_0)"
 "(begin"
 " 'for-loop"
 "(if i_0"
 "(let-values(((phase_0 sc_0)"
-"(hash-iterate-key+value ht_1 i_0)))"
-"(let-values((()"
-"(let-values()"
-"(let-values((()"
-"(let-values()"
-"(begin"
-"(let-values()"
+"(hash-iterate-key+value"
+" ht_0"
+" i_0)))"
+"(let-values(((table_1)"
+"(let-values(((table_1)"
+" table_0))"
 "(if(set-member?"
 "(serialize-state-reachable-scopes"
 " state_0)"
 " sc_0)"
+"(let-values(((table_2)"
+" table_1))"
+"(let-values(((table_3)"
 "(let-values()"
-"(hash-set!"
-" ht_0"
+"(let-values(((key_0"
+" val_0)"
+"(let-values()"
+"(values"
 " phase_0"
-" sc_0))"
-"(void)))"
-"(values)))))"
-"(values)))))"
+" sc_0))))"
+"(hash-set"
+" table_2"
+" key_0"
+" val_0)))))"
+"(values table_3)))"
+" table_1))))"
 "(if(not #f)"
-"(for-loop_0(hash-iterate-next ht_1 i_0))"
-"(values))))"
-"(values))))))"
+"(for-loop_0"
+" table_1"
+"(hash-iterate-next ht_0 i_0))"
+" table_1)))"
+" table_0)))))"
 " for-loop_0)"
-"(hash-iterate-first ht_1))))"
-"(void)"
+" '#hasheqv()"
+"(hash-iterate-first ht_0))))))"
+"(begin"
 "(hash-set! multi-scope-tables_0(multi-scope-scopes ms_0) ht_0)"
 " ht_0)))))))))))"
 "(current-inspector)"
@@ -8785,7 +8794,7 @@ static const char *startup_source =
 "(define-values"
 "(deserialize-multi-scope)"
 "(lambda(name_0 scopes_0)"
-"(begin(multi-scope3.1(new-deserialize-scope-id!) name_0 scopes_0(box(hasheqv))(box(hash))))))"
+"(begin(multi-scope3.1(new-deserialize-scope-id!) name_0(box scopes_0)(box(hasheqv))(box(hash))))))"
 "(define-values"
 "(struct:representative-scope"
 " representative-scope4.1"
@@ -9001,23 +9010,28 @@ static const char *startup_source =
 "(let-values()"
 "(intern-shifted-multi-scope"
 " 0"
-"(multi-scope3.1(new-scope-id!) name_0(make-hasheqv)(box(hasheqv))(box(hash))))))))))"
+"(multi-scope3.1(new-scope-id!) name_0(box(hasheqv))(box(hasheqv))(box(hash))))))))))"
 "(case-lambda(()(begin(new-multi-scope8_0 #f)))((name7_0)(new-multi-scope8_0 name7_0)))))"
 "(define-values"
 "(multi-scope-to-scope-at-phase)"
 "(lambda(ms_0 phase_0)"
 "(begin"
-"(let-values(((or-part_0)(hash-ref(multi-scope-scopes ms_0) phase_0 #f)))"
+"(let-values(((scopes_0)(unbox(multi-scope-scopes ms_0))))"
+"(let-values(((or-part_0)(hash-ref scopes_0 phase_0 #f)))"
 "(if or-part_0"
 " or-part_0"
 "(let-values(((s_0)"
 "(representative-scope4.1"
-"(if(deserialized-scope-id?(multi-scope-id ms_0))(new-deserialize-scope-id!)(new-scope-id!))"
+"(if(deserialized-scope-id?(multi-scope-id ms_0))"
+"(new-deserialize-scope-id!)"
+"(new-scope-id!))"
 " 'module"
 " empty-binding-table"
 " ms_0"
 " phase_0)))"
-"(begin(hash-set!(multi-scope-scopes ms_0) phase_0 s_0) s_0)))))))"
+"(if(box-cas!(multi-scope-scopes ms_0) scopes_0(hash-set scopes_0 phase_0 s_0))"
+" s_0"
+"(multi-scope-to-scope-at-phase ms_0 phase_0)))))))))"
 "(define-values(scope>?)(lambda(sc1_0 sc2_0)(begin(>(scope-id sc1_0)(scope-id sc2_0)))))"
 "(define-values(scope<?)(lambda(sc1_0 sc2_0)(begin(<(scope-id sc1_0)(scope-id sc2_0)))))"
 "(define-values"