X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=d425b3697ad26451f183d8a53244f9f80c100786;hb=9767de1cecfe50560fe1da69fd458b6148a66da3;hp=7eabbc1c93460adbdba3aa2b56a4f3e59c841e4b;hpb=7ce2c42adf3d62f03086de940adaee48e6161a40;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 7eabbc1..d425b36 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -58,7 +58,8 @@ array (make-array-type :complexp t :element-type *wild-type*) - (lexenv-policy (node-lexenv (continuation-dest array))))) + (lexenv-policy (node-lexenv (continuation-dest array)))) + nil) ;;; Return true if ARG is NIL, or is a constant-continuation whose ;;; value is NIL, false otherwise. @@ -110,11 +111,10 @@ (defoptimizer (%with-array-data derive-type) ((array start end)) (let ((atype (continuation-type array))) (when (array-type-p atype) - (values-specifier-type - `(values (simple-array ,(type-specifier - (array-type-specialized-element-type atype)) - (*)) - index index index))))) + (specifier-type + `(simple-array ,(type-specifier + (array-type-specialized-element-type atype)) + (*)))))) (defoptimizer (array-row-major-index derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) @@ -139,11 +139,12 @@ (continuation-value element-type)) (t '*)) - ,(cond ((not simple) - '*) - ((constant-continuation-p dims) - (let ((val (continuation-value dims))) - (if (listp val) val (list val)))) + ,(cond ((constant-continuation-p dims) + (let* ((val (continuation-value dims)) + (cdims (if (listp val) val (list val)))) + (if simple + cdims + (length cdims)))) ((csubtypep (continuation-type dims) (specifier-type 'integer)) '(*)) @@ -187,81 +188,14 @@ ,n-vec)))) ;;; Just convert it into a MAKE-ARRAY. -(define-source-transform make-string (length &key - (element-type ''base-char) - (initial-element - '#.*default-init-char-form*)) - `(make-array (the index ,length) - :element-type ,element-type - :initial-element ,initial-element)) - -(defstruct (specialized-array-element-type-properties - (:conc-name saetp-) - (:constructor !make-saetp (ctype - initial-element-default - n-bits - typecode - &key - (n-pad-elements 0))) - (:copier nil)) - ;; the element type, e.g. # or - ;; # - (ctype (missing-arg) :type ctype :read-only t) - ;; what we get when the low-level vector-creation logic zeroes all - ;; the bits (which also serves as the default value of MAKE-ARRAY's - ;; :INITIAL-ELEMENT keyword) - (initial-element-default (missing-arg) :read-only t) - ;; how many bits per element - (n-bits (missing-arg) :type index :read-only t) - ;; the low-level type code - (typecode (missing-arg) :type index :read-only t) - ;; the number of extra elements we use at the end of the array for - ;; low level hackery (e.g., one element for arrays of BASE-CHAR, - ;; which is used for a fixed #\NULL so that when we call out to C - ;; we don't need to cons a new copy) - (n-pad-elements (missing-arg) :type index :read-only t)) - -(defparameter *specialized-array-element-type-properties* - (map 'simple-vector - (lambda (args) - (destructuring-bind (type-spec &rest rest) args - (let ((ctype (specifier-type type-spec))) - (apply #'!make-saetp ctype rest)))) - `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag - ;; (SIMPLE-STRINGs are stored with an extra trailing - ;; #\NULL for convenience in calling out to C.) - :n-pad-elements 1) - (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag) - (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag) - #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128 - ,sb!vm:simple-array-long-float-widetag) - (bit 0 1 ,sb!vm:simple-bit-vector-widetag) - ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come - ;; before their SIGNED-BYTE partners is significant in the - ;; implementation of the compiler; some of the cross-compiler - ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in - ;; src/compiler/debug-dump.lisp) attempts to create an array - ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7; - ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're - ;; not careful we could get the wrong specialized array when - ;; we try to FIND-IF, below. -- CSR, 2002-07-08 - ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag) - ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag) - ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag) - ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag) - ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag) - ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag) - ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag) - ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag) - ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag) - ((complex single-float) #C(0.0f0 0.0f0) 64 - ,sb!vm:simple-array-complex-single-float-widetag) - ((complex double-float) #C(0.0d0 0.0d0) 128 - ,sb!vm:simple-array-complex-double-float-widetag) - #!+long-float ((complex long-float) #C(0.0L0 0.0L0) - #!+x86 192 #!+sparc 256 - ,sb!vm:simple-array-complex-long-float-widetag) - (t 0 32 ,sb!vm:simple-vector-widetag)))) +(deftransform make-string ((length &key + (element-type 'character) + (initial-element + #.*default-init-char-form*))) + `(the simple-string (make-array (the index length) + :element-type element-type + ,@(when initial-element + '(:initial-element initial-element))))) (deftransform make-array ((dims &key initial-element element-type adjustable fill-pointer) @@ -276,39 +210,42 @@ (continuation-value element-type)))) (eltype-type (ir1-transform-specifier-type eltype)) (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (saetp-ctype saetp))) - *specialized-array-element-type-properties*)) - (creation-form `(make-array dims :element-type ',eltype - ,@(when fill-pointer - '(:fill-pointer fill-pointer)) - ,@(when adjustable - '(:adjustable adjustable))))) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*)) + (creation-form `(make-array dims + :element-type ',(type-specifier (sb!vm:saetp-ctype saetp)) + ,@(when fill-pointer + '(:fill-pointer fill-pointer)) + ,@(when adjustable + '(:adjustable adjustable))))) (unless saetp (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype)) - (cond ((or (null initial-element) - (and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) - (saetp-initial-element-default saetp)))) - (unless (csubtypep (ctype-of (saetp-initial-element-default saetp)) - eltype-type) - ;; This situation arises e.g. in (MAKE-ARRAY 4 - ;; :ELEMENT-TYPE '(INTEGER 1 5)) ANSI's definition of - ;; MAKE-ARRAY says "If INITIAL-ELEMENT is not supplied, - ;; the consequences of later reading an uninitialized - ;; element of new-array are undefined," so this could be - ;; legal code as long as the user plans to write before - ;; he reads, and if he doesn't we're free to do anything - ;; we like. But in case the user doesn't know to write - ;; elements before he reads elements (or to read manuals - ;; before he writes code:-), we'll signal a STYLE-WARNING - ;; in case he didn't realize this. - (compiler-note "The default initial element ~S is not a ~S." - (saetp-initial-element-default saetp) - eltype)) + (cond ((and (constant-continuation-p initial-element) + (eql (continuation-value initial-element) + (sb!vm:saetp-initial-element-default saetp))) creation-form) (t + ;; error checking for target, disabled on the host because + ;; (CTYPE-OF #\Null) is not possible. + #-sb-xc-host + (when (constant-continuation-p initial-element) + (let ((value (continuation-value initial-element))) + (cond + ((not (ctypep value (sb!vm:saetp-ctype saetp))) + ;; this case will cause an error at runtime, so we'd + ;; better WARN about it now. + (compiler-warn "~@<~S is not a ~S (which is the ~ + UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>" + value + (type-specifier (sb!vm:saetp-ctype saetp)) + eltype)) + ((not (ctypep value eltype-type)) + ;; this case will not cause an error at runtime, but + ;; it's still worth STYLE-WARNing about. + (compiler-style-warn "~S is not a ~S." + value eltype))))) `(let ((array ,creation-form)) (multiple-value-bind (vector) (%data-vector-and-index array 0) @@ -334,27 +271,45 @@ (result-type-spec `(simple-array ,eltype (,len))) (eltype-type (ir1-transform-specifier-type eltype)) (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (saetp-ctype saetp))) - *specialized-array-element-type-properties*))) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*))) (unless saetp (give-up-ir1-transform "cannot open-code creation of ~S" result-type-spec)) - - (let* ((n-bits-per-element (saetp-n-bits saetp)) - (typecode (saetp-typecode saetp)) - (n-pad-elements (saetp-n-pad-elements saetp)) + #-sb-xc-host + (unless (csubtypep (ctype-of (sb!vm:saetp-initial-element-default saetp)) + eltype-type) + ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE + ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If + ;; INITIAL-ELEMENT is not supplied, the consequences of later + ;; reading an uninitialized element of new-array are undefined," + ;; so this could be legal code as long as the user plans to + ;; write before he reads, and if he doesn't we're free to do + ;; anything we like. But in case the user doesn't know to write + ;; elements before he reads elements (or to read manuals before + ;; he writes code:-), we'll signal a STYLE-WARNING in case he + ;; didn't realize this. + (compiler-style-warn "The default initial element ~S is not a ~S." + (sb!vm:saetp-initial-element-default saetp) + eltype)) + (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp)) + (typecode (sb!vm:saetp-typecode saetp)) + (n-pad-elements (sb!vm:saetp-n-pad-elements saetp)) (padded-length-form (if (zerop n-pad-elements) 'length `(+ length ,n-pad-elements))) (n-words-form - (if (>= n-bits-per-element sb!vm:n-word-bits) - `(* ,padded-length-form - (the fixnum ; i.e., not RATIO - ,(/ n-bits-per-element sb!vm:n-word-bits))) - (let ((n-elements-per-word (/ sb!vm:n-word-bits - n-bits-per-element))) - (declare (type index n-elements-per-word)) ; i.e., not RATIO - `(ceiling ,padded-length-form ,n-elements-per-word))))) + (cond + ((= n-bits-per-element 0) 0) + ((>= n-bits-per-element sb!vm:n-word-bits) + `(* ,padded-length-form + (the fixnum ; i.e., not RATIO + ,(/ n-bits-per-element sb!vm:n-word-bits)))) + (t + (let ((n-elements-per-word (/ sb!vm:n-word-bits + n-bits-per-element))) + (declare (type index n-elements-per-word)) ; i.e., not RATIO + `(ceiling ,padded-length-form ,n-elements-per-word)))))) (values `(truly-the ,result-type-spec (allocate-vector ,typecode length ,n-words-form)) @@ -483,9 +438,10 @@ ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a ;;; compile-time constant. -(deftransform vector-length ((vector) ((simple-array * (*)))) +(deftransform vector-length ((vector)) (let ((vtype (continuation-type vector))) - (if (array-type-p vtype) + (if (and (array-type-p vtype) + (not (array-type-complexp vtype))) (let ((dim (first (array-type-dimensions vtype)))) (when (eq dim '*) (give-up-ir1-transform)) dim) @@ -532,14 +488,14 @@ ;;; Primitive used to verify indices into arrays. If we can tell at ;;; compile-time or we are generating unsafe code, don't bother with ;;; the VOP. -(deftransform %check-bound ((array dimension index)) - (unless (constant-continuation-p dimension) - (give-up-ir1-transform)) - (let ((dim (continuation-value dimension))) - `(the (integer 0 ,dim) index))) -(deftransform %check-bound ((array dimension index) * * - :policy (and (> speed safety) (= safety 0))) - 'index) +(deftransform %check-bound ((array dimension index) * * :node node) + (cond ((policy node (and (> speed safety) (= safety 0))) + 'index) + ((not (constant-continuation-p dimension)) + (give-up-ir1-transform)) + (t + (let ((dim (continuation-value dimension))) + `(the (integer 0 ,dim) index))))) ;;;; WITH-ARRAY-DATA @@ -601,23 +557,27 @@ (element-type '*) unsafe? fail-inline?) - (let ((size (gensym "SIZE-")) - (defaulted-end (gensym "DEFAULTED-END-")) - (data (gensym "DATA-")) - (cumulative-offset (gensym "CUMULATIVE-OFFSET-"))) + (with-unique-names (size defaulted-end data cumulative-offset) `(let* ((,size (array-total-size ,array)) (,defaulted-end (cond (,end (unless (or ,unsafe? (<= ,end ,size)) ,(if fail-inline? - `(error "End ~W is greater than total size ~W." - ,end ,size) + `(error 'bounding-indices-bad-error + :datum (cons ,start ,end) + :expected-type `(cons (integer 0 ,',size) + (integer ,',start ,',size)) + :object ,array) `(failed-%with-array-data ,array ,start ,end))) ,end) (t ,size)))) (unless (or ,unsafe? (<= ,start ,defaulted-end)) ,(if fail-inline? - `(error "Start ~W is greater than end ~W." ,start ,defaulted-end) + `(error 'bounding-indices-bad-error + :datum (cons ,start ,end) + :expected-type `(cons (integer 0 ,',size) + (integer ,',start ,',size)) + :object ,array) `(failed-%with-array-data ,array ,start ,end))) (do ((,data ,array (%array-data-vector ,data)) (,cumulative-offset 0 @@ -657,11 +617,17 @@ `(aref (the ,',type ,a) ,@i)) (define-source-transform ,setter (a &rest i) `(%aset (the ,',type ,a) ,@i))))) - (define-frob svref %svset simple-vector) - (define-frob schar %scharset simple-string) - (define-frob char %charset string) (define-frob sbit %sbitset (simple-array bit)) (define-frob bit %bitset (array bit))) +(macrolet ((define-frob (reffer setter type) + `(progn + (define-source-transform ,reffer (a i) + `(aref (the ,',type ,a) ,i)) + (define-source-transform ,setter (a i v) + `(%aset (the ,',type ,a) ,i ,v))))) + (define-frob svref %svset simple-vector) + (define-frob schar %scharset simple-string) + (define-frob char %charset string)) (macrolet (;; This is a handy macro for computing the row-major index ;; given a set of indices. We wrap each index with a call @@ -785,7 +751,7 @@ (cond ((csubtypep type (specifier-type '(simple-array * (*)))) ;; no array header nil) - ((and (listp dims) (> (length dims) 1)) + ((and (listp dims) (/= (length dims) 1)) ;; multi-dimensional array, will have a header t) (t