expander & thread: accomodate spurious failure from CAS

racket/src/expander/compile/header.rkt

@@ -122,9 +122,16 @@
                                ,(add-module-path-index! mpis self)
                                ,self-id
                                ,inspector-id)])
+                  ;; loop in case of spurious CAS failure
+                  (letrec-values ([(loop)
+                                   (lambda ()
                                      (begin
                                        (vector-cas! ,syntax-literals-id pos #f stx)
-                    (unsafe-vector*-ref ,syntax-literals-id pos))))))))))
+                                       (let-values ([(stx) (unsafe-vector*-ref ,syntax-literals-id pos)])
+                                         (if stx
+                                             stx
+                                             (loop)))))])
+                    (loop))))))))))
 
 ;; Generate on-demand deserialization (shared across instances); the
 ;; result defines `deserialize-syntax-id`

racket/src/racket/src/startup.inc

@@ -30709,10 +30709,22 @@ static const char *startup_source =
 "(add-module-path-index! mpis_0 self_0)"
 " self-id"
 " inspector-id)))"
+"(list*"
+" 'letrec-values"
+"(list"
+"(list"
+" '(loop)"
+"(list"
+" 'lambda"
+" '()"
 "(list"
 " 'begin"
 "(list* 'vector-cas! syntax-literals-id '(pos #f stx))"
-"(list* 'unsafe-vector*-ref syntax-literals-id '(pos))))))))))))))))))))"
+"(list*"
+" 'let-values"
+"(list(list '(stx)(list* 'unsafe-vector*-ref syntax-literals-id '(pos))))"
+" '((if stx stx(loop))))))))"
+" '((loop))))))))))))))))))))"
 "(define-values"
 "(generate-lazy-syntax-literals-data!)"
 "(lambda(sl_0 mpis_0)"

racket/src/schemify/path-and-fasl.rkt

@@ -138,9 +138,20 @@
                      (fasl->s-exp v
                                   #:datum-intern? #t
                                   #:external-lifts (to-fasl-lifts tf))))
-        (box-cas! vb v v2)
+        (let loop ()
+          (cond
+            [(box-cas! vb v v2)
              (set-to-fasl-wrt! tf #f)
-        (unbox vb)]
+             v2]
+            [else
+             (let ([v (unbox vb)])
+               (cond
+                 [(bytes? v)
+                  ;; must be a spurious CAS failure
+                  (loop)]
+                 [else
+                  ;; other thread beat us to it
+                  v]))]))]
        [else
         ;; already forced (or never fasled)
         v])]))

racket/src/thread/future.rkt

@@ -653,7 +653,10 @@
 
 ;; lock-free synchronization to check whether the box content is #f
 (define (worker-pinged? w)
-  (box-cas! (worker-ping w) #t #t))
+  (cond
+    [(box-cas! (worker-ping w) #t #t) #t]
+    [(box-cas! (worker-ping w) #f #f) #f]
+    [else (worker-pinged? w)]))
 
 ;; called with scheduler lock
 (define (check-in w)

racket/src/thread/place.rkt

@@ -155,7 +155,7 @@
    (host:mutex-release (place-lock p))))
 
 (define (place-has-activity! p)
-  (box-cas! (place-activity-canary p) #f #t)
+  (set-box! (place-activity-canary p) #t)
   (sandman-wakeup (place-wakeup-handle p)))
 
 (void
@@ -163,8 +163,8 @@
   ;; Called in atomic mode by scheduler
   (lambda (callbacks)
     (define p current-place)
-    (unless (box-cas! (place-activity-canary p) #f #f)
+    (when (unbox (place-activity-canary p))
-      (box-cas! (place-activity-canary p) #t #f)
+      (set-box! (place-activity-canary p) #f)
       (host:mutex-acquire (place-lock p))
       (define queued-result (place-queued-result p))
       (define break (place-pending-break p))