X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=7eabbc1c93460adbdba3aa2b56a4f3e59c841e4b;hb=7ce2c42adf3d62f03086de940adaee48e6161a40;hp=e94f70dbba8a892122d47ec8f968055482733bbf;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index e94f70d..7eabbc1 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -25,20 +25,21 @@ element-type-specifier))) ;;; 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*))) - -;;; 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))) + ;; 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*))) ;;; 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 @@ -46,10 +47,20 @@ (defun assert-new-value-type (new-value array) (let ((type (continuation-type array))) (when (array-type-p type) - (assert-continuation-type new-value (array-type-element-type type)))) + (assert-continuation-type + new-value + (array-type-specialized-element-type type) + (lexenv-policy (node-lexenv (continuation-dest new-value)))))) (continuation-type new-value)) -;;; Return true if Arg is NIL, or is a constant-continuation whose +(defun assert-array-complex (array) + (assert-continuation-type + array + (make-array-type :complexp t + :element-type *wild-type*) + (lexenv-policy (node-lexenv (continuation-dest array))))) + +;;; Return true if ARG is NIL, or is a constant-continuation whose ;;; value is NIL, false otherwise. (defun unsupplied-or-nil (arg) (declare (type (or continuation null) arg)) @@ -64,7 +75,8 @@ (defun assert-array-rank (array rank) (assert-continuation-type array - (specifier-type `(array * ,(make-list rank :initial-element '*))))) + (specifier-type `(array * ,(make-list rank :initial-element '*))) + (lexenv-policy (node-lexenv (continuation-dest array))))) (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) @@ -75,7 +87,8 @@ ;; 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)))) + (assert-continuation-type cont (extract-upgraded-element-type array) + (lexenv-policy (node-lexenv node))))) (extract-upgraded-element-type array)) (defoptimizer (%aset derive-type) ((array &rest stuff)) @@ -99,7 +112,7 @@ (when (array-type-p atype) (values-specifier-type `(values (simple-array ,(type-specifier - (array-type-element-type atype)) + (array-type-specialized-element-type atype)) (*)) index index index))))) @@ -119,46 +132,65 @@ (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-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 + '*)))) + (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) +(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)))) + ,@(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-form*)) +(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)) @@ -199,11 +231,20 @@ ;; (SIMPLE-STRINGs are stored with an extra trailing ;; #\NULL for convenience in calling out to C.) :n-pad-elements 1) - (single-float 0.0s0 32 ,sb!vm:simple-array-single-float-widetag) + (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) @@ -213,7 +254,7 @@ ((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.0s0 0.0s0) 64 + ((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) @@ -222,10 +263,64 @@ ,sb!vm:simple-array-complex-long-float-widetag) (t 0 32 ,sb!vm:simple-vector-widetag)))) +(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-continuation-p element-type)) + (give-up-ir1-transform + "ELEMENT-TYPE is not constant.")) + (t + (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))))) + + (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)) + creation-form) + (t + `(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) +;;; :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)) @@ -237,16 +332,15 @@ (continuation-value length) '*)) (result-type-spec `(simple-array ,eltype (,len))) - (eltype-type (specifier-type eltype)) + (eltype-type (ir1-transform-specifier-type eltype)) (saetp (find-if (lambda (saetp) (csubtypep eltype-type (saetp-ctype saetp))) *specialized-array-element-type-properties*))) (unless saetp (give-up-ir1-transform - "cannot open-code creation of ~S" spec)) + "cannot open-code creation of ~S" result-type-spec)) - (let* ((initial-element-default (saetp-initial-element-default saetp)) - (n-bits-per-element (saetp-n-bits saetp)) + (let* ((n-bits-per-element (saetp-n-bits saetp)) (typecode (saetp-typecode saetp)) (n-pad-elements (saetp-n-pad-elements saetp)) (padded-length-form (if (zerop n-pad-elements) @@ -260,47 +354,22 @@ (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)))) - (bare-constructor-form - `(truly-the ,result-type-spec - (allocate-vector ,typecode length ,n-words-form))) - (initial-element-form (if initial-element - 'initial-element - initial-element-default))) + `(ceiling ,padded-length-form ,n-elements-per-word))))) (values - (cond (;; Can we skip the FILL step? - (or (null initial-element) - (and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) - initial-element-default))) - (unless (csubtypep (ctype-of initial-element-default) - 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." - initial-element-default - eltype)) - bare-constructor-form) - (t - `(truly-the ,result-type-spec - (fill ,bare-constructor-form - ,initial-element-form)))) + `(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)) (give-up-ir1-transform @@ -315,8 +384,6 @@ 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)) @@ -334,14 +401,12 @@ (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)))))) @@ -379,7 +444,7 @@ (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))) @@ -520,12 +585,9 @@ `(if (<= ,n-svalue ,n-end ,n-len) ;; success (values ,n-array ,n-svalue ,n-end 0) - ;; failure: Make a NOTINLINE call to - ;; %WITH-ARRAY-DATA with our bad data - ;; to cause the error to be signalled. - (locally - (declare (notinline %with-array-data)) - (%with-array-data ,n-array ,n-svalue ,n-evalue))))) + (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))) @@ -548,14 +610,14 @@ (cond (,end (unless (or ,unsafe? (<= ,end ,size)) ,(if fail-inline? - `(error "End ~D is greater than total size ~D." + `(error "End ~W is greater than total size ~W." ,end ,size) `(failed-%with-array-data ,array ,start ,end))) ,end) (t ,size)))) (unless (or ,unsafe? (<= ,start ,defaulted-end)) ,(if fail-inline? - `(error "Start ~D is greater than end ~D." ,start ,defaulted-end) + `(error "Start ~W is greater than end ~W." ,start ,defaulted-end) `(failed-%with-array-data ,array ,start ,end))) (do ((,data ,array (%array-data-vector ,data)) (,cumulative-offset 0 @@ -569,16 +631,12 @@ (declare (type index ,cumulative-offset)))))) (deftransform %with-array-data ((array start end) - ;; Note: This transform is limited to - ;; VECTOR only because I happened to - ;; create it in order to get sequence - ;; function operations to be more - ;; efficient. It might very well be - ;; reasonable to allow general ARRAY - ;; here, I just haven't tried to - ;; understand the performance issues - ;; involved. -- WHN - (vector index (or index null)) + ;; 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)) * :important t :node node @@ -595,9 +653,9 @@ ;;; assertions on the array. (macrolet ((define-frob (reffer setter type) `(progn - (def-source-transform ,reffer (a &rest i) + (define-source-transform ,reffer (a &rest i) `(aref (the ,',type ,a) ,@i)) - (def-source-transform ,setter (a &rest 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) @@ -682,20 +740,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 (member 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) @@ -704,24 +770,23 @@ '(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 (constant-arg 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 +;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing +;;; as (CONSTANT-ARG (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. + ;; no array header nil) ((and (listp dims) (> (length dims) 1)) - ;; Multi-dimensional array, will have a header. + ;; multi-dimensional array, will have a header t) (t (give-up-ir1-transform))))))