X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Farray.lisp;h=72b59be71cdc585cd5fda75477e679102ec6a55a;hb=389b5755b2eab960c1f4c14045a26de5dbd510c1;hp=2c675f93eeffe2e0706a9c036b2e5c48ec3c2934;hpb=63817d29028c8551cda23f432a3328acd7fdd62f;p=sbcl.git diff --git a/src/compiler/hppa/array.lisp b/src/compiler/hppa/array.lisp index 2c675f9..72b59be 100644 --- a/src/compiler/hppa/array.lisp +++ b/src/compiler/hppa/array.lisp @@ -10,15 +10,13 @@ ;;;; files for more information. (in-package "SB!VM") - ;;;; Allocator for the array header. - (define-vop (make-array-header) (:translate make-array-header) (:policy :fast-safe) (:args (type :scs (any-reg)) - (rank :scs (any-reg))) + (rank :scs (any-reg))) (:arg-types tagged-num tagged-num) (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) (:temporary (:scs (non-descriptor-reg) :type random) ndescr) @@ -57,24 +55,20 @@ (loadw res x 0 other-pointer-lowtag) (inst srl res n-widetag-bits res) (inst addi (- (1- array-dimensions-offset)) res res))) - - ;;;; Bounds checking routine. - - (define-vop (check-bound) (: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))) (: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 bc :>= nil index bound error)) (move index result))) @@ -84,7 +78,6 @@ ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos ;;; elements are represented in integer registers and are built out of ;;; 8, 16, or 32 bit elements. - (macrolet ((def-full-data-vector-frobs (type element-type &rest scs) `(progn (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type @@ -94,8 +87,8 @@ vector-data-offset other-pointer-lowtag ,scs ,element-type data-vector-set))) - (def-partial-data-vector-frobs - (type element-type size signed &rest scs) + (def-partial-data-vector-frobs + (type element-type size signed &rest scs) `(progn (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type ,size ,signed vector-data-offset other-pointer-lowtag ,scs @@ -105,168 +98,166 @@ ,element-type data-vector-set)))) (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) - + (def-partial-data-vector-frobs simple-base-string character :byte nil character-reg) - + #!+sb-unicode + (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-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. -;;; - (macrolet ((def-small-data-vector-frobs (type bits) (let* ((elements-per-word (floor n-word-bits bits)) - (bit-shift (1- (integer-length elements-per-word)))) + (bit-shift (1- (integer-length elements-per-word)))) `(progn (define-vop (,(symbolicate 'data-vector-ref/ type)) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (result :scs (unsigned-reg) :from (:argument 0))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (inst srl index ,bit-shift temp) - (inst sh2add temp object lip) - (loadw result lip vector-data-offset other-pointer-lowtag) - (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) - ,@(unless (= bits 1) - `((inst addi ,(1- bits) temp temp))) - (inst mtctl temp :sar) - (inst extru result :variable ,bits result))) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst srl index ,bit-shift temp) + (inst sh2add temp object lip) + (loadw result lip vector-data-offset other-pointer-lowtag) + (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) + ,@(unless (= bits 1) + `((inst addi ,(1- bits) temp temp))) + (inst mtctl temp :sar) + (inst extru result :variable ,bits result))) (define-vop (,(symbolicate 'data-vector-ref-c/ type)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:arg-types ,type (:constant index)) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) - other-pointer-lowtag))) - (cond ((typep offset '(signed-byte 14)) - (inst ldw offset object result)) - (t - (inst ldil (ldb (byte 21 11) offset) temp) - (inst ldw (ldb (byte 11 0) offset) temp result)))) - (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result)))) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) + other-pointer-lowtag))) + (cond ((typep offset '(signed-byte 14)) + (inst ldw offset object result)) + (t + (inst ldil (ldb (byte 21 11) offset) temp) + (inst ldw (ldb (byte 11 0) offset) temp result)))) + (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result)))) (define-vop (,(symbolicate 'data-vector-set/ type)) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) temp old) - (:temporary (:scs (interior-reg)) lip) - (:generator 25 - (inst srl index ,bit-shift temp) - (inst sh2add temp object lip) - (loadw old lip vector-data-offset other-pointer-lowtag) - (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) - ,@(unless (= bits 1) - `((inst addi ,(1- bits) temp temp))) - (inst mtctl temp :sar) - (inst dep (sc-case value (immediate (tn-value value)) (t value)) - :variable ,bits old) - (storew old lip vector-data-offset other-pointer-lowtag) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (t - (move value result))))) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp old) + (:temporary (:scs (interior-reg)) lip) + (:generator 25 + (inst srl index ,bit-shift temp) + (inst sh2add temp object lip) + (loadw old lip vector-data-offset other-pointer-lowtag) + (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp) + ,@(unless (= bits 1) + `((inst addi ,(1- bits) temp temp))) + (inst mtctl temp :sar) + (inst dep (sc-case value (immediate (tn-value value)) (t value)) + :variable ,bits old) + (storew old lip vector-data-offset other-pointer-lowtag) + (sc-case value + (immediate + (inst li (tn-value value) result)) + (t + (move value result))))) (define-vop (,(symbolicate 'data-vector-set-c/ type)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) - (:arg-types ,type - (:constant index) - positive-fixnum) - (:info index) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg)) old) - (:temporary (:scs (interior-reg)) lip) - (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) - other-pointer-lowtag))) - (cond ((typep offset '(signed-byte 14)) - (inst ldw offset object old)) - (t - (inst move object lip) - (inst addil (ldb (byte 21 11) offset) lip) - (inst ldw (ldb (byte 11 0) offset) lip old))) - (inst dep (sc-case value - (immediate (tn-value value)) - (t value)) - (+ (* extra ,bits) ,(1- bits)) - ,bits - old) - (if (typep offset '(signed-byte 14)) - (inst stw old offset object) - (inst stw old (ldb (byte 11 0) offset) lip))) - (sc-case value - (immediate - (inst li (tn-value value) result)) - (t - (move value result)))))))))) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type + (:constant index) + positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) old) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vector-data-offset) n-word-bytes) + other-pointer-lowtag))) + (cond ((typep offset '(signed-byte 14)) + (inst ldw offset object old)) + (t + (inst move object lip) + (inst addil (ldb (byte 21 11) offset) lip) + (inst ldw (ldb (byte 11 0) offset) lip old))) + (inst dep (sc-case value + (immediate (tn-value value)) + (t value)) + (+ (* extra ,bits) ,(1- bits)) + ,bits + old) + (if (typep offset '(signed-byte 14)) + (inst stw old offset object) + (inst stw old (ldb (byte 11 0) offset) lip))) + (sc-case value + (immediate + (inst li (tn-value value) result)) + (t + (move value result)))))))))) (def-small-data-vector-frobs simple-bit-vector 1) (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) ;;; And the float variants. -;;; - (define-vop (data-vector-ref/simple-array-single-float) (:note "inline array access") (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset)) + (index :scs (any-reg) :to (:argument 0) :target offset)) (:arg-types simple-array-single-float positive-fixnum) (:results (value :scs (single-reg))) (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) (:result-types single-float) (:generator 5 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - index offset) + index offset) (inst fldx offset object value))) (define-vop (data-vector-set/simple-array-single-float) @@ -274,15 +265,15 @@ (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset) - (value :scs (single-reg) :target result)) + (index :scs (any-reg) :to (:argument 0) :target offset) + (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) (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset) (:generator 5 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - index offset) + index offset) (inst fstx value offset object) (unless (location= result value) (inst funop :copy value result)))) @@ -292,7 +283,7 @@ (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset)) + (index :scs (any-reg) :to (:argument 0) :target offset)) (:arg-types simple-array-double-float positive-fixnum) (:results (value :scs (double-reg))) (:result-types double-float) @@ -300,7 +291,7 @@ (:generator 7 (inst sll index 1 offset) (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) + offset offset) (inst fldx offset object value))) (define-vop (data-vector-set/simple-array-double-float) @@ -308,8 +299,8 @@ (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:argument 1)) - (index :scs (any-reg) :to (:argument 0) :target offset) - (value :scs (double-reg) :target result)) + (index :scs (any-reg) :to (:argument 0) :target offset) + (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) @@ -317,20 +308,19 @@ (:generator 20 (inst sll index 1 offset) (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) + offset offset) (inst fstx value offset object) (unless (location= result value) (inst funop :copy value result)))) ;;; Complex float arrays. - (define-vop (data-vector-ref/simple-array-complex-single-float) (:note "inline array access") (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) - (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 (non-descriptor-reg) :from (:argument 1)) offset) @@ -338,7 +328,7 @@ (:generator 5 (inst sll index 1 offset) (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) + offset offset) (let ((real-tn (complex-single-reg-real-tn value))) (inst fldx offset object real-tn)) (let ((imag-tn (complex-single-reg-imag-tn value))) @@ -350,35 +340,35 @@ (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) - (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 (non-descriptor-reg) :from (:argument 1)) offset) (:generator 5 (inst sll index 1 offset) (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) + offset offset) (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 fstx value-real offset object) (unless (location= result-real value-real) - (inst funop :copy value-real result-real))) + (inst funop :copy 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 addi n-word-bytes offset offset) (inst fstx value-imag offset object) (unless (location= result-imag value-imag) - (inst funop :copy value-imag result-imag))))) + (inst funop :copy 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) :to :result) - (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) @@ -386,7 +376,7 @@ (:generator 7 (inst sll index 2 offset) (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) + offset offset) (let ((real-tn (complex-double-reg-real-tn value))) (inst fldx offset object real-tn)) (let ((imag-tn (complex-double-reg-imag-tn value))) @@ -398,82 +388,72 @@ (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) - (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 (non-descriptor-reg) :from (:argument 1)) offset) (:generator 20 (inst sll index 2 offset) (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - offset offset) + offset offset) (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 fstx value-real offset object) (unless (location= result-real value-real) - (inst funop :copy value-real result-real))) + (inst funop :copy 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 addi (* 2 n-word-bytes) offset offset) (inst fstx value-imag offset object) (unless (location= result-imag value-imag) - (inst funop :copy value-imag result-imag))))) + (inst funop :copy value-imag result-imag))))) ;;; These VOPs are used for implementing float slots in structures (whose raw ;;; data is an unsigned-32 vector. -;;; (define-vop (raw-ref-single data-vector-ref/simple-array-single-float) (:translate %raw-ref-single) (:arg-types sb!c::raw-vector positive-fixnum)) -;;; (define-vop (raw-set-single data-vector-set/simple-array-single-float) (:translate %raw-set-single) (:arg-types sb!c::raw-vector positive-fixnum single-float)) -;;; (define-vop (raw-ref-double data-vector-ref/simple-array-double-float) (:translate %raw-ref-double) (:arg-types sb!c::raw-vector positive-fixnum)) -;;; (define-vop (raw-set-double data-vector-set/simple-array-double-float) (:translate %raw-set-double) (: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)) ;;; These vops are useful for accessing the bits of a vector irrespective of ;;; what type of vector it is. -;;; - (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num %raw-bits) (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num %set-raw-bits) - - +(define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag + (unsigned-reg) unsigned-num %vector-raw-bits) +(define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag + (unsigned-reg) unsigned-num %set-vector-raw-bits) ;;;; Misc. Array VOPs. - (define-vop (get-vector-subtype get-header-data)) (define-vop (set-vector-subtype set-header-data)) -