From: Alastair Bridgewater <lisphacker@users.sourceforge.net>
Date: Thu, 7 Oct 2010 16:37:10 +0000 (+0000)
Subject: 1.0.43.33: ppc: Implement %ARRAY-ATOMIC-INCF/WORD
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b50d5a1e6413d6aeb9e5697dba6d9c74e199b97b;p=sbcl.git

1.0.43.33: ppc: Implement %ARRAY-ATOMIC-INCF/WORD

  * Implement new VOP ARRAY-ATOMIC-INCF/WORD

  * Add ppc to the appropriate reader coditionals to
enable use of the new VOP.
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 397a658..5873842 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1223,7 +1223,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%ARRAY-DISPLACED-FROM"
                "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
                "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK"
-               #!+(or x86 x86-64)
+               #!+(or x86 x86-64 ppc)
                "%ARRAY-ATOMIC-INCF/WORD"
                "%ASSOC"
                "%ASSOC-EQ"
diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 0903f52..5d2d598 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -177,7 +177,7 @@ EXPERIMENTAL: Interface subject to change."
         (aref
          (when (cddr args)
            (invalid-place))
-         #!+(or x86 x86-64)
+         #!+(or x86 x86-64 ppc)
          (with-unique-names (array)
            `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args))))
               (%array-atomic-incf/word
@@ -189,7 +189,7 @@ EXPERIMENTAL: Interface subject to change."
                                 `(the sb!vm:signed-word ,diff))
                                (atomic-decf
                                 `(- (the sb!vm:signed-word ,diff))))))))
-         #!-(or x86 x86-64)
+         #!-(or x86 x86-64 ppc)
          (with-unique-names (array index old-value)
            (let ((incremented-value
                   (ecase name
@@ -289,7 +289,7 @@ EXPERIMENTAL: Interface subject to change."
   (expand-atomic-frob 'atomic-decf place diff))
 
 ;; Interpreter stubs for ATOMIC-INCF.
-#!+(or x86 x86-64)
+#!+(or x86 x86-64 ppc)
 (defun %array-atomic-incf/word (array index diff)
   (declare (type (simple-array word (*)) array)
            (fixnum index)
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 59608a9..e608152 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -168,7 +168,7 @@
 #!+(or x86 x86-64 ppc)
 (defknown %raw-instance-atomic-incf/word (instance index sb!vm:word) sb!vm:word
     (unsafe always-translatable))
-#!+(or x86 x86-64)
+#!+(or x86 x86-64 ppc)
 (defknown %array-atomic-incf/word (t index sb!vm:word) sb!vm:word
   (unsafe always-translatable))
 
diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp
index 37cf6ea..0f66433 100644
--- a/src/compiler/ppc/array.lisp
+++ b/src/compiler/ppc/array.lisp
@@ -558,4 +558,31 @@
          (value :scs (signed-reg)))
   (:results (result :scs (signed-reg)))
   (:result-types tagged-num))
+
+;;;; ATOMIC-INCF for arrays
 
+(define-vop (array-atomic-incf/word)
+  (:translate %array-atomic-incf/word)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg) :target offset)
+         (diff :scs (unsigned-reg)))
+  (:arg-types * positive-fixnum unsigned-num)
+  (:results (result :scs (unsigned-reg) :from :load))
+  (:result-types unsigned-num)
+  (:temporary (:sc unsigned-reg :from (:argument 1)) offset)
+  (:temporary (:sc non-descriptor-reg) sum)
+  (:generator 4
+    (inst addi offset index
+          (- (* vector-data-offset n-word-bytes)
+             other-pointer-lowtag))
+    ;; load the slot value, add DIFF, write the sum back, and return
+    ;; the original slot value, atomically, and include a memory
+    ;; barrier.
+    (inst sync)
+    LOOP
+    (inst lwarx result offset object)
+    (inst add sum result diff)
+    (inst stwcx. sum offset object)
+    (inst bne LOOP)
+    (inst isync)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 613ccfb..b0f1c21 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.43.32"
+"1.0.43.33"