X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=579064e88e77db57fc7dfe63dc4e1a8982afff2a;hb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;hp=d2eafd110a6b1979d505b74547907f44815767c0;hpb=11b8fcf55c80cb2686fb49663fa4d96f9b152ce4;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index d2eafd1..579064e 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -35,7 +35,11 @@ ;; 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 @@ -43,10 +47,19 @@ (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-specialized-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)) +(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) @@ -62,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)) @@ -73,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-upgraded-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)) @@ -117,23 +132,42 @@ (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 @@ -240,7 +274,7 @@ "ELEMENT-TYPE is not constant.")) (t (continuation-value element-type)))) - (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*)) @@ -252,7 +286,7 @@ (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) @@ -270,9 +304,9 @@ ;; 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)) + (compiler-style-warn "The default initial element ~S is not a ~S." + (saetp-initial-element-default saetp) + eltype)) creation-form) (t `(let ((array ,creation-form)) @@ -280,7 +314,7 @@ (%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; the lack of @@ -298,7 +332,7 @@ (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*))) @@ -551,7 +585,9 @@ `(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)))) + (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)))