(mask ,(1- (ash 1 bits)))
(shift (* extra ,bits)))
(unless (= value mask)
- (inst and old (lognot (ash mask shift))))
+ (inst and old (ldb (byte 32 0) (lognot (ash mask shift)))))
(unless (zerop value)
(inst or old (ash value shift)))))
(unsigned-reg
(inst fstd result))
(inst fxch value)))))))
-#!+long-float
-(define-vop (data-vector-ref/simple-array-long-float)
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg)))
- (:arg-types simple-array-long-float positive-fixnum)
- (:temporary (:sc any-reg :from :eval :to :result) temp)
- (:results (value :scs (long-reg)))
- (:result-types long-float)
- (:generator 7
- ;; temp = 3 * index
- (inst lea temp (make-ea :dword :base index :index index :scale 2))
- (with-empty-tn@fp-top(value)
- (inst fldl (make-ea :dword :base object :index temp :scale 1
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))))))
-#!+long-float
-(define-vop (data-vector-ref-c/simple-array-long-float)
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types simple-array-long-float (:constant (signed-byte 30)))
- (:results (value :scs (long-reg)))
- (:result-types long-float)
- (:generator 6
- (with-empty-tn@fp-top(value)
- (inst fldl (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 12 index))
- other-pointer-lowtag))))))
-
-#!+long-float
-(define-vop (data-vector-set/simple-array-long-float)
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg))
- (value :scs (long-reg) :target result))
- (:arg-types simple-array-long-float positive-fixnum long-float)
- (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
- (:results (result :scs (long-reg)))
- (:result-types long-float)
- (:generator 20
- ;; temp = 3 * index
- (inst lea temp (make-ea :dword :base index :index index :scale 2))
- (cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (store-long-float
- (make-ea :dword :base object :index temp :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (store-long-float
- (make-ea :dword :base object :index temp :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
-
-#!+long-float
-(define-vop (data-vector-set-c/simple-array-long-float)
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs (long-reg) :target result))
- (:info index)
- (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
- (:results (result :scs (long-reg)))
- (:result-types long-float)
- (:generator 19
- (cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (store-long-float (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 12 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (store-long-float (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 12 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
;;; complex float variants
(inst fxch value-imag))))
-#!+long-float
-(define-vop (data-vector-ref/simple-array-complex-long-float)
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg)))
- (:arg-types simple-array-complex-long-float positive-fixnum)
- (:temporary (:sc any-reg :from :eval :to :result) temp)
- (:results (value :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 7
- ;; temp = 3 * index
- (inst lea temp (make-ea :dword :base index :index index :scale 2))
- (let ((real-tn (complex-long-reg-real-tn value)))
- (with-empty-tn@fp-top (real-tn)
- (inst fldl (make-ea :dword :base object :index temp :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))))
- (let ((imag-tn (complex-long-reg-imag-tn value)))
- (with-empty-tn@fp-top (imag-tn)
- (inst fldl (make-ea :dword :base object :index temp :scale 2
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 12)
- other-pointer-lowtag)))))))
-
-#!+long-float
-(define-vop (data-vector-ref-c/simple-array-complex-long-float)
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
- (:results (value :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 6
- (let ((real-tn (complex-long-reg-real-tn value)))
- (with-empty-tn@fp-top (real-tn)
- (inst fldl (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index))
- other-pointer-lowtag)))))
- (let ((imag-tn (complex-long-reg-imag-tn value)))
- (with-empty-tn@fp-top (imag-tn)
- (inst fldl (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index) 12)
- other-pointer-lowtag)))))))
-
-#!+long-float
-(define-vop (data-vector-set/simple-array-complex-long-float)
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg))
- (value :scs (complex-long-reg) :target result))
- (:arg-types simple-array-complex-long-float positive-fixnum
- complex-long-float)
- (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
- (:results (result :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 20
- ;; temp = 3 * index
- (inst lea temp (make-ea :dword :base index :index index :scale 2))
- (let ((value-real (complex-long-reg-real-tn value))
- (result-real (complex-long-reg-real-tn result)))
- (cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (store-long-float
- (make-ea :dword :base object :index temp :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (store-long-float
- (make-ea :dword :base object :index temp :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
- (let ((value-imag (complex-long-reg-imag-tn value))
- (result-imag (complex-long-reg-imag-tn result)))
- (inst fxch value-imag)
- (store-long-float
- (make-ea :dword :base object :index temp :scale 2
- :disp (- (+ (* vector-data-offset n-word-bytes) 12)
- other-pointer-lowtag)))
- (unless (location= value-imag result-imag)
- (inst fstd result-imag))
- (inst fxch value-imag))))
-#!+long-float
-(define-vop (data-vector-set-c/simple-array-complex-long-float)
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs (complex-long-reg) :target result))
- (:info index)
- (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
- complex-long-float)
- (:results (result :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 19
- (let ((value-real (complex-long-reg-real-tn value))
- (result-real (complex-long-reg-real-tn result)))
- (cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (store-long-float
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (store-long-float
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
- (let ((value-imag (complex-long-reg-imag-tn value))
- (result-imag (complex-long-reg-imag-tn result)))
- (inst fxch value-imag)
- (store-long-float
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- ;; FIXME: There are so many of these bare constants
- ;; (24, 12..) in the LONG-FLOAT code that it's
- ;; ridiculous. I should probably just delete it all
- ;; instead of appearing to flirt with supporting
- ;; this maintenance nightmare.
- (* 24 index) 12)
- other-pointer-lowtag)))
- (unless (location= value-imag result-imag)
- (inst fstd result-imag))
- (inst fxch value-imag))))
\f
;;; unsigned-byte-8
(macrolet ((define-data-vector-frobs (ptype)
;;; simple-string
+#!+sb-unicode
+(progn
+(define-vop (data-vector-ref/simple-base-string)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types simple-base-string positive-fixnum)
+ (:results (value :scs (character-reg)))
+ (:result-types character)
+ (:generator 5
+ (inst movzx value
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
+
+(define-vop (data-vector-ref-c/simple-base-string)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-base-string (:constant (signed-byte 30)))
+ (:results (value :scs (character-reg)))
+ (:result-types character)
+ (:generator 4
+ (inst movzx value
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
+
+(define-vop (data-vector-set/simple-base-string)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (character-reg) :target eax))
+ (:arg-types simple-base-string positive-fixnum character)
+ (:temporary (:sc character-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (character-reg)))
+ (:result-types character)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ al-tn)
+ (move result eax)))
+
+(define-vop (data-vector-set-c/simple-base-string)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (character-reg)))
+ (:info index)
+ (:arg-types simple-base-string (:constant (signed-byte 30)) character)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (character-reg)))
+ (:result-types character)
+ (:generator 4
+ (move eax value)
+ (inst mov (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ al-tn)
+ (move result eax)))
+) ; PROGN
+
+#!-sb-unicode
+(progn
(define-vop (data-vector-ref/simple-base-string)
(:translate data-vector-ref)
(:policy :fast-safe)
value)
(move result value)))
-(define-vop (data-vector-set/simple-base-string-c)
+(define-vop (data-vector-set-c/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
other-pointer-lowtag))
value)
(move result value)))
+) ; PROGN
+
+#!+sb-unicode
+(define-full-reffer data-vector-ref/simple-character-string
+ simple-character-string vector-data-offset other-pointer-lowtag
+ (character-reg) character data-vector-ref)
+#!+sb-unicode
+(define-full-setter data-vector-set/simple-character-string
+ simple-character-string vector-data-offset other-pointer-lowtag
+ (character-reg) character data-vector-set)
;;; signed-byte-8
(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
(:translate %raw-set-double)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
-#!+long-float
-(define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
- (:translate %raw-ref-long)
- (:arg-types sb!c::raw-vector positive-fixnum))
-#!+long-float
-(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
- (:translate %raw-ref-long)
- (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
-#!+long-float
-(define-vop (raw-set-double data-vector-set/simple-array-long-float)
- (:translate %raw-set-long)
- (:arg-types sb!c::raw-vector positive-fixnum long-float))
-#!+long-float
-(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
- (:translate %raw-set-long)
- (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) long-float))
+
;;;; complex-float raw structure slot accessors
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))
complex-double-float))
-#!+long-float
-(define-vop (raw-ref-complex-long
- data-vector-ref/simple-array-complex-long-float)
- (:translate %raw-ref-complex-long)
- (:arg-types sb!c::raw-vector positive-fixnum))
-#!+long-float
-(define-vop (raw-ref-complex-long-c
- data-vector-ref-c/simple-array-complex-long-float)
- (:translate %raw-ref-complex-long)
- (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
-#!+long-float
-(define-vop (raw-set-complex-long
- data-vector-set/simple-array-complex-long-float)
- (:translate %raw-set-complex-long)
- (:arg-types sb!c::raw-vector positive-fixnum complex-long-float))
-#!+long-float
-(define-vop (raw-set-complex-long-c
- data-vector-set-c/simple-array-complex-long-float)
- (:translate %raw-set-complex-long)
- (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
- complex-long-float))
+
;;; These vops are useful for accessing the bits of a vector
;;; irrespective of what type of vector it is.
projects / sbcl.git / blobdiff