X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=6dae5357f9216a9a728fddd3213d855c145ccf2a;hb=3c5609fe910bae51ff885c8cfd4be879151e7489;hp=98d26dbf6ce3817dabb622aef4e790398fe9db85;hpb=2d195da5e29feadce7190ea1a68a2efa83a5e1c0;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 98d26db..6dae535 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -11,47 +11,79 @@ (in-package "SB!C") -;;;; Derive-Type Optimizers - -;;; Array operations that use a specific number of indices implicitly assert -;;; that the array is of that rank. -(defun assert-array-rank (array rank) - (assert-continuation-type - array - (specifier-type `(array * ,(make-list rank :initial-element '*))))) - -;;; Array access functions return an object from the array, hence its -;;; type will be asserted to be array element type. -(defun extract-element-type (array) - (let ((type (continuation-type array))) - (if (array-type-p type) - (array-type-element-type type) - *universal-type*))) +;;;; utilities for optimizing array operations + +;;; Return UPGRADED-ARRAY-ELEMENT-TYPE for LVAR, or do +;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be +;;; determined. +(defun upgraded-element-type-specifier-or-give-up (lvar) + (let* ((element-ctype (extract-upgraded-element-type lvar)) + (element-type-specifier (type-specifier element-ctype))) + (if (eq element-type-specifier '*) + (give-up-ir1-transform + "upgraded array element type not known at compile time") + element-type-specifier))) ;;; Array access functions return an object from the array, hence its ;;; type is going to be the array upgraded element type. (defun extract-upgraded-element-type (array) - (let ((type (continuation-type array))) + (let ((type (lvar-type array))) + ;; Note that this IF mightn't be satisfied even if the runtime + ;; value is known to be a subtype of some specialized ARRAY, because + ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE), + ;; which are represented in the compiler as INTERSECTION-TYPE, not + ;; array type. (if (array-type-p type) (array-type-specialized-element-type type) - *universal-type*))) + ;; KLUDGE: there is no good answer here, but at least + ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be + ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR, + ;; 2002-08-21 + *wild-type*))) + +(defun extract-declared-element-type (array) + (let ((type (lvar-type array))) + (if (array-type-p type) + (array-type-element-type type) + *wild-type*))) ;;; The ``new-value'' for array setters must fit in the array, and the ;;; return type is going to be the same as the new-value for SETF ;;; functions. (defun assert-new-value-type (new-value array) - (let ((type (continuation-type array))) + (let ((type (lvar-type array))) (when (array-type-p type) - (assert-continuation-type new-value (array-type-element-type type)))) - (continuation-type new-value)) + (assert-lvar-type + new-value + (array-type-specialized-element-type type) + (lexenv-policy (node-lexenv (lvar-dest new-value)))))) + (lvar-type new-value)) + +(defun assert-array-complex (array) + (assert-lvar-type + array + (make-array-type :complexp t + :element-type *wild-type*) + (lexenv-policy (node-lexenv (lvar-dest array)))) + nil) -;;; Return true if Arg is NIL, or is a constant-continuation whose value is -;;; NIL, false otherwise. +;;; Return true if ARG is NIL, or is a constant-lvar whose +;;; value is NIL, false otherwise. (defun unsupplied-or-nil (arg) - (declare (type (or continuation null) arg)) + (declare (type (or lvar null) arg)) (or (not arg) - (and (constant-continuation-p arg) - (not (continuation-value arg))))) + (and (constant-lvar-p arg) + (not (lvar-value arg))))) + +;;;; DERIVE-TYPE optimizers + +;;; Array operations that use a specific number of indices implicitly +;;; assert that the array is of that rank. +(defun assert-array-rank (array rank) + (assert-lvar-type + array + (specifier-type `(array * ,(make-list rank :initial-element '*))) + (lexenv-policy (node-lexenv (lvar-dest array))))) (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) @@ -59,10 +91,6 @@ (defoptimizer (aref derive-type) ((array &rest indices) node) (assert-array-rank array (length indices)) - ;; If the node continuation has a single use then assert its type. - (let ((cont (node-cont node))) - (when (= (length (find-uses cont)) 1) - (assert-continuation-type cont (extract-element-type array)))) (extract-upgraded-element-type array)) (defoptimizer (%aset derive-type) ((array &rest stuff)) @@ -82,13 +110,12 @@ ;;; Figure out the type of the data vector if we know the argument ;;; element type. (defoptimizer (%with-array-data derive-type) ((array start end)) - (let ((atype (continuation-type array))) + (let ((atype (lvar-type array))) (when (array-type-p atype) - (values-specifier-type - `(values (simple-array ,(type-specifier - (array-type-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)) @@ -106,189 +133,254 @@ (let ((simple (and (unsupplied-or-nil adjustable) (unsupplied-or-nil displaced-to) (unsupplied-or-nil fill-pointer)))) - (specifier-type - `(,(if simple 'simple-array 'array) - ,(cond ((not element-type) 't) - ((constant-continuation-p element-type) - (continuation-value element-type)) - (t - '*)) - ,(cond ((not simple) - '*) - ((constant-continuation-p dims) - (let ((val (continuation-value dims))) - (if (listp val) val (list val)))) - ((csubtypep (continuation-type dims) - (specifier-type 'integer)) - '(*)) - (t - '*)))))) + (or (careful-specifier-type + `(,(if simple 'simple-array 'array) + ,(cond ((not element-type) t) + ((constant-lvar-p element-type) + (let ((ctype (careful-specifier-type + (lvar-value element-type)))) + (cond + ((or (null ctype) (unknown-type-p ctype)) '*) + (t (sb!xc:upgraded-array-element-type + (lvar-value element-type)))))) + (t + '*)) + ,(cond ((constant-lvar-p dims) + (let* ((val (lvar-value dims)) + (cdims (if (listp val) val (list val)))) + (if simple + cdims + (length cdims)))) + ((csubtypep (lvar-type dims) + (specifier-type 'integer)) + '(*)) + (t + '*)))) + (specifier-type 'array)))) + +;;; Complex array operations should assert that their array argument +;;; is complex. In SBCL, vectors with fill-pointers are complex. +(defoptimizer (fill-pointer derive-type) ((vector)) + (assert-array-complex vector)) +(defoptimizer (%set-fill-pointer derive-type) ((vector index)) + (declare (ignorable index)) + (assert-array-complex vector)) + +(defoptimizer (vector-push derive-type) ((object vector)) + (declare (ignorable object)) + (assert-array-complex vector)) +(defoptimizer (vector-push-extend derive-type) + ((object vector &optional index)) + (declare (ignorable object index)) + (assert-array-complex vector)) +(defoptimizer (vector-pop derive-type) ((vector)) + (assert-array-complex vector)) ;;;; constructors ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the ;;; elements. -(def-source-transform vector (&rest elements) - (if (byte-compiling) - (values nil t) - (let ((len (length elements)) - (n -1)) - (once-only ((n-vec `(make-array ,len))) - `(progn - ,@(mapcar #'(lambda (el) - (once-only ((n-val el)) - `(locally (declare (optimize (safety 0))) - (setf (svref ,n-vec ,(incf n)) - ,n-val)))) - elements) - ,n-vec))))) +(define-source-transform vector (&rest elements) + (let ((len (length elements)) + (n -1)) + (once-only ((n-vec `(make-array ,len))) + `(progn + ,@(mapcar (lambda (el) + (once-only ((n-val el)) + `(locally (declare (optimize (safety 0))) + (setf (svref ,n-vec ,(incf n)) + ,n-val)))) + elements) + ,n-vec)))) ;;; Just convert it into a MAKE-ARRAY. -(def-source-transform make-string (length &key - (element-type ''base-char) - (initial-element default-init-char)) - (if (byte-compiling) - (values nil t) - `(make-array (the index ,length) - :element-type ,element-type - :initial-element ,initial-element))) - -(defparameter *array-info* - #((base-char #.default-init-char 8 sb!vm:simple-string-type) - (single-float 0.0s0 32 sb!vm:simple-array-single-float-type) - (double-float 0.0d0 64 sb!vm:simple-array-double-float-type) - #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128 - sb!vm:simple-array-long-float-type) - (bit 0 1 sb!vm:simple-bit-vector-type) - ((unsigned-byte 2) 0 2 sb!vm:simple-array-unsigned-byte-2-type) - ((unsigned-byte 4) 0 4 sb!vm:simple-array-unsigned-byte-4-type) - ((unsigned-byte 8) 0 8 sb!vm:simple-array-unsigned-byte-8-type) - ((unsigned-byte 16) 0 16 sb!vm:simple-array-unsigned-byte-16-type) - ((unsigned-byte 32) 0 32 sb!vm:simple-array-unsigned-byte-32-type) - ((signed-byte 8) 0 8 sb!vm:simple-array-signed-byte-8-type) - ((signed-byte 16) 0 16 sb!vm:simple-array-signed-byte-16-type) - ((signed-byte 30) 0 32 sb!vm:simple-array-signed-byte-30-type) - ((signed-byte 32) 0 32 sb!vm:simple-array-signed-byte-32-type) - ((complex single-float) #C(0.0s0 0.0s0) 64 - sb!vm:simple-array-complex-single-float-type) - ((complex double-float) #C(0.0d0 0.0d0) 128 - sb!vm:simple-array-complex-double-float-type) - #!+long-float - ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256 - sb!vm:simple-array-complex-long-float-type) - (t 0 32 sb!vm:simple-vector-type))) +(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) + (t &rest *)) + (when (null initial-element) + (give-up-ir1-transform)) + (let* ((eltype (cond ((not element-type) t) + ((not (constant-lvar-p element-type)) + (give-up-ir1-transform + "ELEMENT-TYPE is not constant.")) + (t + (lvar-value element-type)))) + (eltype-type (ir1-transform-specifier-type eltype)) + (saetp (find-if (lambda (saetp) + (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 ((and (constant-lvar-p initial-element) + (eql (lvar-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-lvar-p initial-element) + (let ((value (lvar-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. + (warn 'array-initial-element-mismatch + :format-control "~@<~S is not a ~S (which is the ~ + ~S of ~S).~@:>" + :format-arguments + (list + value + (type-specifier (sb!vm:saetp-ctype saetp)) + 'upgraded-array-element-type + 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) + (fill vector initial-element)) + array))))) ;;; The integer type restriction on the length ensures that it will be -;;; a vector. The lack of adjustable, fill-pointer, and displaced-to -;;; keywords ensures that it will be simple. -(deftransform make-array ((length &key initial-element element-type) +;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and +;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of +;;; :INITIAL-ELEMENT relies on another transform to deal with that +;;; kind of initialization efficiently. +(deftransform make-array ((length &key element-type) (integer &rest *)) (let* ((eltype (cond ((not element-type) t) - ((not (constant-continuation-p element-type)) + ((not (constant-lvar-p element-type)) (give-up-ir1-transform "ELEMENT-TYPE is not constant.")) (t - (continuation-value element-type)))) - (len (if (constant-continuation-p length) - (continuation-value length) + (lvar-value element-type)))) + (len (if (constant-lvar-p length) + (lvar-value length) '*)) - (spec `(simple-array ,eltype (,len))) - (eltype-type (specifier-type eltype))) - (multiple-value-bind (default-initial-element element-size typecode) - (dovector (info *array-info* - (give-up-ir1-transform - "cannot open-code creation of ~S" spec)) - (when (csubtypep eltype-type (specifier-type (car info))) - (return (values-list (cdr info))))) - (let* ((nwords-form - (if (>= element-size sb!vm:word-bits) - `(* length ,(/ element-size sb!vm:word-bits)) - (let ((elements-per-word (/ 32 element-size))) - `(truncate (+ length - ,(if (eq 'sb!vm:simple-string-type typecode) - ;; (Simple strings are stored with an - ;; extra trailing null for convenience - ;; in calling out to C.) - elements-per-word - (1- elements-per-word))) - ,elements-per-word)))) - (constructor - `(truly-the ,spec - (allocate-vector ,typecode length ,nwords-form)))) - (values - (cond ((and default-initial-element - (or (null initial-element) - (and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) - default-initial-element)))) - (unless (csubtypep (ctype-of default-initial-element) - 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 before he reads, we'll signal a - ;; STYLE-WARNING in case he didn't realize this. - ;; - ;; FIXME: should be STYLE-WARNING, not note - (compiler-note "The default initial element ~S is not a ~S." - default-initial-element - eltype)) - constructor) - (t - `(truly-the ,spec (fill ,constructor initial-element)))) - '((declare (type index length)))))))) + (eltype-type (ir1-transform-specifier-type eltype)) + (result-type-spec + `(simple-array + ,(if (unknown-type-p eltype-type) + (give-up-ir1-transform + "ELEMENT-TYPE is an unknown type: ~S" eltype) + (sb!xc:upgraded-array-element-type eltype)) + (,len))) + (saetp (find-if (lambda (saetp) + (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)) + #-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 + (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)) + '((declare (type index length))))))) ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, ;;; and displaced-to keywords ensures that it will be simple. -(deftransform make-array ((dims &key initial-element element-type) +;;; +;;; FIXME: should we generalize this transform to non-simple (though +;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to +;;; deal with those? Maybe when the DEFTRANSFORM +;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? -- +;;; CSR, 2002-07-01 +(deftransform make-array ((dims &key element-type) (list &rest *)) - (unless (or (null element-type) (constant-continuation-p element-type)) + (unless (or (null element-type) (constant-lvar-p element-type)) (give-up-ir1-transform "The element-type is not constant; cannot open code array creation.")) - (unless (constant-continuation-p dims) + (unless (constant-lvar-p dims) (give-up-ir1-transform "The dimension list is not constant; cannot open code array creation.")) - (let ((dims (continuation-value dims))) + (let ((dims (lvar-value dims))) (unless (every #'integerp dims) (give-up-ir1-transform "The dimension list contains something other than an integer: ~S" dims)) (if (= (length dims) 1) `(make-array ',(car dims) - ,@(when initial-element - '(:initial-element initial-element)) ,@(when element-type '(:element-type element-type))) (let* ((total-size (reduce #'* dims)) (rank (length dims)) (spec `(simple-array ,(cond ((null element-type) t) - ((constant-continuation-p element-type) - (continuation-value element-type)) + ((and (constant-lvar-p element-type) + (ir1-transform-specifier-type + (lvar-value element-type))) + (sb!xc:upgraded-array-element-type + (lvar-value element-type))) (t '*)) ,(make-list rank :initial-element '*)))) - `(let ((header (make-array-header sb!vm:simple-array-type ,rank))) + `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))) (setf (%array-fill-pointer header) ,total-size) (setf (%array-fill-pointer-p header) nil) (setf (%array-available-elements header) ,total-size) (setf (%array-data-vector header) (make-array ,total-size ,@(when element-type - '(:element-type element-type)) - ,@(when initial-element - '(:initial-element initial-element)))) + '(:element-type element-type)))) (setf (%array-displaced-p header) nil) ,@(let ((axis -1)) - (mapcar #'(lambda (dim) - `(setf (%array-dimension header ,(incf axis)) - ,dim)) + (mapcar (lambda (dim) + `(setf (%array-dimension header ,(incf axis)) + ,dim)) dims)) (truly-the ,spec header)))))) @@ -297,12 +389,41 @@ ;;; Transforms for various array properties. If the property is know ;;; at compile time because of a type spec, use that constant value. +;;; Most of this logic may end up belonging in code/late-type.lisp; +;;; however, here we also need the -OR-GIVE-UP for the transforms, and +;;; maybe this is just too sloppy for actual type logic. -- CSR, +;;; 2004-02-18 +(defun array-type-dimensions-or-give-up (type) + (typecase type + (array-type (array-type-dimensions type)) + (union-type + (let ((types (union-type-types type))) + ;; there are at least two types, right? + (aver (> (length types) 1)) + (let ((result (array-type-dimensions-or-give-up (car types)))) + (dolist (type (cdr types) result) + (unless (equal (array-type-dimensions-or-give-up type) result) + (give-up-ir1-transform)))))) + ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ] + (t (give-up-ir1-transform)))) + +(defun conservative-array-type-complexp (type) + (typecase type + (array-type (array-type-complexp type)) + (union-type + (let ((types (union-type-types type))) + (aver (> (length types) 1)) + (let ((result (conservative-array-type-complexp (car types)))) + (dolist (type (cdr types) result) + (unless (eq (conservative-array-type-complexp type) result) + (return-from conservative-array-type-complexp :maybe)))))) + ;; FIXME: intersection type + (t :maybe))) + ;;; If we can tell the rank from the type info, use it instead. (deftransform array-rank ((array)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((array-type (lvar-type array))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (if (not (listp dims)) (give-up-ir1-transform "The array rank is not known at compile time: ~S" @@ -315,25 +436,23 @@ ;;; (if it's simple and a vector). (deftransform array-dimension ((array axis) (array index)) - (unless (constant-continuation-p axis) + (unless (constant-lvar-p axis) (give-up-ir1-transform "The axis is not constant.")) - (let ((array-type (continuation-type array)) - (axis (continuation-value axis))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((array-type (lvar-type array)) + (axis (lvar-value axis))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (unless (listp dims) (give-up-ir1-transform "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime.")) (unless (> (length dims) axis) - (abort-ir1-transform "The array has dimensions ~S, ~D is too large." + (abort-ir1-transform "The array has dimensions ~S, ~W is too large." dims axis)) (let ((dim (nth axis dims))) (cond ((integerp dim) dim) ((= (length dims) 1) - (ecase (array-type-complexp array-type) + (ecase (conservative-array-type-complexp array-type) ((t) '(%array-dimension array 0)) ((nil) @@ -347,10 +466,8 @@ ;;; If the length has been declared and it's simple, just return it. (deftransform length ((vector) ((simple-array * (*)))) - (let ((type (continuation-type vector))) - (unless (array-type-p type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions type))) + (let ((type (lvar-type vector))) + (let ((dims (array-type-dimensions-or-give-up type))) (unless (and (listp dims) (integerp (car dims))) (give-up-ir1-transform "Vector length is unknown, must call LENGTH at runtime.")) @@ -365,13 +482,14 @@ ;;; If a simple array with known dimensions, then VECTOR-LENGTH is a ;;; compile-time constant. -(deftransform vector-length ((vector) ((simple-array * (*)))) - (let ((vtype (continuation-type vector))) - (if (array-type-p vtype) - (let ((dim (first (array-type-dimensions vtype)))) - (when (eq dim '*) (give-up-ir1-transform)) - dim) - (give-up-ir1-transform)))) +(deftransform vector-length ((vector)) + (let ((vtype (lvar-type vector))) + (let ((dim (first (array-type-dimensions-or-give-up vtype)))) + (when (eq dim '*) + (give-up-ir1-transform)) + (when (conservative-array-type-complexp vtype) + (give-up-ir1-transform)) + dim))) ;;; Again, if we can tell the results from the type, just use it. ;;; Otherwise, if we know the rank, convert into a computation based @@ -380,10 +498,8 @@ ;;; INDEX. (deftransform array-total-size ((array) (array)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((array-type (lvar-type array))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (unless (listp dims) (give-up-ir1-transform "can't tell the rank at compile time")) (if (member '* dims) @@ -395,13 +511,11 @@ ;;; Only complex vectors have fill pointers. (deftransform array-has-fill-pointer-p ((array)) - (let ((array-type (continuation-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions array-type))) + (let ((array-type (lvar-type array))) + (let ((dims (array-type-dimensions-or-give-up array-type))) (if (and (listp dims) (not (= (length dims) 1))) nil - (ecase (array-type-complexp array-type) + (ecase (conservative-array-type-complexp array-type) ((t) t) ((nil) @@ -414,44 +528,157 @@ ;;; 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-lvar-p dimension)) + (give-up-ir1-transform)) + (t + (let ((dim (lvar-value dimension))) + `(the (integer 0 (,dim)) index))))) -;;;; array accessors +;;;; WITH-ARRAY-DATA -;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR, -;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET -;;; -- source transforms. +;;; This checks to see whether the array is simple and the start and +;;; end are in bounds. If so, it proceeds with those values. +;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA +;;; may be further optimized. +;;; +;;; Given any ARRAY, bind DATA-VAR to the array's data vector and +;;; START-VAR and END-VAR to the start and end of the designated +;;; portion of the data vector. SVALUE and EVALUE are any start and +;;; end specified to the original operation, and are factored into the +;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative +;;; offset of all displacements encountered, and does not include +;;; SVALUE. ;;; -;;; We convert all typed array accessors into aref and %aset with type +;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is +;;; forced to be inline, overriding the ordinary judgment of the +;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are +;;; fairly picky about their arguments, figuring that if you haven't +;;; bothered to get all your ducks in a row, you probably don't care +;;; that much about speed anyway! But in some cases it makes sense to +;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and +;;; the DEFTRANSFORM can't tell that that's going on, so it can make +;;; sense to use FORCE-INLINE option in that case. +(def!macro with-array-data (((data-var array &key offset-var) + (start-var &optional (svalue 0)) + (end-var &optional (evalue nil)) + &key force-inline) + &body forms) + (once-only ((n-array array) + (n-svalue `(the index ,svalue)) + (n-evalue `(the (or index null) ,evalue))) + `(multiple-value-bind (,data-var + ,start-var + ,end-var + ,@(when offset-var `(,offset-var))) + (if (not (array-header-p ,n-array)) + (let ((,n-array ,n-array)) + (declare (type (simple-array * (*)) ,n-array)) + ,(once-only ((n-len `(length ,n-array)) + (n-end `(or ,n-evalue ,n-len))) + `(if (<= ,n-svalue ,n-end ,n-len) + ;; success + (values ,n-array ,n-svalue ,n-end 0) + (failed-%with-array-data ,n-array + ,n-svalue + ,n-evalue)))) + (,(if force-inline '%with-array-data-macro '%with-array-data) + ,n-array ,n-svalue ,n-evalue)) + ,@forms))) + +;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in +;;; DEFTRANSFORMs and DEFUNs. +(def!macro %with-array-data-macro (array + start + end + &key + (element-type '*) + unsafe? + fail-inline?) + (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 '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 '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 + (+ ,cumulative-offset + (%array-displacement ,data)))) + ((not (array-header-p ,data)) + (values (the (simple-array ,element-type 1) ,data) + (the index (+ ,cumulative-offset ,start)) + (the index (+ ,cumulative-offset ,defaulted-end)) + (the index ,cumulative-offset))) + (declare (type index ,cumulative-offset)))))) + +(deftransform %with-array-data ((array start end) + ;; It might very well be reasonable to + ;; allow general ARRAY here, I just + ;; haven't tried to understand the + ;; performance issues involved. -- + ;; WHN, and also CSR 2002-05-26 + ((or vector simple-array) index (or index null)) + * + :node node + :policy (> speed space)) + "inline non-SIMPLE-vector-handling logic" + (let ((element-type (upgraded-element-type-specifier-or-give-up array))) + `(%with-array-data-macro array start end + :unsafe? ,(policy node (= safety 0)) + :element-type ,element-type))) + +;;;; array accessors + +;;; We convert all typed array accessors into AREF and %ASET with type ;;; assertions on the array. +(macrolet ((define-bit-frob (reffer setter simplep) + `(progn + (define-source-transform ,reffer (a &rest i) + `(aref (the (,',(if simplep 'simple-array 'array) + bit + ,(mapcar (constantly '*) i)) + ,a) ,@i)) + (define-source-transform ,setter (a &rest i) + `(%aset (the (,',(if simplep 'simple-array 'array) + bit + ,(cdr (mapcar (constantly '*) i))) + ,a) ,@i))))) + (define-bit-frob sbit %sbitset t) + (define-bit-frob bit %bitset nil)) (macrolet ((define-frob (reffer setter type) `(progn - (def-source-transform ,reffer (a &rest i) - (if (byte-compiling) - (values nil t) - `(aref (the ,',type ,a) ,@i))) - (def-source-transform ,setter (a &rest i) - (if (byte-compiling) - (values nil t) - `(%aset (the ,',type ,a) ,@i)))))) + (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) - (define-frob sbit %sbitset (simple-array bit)) - (define-frob bit %bitset (array bit))) + (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 ;; to %CHECK-BOUND to ensure that everything works out ;; correctly. We can wrap all the interior arithmetic with - ;; TRULY-THE INDEX because we know the the resultant + ;; TRULY-THE INDEX because we know the resultant ;; row-major index must be an index. (with-row-major-index ((array indices index &optional new-value) &rest body) @@ -464,10 +691,10 @@ `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value))) (let* (,@(let ((,index -1)) - (mapcar #'(lambda (name) - `(,name (array-dimension - ,',array - ,(incf ,index)))) + (mapcar (lambda (name) + `(,name (array-dimension + ,',array + ,(incf ,index)))) dims)) (,',index ,(if (null dims) @@ -524,20 +751,28 @@ ;;;; and eliminates the need for any VM-dependent transforms to handle ;;;; these cases. -(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 - bit-andc2 bit-orc1 bit-orc2)) - ;; Make a result array if result is NIL or unsupplied. - (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array) - '(bit-vector bit-vector &optional null) '* - :eval-name t - :policy (>= speed space)) - `(,fun bit-array-1 bit-array-2 - (make-array (length bit-array-1) :element-type 'bit))) - ;; If result is T, make it the first arg. - (deftransform fun ((bit-array-1 bit-array-2 result-bit-array) - '(bit-vector bit-vector (member t)) '* - :eval-name t) - `(,fun bit-array-1 bit-array-2 bit-array-1))) +(macrolet ((def (fun) + `(progn + (deftransform ,fun ((bit-array-1 bit-array-2 + &optional result-bit-array) + (bit-vector bit-vector &optional null) * + :policy (>= speed space)) + `(,',fun bit-array-1 bit-array-2 + (make-array (length bit-array-1) :element-type 'bit))) + ;; If result is T, make it the first arg. + (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array) + (bit-vector bit-vector (eql t)) *) + `(,',fun bit-array-1 bit-array-2 bit-array-1))))) + (def bit-and) + (def bit-ior) + (def bit-xor) + (def bit-eqv) + (def bit-nand) + (def bit-nor) + (def bit-andc1) + (def bit-andc2) + (def bit-orc1) + (def bit-orc2)) ;;; Similar for BIT-NOT, but there is only one arg... (deftransform bit-not ((bit-array-1 &optional result-bit-array) @@ -546,24 +781,22 @@ '(bit-not bit-array-1 (make-array (length bit-array-1) :element-type 'bit))) (deftransform bit-not ((bit-array-1 result-bit-array) - (bit-vector (constant-argument t))) + (bit-vector (eql t))) '(bit-not bit-array-1 bit-array-1)) -;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing -;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant -;;; value? ;;; Pick off some constant cases. -(deftransform array-header-p ((array) (array)) - (let ((type (continuation-type array))) - (declare (optimize (safety 3))) - (unless (array-type-p type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions type))) - (cond ((csubtypep type (specifier-type '(simple-array * (*)))) - ;; No array header. - nil) - ((and (listp dims) (> (length dims) 1)) - ;; Multi-dimensional array, will have a header. - t) - (t - (give-up-ir1-transform)))))) +(defoptimizer (array-header-p derive-type) ((array)) + (let ((type (lvar-type array))) + (cond ((not (array-type-p type)) + ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP + nil) + (t + (let ((dims (array-type-dimensions type))) + (cond ((csubtypep type (specifier-type '(simple-array * (*)))) + ;; no array header + (specifier-type 'null)) + ((and (listp dims) (/= (length dims) 1)) + ;; multi-dimensional array, will have a header + (specifier-type '(eql t))) + (t + nil)))))))