-;;; reference VOPs inherited by basic memory reference operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;;
+;;;; the PPC definitions of some general purpose memory reference VOPs
+;;;; inherited by basic memory reference operations
-(in-package "SB!VM")
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+(in-package "SB!VM")
+\f
;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
;;; be read or written is a property of the VOP used.
;;;
;;;
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
\f
;;;; Indexed references:
-;;; Define-Indexer -- Internal
-;;;
-;;; Define some VOPs for indexed memory reference.
-;;;
+;;; Define some VOPs for indexed memory reference.
(defmacro define-indexer (name write-p ri-op rr-op shift &optional sign-extend-byte)
`(define-vop (,name)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- ,@(when write-p
- '((value :scs (any-reg descriptor-reg) :target result))))
+ (index :scs (any-reg zero immediate))
+ ,@(when write-p
+ '((value :scs (any-reg descriptor-reg) :target result))))
(:arg-types * tagged-num ,@(when write-p '(*)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (,(if write-p 'result 'value)
- :scs (any-reg descriptor-reg)))
+ :scs (any-reg descriptor-reg)))
(: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)
- (- sb!vm:word-shift ,shift)))
- (ash offset sb!vm:word-shift))
- lowtag)))
- (etypecase offset
- ((signed-byte 16)
- (inst ,ri-op value object offset))
- ((or (unsigned-byte 32) (signed-byte 32))
- (inst lr temp offset)
- (inst ,rr-op value object temp)))))
- (t
- ,@(unless (zerop shift)
- `((inst srwi temp index ,shift)))
- (inst addi temp ,(if (zerop shift) 'index 'temp)
- (- (ash offset sb!vm:word-shift) lowtag))
- (inst ,rr-op value object temp)))
+ ((immediate zero)
+ (let ((offset (- (+ (if (sc-is index zero)
+ 0
+ (ash (tn-value index)
+ (- word-shift ,shift)))
+ (ash offset word-shift))
+ lowtag)))
+ (etypecase offset
+ ((signed-byte 16)
+ (inst ,ri-op value object offset))
+ ((or (unsigned-byte 32) (signed-byte 32))
+ (inst lr temp offset)
+ (inst ,rr-op value object temp)))))
+ (t
+ ,@(unless (zerop shift)
+ `((inst srwi temp index ,shift)))
+ (inst addi temp ,(if (zerop shift) 'index 'temp)
+ (- (ash offset word-shift) lowtag))
+ (inst ,rr-op value object temp)))
,@(when sign-extend-byte
`((inst extsb value value)))
,@(when write-p
- '((move result value))))))
+ '((move result value))))))
(define-indexer word-index-ref nil lwz lwzx 0)
(define-indexer word-index-set t stw stwx 0)
(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)))