add box-cas! and vector-cas!

original commit: a416f68a7a02c777881f4848599deefb120d33ae

LOG

@@ -971,3 +971,9 @@
   bootstrap failures after small changes like the recent change to
   procedure names, so we don't have to rebuild the boot files as often.
     Mf-base
+- added box-cas! and vector-cas!
+    prims.ss, cpnanopass.ss, np-languages.ss,
+    cmacros.ss, library.ss, primdata.ss
+    x86_64.ss x86.ss, ppc32.ss, arm32.ss,
+    5_6.ms, 5_8.ms, root-experr*,
+    objects.stex, release_notes.stex

csug/objects.stex

@@ -651,6 +651,29 @@ See also the description of fixnum-only vectors (fxvectors) below.
   v) ;=> #(1 2 73 4 5)
 \endschemedisplay
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{vector-cas!}{\categoryprocedure}{(vector-cas! \var{vector} \var{n} \var{old-obj} \var{new-obj})}
+\returns \scheme{#t} if \var{vector} is changed, \scheme{#f} otherwise
+\listlibraries
+\endentryheader
+
+\noindent
+\var{vector} must be mutable.
+\scheme{vector-cas!} atomically changes the \var{n}th element of \var{vector} to \var{new-obj}
+if the replaced \var{n}th element is \scheme{eq?} to \var{old-obj}.
+If the \var{n}th element of \var{vector} that would be replaced
+is not \scheme{eq?} to \var{old-obj}, then
+\var{vector} is unchanged.
+
+\schemedisplay
+(define v (vector 'old0 'old1 'old2))
+(vector-cas! v 1 'old1 'new1) ;=> #t
+(vector-ref v 1) ;=> 'new1
+(vector-cas! v 2 'old1 'new2) ;=> #f
+(vector-ref v 2) ;=> 'old2
+\endschemedisplay
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{mutable-vector?}{\categoryprocedure}{(mutable-vector? \var{obj})}
@@ -1260,6 +1283,28 @@ Any attempt to modify an immutable box causes an exception to be raised.
     (unbox b))) ;=> 4
 \endschemedisplay
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{box-cas!}{\categoryprocedure}{(box-cas! \var{box} \var{old-obj} \var{new-obj})}
+\returns \scheme{#t} if \var{box} is changed, \scheme{#f} otherwise
+\listlibraries
+\endentryheader
+
+\noindent
+\var{box} must be mutable.
+\scheme{box-cas!} atomically changes the content of \var{box} to \var{new-obj}
+if the replaced content is \scheme{eq?} to \var{old-obj}.
+If the content of \var{box} that would be replaced is not \scheme{eq?} to \var{old-obj}, then
+\var{box} is unchanged.
+
+\schemedisplay
+(define b (box 'old))
+(box-cas! b 'old 'new) ;=> #t
+(unbox b) ;=> 'new
+(box-cas! b 'other 'wrong) ;=> #f
+(unbox b) ;=> 'new
+\endschemedisplay
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{mutable-box?}{\categoryprocedure}{(mutable-box? \var{obj})}

mats/5_6.ms

@@ -1220,3 +1220,49 @@
     (error? (fxvector-set! immutable-123-fxvector 0 1))
     (error? (fxvector-fill! immutable-123-fxvector 0))
 )
+
+(mat vector-cas!
+  (begin
+    (define vec1 (vector 1 2 3))
+    (define vec2 (vector 'apple 'banana 'coconut))
+    (eq? 1 (vector-ref vec1 0)))
+  (not (vector-cas! vec1 0 0 1))
+  (eq? 1 (vector-ref vec1 0))
+  (vector-cas! vec1 0 1 4)
+  (eq? 4 (vector-ref vec1 0))
+  (not (vector-cas! vec1 0 1 5))
+
+  (not (vector-cas! vec1 1 0 1))
+  (eq? 2 (vector-ref vec1 1))
+  (vector-cas! vec1 1 2 5)
+  (eq? 5 (vector-ref vec1 1))
+
+  (not (vector-cas! vec2 0 'banana 'donut))
+  (vector-cas! vec2 0 'apple 'donut)
+  (not (vector-cas! vec2 0 'apple 'eclair))
+  (eq? 'donut (vector-ref vec2 0))
+
+  (not (vector-cas! vec2 1 'apple 'fig))
+  (vector-cas! vec2 1 'banana 'fig)
+  (not (vector-cas! vec2 1 'banana 'grape))
+  (eq? 'fig (vector-ref vec2 1))
+
+  (error? (vector-cas! vec1)) ; arity
+  (error? (vector-cas! vec1 1)) ; arity
+  (error? (vector-cas! vec1 1 2)) ; arity
+  (error? (vector-cas! 1 vec1 2 3)) ; not a vector
+  (error? (vector-cas! (vector->immutable-vector vec1) 1 2 3)) ; not a mutable vector
+  (error? (vector-cas! vec1 vec1 2 3)) ; not a fixnum
+  (error? (vector-cas! vec1 (expt 2 100) 2 3)) ; not a fixnum
+  (error? (vector-cas! vec1 -1 2 3)) ; out of range
+  (error? (vector-cas! vec1 5 2 3)) ; out of range
+
+  ;; make sure `vector-cas!` works with GC generations:
+  (begin
+    (collect 0)
+    (let ([g1 (gensym)])
+      (and (vector-cas! vec2 2 'coconut g1)
+           (begin
+             (collect 0)
+             (eq? g1 (vector-ref vec2 2))))))
+)

mats/5_8.ms

@@ -30,3 +30,37 @@
         (set-box! x 4)
         (and (equal? x '#&4) (equal? (unbox x) 4)))
  )
+
+(mat box-cas!
+  (begin
+    (define bx1 (box 1))
+    (define bx2 (box 'apple))
+    (eq? 1 (unbox bx1)))
+  (not (box-cas! bx1 0 1))
+  (eq? 1 (unbox bx1))
+  (box-cas! bx1 1 2)
+  (eq? 2 (unbox bx1))
+
+  (not (box-cas! bx2 #f 'banana))
+  (box-cas! bx2 'apple 'banana)
+  (not (box-cas! bx2 'apple 'banana))
+  (eq? 'banana (unbox bx2))
+
+  (not (box-cas! (box (bitwise-arithmetic-shift-left 1 40))
+                 (bitwise-arithmetic-shift-left 2 40)
+                 'wrong))
+
+  (error? (box-cas! bx1)) ; arity
+  (error? (box-cas! bx1 1)) ; arity
+  (error? (box-cas! 1 bx1 2)) ; not a box
+  (error? (box-cas! (box-immutable 1) 1 2)) ; not a mutable box
+
+  ;; make sure `box-cas!` works with GC generations:
+  (begin
+    (collect 0)
+    (let ([g1 (gensym)])
+      (and (box-cas! bx2 'banana g1)
+           (begin
+             (collect 0)
+             (eq? g1 (unbox bx2))))))
+  )

mats/root-experr-compile-0-f-f-f

@@ -3954,6 +3954,15 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector".
 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector".
 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector".
+5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1)".
+5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1)".
+5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1 2)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1 is not a mutable vector".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1267650600228229401496703205376 is not a valid index for #(4 5 3)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -1 is not a valid index for #(4 5 3)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 5 is not a valid index for #(4 5 3)".
 5_7.mo:Expected error in mat string->symbol: "string->symbol: 3 is not a string".
 5_7.mo:Expected error in mat string->symbol: "string->symbol: a is not a string".
 5_7.mo:Expected error in mat gensym: "gensym: #(a b c) is not a string".
@@ -3976,6 +3985,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol".
 5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol".
 5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol".
+5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1)".
+5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1 1)".
+5_8.mo:Expected error in mat box-cas!: "box-cas!: 1 is not a mutable box".
+5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box".
 6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
 6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
 6.mo:Expected error in mat port-operations: "open-output-file: failed for /nonexistent/directory/nonexistent/file: no such file or directory".

mats/root-experr-compile-2-f-f-f

@@ -3954,6 +3954,15 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector".
 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector".
 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector".
+5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1)".
+5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1)".
+5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1 2)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1 is not a mutable vector".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1267650600228229401496703205376 is not a valid index for #(4 5 3)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -1 is not a valid index for #(4 5 3)".
+5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 5 is not a valid index for #(4 5 3)".
 5_7.mo:Expected error in mat string->symbol: "string->symbol: 3 is not a string".
 5_7.mo:Expected error in mat string->symbol: "string->symbol: a is not a string".
 5_7.mo:Expected error in mat gensym: "gensym: #(a b c) is not a string".
@@ -3976,6 +3985,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol".
 5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol".
 5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol".
+5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1)".
+5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1 1)".
+5_8.mo:Expected error in mat box-cas!: "box-cas!: 1 is not a mutable box".
+5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box".
 6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
 6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
 6.mo:Expected error in mat port-operations: "open-output-file: failed for /nonexistent/directory/nonexistent/file: no such file or directory".

mats/thread.ms

@@ -1486,4 +1486,40 @@
                       (equal? (condition-irritants c) (list 'a)))])
         (p 'a)))
  )
+
+(mat cas
+ (begin
+   (define (check container container-ref container-cas!)
+     (let ([N 1000]
+           [M 4]
+           [done 0]
+           [m (make-mutex)]
+           [c (make-condition)])
+       (define (bump)
+         (let loop ([i 0])
+           (unless (= i N)
+             (let ([v (container-ref container)])
+               (if (container-cas! container v (add1 v))
+                   (loop (add1 i))
+                   (loop i)))))
+         (mutex-acquire m)
+         (set! done (add1 done))
+         (condition-signal c)
+         (mutex-release m))
+       (let loop ([j 0])
+         (when (< j M)
+           (fork-thread bump)
+           (loop (add1 j))))
+       (mutex-acquire m)
+       (let loop ()
+         (cond
+          [(= done M)
+           (mutex-release m)]
+          [else
+           (condition-wait c m)
+           (loop)]))
+       (= (container-ref container) (* M N))))
+   (check (box 0) unbox box-cas!))
+ (check (vector 1 0 2) (lambda (v) (vector-ref v 1)) (lambda (v o n) (vector-cas! v 1 o n))))
+
 )

release_notes/release_notes.stex

@@ -58,6 +58,14 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
+\subsection{Atomic compare-and-set (9.5.1)}
+
+The new procedures \scheme{box-cas!} and \scheme{vector-cas!}
+atomically update a box or vector with a given new value when the
+current content is \scheme{eq?} to a given old value. Atomicity is
+guaranteed even if multiple threads attempt to update the same box or
+vector.
+
 \subsection{Foreign-procedure thread activation (9.5.1)}
 
 A new \scheme{__collect_safe} foreign-procedure convention, which can

s/arm32.ss

@@ -845,7 +845,16 @@
              (seq
                `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
                `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
-               `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]))
+               `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))])
+    (define-instruction effect (cas)
+      [(op (x ur) (y ur) (w funky12) (old ur) (new ur))
+       (lea->reg x y w
+         (lambda (r)
+	   (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
+             (seq
+               `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
+               `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
+	       `(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))
 
   (define-instruction effect (pause)
     ; NB: user sqrt or something like that?
@@ -888,7 +897,7 @@
                      asm-indirect-call asm-condition-code
                      asm-fl-load/store 
                      asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc 
-                     asm-lock asm-lock+/-
+                     asm-lock asm-lock+/- asm-cas
                      asm-flop-2 asm-flsqrt asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
@@ -1956,6 +1965,22 @@
                 [(locked-decr!) (emit subi #f tmp1 tmp1 1 code*)]
                 [else (sorry! who "unexpected op ~s" op)])))))))
 
+  (define-who asm-cas
+    ;   tmp = ldrex src
+    ;   cmp tmp, old
+    ;   bne L (+2)
+    ;   tmp2 = strex new, src
+    ;   cmp tmp2, 0
+    ; L:
+    (lambda (code* src old new tmp1 tmp2)
+      (Trivit (src old new tmp1 tmp2)
+        (emit ldrex tmp1 src
+          (emit cmp tmp1 old
+            (emit bnei 1
+              (emit strex tmp2 new src
+                (emit cmpi tmp2 0
+                   code*))))))))
+
   (define asm-fl-relop
     (lambda (info)
       (lambda (l1 l2 offset x y)

s/cmacros.ss

@@ -2340,6 +2340,7 @@
      (cdr #f 1 #t #t)
      (unbox #f 1 #t #t)
      (set-box! #f 2 #t #t)
+     (box-cas! #f 3 #t #t)
      (= #f 2 #f #t)
      (< #f 2 #f #t)
      (> #f 2 #f #t)
@@ -2423,6 +2424,7 @@
      (map2 #f 3 #f #t)
      (for-each1 #f 2 #f #t)
      (vector-ref #f 2 #t #t)
+     (vector-cas! #f 4 #t #t)
      (vector-set! #f 3 #t #t)
      (vector-length #f 1 #t #t)
      (string-ref #f 2 #t #t)

s/cpnanopass.ss

@@ -2974,11 +2974,14 @@
         (define build-dirty-store
           (case-lambda
             [(base offset e) (build-dirty-store base %zero offset e)]
-            [(base index offset e)
+            [(base index offset e) (build-dirty-store base index offset e
+                                     (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e))
+                                     (lambda (s r) `(seq ,s ,r)))]
+            [(base index offset e build-assign build-seq)
              (if (nanopass-case (L7 Expr) e
                    [(quote ,d) (ptr->imm d)]
                    [else #f])
-                 `(set! ,(%mref ,base ,index ,offset) ,e)
+                 (build-assign base index offset e)
                  (let ([a (if (eq? index %zero)
                               (%lea ,base offset)
                               (%lea ,base ,index offset))])
@@ -2990,17 +2993,28 @@
                        (bind #f ([e e])
                          ; eval a second so the address is not live across any calls
                          (bind #t ([a a])
-                           `(seq
+                           (build-seq
-                              (set! ,(%mref ,a 0) ,e)
+                             (build-assign a %zero 0 e)
-                              ,(%inline remember ,a))))
+                             (%inline remember ,a))))
                        (bind #t ([e e])
                          ; eval a second so the address is not live across any calls
                          (bind #t ([a a])
-                           `(seq
+                           (build-seq
-                              (set! ,(%mref ,a 0) ,e)
+                             (build-assign a %zero 0 e)
-                              (if ,(%type-check mask-fixnum type-fixnum ,e)
+                             `(if ,(%type-check mask-fixnum type-fixnum ,e)
                                   ,(%constant svoid)
                                   ,(%inline remember ,a))))))))]))
+        (define make-build-cas
+          (lambda (old-v)
+            (lambda (base index offset v)
+              `(seq
+                ,(%inline cas ,base ,index (immediate ,offset) ,old-v ,v)
+                (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code)))))
+        (define build-cas-seq
+          (lambda (cas remember)
+            `(if ,cas
+                 (seq ,remember ,(%constant strue))
+                 ,(%constant sfalse))))
         (define build-$record
           (lambda (tag args)
             (bind #f (tag)
@@ -5063,6 +5077,10 @@
           [(e1 e2) (build-dirty-store e1 (constant pair-cdr-disp) e2)])
         (define-inline 3 set-box!
           [(e1 e2) (build-dirty-store e1 (constant box-ref-disp) e2)])
+        (define-inline 3 box-cas!
+          [(e1 e2 e3)
+           (bind #t (e2)
+             (build-dirty-store e1 %zero (constant box-ref-disp) e3 (make-build-cas e2) build-cas-seq))])
         (define-inline 3 $set-symbol-name!
           [(e1 e2) (build-dirty-store e1 (constant symbol-name-disp) e2)])
         (define-inline 3 $set-symbol-property-list!
@@ -5079,6 +5097,12 @@
              `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
                   ,(build-dirty-store e-box (constant box-ref-disp) e-new)
                   ,(build-libcall #t src sexpr set-box! e-box e-new)))])
+        (define-inline 2 box-cas!
+          [(e-box e-old e-new)
+           (bind #t (e-box e-old e-new)
+             `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
+                  ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq)
+                  ,(build-libcall #t src sexpr box-cas! e-box e-old e-new)))])
         (define-inline 2 set-car!
           [(e-pair e-new)
            (bind #t (e-pair e-new)
@@ -7884,6 +7908,21 @@
                       ,(build-libcall #t src sexpr vector-set! e-v e-i e-new)))])
             (define-inline 3 $vector-set-immutable!
               [(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)]))
+          (let ()
+            (define (go e-v e-i e-old e-new)
+              (nanopass-case (L7 Expr) e-i
+                [(quote ,d)
+                 (guard (target-fixnum? d))
+                 (build-dirty-store e-v %zero (+ (fix d) (constant vector-data-disp)) e-new (make-build-cas e-old) build-cas-seq)]
+                [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new (make-build-cas e-old) build-cas-seq)]))
+            (define-inline 3 vector-cas!
+              [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])
+            (define-inline 2 vector-cas!
+              [(e-v e-i e-old e-new)
+               (bind #t (e-v e-i e-old e-new)
+                 `(if ,(build-vector-set!-check e-v e-i #f)
+                      ,(go e-v e-i e-old e-new)
+                      ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new)))]))
           (let ()
             (define (go e-v e-i e-new)
               `(set!

s/library.ss

@@ -304,6 +304,11 @@
   (define-library-entry (vector-length v)
     (vector-oops 'vector-length v))
 
+  (define-library-entry (vector-cas! v i old-x new-x)
+    (if (mutable-vector? v)
+        (index-oops 'vector-cas! v i)
+        (mutable-vector-oops 'vector-cas! v)))
+
   (define-library-entry (fxvector-ref v i)
     (if (fxvector? v)
         (index-oops 'fxvector-ref v i)
@@ -416,6 +421,9 @@
 (define-library-entry (set-box! b v)
   ($oops 'set-box! "~s is not a mutable box" b))
 
+(define-library-entry (box-cas! b old-v new-v)
+  ($oops 'box-cas! "~s is not a mutable box" b))
+
 (let ()
 (define (fxnonfixnum1 who x)
   ($oops who "~s is not a fixnum" x))

s/np-languages.ss

@@ -520,6 +520,7 @@
   (declare-primitive store-with-update effect #f) ; ppc
   (declare-primitive unactivate-thread effect #f) ; threaded version only
   (declare-primitive vpush-multiple effect #f) ; arm
+  (declare-primitive cas effect #f)
 
   (declare-primitive < pred #t)
   (declare-primitive <= pred #t)

s/ppc32.ss

@@ -786,7 +786,15 @@
            (let ([u (make-tmp 'u)])
              (seq
                `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
-               `(asm ,null-info ,(asm-lock+/- op) ,base ,index ,u)))))]))
+               `(asm ,null-info ,(asm-lock+/- op) ,base ,index ,u)))))])
+    (define-instruction effect (cas)
+      [(op (x ur) (y ur) (w shifted-integer16 integer16) (old ur) (new ur))
+       (lea->reg x y w
+         (lambda (base index)
+	   (let ([u (make-tmp 'u)])
+             (seq
+               `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+	       `(asm ,info ,asm-cas ,base ,index ,old ,new ,u)))))]))
 
   (define-instruction effect (pause)
     [(op) `(asm ,info ,asm-isync)])
@@ -831,7 +839,7 @@
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
                      asm-indirect-call asm-condition-code
                      asm-trunc asm-flt
-                     asm-lock asm-lock+/-
+                     asm-lock asm-lock+/- asm-cas
                      asm-fl-load/store
                      asm-flop-2 asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
@@ -1777,6 +1785,21 @@
                   (emit bne -3 
                     (emit cmpi tmp `(imm 0) code*))))))))))
 
+  (define-who asm-cas
+    ;   tmp = lwarx [base,index] 
+    ;   cmp tmp, old
+    ;   bc (ne) L 2
+    ;   stwcx. new [base,index] -- also sets condition code
+    ; L:
+    (lambda (code* base index old new tmp)
+      (assert (not (eq? tmp %real-zero)))
+      (Trivit (base index old new tmp)
+        (emit lwarx tmp base index
+          (emit cmpl tmp old
+            (emit bne 2
+              (emit stwcx. new base index
+                code*)))))))
+
   (define asm-fl-relop
     (lambda (info)
       (lambda (l1 l2 offset x y)

s/primdata.ss

@@ -1140,6 +1140,7 @@
   (block-write [sig [(textual-output-port string) (textual-output-port string length) -> (void)]] [flags true])
   (box [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
+  (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags])
   (box-immutable [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (break [sig [(ptr ...) -> (ptr ...)]] [flags])
   (bwp-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
@@ -1686,6 +1687,7 @@
   (utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument
   (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
   (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
+  (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags])
   (vector-copy [sig [(vector) -> (vector)]] [flags alloc])
   (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc])
   (vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])

s/prims.ss

@@ -1070,6 +1070,10 @@
    (lambda (v i x)
       (#2%vector-set! v i x)))
 
+(define vector-cas!
+   (lambda (v i old-x new-x)
+      (#2%vector-cas! v i old-x new-x)))
+
 (define vector-set-fixnum!
   (lambda (v i x)
     (#2%vector-set-fixnum! v i x)))
@@ -1148,6 +1152,12 @@
           (set-box! b v)
           ($oops 'set-box! "~s is not a mutable box" b))))
 
+(define-who box-cas!
+   (lambda (b old-v new-v)
+      (if (mutable-box? b)
+          (box-cas! b old-v new-v)
+          ($oops who "~s is not a mutable box" b))))
+
 (define mutable-box?
   (lambda (b)
     (#3%mutable-box? b)))

s/x86.ss

@@ -882,6 +882,15 @@
     [(op (x ur) (y ur) (w imm32))
      `(asm ,info ,asm-locked-decr ,x ,y ,w)])
 
+  (define-instruction effect (cas)
+    [(op (x ur) (y ur) (w imm32) (old ur) (new ur))
+     (let ([ueax (make-precolored-unspillable 'ueax %eax)])
+       (with-output-language (L15d Effect)
+         (seq
+           `(set! ,(make-live-info) ,ueax ,old)
+           ;; NB: may modify %eax:
+           `(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,ueax ,new))))])
+
   (define-instruction effect (pause)
     [(op) `(asm ,info ,asm-pause)])
 
@@ -931,7 +940,7 @@
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
                      asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
                      asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
-                     asm-exchange asm-pause asm-locked-incr asm-locked-decr
+                     asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
                      asm-flop-2 asm-flsqrt asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
@@ -1077,6 +1086,8 @@
   (define-op locked-dec (b *) locked-unary-op #b1111111 #b001)
   (define-op locked-inc (b *) locked-unary-op #b1111111 #b000)
 
+  (define-op locked-cmpxchg (*) locked-cmpxchg-op)
+
   ; also do inc-reg dec-reg
 
   (define-op call      jump-op #b010)
@@ -1224,6 +1235,20 @@
         (ax-ea-sib dest-ea)
         (ax-ea-addr-disp dest-ea))))
 
+  (define locked-cmpxchg-op
+    (lambda (op size dest-ea new-reg code*)
+      (begin
+        (emit-code (op dest-ea new-reg code*)
+          (build byte #xf0) ; lock prefix
+          (build byte #x0f)
+          (build byte
+            (byte-fields
+              [1 #b1011000]
+              [0 (ax-size-code size)]))
+          (ax-ea-modrm-reg dest-ea new-reg)
+          (ax-ea-sib dest-ea)
+          (ax-ea-addr-disp dest-ea)))))
+
   (define pushil-op
     (lambda (op imm-ea code*)
       (if (ax-range? -128 imm-ea 127)
@@ -1914,6 +1939,11 @@
       (let ([dest (build-mem-opnd base index offset)])
         (emit locked-dec dest code*))))
 
+  (define asm-locked-cmpxchg
+    (lambda (code* base index offset old-v new-v)
+      (let ([dest (build-mem-opnd base index offset)])
+        (emit locked-cmpxchg dest (cons 'reg new-v) code*))))
+
   (define asm-pause
     (lambda (code*)
       (emit pause code*)))

s/x86_64.ss

@@ -939,6 +939,15 @@
     [(op (x ur) (y ur) (w imm32))
      `(asm ,info ,asm-locked-decr ,x ,y ,w)])
 
+  (define-instruction effect (cas)
+    [(op (x ur) (y ur) (w imm32) (old ur) (new ur))
+     (let ([urax (make-precolored-unspillable 'urax %rax)])
+       (with-output-language (L15d Effect)
+         (seq
+           `(set! ,(make-live-info) ,urax ,old)
+           ;; NB: may modify %rax:
+           `(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,urax ,new))))])
+
   (define-instruction effect (pause)
     [(op) `(asm ,info ,asm-pause)])
 
@@ -989,7 +998,7 @@
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
                      asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
                      asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
-                     asm-exchange asm-pause asm-locked-incr asm-locked-decr
+                     asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
                      asm-flop-2 asm-flsqrt asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
@@ -1127,6 +1136,8 @@
   (define-op locked-dec (#;b *) locked-unary-op #b1111111 #b001)
   (define-op locked-inc (#;b *) locked-unary-op #b1111111 #b000)
 
+  (define-op locked-cmpxchg (*) locked-cmpxchg-op)
+
   ; also do inc-reg dec-reg
 
   ; the following are forms of the call instruction and push the return address
@@ -1270,6 +1281,21 @@
         (ax-ea-sib dest-ea)
         (ax-ea-addr-disp dest-ea))))
 
+  (define locked-cmpxchg-op
+    (lambda (op size dest-ea new-reg code*)
+      (begin
+        (emit-code (op dest-ea new-reg code*)
+          (build byte #xf0) ; lock prefix
+          (ax-ea-rex (if (eq? size 'quad) 1 0) dest-ea new-reg size)
+          (build byte #x0f)
+          (build byte
+            (byte-fields
+              [1 #b1011000]
+              [0 (ax-size-code size)]))
+          (ax-ea-modrm-reg dest-ea new-reg)
+          (ax-ea-sib dest-ea)
+          (ax-ea-addr-disp dest-ea)))))
+
   (define pushi-op
     (lambda (op imm-ea code*)
       (if (ax-range? -128 imm-ea 127)
@@ -2019,6 +2045,11 @@
       (let ([dest (build-mem-opnd base index offset)])
         (emit locked-dec dest code*))))
 
+  (define asm-locked-cmpxchg
+    (lambda (code* base index offset old-v new-v)
+      (let ([dest (build-mem-opnd base index offset)])
+        (emit locked-cmpxchg dest (cons 'reg new-v) code*))))
+
   (define asm-pause
     (lambda (code*)
       (emit pause code*)))