X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=5aaf16ae5fd6f55067dcd436cb589507bab0e24e;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=580bda619d8a05825cf5a698784172776bbb3c84;hpb=7c5a4db7b036edb8969b93db5c114df88995ee6e;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 580bda6..5aaf16a 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -17,13 +17,15 @@ ;;; 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))) + (let ((element-type-specifier (upgraded-element-type-specifier lvar))) (if (eq element-type-specifier '*) (give-up-ir1-transform "upgraded array element type not known at compile time") element-type-specifier))) +(defun upgraded-element-type-specifier (lvar) + (type-specifier (extract-upgraded-element-type lvar))) + ;;; Array access functions return an object from the array, hence its type is ;;; going to be the array upgraded element type. Secondary return value is the ;;; known supertype of the upgraded-array-element-type, if if the exact @@ -112,6 +114,63 @@ (assert-array-rank array (length indices)) *universal-type*) +(deftransform array-in-bounds-p ((array &rest subscripts)) + (flet ((give-up () + (give-up-ir1-transform + "~@")) + (bound-known-p (x) + (integerp x))) ; might be NIL or * + (block nil + (let ((dimensions (array-type-dimensions-or-give-up + (lvar-conservative-type array)))) + ;; shortcut for zero dimensions + (when (some (lambda (dim) + (and (bound-known-p dim) (zerop dim))) + dimensions) + (return nil)) + ;; we first collect the subscripts LVARs' bounds and see whether + ;; we can already decide on the result of the optimization without + ;; even taking a look at the dimensions. + (flet ((subscript-bounds (subscript) + (let* ((type (lvar-type subscript)) + (low (numeric-type-low type)) + (high (numeric-type-high type))) + (cond + ((and (or (not (bound-known-p low)) (minusp low)) + (or (not (bound-known-p high)) (not (minusp high)))) + ;; can't be sure about the lower bound and the upper bound + ;; does not give us a definite clue either. + (give-up)) + ((and (bound-known-p high) (minusp high)) + (return nil)) ; definitely below lower bound (zero). + (t + (cons low high)))))) + (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts)) + (subscripts-lower-bound (mapcar #'car subscripts-bounds)) + (subscripts-upper-bound (mapcar #'cdr subscripts-bounds)) + (in-bounds 0)) + (mapcar (lambda (low high dim) + (cond + ;; first deal with infinite bounds + ((some (complement #'bound-known-p) (list low high dim)) + (when (and (bound-known-p dim) (bound-known-p low) (<= dim low)) + (return nil))) + ;; now we know all bounds + ((>= low dim) + (return nil)) + ((< high dim) + (aver (not (minusp low))) + (incf in-bounds)) + (t + (give-up)))) + subscripts-lower-bound + subscripts-upper-bound + dimensions) + (if (eql in-bounds (length dimensions)) + t + (give-up)))))))) + (defoptimizer (aref derive-type) ((array &rest indices) node) (assert-array-rank array (length indices)) (derive-aref-type array)) @@ -217,19 +276,9 @@ ;;;; constructors -;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the -;;; elements. +;;; Convert VECTOR into a MAKE-ARRAY. (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)))) + `(make-array ,(length elements) :initial-contents (list ,@elements))) ;;; Just convert it into a MAKE-ARRAY. (deftransform make-string ((length &key @@ -241,6 +290,165 @@ ,@(when initial-element '(:initial-element initial-element))))) +;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, +;;; so that we can pick them apart. +(define-source-transform make-array (&whole form dimensions &rest keyargs + &environment env) + (if (and (fun-lexically-notinline-p 'list) + (fun-lexically-notinline-p 'vector)) + (values nil t) + `(locally (declare (notinline list vector)) + ;; Transform '(3) style dimensions to integer args directly. + ,(if (sb!xc:constantp dimensions env) + (let ((dims (constant-form-value dimensions env))) + (if (and (listp dims) (= 1 (length dims))) + `(make-array ',(car dims) ,@keyargs) + form)) + form)))) + +;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY +;;; call which creates a vector with a known element type -- and tries +;;; to do a good job with all the different ways it can happen. +(defun transform-make-array-vector (length element-type initial-element + initial-contents call) + (aver (or (not element-type) (constant-lvar-p element-type))) + (let* ((c-length (when (constant-lvar-p length) + (lvar-value length))) + (elt-spec (if element-type + (lvar-value element-type) + t)) + (elt-ctype (ir1-transform-specifier-type elt-spec)) + (saetp (if (unknown-type-p elt-ctype) + (give-up-ir1-transform "~S is an unknown type: ~S" + :element-type elt-spec) + (find-saetp-by-ctype elt-ctype))) + (default-initial-element (sb!vm:saetp-initial-element-default saetp)) + (n-bits (sb!vm:saetp-n-bits saetp)) + (typecode (sb!vm:saetp-typecode saetp)) + (n-pad-elements (sb!vm:saetp-n-pad-elements saetp)) + (n-words-form + (if c-length + (ceiling (* (+ c-length n-pad-elements) n-bits) + sb!vm:n-word-bits) + (let ((padded-length-form (if (zerop n-pad-elements) + 'length + `(+ length ,n-pad-elements)))) + (cond + ((= n-bits 0) 0) + ((>= n-bits sb!vm:n-word-bits) + `(* ,padded-length-form + ;; i.e., not RATIO + ,(the fixnum (/ n-bits sb!vm:n-word-bits)))) + (t + (let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits))) + (declare (type index n-elements-per-word)) ; i.e., not RATIO + `(ceiling ,padded-length-form ,n-elements-per-word))))))) + (result-spec + `(simple-array ,(sb!vm:saetp-specifier saetp) (,(or c-length '*)))) + (alloc-form + `(truly-the ,result-spec + (allocate-vector ,typecode (the index length) ,n-words-form)))) + (cond ((and initial-element initial-contents) + (abort-ir1-transform "Both ~S and ~S specified." + :initial-contents :initial-element)) + ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a + ;; constant LENGTH. + ((and initial-contents c-length + (lvar-matches initial-contents + :fun-names '(list vector sb!impl::backq-list) + :arg-count c-length)) + (let ((parameters (eliminate-keyword-args + call 1 '((:element-type element-type) + (:initial-contents initial-contents)))) + (elt-vars (make-gensym-list c-length)) + (lambda-list '(length))) + (splice-fun-args initial-contents :any c-length) + (dolist (p parameters) + (setf lambda-list + (append lambda-list + (if (eq p 'initial-contents) + elt-vars + (list p))))) + `(lambda ,lambda-list + (declare (type ,elt-spec ,@elt-vars) + (ignorable ,@lambda-list)) + (truly-the ,result-spec + (initialize-vector ,alloc-form ,@elt-vars))))) + ;; constant :INITIAL-CONTENTS and LENGTH + ((and initial-contents c-length (constant-lvar-p initial-contents)) + (let ((contents (lvar-value initial-contents))) + (unless (= c-length (length contents)) + (abort-ir1-transform "~S has ~S elements, vector length is ~S." + :initial-contents (length contents) c-length)) + (let ((parameters (eliminate-keyword-args + call 1 '((:element-type element-type) + (:initial-contents initial-contents))))) + `(lambda (length ,@parameters) + (declare (ignorable ,@parameters)) + (truly-the ,result-spec + (initialize-vector ,alloc-form + ,@(map 'list (lambda (elt) + `(the ,elt-spec ',elt)) + contents))))))) + ;; any other :INITIAL-CONTENTS + (initial-contents + (let ((parameters (eliminate-keyword-args + call 1 '((:element-type element-type) + (:initial-contents initial-contents))))) + `(lambda (length ,@parameters) + (declare (ignorable ,@parameters)) + (unless (= length (length initial-contents)) + (error "~S has ~S elements, vector length is ~S." + :initial-contents (length initial-contents) length)) + (truly-the ,result-spec + (replace ,alloc-form initial-contents))))) + ;; :INITIAL-ELEMENT, not EQL to the default + ((and initial-element + (or (not (constant-lvar-p initial-element)) + (not (eql default-initial-element (lvar-value initial-element))))) + (let ((parameters (eliminate-keyword-args + call 1 '((:element-type element-type) + (:initial-element initial-element)))) + (init (if (constant-lvar-p initial-element) + (list 'quote (lvar-value initial-element)) + 'initial-element))) + `(lambda (length ,@parameters) + (declare (ignorable ,@parameters)) + (truly-the ,result-spec + (fill ,alloc-form (the ,elt-spec ,init)))))) + ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the + ;; default + (t + #-sb-xc-host + (unless (ctypep default-initial-element elt-ctype) + ;; 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. + (if initial-element + (compiler-warn "~S ~S is not a ~S" + :initial-element default-initial-element + elt-spec) + (compiler-style-warn "The default initial element ~S is not a ~S." + default-initial-element + elt-spec))) + (let ((parameters (eliminate-keyword-args + call 1 '((:element-type element-type) + (:initial-element initial-element))))) + `(lambda (length ,@parameters) + (declare (ignorable ,@parameters)) + ,alloc-form)))))) + +;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least +;;; specific must come first, otherwise suboptimal transforms will result for +;;; some forms. + (deftransform make-array ((dims &key initial-element element-type adjustable fill-pointer) (t &rest *)) @@ -300,74 +508,6 @@ (fill vector (the ,(sb!vm:saetp-specifier saetp) 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; 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-lvar-p element-type)) - (give-up-ir1-transform - "ELEMENT-TYPE is not constant.")) - (t - (lvar-value element-type)))) - (len (if (constant-lvar-p length) - (lvar-value 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 (ctypep (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. @@ -377,50 +517,84 @@ ;;; 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-lvar-p element-type)) - (give-up-ir1-transform - "The element-type is not constant; cannot open code array creation.")) - (unless (constant-lvar-p dims) - (give-up-ir1-transform - "The dimension list is not constant; cannot open code array creation.")) - (let ((dims (lvar-value dims))) - (unless (every #'integerp dims) +(deftransform make-array ((dims &key + element-type initial-element initial-contents) + (list &key + (:element-type (constant-arg *)) + (:initial-element *) + (:initial-contents *)) + * + :node call) + (block make-array + (when (lvar-matches dims :fun-names '(list) :arg-count 1) + (let ((length (car (splice-fun-args dims :any 1)))) + (return-from make-array + (transform-make-array-vector length + element-type + initial-element + initial-contents + call)))) + (unless (constant-lvar-p 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 element-type - '(:element-type element-type))) - (let* ((total-size (reduce #'* dims)) - (rank (length dims)) - (spec `(simple-array - ,(cond ((null element-type) t) - ((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-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)))) - (setf (%array-displaced-p header) nil) - (setf (%array-displaced-from header) nil) - ,@(let ((axis -1)) - (mapcar (lambda (dim) - `(setf (%array-dimension header ,(incf axis)) - ,dim)) - dims)) - (truly-the ,spec header)))))) + "The dimension list is not constant; cannot open code array creation.")) + (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 element-type + '(:element-type element-type)) + ,@(when initial-element + '(:initial-element initial-element)) + ,@(when initial-contents + '(:initial-contents initial-contents))) + (let* ((total-size (reduce #'* dims)) + (rank (length dims)) + (spec `(simple-array + ,(cond ((null element-type) t) + ((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-widetag ,rank)) + (data (make-array ,total-size + ,@(when element-type + '(:element-type element-type)) + ,@(when initial-element + '(:initial-element initial-element))))) + ,@(when initial-contents + ;; FIXME: This is could be open coded at least a bit too + `((sb!impl::fill-data-vector data ',dims initial-contents))) + (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) data) + (setf (%array-displaced-p header) nil) + (setf (%array-displaced-from header) nil) + ,@(let ((axis -1)) + (mapcar (lambda (dim) + `(setf (%array-dimension header ,(incf axis)) + ,dim)) + dims)) + (truly-the ,spec header))))))) + +(deftransform make-array ((dims &key element-type initial-element initial-contents) + (integer &key + (:element-type (constant-arg *)) + (:initial-element *) + (:initial-contents *)) + * + :node call) + (transform-make-array-vector dims + element-type + initial-element + initial-contents + call)) ;;;; miscellaneous properties of arrays @@ -441,9 +615,14 @@ (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)))))) + (give-up-ir1-transform + "~@" + (type-specifier type))))))) ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ] - (t (give-up-ir1-transform)))) + (t + (give-up-ir1-transform + "~@" + (type-specifier type))))) (defun conservative-array-type-complexp (type) (typecase type