master: Add sb-vm:%atomic-exchange

The branch "master" has been updated in SBCL:
       via  341713c776046393dfe3dc15031c7ca3fde8488c (commit)
      from  0a17885e2733eea227cf5b5d404cd5bb8bbd8c2e (commit)

- Log -----------------------------------------------------------------
commit 341713c776046393dfe3dc15031c7ca3fde8488c
Author: Douglas Katzman <[email protected]>
Date:   Wed Aug 5 20:53:48 2026 +0000

    Add sb-vm:%atomic-exchange
---
 src/code/setf-funs.lisp       | 40 ++++++++++++++++++++++++++++++++++++++++
 src/compiler/arm64/insts.lisp |  5 +++++
 tests/atomic-xchg.pure.lisp   | 28 ++++++++++++++++++++++++++++
 3 files changed, 73 insertions(+)

diff --git a/src/code/setf-funs.lisp b/src/code/setf-funs.lisp
index 1750e76bf..ab49e56f0 100644
--- a/src/code/setf-funs.lisp
+++ b/src/code/setf-funs.lisp
@@ -78,3 +78,43 @@
   get subseq
   ;; Have explicit redundant definitions...
   bit sbit aref gethash)
+
+(in-package "SB-VM")
+(export '%atomic-exchange)
+(defmacro %atomic-exchange (place value)
+  ;; Given PLACE which is of a very restricted kind - (STRUCT-SLOT-ACCESSOR instance)
+  ;; atomically swap VALUE and return the old, unconditionally.
+  (destructuring-bind (accessor instance) place
+    (let* ((info (the (cons defstruct-description defstruct-slot-description)
+                      (info :function :source-transform accessor)))
+           (dsd (cdr info))
+           (disp (- (ash (+ instance-slots-offset (dsd-index dsd)) word-shift)
+                    instance-pointer-lowtag))
+           (type (dsd-type dsd)))
+      (declare (ignorable disp type))
+      #+(or arm64 riscv64 x86-64)
+      (multiple-value-bind (sc primtype)
+          (ecase (dsd-raw-type dsd)
+            (t (if (eq type 'fixnum)
+                   (values 'any-reg 'tagged-num)
+                   (values 'descriptor-reg 't)))
+            (signed-word (values 'signed-reg 'signed-num))
+            (word (values 'unsigned-reg 'unsigned-num)))
+        `(truly-the ,type
+          (inline-vop (((instance descriptor-reg t) (the ,(dd-name (car info)) ,instance))
+                       ((val ,sc ,primtype) (the ,type ,value))
+                       ((temp)))
+                      ((res ,sc ,primtype))
+           #+arm64 (progn (inst add temp instance ,disp)
+                          (inst swpal val res temp))
+           #+riscv (progn (inst addi temp instance ,disp)
+                          (inst amoswap res val temp :aq :rl))
+           #+x86-64 (progn (move temp val)
+                           (inst xchg temp (ea ,disp instance)) ; LOCK is implicit
+                           (move res temp)))))
+      #-(or arm64 riscv64 x86-64)
+      `(let* ((.instance. ,instance) ; GET-CAS-EXPANSION exists. I don't care
+              (.new. ,value)
+              (.old. (,accessor .instance.)))
+         (loop until (eq .old. (setf .old. (cas ,place .old. .new.))))
+         .old.))))
diff --git a/src/compiler/arm64/insts.lisp b/src/compiler/arm64/insts.lisp
index 21d736741..4fcee845d 100644
--- a/src/compiler/arm64/insts.lisp
+++ b/src/compiler/arm64/insts.lisp
@@ -2032,6 +2032,11 @@
 (def-ldatomic ldseta #b001100 1 0)
 (def-ldatomic ldsetal #b001100 1 1)
 
+(def-ldatomic swp #b100000 0 0)
+(def-ldatomic swpa #b100000 1 0)
+(def-ldatomic swpal #b100000 1 1)
+(def-ldatomic swpl #b100000 0 1)
+
 (define-instruction-format (ldaddb 32)
   (size :field (byte 2 30))
   (op2 :field (byte 6 24) :value #b111000)
diff --git a/tests/atomic-xchg.pure.lisp b/tests/atomic-xchg.pure.lisp
new file mode 100644
index 000000000..53c04b8d7
--- /dev/null
+++ b/tests/atomic-xchg.pure.lisp
@@ -0,0 +1,28 @@
+(defstruct s (f 0 :type fixnum) (w 0 :type word) (sw 0 :type signed-word))
+
+(defun swapw (mystruct v) (sb-vm:%atomic-exchange (s-w mystruct) v))
+(defun swapsw (mystruct v) (sb-vm:%atomic-exchange (s-sw mystruct) v))
+(defun swapf (mystruct v) (sb-vm:%atomic-exchange (s-f mystruct) v))
+
+(mapc 'compile '(swapw swapsw swapf))
+
+(with-test (:name :atomic-exchange-word)
+  (let ((s (make-s)))
+    (assert (= (swapsw s 5) 0))
+    (assert (= (s-sw s) 5))
+    (assert (= (swapsw s 1000) 5))
+    (assert (= (s-sw s) 1000))))
+
+(with-test (:name :atomic-exchange-signed-word)
+  (let ((s (make-s)))
+    (assert (= (swapsw s 5) 0))
+    (assert (= (s-sw s) 5))
+    (assert (= (swapsw s -100) 5))
+    (assert (= (s-sw s) -100))))
+
+(with-test (:name :atomic-exchange-fixnum)
+  (let ((s (make-s)))
+    (assert (= (swapf s 5) 0))
+    (assert (= (s-f s) 5))
+    (assert (= (swapf s -100) 5))
+    (assert (= (s-f s) -100))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL