ppc, ppc64: add %raw-instance-cas/signed-word

src/code/cas.lisp

@@ -31,11 +31,11 @@
   ;; because it is used for effect. And if compare-and-swap vops exist,
   ;; then the setter isn't used at all.
   (def %instance-cas (instance index) %instance-ref %instance-set)
-  #+(or x86-64 x86 riscv loongarch64)
+  #+(or arm64 ppc ppc64 x86-64 x86 riscv loongarch64)
   (def %raw-instance-cas/word (instance index)
        %raw-instance-ref/word
        %raw-instance-set/word)
-  #+(or arm64 riscv x86 x86-64 loongarch64)
+  #+(or arm64 riscv ppc ppc64 x86 x86-64 loongarch64)
   (def %raw-instance-cas/signed-word (instance index)
        %raw-instance-ref/signed-word
        %raw-instance-set/signed-word)

src/code/macros.lisp

@@ -1778,7 +1778,7 @@ invoked. In that case it will store into PLACE and start over."
              ((t) '%instance-cas)
              #+(or arm64 loongarch64 ppc ppc64 riscv x86 x86-64)
              ((word) '%raw-instance-cas/word)
-             #+(or arm64 loongarch64 riscv x86 x86-64)
+             #+(or arm64 loongarch64 ppc ppc64 riscv x86 x86-64)
              ((sb-vm:signed-word) '%raw-instance-cas/signed-word))))
     (unless casser
       (error "Cannot use COMPARE-AND-SWAP with structure accessor ~

src/compiler/generic/vm-fndb.lisp

@@ -240,7 +240,7 @@
 #+(or arm64 loongarch64 ppc ppc64 riscv x86 x86-64)
 (defknown %raw-instance-cas/word (instance index sb-vm:word sb-vm:word)
   sb-vm:word ())
-#+(or arm64 loongarch64 riscv x86 x86-64)
+#+(or arm64 loongarch64 ppc ppc64 riscv x86 x86-64)
 (defknown %raw-instance-cas/signed-word (instance index sb-vm:signed-word sb-vm:signed-word)
   sb-vm:signed-word ())
 (defknown %raw-instance-xchg/word (instance index sb-vm:word) sb-vm:word ())

src/compiler/ppc/cell.lisp

@@ -435,6 +435,16 @@
   (:result-types unsigned-num)
   (:translate %raw-instance-cas/word))
 
+(define-vop (%raw-instance-cas/signed-word %instance-cas)
+  (:args (object)
+         (index)
+         (old-value :scs (signed-reg))
+         (new-value :scs (signed-reg)))
+  (:arg-types * tagged-num signed-num signed-num)
+  (:results (result :scs (signed-reg) :from :load))
+  (:result-types signed-num)
+  (:translate %raw-instance-cas/signed-word))
+
 
 ;;;; Code object frobbing.
 

src/compiler/ppc64/cell.lisp

@@ -504,6 +504,16 @@
   (:result-types unsigned-num)
   (:translate %raw-instance-cas/word))
 
+(define-vop (%raw-instance-cas/signed-word %instance-cas)
+  (:args (object)
+         (index)
+         (old-value :scs (signed-reg))
+         (new-value :scs (signed-reg)))
+  (:arg-types * tagged-num signed-num signed-num)
+  (:results (result :scs (signed-reg) :from :load))
+  (:result-types signed-num)
+  (:translate %raw-instance-cas/signed-word))
+
 
 ;;;; Code object frobbing.
 

tests/atomic-xchg.pure.lisp

@@ -1,3 +1,6 @@
+(unless (vop-existsp "SB-KERNEL:%RAW-INSTANCE-CAS/SIGNED-WORD")
+  (invoke-restart 'run-tests::skip-file))
+
 (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))

tests/compare-and-swap.impure.lisp

@@ -152,14 +152,14 @@
     (assert (= (- (ash 1 sb-vm:n-word-bits) 2) (box-word box)))))
 
 (with-test (:name :cas-raw-instance-ref-word
-            :skipped-on (not (or :x86 :x86-64)))
+            :implemented-on (:vop-existsp "SB-KERNEL:%RAW-INSTANCE-CAS/WORD"))
   (let ((foo (make-box :word 42)))
     ;; basic smoke test - not checking for atomicity or anything
     (assert (eql (cas (box-word foo) 42 43) 42))
     (assert (eql (cas (box-word foo) 43 44) 43))))
 
 (with-test (:name :atomic-incf-full-call-lp1381867
-            :skipped-on (not (or :x86 :x86-64 :ppc)))
+            :implemented-on (:vop-existsp "SB-KERNEL:%RAW-INSTANCE-ATOMIC-INCF/WORD"))
   ;; contortions to avoid reader errors
   (let* ((%riai/w (intern "%RAW-INSTANCE-ATOMIC-INCF/WORD" "SB-KERNEL"))
          (form
@@ -729,7 +729,7 @@
   (setf small-generation-limit 1)))
 
 (test-util:with-test (:name :cas-aref
-                      :skipped-on (not (or :arm64 :x86-64)))
+                      :implemented-on (or :arm64 :x86-64))
   (dolist (bits '(8 16 32 #+64-bit 64))
     (let ((unsigned (make-array '(3 3) :element-type `(unsigned-byte ,bits)
                                 :initial-element 0))
@@ -744,7 +744,7 @@
       (assert (equalp unsigned #2A((1 2 3) (4 5 6) (7 8 9))))
       (assert (equalp signed #2A((-4 -3 -2) (-1 0 1) (2 3 4)))))))
 
-(test-util:with-test (:name :cas-aref-float :skipped-on (not :x86-64))
+(test-util:with-test (:name :cas-aref-float :implemented-on :x86-64)
   (dolist (et '(single-float double-float))
     (let ((a (make-array 4 :element-type et)))
       (dotimes (i 4)

tests/test-util.lisp

@@ -347,13 +347,19 @@
       (really-invoke-debugger condition))))
 
 (defun vop-existsp (name &optional (query :translate))
-  (ecase query
-    (:named
-     (gethash name sb-c::*backend-template-names*))
-    (:translate
-     (let ((info (sb-int:info :function :info name)))
-       (when info
-         (sb-c::fun-info-templates info))))))
+  (let ((name (if (stringp name)
+                  (let ((colon (position #\: name)))
+                    (find-symbol (subseq name (1+ colon))
+                                 (subseq name 0 colon)))
+                  name)))
+    (when name
+      (ecase query
+        (:named
+         (gethash name sb-c::*backend-template-names*))
+        (:translate
+         (let ((info (sb-int:info :function :info name)))
+           (when info
+             (sb-c::fun-info-templates info))))))))
 
 (defun skipped-p (x)
   (typecase x