X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Farray.lisp;h=000f5d4793b4c223d7a74510f939c7e6e2adcbe8;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=35568d8a87e7cedf74fff07cfe082b011070a8f0;hpb=83764e089aec9f082ce7c038f45ff8883d9ca957;p=sbcl.git diff --git a/src/compiler/alpha/array.lisp b/src/compiler/alpha/array.lisp index 35568d8..000f5d4 100644 --- a/src/compiler/alpha/array.lisp +++ b/src/compiler/alpha/array.lisp @@ -12,20 +12,19 @@ (in-package "SB!VM") ;;;; allocator for the array header - (define-vop (make-array-header) (: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) + (inst addq rank (+ (* (1+ array-dimensions-offset) n-word-bytes) + lowtag-mask) + bytes) (inst li (lognot lowtag-mask) header) (inst and bytes header bytes) (inst addq rank (fixnumize (1- array-dimensions-offset)) header) @@ -36,8 +35,6 @@ (inst bis alloc-tn other-pointer-lowtag result) (storew header result 0 other-pointer-lowtag) (inst addq alloc-tn bytes alloc-tn)))) - - ;;;; additional accessors and setters for the array header (define-full-reffer %array-dimension * @@ -61,20 +58,19 @@ (inst sll temp n-fixnum-tag-bits 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))) (: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)))) @@ -87,27 +83,27 @@ (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) @@ -125,7 +121,7 @@ (: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) @@ -137,7 +133,7 @@ (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))) @@ -158,15 +154,15 @@ (: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) @@ -174,14 +170,14 @@ (: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) @@ -193,11 +189,11 @@ (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) @@ -206,13 +202,13 @@ (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 @@ -231,7 +227,7 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (value :scs (unsigned-reg zero immediate) - :target result)) + :target result)) (:arg-types ,type (:constant (integer 0 @@ -247,47 +243,50 @@ (: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)))) - (cond ((= extra ,(1- elements-per-word)) + ,(1- (ash 1 bits)))) + (cond #+#.(cl:if + (cl:= sb-vm:n-word-bits sb-vm:n-machine-word-bits) + '(and) '(or)) + ((= extra ,(1- elements-per-word)) (inst sll old ,bits old) (inst srl old ,bits old)) (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)))) - (cond ((< value #x10000) + ,bits)))) + (cond ((< value #x100) (inst bis old value old)) (t (inst li value temp) (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 @@ -299,37 +298,40 @@ (move value result)))))))))) (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg null zero) - - (def-partial-data-vector-frobs simple-base-string base-char :byte nil - base-char-reg) - + + (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-signed-byte-30 tagged-num any-reg) - + + (def-full-data-vector-frobs simple-array-unsigned-fixnum positive-fixnum + any-reg) + (def-full-data-vector-frobs simple-array-fixnum 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) @@ -343,7 +345,7 @@ (: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) @@ -351,17 +353,17 @@ (: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) @@ -369,9 +371,9 @@ (: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)))) @@ -380,7 +382,7 @@ (: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) @@ -389,17 +391,17 @@ (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) @@ -408,8 +410,8 @@ (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)))) @@ -420,7 +422,7 @@ (: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) @@ -430,49 +432,49 @@ (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) @@ -484,92 +486,53 @@ (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))))) -;;; 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) - (: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) - (: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) - (: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) - (: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 #+gengc nil) +(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