X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=5aaf16ae5fd6f55067dcd436cb589507bab0e24e;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=4c4ec20b5e1a8b3ee14e292b05e04d3bd10ec9c6;hpb=16f861fd9d7c9246a22a212c26d97fb2e3712607;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 4c4ec20..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)) @@ -351,7 +410,7 @@ call 1 '((:element-type element-type) (:initial-element initial-element)))) (init (if (constant-lvar-p initial-element) - (lvar-value initial-element) + (list 'quote (lvar-value initial-element)) 'initial-element))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) @@ -380,24 +439,74 @@ default-initial-element elt-spec))) (let ((parameters (eliminate-keyword-args - call 1 '((:element-type element-type))))) + call 1 '((:element-type element-type) + (:initial-element initial-element))))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) ,alloc-form)))))) -(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)) +;;; 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 *)) + (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 (the ,(sb!vm:saetp-specifier saetp) initial-element))) + array))))) ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, @@ -474,64 +583,18 @@ dims)) (truly-the ,spec header))))))) -(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 (the ,(sb!vm:saetp-specifier saetp) initial-element))) - array))))) +(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 @@ -552,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