(:policy :fast-safe)
(:translate make-array-header)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types positive-fixnum positive-fixnum)
(:temporary (:scs (any-reg)) bytes)
(:temporary (:scs (non-descriptor-reg)) header)
(:results (result :scs (descriptor-reg)))
(:generator 13
(inst addq rank (+ (* array-dimensions-offset n-word-bytes)
- lowtag-mask)
- bytes)
+ lowtag-mask)
+ bytes)
(inst li (lognot lowtag-mask) header)
(inst and bytes header bytes)
(inst addq rank (fixnumize (1- array-dimensions-offset)) header)
(:translate %check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
- (bound :scs (any-reg descriptor-reg))
- (index :scs (any-reg descriptor-reg) :target result))
+ (bound :scs (any-reg descriptor-reg))
+ (index :scs (any-reg descriptor-reg) :target result))
(:results (result :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index)))
+ array bound index)))
(inst cmpult index bound temp)
(inst beq temp error)
(move index result))))
(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
`(progn
(define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
- ,type
+ ,type
vector-data-offset other-pointer-lowtag
,(remove-if (lambda (x) (member x '(null zero))) scs)
,element-type
data-vector-ref)
(define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
- ,type
+ ,type
vector-data-offset other-pointer-lowtag ,scs ,element-type
data-vector-set #+gengc ,(if (member 'descriptor-reg scs)
- t
- nil))))
+ t
+ nil))))
(def-partial-data-vector-frobs
(type element-type size signed &rest scs)
`(progn
(define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
- ,type
+ ,type
,size ,signed vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-ref)
(define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type)
- ,type
+ ,type
,size vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-set)))
(def-small-data-vector-frobs (type bits)
(:result-types positive-fixnum)
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg) :to (:result 0))
- temp result)
+ temp result)
(:generator 20
(inst srl index ,bit-shift temp)
(inst sll temp n-fixnum-tag-bits temp)
(inst and index ,(1- elements-per-word) temp)
,@(unless (= bits 1)
`((inst sll temp
- ,(1- (integer-length bits)) temp)))
+ ,(1- (integer-length bits)) temp)))
(inst srl result temp result)
(inst and result ,(1- (ash 1 bits)) result)
(inst sll result n-fixnum-tag-bits value)))
(:result-types positive-fixnum)
(:generator 15
(multiple-value-bind (word extra)
- (floor index ,elements-per-word)
+ (floor index ,elements-per-word)
(loadw result object (+ word
- vector-data-offset)
+ vector-data-offset)
other-pointer-lowtag)
(unless (zerop extra)
(inst srl result (* extra ,bits) result))
(unless (= extra ,(1- elements-per-word))
(inst and result ,(1- (ash 1 bits))
- result)))))
+ result)))))
(define-vop (,(symbolicate 'data-vector-set/ type))
(:note "inline array store")
(:translate data-vector-set)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg) :target shift)
(value :scs (unsigned-reg zero immediate)
- :target result))
+ :target result))
(:arg-types ,type positive-fixnum positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) temp old)
(:temporary (:scs (non-descriptor-reg)
- :from (:argument 1)) shift)
+ :from (:argument 1)) shift)
(:generator 25
(inst srl index ,bit-shift temp)
(inst sll temp n-fixnum-tag-bits temp)
(inst and index ,(1- elements-per-word) shift)
,@(unless (= bits 1)
`((inst sll shift ,(1- (integer-length
- bits))
- shift)))
+ bits))
+ shift)))
(unless (and (sc-is value immediate)
(= (tn-value value)
- ,(1- (ash 1 bits))))
+ ,(1- (ash 1 bits))))
(inst li ,(1- (ash 1 bits)) temp)
(inst sll temp shift temp)
(inst not temp temp)
(sc-case value
(immediate
(inst li
- (logand (tn-value value)
- ,(1- (ash 1 bits)))
- temp))
+ (logand (tn-value value)
+ ,(1- (ash 1 bits)))
+ temp))
(unsigned-reg
(inst and value
- ,(1- (ash 1 bits))
- temp)))
+ ,(1- (ash 1 bits))
+ temp)))
(inst sll temp shift temp)
(inst bis old temp old))
(inst stl old
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(value :scs (unsigned-reg zero immediate)
- :target result))
+ :target result))
(:arg-types ,type
(:constant
(integer 0
(:temporary (:scs (non-descriptor-reg)) temp old)
(:generator 20
(multiple-value-bind (word extra)
- (floor index ,elements-per-word)
+ (floor index ,elements-per-word)
(inst ldl old
(- (* (+ word vector-data-offset)
- n-word-bytes)
+ n-word-bytes)
other-pointer-lowtag)
object)
(unless (and (sc-is value immediate)
(= (tn-value value)
- ,(1- (ash 1 bits))))
+ ,(1- (ash 1 bits))))
(cond #+#.(cl:if
(cl:= sb-vm:n-word-bits sb-vm:n-machine-word-bits)
'(and) '(or))
(t
(inst li
(lognot (ash ,(1- (ash 1
- bits))
- (* extra ,bits)))
+ bits))
+ (* extra ,bits)))
temp)
(inst and old temp old))))
(sc-case value
(zero)
(immediate
(let ((value
- (ash (logand (tn-value
- value)
- ,(1- (ash 1
- bits)))
+ (ash (logand (tn-value
+ value)
+ ,(1- (ash 1
+ bits)))
(* extra
- ,bits))))
+ ,bits))))
(cond ((< value #x100)
(inst bis old value old))
(t
(inst bis old temp old)))))
(unsigned-reg
(inst sll value (* extra ,bits)
- temp)
+ temp)
(inst bis old temp old)))
(inst stl old
(- (* (+ word vector-data-offset)
- n-word-bytes)
+ n-word-bytes)
other-pointer-lowtag)
object)
(sc-case value
(move value result))))))))))
(def-full-data-vector-frobs simple-vector *
descriptor-reg any-reg null zero)
-
+
(def-partial-data-vector-frobs simple-base-string character :byte nil
character-reg)
#!+sb-unicode ; FIXME: what about when a word is 64 bits?
(def-full-data-vector-frobs simple-character-string character character-reg)
-
+
(def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
:byte nil unsigned-reg signed-reg)
-
+
(def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
:short nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
:short nil unsigned-reg signed-reg)
-
+
(def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
unsigned-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
unsigned-reg)
-
+
(def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
:byte t signed-reg)
-
+
(def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
:short t signed-reg)
-
- (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
+
+ (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
(def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
-
+
(def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
signed-reg)
-
+
;; Integer vectors whos elements are smaller than a byte. I.e. bit,
;; 2-bit, and 4-bit vectors.
(def-small-data-vector-frobs simple-bit-vector 1)
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-single-float positive-fixnum)
(:results (value :scs (single-reg)))
(:result-types single-float)
(:generator 20
(inst addq object index lip)
(inst lds value
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- lip)))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ lip)))
(define-vop (data-vector-set/simple-array-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
(:arg-types simple-array-single-float positive-fixnum single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 20
(inst addq object index lip)
(inst sts value
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- lip)
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ lip)
(unless (location= result value)
(inst fmove value result))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-double-float positive-fixnum)
(:results (value :scs (double-reg)))
(:result-types double-float)
(inst addq object index lip)
(inst addq lip index lip)
(inst ldt value
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- lip)))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ lip)))
(define-vop (data-vector-set/simple-array-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
(:arg-types simple-array-double-float positive-fixnum double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(inst addq object index lip)
(inst addq lip index lip)
(inst stt value
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag) lip)
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag) lip)
(unless (location= result value)
(inst fmove value result))))
\f
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-single-float positive-fixnum)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (interior-reg)) lip)
(inst addq object index lip)
(inst addq lip index lip)
(inst lds real-tn
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- lip))
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ lip))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst lds imag-tn
- (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
- lip))))
+ (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
+ lip))))
(define-vop (data-vector-set/simple-array-complex-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
(:arg-types simple-array-complex-single-float positive-fixnum
- complex-single-float)
+ complex-single-float)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 5
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(inst addq object index lip)
(inst addq lip index lip)
(inst sts value-real
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- lip)
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ lip)
(unless (location= result-real value-real)
- (inst fmove value-real result-real)))
+ (inst fmove value-real result-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst sts value-imag
- (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
- lip)
+ (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
+ lip)
(unless (location= result-imag value-imag)
- (inst fmove value-imag result-imag)))))
+ (inst fmove value-imag result-imag)))))
(define-vop (data-vector-ref/simple-array-complex-double-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-double-float positive-fixnum)
(:results (value :scs (complex-double-reg)))
(:result-types complex-double-float)
(inst addq lip index lip)
(inst addq lip index lip)
(inst ldt real-tn
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- lip))
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ lip))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst ldt imag-tn
- (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
- lip))))
+ (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
+ lip))))
(define-vop (data-vector-set/simple-array-complex-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
(:arg-types simple-array-complex-double-float positive-fixnum
- complex-double-float)
+ complex-double-float)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(:temporary (:scs (interior-reg)) lip)
(:generator 20
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(inst addq object index lip)
(inst addq lip index lip)
(inst addq lip index lip)
(inst addq lip index lip)
(inst stt value-real
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- lip)
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ lip)
(unless (location= result-real value-real)
- (inst fmove value-real result-real)))
+ (inst fmove value-real result-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst stt value-imag
- (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
- lip)
+ (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
+ lip)
(unless (location= result-imag value-imag)
- (inst fmove value-imag result-imag)))))
+ (inst fmove value-imag result-imag)))))
\f
;;; These VOPs are used for implementing float slots in structures
(:arg-types sb!c::raw-vector positive-fixnum double-float))
(define-vop (raw-ref-complex-single
- data-vector-ref/simple-array-complex-single-float)
+ 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)
+ 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)
+ 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)
+ data-vector-set/simple-array-complex-double-float)
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
projects / sbcl.git / blobdiff