1.0.41.35: ppc: Implement compare-and-swap-vops.

  * Based roughly on the x86-64 version and the differences
between x86oid define-full-reffer and the PPC use of VOPs
instead (the VOPs seem smart enough, why do x86oids do the
whole define-full-reffer / -c VOP thing?).

  * Compare-and-swap VOPs are full memory barriers.

  * Left the VOPs conditionally-compiled in based on the
compare-and-swap-vops feature, more as documentation of what
is involved than anything else.

  * Enabled compare-and-swap-vops for all PPC targets.

make-config.sh

@@ -331,6 +331,7 @@ elif [ "$sbcl_arch" = "mips" ]; then
 elif [ "$sbcl_arch" = "ppc" ]; then
     printf ' :gencgc :stack-allocatable-closures :stack-allocatable-lists' >> $ltf
     printf ' :linkage-table :raw-instance-init-vops :memory-barrier-vops' >> $ltf
+    printf ' :compare-and-swap-vops' >> $ltf
     if [ "$sbcl_os" = "linux" ]; then
         # Use a C program to detect which kind of glibc we're building on,
         # to bandage across the break in source compatibility between

src/compiler/ppc/array.lisp

@@ -140,6 +140,13 @@
   (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.

src/compiler/ppc/cell.lisp

@@ -31,9 +31,69 @@
   (:generator 1
     (storew value object offset lowtag)))
 
+#!+compare-and-swap-vops
+(define-vop (compare-and-swap-slot)
+  (:args (object :scs (descriptor-reg))
+         (old :scs (descriptor-reg any-reg))
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg) :from :load))
+  (:generator 5
+    (inst sync)
+    (inst li temp (- (* offset n-word-bytes) lowtag))
+    LOOP
+    (inst lwarx result temp object)
+    (inst cmpw result old)
+    (inst bne EXIT)
+    (inst stwcx. new temp object)
+    (inst bne LOOP)
+    EXIT
+    (inst isync)))
+
 
 ;;;; Symbol hacking VOPs:
 
+#!+compare-and-swap-vops
+(define-vop (%compare-and-swap-symbol-value)
+  (:translate %compare-and-swap-symbol-value)
+  (:args (symbol :scs (descriptor-reg))
+         (old :scs (descriptor-reg any-reg))
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:results (result :scs (descriptor-reg any-reg) :from :load))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 15
+    (inst sync)
+    #!+sb-thread
+    (assemble ()
+      (loadw temp symbol symbol-tls-index-slot other-pointer-lowtag)
+      ;; Thread-local area, no synchronization needed.
+      (inst lwzx result thread-base-tn temp)
+      (inst cmpw result old)
+      (inst bne DONT-STORE-TLS)
+      (inst stwx new thread-base-tn temp)
+      DONT-STORE-TLS
+
+      (inst cmpwi result no-tls-value-marker-widetag)
+      (inst bne CHECK-UNBOUND))
+
+    (inst li temp (- (* symbol-value-slot n-word-bytes)
+                     other-pointer-lowtag))
+    LOOP
+    (inst lwarx result symbol temp)
+    (inst cmpw result old)
+    (inst bne CHECK-UNBOUND)
+    (inst stwcx. new symbol temp)
+    (inst bne LOOP)
+
+    CHECK-UNBOUND
+    (inst isync)
+    (inst cmpwi result unbound-marker-widetag)
+    (inst beq (generate-error-code vop 'unbound-symbol-error symbol))))
+
 ;;; The compiler likes to be able to directly SET symbols.
 (define-vop (%set-symbol-global-value cell-set)
   (:variant symbol-value-slot other-pointer-lowtag))
@@ -411,7 +471,12 @@
   (:variant instance-slots-offset instance-pointer-lowtag)
   (:arg-types instance positive-fixnum *))
 
-
+#!+compare-and-swap-vops
+(define-vop (%compare-and-swap-instance-ref word-index-cas)
+  (:policy :fast-safe)
+  (:translate %compare-and-swap-instance-ref)
+  (:variant instance-slots-offset instance-pointer-lowtag)
+  (:arg-types instance tagged-num * *))
 
 
 ;;;; Code object frobbing.

src/compiler/ppc/memory.lisp

@@ -104,3 +104,39 @@
 (define-indexer signed-byte-index-ref nil lbz lbzx 2 t)
 (define-indexer byte-index-set t stb stbx 2)
 
+#!+compare-and-swap-vops
+(define-vop (word-index-cas)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg zero immediate))
+         (old-value :scs (any-reg descriptor-reg))
+         (new-value :scs (any-reg descriptor-reg)))
+  (:arg-types * tagged-num * *)
+  (:temporary (:sc non-descriptor-reg) temp)
+  (:results (result :scs (any-reg descriptor-reg) :from :load))
+  (:result-types *)
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case index
+      ((immediate zero)
+       (let ((offset (- (+ (if (sc-is index zero)
+                               0
+                             (ash (tn-value index) word-shift))
+                           (ash offset word-shift))
+                        lowtag)))
+         (inst lr temp offset)))
+      (t
+       ;; KLUDGE: This relies on N-FIXNUM-TAG-BITS being the same as
+       ;; WORD-SHIFT.  I know better than to do this.  --AB, 2010-Jun-16
+       (inst addi temp index
+             (- (ash offset word-shift) lowtag))))
+
+    (inst sync)
+    LOOP
+    (inst lwarx result temp object)
+    (inst cmpw result old-value)
+    (inst bne EXIT)
+    (inst stwcx. new-value temp object)
+    (inst bne LOOP)
+    EXIT
+    (inst isync)))

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.41.34"
+"1.0.41.35"