Re: master: arm64: implement %vector-cas-pair (for Armv8.1-A or later)

        "The file #P"/proc/cpuinfo" does not exist: No such file or directory"

On Thu, Jan 8, 2026 at 11:24 PM snuglas via Sbcl-commits
<[email protected]> wrote:
>
> The branch "master" has been updated in SBCL:
>        via  e0c54aa0968bea23f2e0044f76f501525adcd625 (commit)
>       from  3f57e70440ae3d6233b674556b9540c0ad89c0d7 (commit)
>
> - Log -----------------------------------------------------------------
> commit e0c54aa0968bea23f2e0044f76f501525adcd625
> Author: Douglas Katzman <[email protected]>
> Date:   Thu Jan 8 20:12:06 2026 +0000
>
>     arm64: implement %vector-cas-pair (for Armv8.1-A or later)
> ---
>  make-target-2-load.lisp            |  7 ++++---
>  src/code/stubs.lisp                |  3 ++-
>  src/compiler/arm64/insts.lisp      | 21 +++++++++++++++++++++
>  src/compiler/arm64/memory.lisp     | 32 ++++++++++++++++++++++++++++++++
>  src/compiler/generic/vm-fndb.lisp  |  3 +++
>  src/compiler/x86-64/cell.lisp      |  2 +-
>  src/compiler/x86/cell.lisp         |  2 +-
>  tests/compare-and-swap.impure.lisp | 31 +++++++++++++++++++++----------
>  8 files changed, 85 insertions(+), 16 deletions(-)
>
> diff --git a/make-target-2-load.lisp b/make-target-2-load.lisp
> index 393312193..270cdf3e7 100644
> --- a/make-target-2-load.lisp
> +++ b/make-target-2-load.lisp
> @@ -436,9 +436,10 @@ Please check that all strings which were not recognizable to the compiler
>                              ;; need this for defining a vop which
>                              ;; tests the x86-64 allocation profiler
>                              sb-vm::pseudo-atomic
> -                            ,@(or #+(or x86 x86-64) '(sb-vm::%vector-cas-pair
> -                                                      sb-vm::%instance-cas-pair
> -                                                      sb-vm::%cons-cas-pair))
> +                            ,@(or #+(or arm64 x86 x86-64)
> +                                  '(sb-vm::%vector-cas-pair
> +                                    sb-vm::%instance-cas-pair
> +                                    sb-vm::%cons-cas-pair))
>                              ;; Naughty outside-world code uses these.
>                              #+x86-64 sb-vm::reg-in-size))
>             (let ((s (string symbol))) (and (search "THREAD-" s) (search "-SLOT" s)))
> diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp
> index 0a6eb0a7a..12bc63cc7 100644
> --- a/src/code/stubs.lisp
> +++ b/src/code/stubs.lisp
> @@ -139,9 +139,10 @@
>    #+compare-and-swap-vops
>    (def* (%array-atomic-incf/word (array index diff))
>          (%raw-instance-atomic-incf/word (instance index diff)))
> +  #+(or arm64 x86 x86-64)
> +  (def* (sb-vm::%vector-cas-pair (vector index old1 old2 new1 new2)))
>    #+(or x86 x86-64)
>    (def* (sb-vm::%cpu-identification (eax ecx))
> -        (sb-vm::%vector-cas-pair (vector index old1 old2 new1 new2))
>          (sb-vm::%instance-cas-pair (instance index old1 old2 new1 new2))
>          (sb-vm::%cons-cas-pair (cons old1 old2 new1 new2)))
>
> diff --git a/src/compiler/arm64/insts.lisp b/src/compiler/arm64/insts.lisp
> index f498124df..721858dce 100644
> --- a/src/compiler/arm64/insts.lisp
> +++ b/src/compiler/arm64/insts.lisp
> @@ -1728,6 +1728,27 @@
>  (def-casb casalh 1 1 1)
>  (def-casb caslh 1 1 0)
>
> +;;;  32-bit CASP   (sz == 0 && L == 0 && o0 == 0)
> +;;;  32-bit CASPA  (sz == 0 && L == 1 && o0 == 0)
> +;;;  32-bit CASPAL (sz == 0 && L == 1 && o0 == 1)
> +;;;  32-bit CASPL  (sz == 0 && L == 0 && o0 == 1)
> +;;;  64-bit CASP   (sz == 1 && L == 0 && o0 == 0)
> +;;;  64-bit CASPA  (sz == 1 && L == 1 && o0 == 0)
> +;;;  64-bit CASPAL (sz == 1 && L == 1 && o0 == 1)
> +;;;  64-bit CASPL  (sz == 1 && L == 0 && o0 == 1)
> +
> +;;; Given that memory ordering semantics are completely unknown to the compiler,
> +;;; the full set of CASP instructions are not terribly interesting for us.
> +;;; The strongest barrier is enough.
> +(define-instruction caspal (segment rs rt rn) ; CAS pair acquire + release
> +  (:printer cas ((size1 0) (o2 0) (L 1) (o0 1))
> +            '(:name :tab rs ", " rt ", [" rn "]"))
> +  (:emitter
> +   (emit-ldr-str-exclusive segment #b01 0 1 1
> +                           (gpr-offset rs)
> +                           1 31
> +                           (gpr-offset rn)
> +                           (gpr-offset rt))))
>  ;;;
>
>  (def-emitter ldatomic
> diff --git a/src/compiler/arm64/memory.lisp b/src/compiler/arm64/memory.lisp
> index 91113d946..e05159f00 100644
> --- a/src/compiler/arm64/memory.lisp
> +++ b/src/compiler/arm64/memory.lisp
> @@ -135,6 +135,38 @@
>      (move result old-value)
>      (inst casal result new-value lip)))
>
> +(define-vop (%vector-cas-pair)
> +  (:translate %vector-cas-pair)
> +  (:policy :fast-safe)
> +  (:args (object :scs (descriptor-reg) :to (:result 0))
> +         (index :scs (any-reg))
> +         (old1 :scs (any-reg descriptor-reg))
> +         (old2 :scs (any-reg descriptor-reg))
> +         (new1 :scs (any-reg descriptor-reg))
> +         (new2 :scs (any-reg descriptor-reg)))
> +  (:arg-types * tagged-num * * * *)
> +  (:temporary (:sc descriptor-reg :offset r0-offset :from (:argument 2) :to (:result 0)) oldpair-first)
> +  (:temporary (:sc descriptor-reg :offset r1-offset :from (:argument 3) :to (:result 1)) oldpair-second)
> +  (:temporary (:sc descriptor-reg :offset r2-offset :from (:argument 4) :to (:result 0)) newpair-first)
> +  (:temporary (:sc descriptor-reg :offset r3-offset :from (:argument 5) :to (:result 0)) newpair-second)
> +  (:temporary (:sc unsigned-reg) tmp)
> +  (:temporary (:sc non-descriptor-reg) lip)
> +  (:results (result1 :scs (any-reg descriptor-reg))
> +            (result2 :scs (any-reg descriptor-reg)))
> +  (:result-types * *)
> +  (:policy :fast-safe)
> +  (:generator 3
> +    (inst add lip object (lsl index (- word-shift n-fixnum-tag-bits)))
> +    (inst add-sub lip lip (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
> +    (emit-gengc-barrier object lip tmp t)
> +    (move oldpair-first old1)
> +    (move oldpair-second old2)
> +    (move newpair-first new1)
> +    (move newpair-second new2)
> +    (inst caspal oldpair-first newpair-first lip)
> +    (move result1 oldpair-first)
> +    (move result2 oldpair-second)))
> +
>  #+sb-thread
>  (define-vop (set-instance-hashed-return-address)
>    (:args (object :scs (descriptor-reg)))
> diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
> index fa2a86d8e..3564e8ed3 100644
> --- a/src/compiler/generic/vm-fndb.lisp
> +++ b/src/compiler/generic/vm-fndb.lisp
> @@ -251,6 +251,9 @@
>    sb-vm:signed-word ())
>  (defknown %raw-instance-xchg/word (instance index sb-vm:word) sb-vm:word ())
>
> +;; vector, index, old1, old2, new1, new2 -> old1, old2
> +(defknown sb-vm::%vector-cas-pair (simple-vector index t t t t) (values t t))
> +
>  (macrolet ((define-raw-slot-defknowns ()
>               `(progn
>                  ,@(map 'list
> diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
> index 70a1e5c51..caf438b5a 100644
> --- a/src/compiler/x86-64/cell.lisp
> +++ b/src/compiler/x86-64/cell.lisp
> @@ -719,7 +719,6 @@
>  ;;;;
>
>  (defknown %cons-cas-pair (cons t t t t) (values t t))
> -(defknown %vector-cas-pair (simple-vector index t t t t) (values t t))
>  ;; %INSTANCE-CAS-PAIR only operates on tagged slots (for now)
>  (defknown %instance-cas-pair (instance index t t t t) (values t t))
>
> @@ -761,6 +760,7 @@
>            ;; this is sufficiently confusing that I don't want to try reusing
>            ;; one of the other declared temps as the EA for the store barrier.
>            (:temporary (:sc unsigned-reg) temp)
> +          ;; FIXME: these operand lifetimes are wrong for INDEXEDP = NIL.
>            (:temporary (:sc unsigned-reg :offset rax-offset
>                         :from (:argument 2) :to (:result 0)) eax)
>            (:temporary (:sc unsigned-reg :offset rdx-offset
> diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
> index ca3a36f7e..3b8e93747 100644
> --- a/src/compiler/x86/cell.lisp
> +++ b/src/compiler/x86/cell.lisp
> @@ -655,7 +655,6 @@
>  ;;;;
>
>  (defknown %cons-cas-pair (cons t t t t) (values t t))
> -(defknown %vector-cas-pair (simple-vector index t t t t) (values t t))
>  ;; %INSTANCE-CAS-PAIR only operates on tagged slots (for now)
>  (defknown %instance-cas-pair (instance index t t t t) (values t t))
>
> @@ -690,6 +689,7 @@
>                   (new-hi :scs (descriptor-reg any-reg) :target ecx))
>            (:results (result-lo :scs (descriptor-reg any-reg))
>                      (result-hi :scs (descriptor-reg any-reg)))
> +          ;; FIXME: these operand lifetimes are wrong for INDEX-ARG = NIL
>            (:temporary (:sc unsigned-reg :offset eax-offset
>                         :from (:argument 2) :to (:result 0)) eax)
>            (:temporary (:sc unsigned-reg :offset edx-offset
> diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
> index 8fe1c2ad1..f1dbd8c40 100644
> --- a/tests/compare-and-swap.impure.lisp
> +++ b/tests/compare-and-swap.impure.lisp
> @@ -579,6 +579,7 @@
>      (%instance-cas-pair inst ind old1 old2 new1 new2))
>
>    (defun test-wide-cmpxchg ()
> +    #-arm64
>      (let ((x (cons 'a 'b)))
>        (multiple-value-bind (old1 old2) (test-a-cons x 'a 'b 'foo 'bar)
>          (assert (and (eq old1 'a) (eq old2 'b) (equal x '(foo . bar)))))
> @@ -591,6 +592,7 @@
>        (multiple-value-bind (old1 old2) (test-a-vect x 2 nil nil 'foo 'bar)
>          (assert (and (null old1) (null old2) (equalp x #(nil nil foo bar nil nil))))))
>
> +    #-arm64
>      ;; Same remark applies - just check that the offset to the slot is right.
>      (let ((s (make-my-struct :three 'the :four 'floor)))
>        ;; in slots 3 and 4 put your bootee (a baby shoe, i.e.) on the floor
> @@ -600,19 +602,28 @@
>                       (eq (my-struct-four s) 'bootee)))))
>      t))
>
> -(test-util:with-test (:name :wide-compare-and-exchange
> -                      :skipped-on (not (or :x86 :x86-64)))
> +(defun should-test-dblcas ()
> +  #+arm64
> +  (with-open-file (f "/proc/cpuinfo")
> +    (loop repeat 4
> +          thereis (let ((line (read-line f)))
> +                    (and (search "Features" line) (search " atomics " line)))))
> +  #+(or x86 x86-64)
>    (multiple-value-bind (a b c d) (%cpu-identification 0 0)
>      (declare (ignore b c d))
>      ;; paranoidly check for whether we can execute function ID 1
> -    (or (and (>= a 1) ; the highest function ID
> -             (multiple-value-bind (a b c d) (%cpu-identification 1 0)
> -               (declare (ignore a b) (ignorable c d))
> -               ;; paranoidly check for CMPXCHGxB presence
> -               ;; constants from Table 3-20 and 3-21 of Intel manual
> -               (and #+x86(logbitp 8 d) #+x86-64(logbitp 13 c)
> -                    (test-wide-cmpxchg))))
> -        (format t "Double-width compare-and-swap NOT TESTED~%"))))
> +    (and (>= a 1) ; the highest function ID
> +         (multiple-value-bind (a b c d) (%cpu-identification 1 0)
> +           (declare (ignore a b) (ignorable c d))
> +           ;; paranoidly check for CMPXCHGxB presence
> +           ;; constants from Table 3-20 and 3-21 of Intel manual
> +           (and #+x86 (logbitp 8 d) #+x86-64 (logbitp 13 c))))))
> +
> +(test-util:with-test (:name :wide-compare-and-exchange
> +                      :skipped-on (not (or :arm64 :x86 :x86-64)))
> +  (if (should-test-dblcas)
> +      (test-wide-cmpxchg)
> +      (format t "Double-width compare-and-swap NOT TESTED~%")))
>
>  (test-util:with-test (:name :cas-sap-ref-smoke-test
>                              :fails-on :riscv ; unsigned-32-bit gets the wrong answer
>
> -----------------------------------------------------------------------
>
>
> 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