Re: master: Add sb-vm:%atomic-exchange

On arm64, swp is not available everywhere, only with FEAT_LSE (i.e.
ARM v8.1 and later). (It's available on all arm64 Macs.)

On Wed, Aug 5, 2026 at 11:54 PM snuglas via Sbcl-commits
<[email protected]> wrote:
>
> 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
>
>
> _______________________________________________
> Sbcl-commits mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits


_______________________________________________
Sbcl-commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/sbcl-commits