X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Farray.lisp;h=cf3af860af2edbee20345aa2fefb47bb348c1416;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=ccd188019bf7c660ccdfd2445c547696ffb8938e;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/alpha/array.lisp b/src/compiler/alpha/array.lisp index ccd1880..cf3af86 100644 --- a/src/compiler/alpha/array.lisp +++ b/src/compiler/alpha/array.lisp @@ -1,24 +1,17 @@ -;;; -*- Package: ALPHA -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; - -;;; -;;; ********************************************************************** -;;; -;;; This file contains the Alpha definitions for array operations. -;;; -;;; Written by William Lott -;;; Conversion by Sean Hallgren -;;; Complex-float support by Douglas Crosher 1998. -;;; -(in-package "SB!VM") +;;;; the Alpha definitions for array operations +;;;; 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") -;;;; Allocator for the array header. +;;;; allocator for the array header (define-vop (make-array-header) (:policy :fast-safe) @@ -30,23 +23,23 @@ (:temporary (:scs (non-descriptor-reg)) header) (:results (result :scs (descriptor-reg))) (:generator 13 - (inst addq rank (+ (* array-dimensions-offset word-bytes) + (inst addq rank (+ (* 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) - (inst sll header type-bits header) + (inst sll header n-widetag-bits header) (inst bis header type header) (inst srl header 2 header) (pseudo-atomic () - (inst bis alloc-tn other-pointer-type result) - (storew header result 0 other-pointer-type) + (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. +;;;; additional accessors and setters for the array header (defknown sb!impl::%array-dimension (t index) index (flushable)) @@ -54,12 +47,12 @@ ()) (define-full-reffer %array-dimension * - array-dimensions-offset other-pointer-type + array-dimensions-offset other-pointer-lowtag (any-reg) positive-fixnum sb!impl::%array-dimension) (define-full-setter %set-array-dimension * - array-dimensions-offset other-pointer-type - (any-reg) positive-fixnum sb!impl::%set-array-dimension #+gengc nil) + array-dimensions-offset other-pointer-lowtag + (any-reg) positive-fixnum sb!impl::%set-array-dimension #!+gengc nil) (defknown sb!impl::%array-rank (t) index (flushable)) @@ -71,15 +64,14 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:results (res :scs (any-reg descriptor-reg))) (:generator 6 - (loadw temp x 0 other-pointer-type) - (inst sra temp type-bits temp) + (loadw temp x 0 other-pointer-lowtag) + (inst sra temp n-widetag-bits temp) (inst subq temp (1- array-dimensions-offset) temp) (inst sll temp 2 res))) -;;;; Bounds checking routine. - +;;;; bounds checking routine (define-vop (check-bound) (:translate %check-bound) @@ -97,37 +89,40 @@ (inst cmpult index bound temp) (inst beq temp error) (move index result)))) - - -;;;; Accessors/Setters - -;;; 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. +;;;; accessors/setters +;;; Variants built on top of word-index-ref, etc. I.e. those vectors +;;; whose 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 - vector-data-offset other-pointer-type - ,(remove-if #'(lambda (x) (member x '(null zero))) scs) + (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" 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 - vector-data-offset other-pointer-type ,scs ,element-type - data-vector-set #+gengc ,(if (member 'descriptor-reg scs) t nil)))) + (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) + ,type + vector-data-offset other-pointer-lowtag ,scs ,element-type + data-vector-set #+gengc ,(if (member 'descriptor-reg scs) + t + nil)))) (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-type ,scs + (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" 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 - ,size vector-data-offset other-pointer-type ,scs + (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) + ,type + ,size vector-data-offset other-pointer-lowtag ,scs ,element-type data-vector-set))) (def-small-data-vector-frobs (type bits) - (let* ((elements-per-word (floor word-bits bits)) + (let* ((elements-per-word (floor n-word-bits bits)) (bit-shift (1- (integer-length elements-per-word)))) `(progn (define-vop (,(symbolicate 'data-vector-ref/ type)) @@ -140,18 +135,20 @@ (:results (value :scs (any-reg))) (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) + temp result) (:generator 20 (inst srl index ,bit-shift temp) (inst sll temp 2 temp) (inst addq object temp lip) (inst ldl result - (- (* vector-data-offset word-bytes) - other-pointer-type) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip) (inst and index ,(1- elements-per-word) temp) ,@(unless (= bits 1) - `((inst sll temp ,(1- (integer-length bits)) temp))) + `((inst sll temp + ,(1- (integer-length bits)) temp))) (inst srl result temp result) (inst and result ,(1- (ash 1 bits)) result) (inst sll result 2 value))) @@ -163,47 +160,55 @@ (:constant (integer 0 ,(1- (* (1+ (- (floor (+ #x7fff - other-pointer-type) - word-bytes) + other-pointer-lowtag) + n-word-bytes) vector-data-offset)) elements-per-word))))) (:info index) (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 15 - (multiple-value-bind (word extra) (floor index ,elements-per-word) - (loadw result object (+ word vector-data-offset) - other-pointer-type) + (multiple-value-bind (word extra) + (floor index ,elements-per-word) + (loadw result object (+ word + 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))))) + (inst and result ,(1- (ash 1 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) :target shift) - (value :scs (unsigned-reg zero immediate) :target result)) + (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 (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) temp old) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) + (:temporary (:scs (non-descriptor-reg) + :from (:argument 1)) shift) (:generator 25 (inst srl index ,bit-shift temp) (inst sll temp 2 temp) (inst addq object temp lip) (inst ldl old - (- (* vector-data-offset word-bytes) - other-pointer-type) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip) (inst and index ,(1- elements-per-word) shift) ,@(unless (= bits 1) - `((inst sll shift ,(1- (integer-length bits)) shift))) + `((inst sll shift ,(1- (integer-length + bits)) + shift))) (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) + (= (tn-value value) + ,(1- (ash 1 bits)))) (inst li ,(1- (ash 1 bits)) temp) (inst sll temp shift temp) (inst not temp temp) @@ -211,14 +216,19 @@ (unless (sc-is value zero) (sc-case value (immediate - (inst li (logand (tn-value value) ,(1- (ash 1 bits))) temp)) + (inst li + (logand (tn-value value) + ,(1- (ash 1 bits))) + temp)) (unsigned-reg - (inst and value ,(1- (ash 1 bits)) temp))) + (inst and value + ,(1- (ash 1 bits)) + temp))) (inst sll temp shift temp) (inst bis old temp old)) (inst stl old - (- (* vector-data-offset word-bytes) - other-pointer-type) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip) (sc-case value (immediate @@ -231,13 +241,14 @@ (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (value :scs (unsigned-reg zero immediate) :target result)) + (value :scs (unsigned-reg zero immediate) + :target result)) (:arg-types ,type (:constant (integer 0 ,(1- (* (1+ (- (floor (+ #x7fff - other-pointer-type) - word-bytes) + other-pointer-lowtag) + n-word-bytes) vector-data-offset)) elements-per-word)))) positive-fixnum) @@ -246,37 +257,49 @@ (:result-types positive-fixnum) (:temporary (:scs (non-descriptor-reg)) temp old) (:generator 20 - (multiple-value-bind (word extra) (floor index ,elements-per-word) + (multiple-value-bind (word extra) + (floor index ,elements-per-word) (inst ldl object - (- (* (+ word vector-data-offset) word-bytes) - other-pointer-type) + (- (* (+ word vector-data-offset) + n-word-bytes) + other-pointer-lowtag) old) (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) + (= (tn-value value) + ,(1- (ash 1 bits)))) (cond ((= 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))) + (lognot (ash ,(1- (ash 1 + 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))) - (* extra ,bits)))) + (let ((value + (ash (logand (tn-value + value) + ,(1- (ash 1 + bits))) + (* extra + ,bits)))) (cond ((< value #x10000) (inst bis old value old)) (t (inst li value temp) (inst bis old temp old))))) (unsigned-reg - (inst sll value (* extra ,bits) temp) + (inst sll value (* extra ,bits) + temp) (inst bis old temp old))) (inst stl old - (- (* (+ word vector-data-offset) word-bytes) - other-pointer-type) + (- (* (+ word vector-data-offset) + n-word-bytes) + other-pointer-lowtag) object) (sc-case value (immediate @@ -308,19 +331,16 @@ (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) + (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. - ;; - + ;; 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) (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. -;;; +;;; and the float variants.. (define-vop (data-vector-ref/simple-array-single-float) (:note "inline array access") @@ -335,8 +355,8 @@ (:generator 20 (inst addq object index lip) (inst lds value - (- (* vector-data-offset word-bytes) - other-pointer-type) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip))) (define-vop (data-vector-set/simple-array-single-float) @@ -353,8 +373,8 @@ (:generator 20 (inst addq object index lip) (inst sts value - (- (* vector-data-offset word-bytes) - other-pointer-type) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip) (unless (location= result value) (inst fmove value result)))) @@ -373,8 +393,8 @@ (inst addq object index lip) (inst addq lip index lip) (inst ldt value - (- (* vector-data-offset word-bytes) - other-pointer-type) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip))) (define-vop (data-vector-set/simple-array-double-float) @@ -392,13 +412,12 @@ (inst addq object index lip) (inst addq lip index lip) (inst stt value - (- (* vector-data-offset word-bytes) - other-pointer-type) lip) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip) (unless (location= result value) (inst fmove value result)))) - -;;; Complex float arrays. +;;; complex float arrays (define-vop (data-vector-ref/simple-array-complex-single-float) (:note "inline array access") @@ -415,11 +434,11 @@ (inst addq object index lip) (inst addq lip index lip) (inst lds real-tn - (- (* vector-data-offset word-bytes) other-pointer-type) + (- (* 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) word-bytes) other-pointer-type) + (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) lip)))) (define-vop (data-vector-set/simple-array-complex-single-float) @@ -440,14 +459,14 @@ (inst addq object index lip) (inst addq lip index lip) (inst sts value-real - (- (* vector-data-offset word-bytes) other-pointer-type) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) lip) (unless (location= result-real value-real) (inst fmove value-real result-real))) (let ((value-imag (complex-single-reg-imag-tn value)) (result-imag (complex-single-reg-imag-tn result))) (inst sts value-imag - (- (* (1+ vector-data-offset) word-bytes) other-pointer-type) + (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) lip) (unless (location= result-imag value-imag) (inst fmove value-imag result-imag))))) @@ -469,11 +488,11 @@ (inst addq lip index lip) (inst addq lip index lip) (inst ldt real-tn - (- (* vector-data-offset word-bytes) other-pointer-type) + (- (* 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) word-bytes) other-pointer-type) + (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) lip)))) (define-vop (data-vector-set/simple-array-complex-double-float) @@ -496,21 +515,21 @@ (inst addq lip index lip) (inst addq lip index lip) (inst stt value-real - (- (* vector-data-offset word-bytes) other-pointer-type) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) lip) (unless (location= result-real value-real) (inst fmove value-real result-real))) (let ((value-imag (complex-double-reg-imag-tn value)) (result-imag (complex-double-reg-imag-tn result))) (inst stt value-imag - (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type) + (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) lip) (unless (location= result-imag value-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. +;;; 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) @@ -550,19 +569,16 @@ (:arg-types simple-array-unsigned-byte-32 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-type (unsigned-reg) unsigned-num +;;; +(define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num %raw-bits) -(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) +(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num %set-raw-bits #+gengc nil) - -;;;; Misc. Array VOPs. +;;;; misc. array VOPs (define-vop (get-vector-subtype get-header-data)) (define-vop (set-vector-subtype set-header-data))