Permalink
Browse files

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.
  • Loading branch information...
1 parent 43a3cc0 commit 5745b5a5b2e3b967bf3876b4306f31b3c78495fa Alastair Bridgewater committed Aug 8, 2010
Showing with 111 additions and 2 deletions.
  1. +1 −0 make-config.sh
  2. +7 −0 src/compiler/ppc/array.lisp
  3. +66 −1 src/compiler/ppc/cell.lisp
  4. +36 −0 src/compiler/ppc/memory.lisp
  5. +1 −1 version.lisp-expr
View
@@ -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
@@ -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.
View
@@ -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.
@@ -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)))
View
@@ -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"

0 comments on commit 5745b5a

Please sign in to comment.