X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Farray.lisp;h=65f7aeca8fe65935cd94bb7620e6a318f4a88d79;hb=0dda5090b6c16a641000b4eb2dcd479f39b784ca;hp=6e0aca30859060c0c1767dc03b54873819b7ecb3;hpb=3a0f3612dc2bbf3e4e8e7395bcbbf8cd1791b963;p=sbcl.git

diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp
index 6e0aca3..65f7aec 100644
--- a/src/compiler/ppc/array.lisp
+++ b/src/compiler/ppc/array.lisp
@@ -28,7 +28,8 @@
   (:results (result :scs (descriptor-reg)))
   (:generator 0
     (pseudo-atomic (pa-flag)
-      (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
+      (inst addi ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
+                                lowtag-mask))
       (inst clrrwi ndescr ndescr n-lowtag-bits)
       (allocation header ndescr other-pointer-lowtag
                   :temp-tn gc-temp
@@ -77,7 +78,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 5
-    (let ((error (generate-error-code vop invalid-array-index-error
+    (let ((error (generate-error-code vop 'invalid-array-index-error
                                       array bound index)))
       (inst cmplw index bound)
       (inst bge error)
@@ -132,13 +133,20 @@
   (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
     unsigned-num unsigned-reg)
 
-  (def-data-vector-frobs simple-array-unsigned-byte-29 word-index
+  (def-data-vector-frobs simple-array-unsigned-fixnum word-index
     positive-fixnum any-reg)
-  (def-data-vector-frobs simple-array-signed-byte-30 word-index
+  (def-data-vector-frobs simple-array-fixnum word-index
     tagged-num any-reg)
   (def-data-vector-frobs simple-array-signed-byte-32 word-index
     signed-num signed-reg))
 
+#!+compare-and-swap-vops
+(define-vop (%compare-and-swap-svref word-index-cas)
+  (:note "inline array compare-and-swap")
+  (:policy :fast-safe)
+  (:variant vector-data-offset other-pointer-lowtag)
+  (:translate %compare-and-swap-svref)
+  (:arg-types simple-vector positive-fixnum * *))
 
 ;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
 ;;; and 4-bit vectors.
@@ -473,68 +481,10 @@
         (inst fmr result-imag value-imag)))))
 
 
-;;; These VOPs are used for implementing float slots in structures (whose raw
-;;; data is an unsigned-32 vector.
-;;;
-(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
-  (:translate %raw-ref-single)
-  (:arg-types sb!c::raw-vector positive-fixnum))
-;;;
-(define-vop (raw-set-single data-vector-set/simple-array-single-float)
-  (:translate %raw-set-single)
-  (:arg-types sb!c::raw-vector positive-fixnum single-float))
-;;;
-(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
-  (:translate %raw-ref-double)
-  (:arg-types sb!c::raw-vector positive-fixnum))
-;;;
-(define-vop (raw-set-double data-vector-set/simple-array-double-float)
-  (:translate %raw-set-double)
-  (:arg-types sb!c::raw-vector positive-fixnum double-float))
-
-(define-vop (raw-ref-complex-single
-             data-vector-ref/simple-array-complex-single-float)
-  (:translate %raw-ref-complex-single)
-  (:arg-types sb!c::raw-vector positive-fixnum))
-;;;
-(define-vop (raw-set-complex-single
-             data-vector-set/simple-array-complex-single-float)
-  (:translate %raw-set-complex-single)
-  (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
-;;;
-(define-vop (raw-ref-complex-double
-             data-vector-ref/simple-array-complex-double-float)
-  (:translate %raw-ref-complex-double)
-  (:arg-types sb!c::raw-vector positive-fixnum))
-;;;
-(define-vop (raw-set-complex-double
-             data-vector-set/simple-array-complex-double-float)
-  (:translate %raw-set-complex-double)
-  (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
-
-
 ;;; These vops are useful for accessing the bits of a vector irrespective of
 ;;; what type of vector it is.
 ;;;
 
-(define-vop (raw-bits word-index-ref)
-  (:note "raw-bits VOP")
-  (:translate %raw-bits)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 other-pointer-lowtag))
-
-(define-vop (set-raw-bits word-index-set)
-  (:note "setf raw-bits VOP")
-  (:translate %set-raw-bits)
-  (:args (object :scs (descriptor-reg))
-         (index :scs (any-reg zero immediate))
-         (value :scs (unsigned-reg)))
-  (:arg-types * positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 other-pointer-lowtag))
-
 (define-vop (vector-raw-bits word-index-ref)
   (:note "vector-raw-bits VOP")
   (:translate %vector-raw-bits)
@@ -608,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)))