X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f31fb9c4f853b77fb8c3014c03bd33c314b0c62a;hb=174feb792c8082846666e1218c58d5b0ab3b85b0;hp=f65cc3aa1acd28d6a240f1f1a6148b526c28c929;hpb=d7ca32c95549ea9dd6c68b813c4ac1f1d66984e1;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f65cc3a..f31fb9c 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -411,7 +411,8 @@ (join-blocks block next)) t) ((and (null (block-start-uses next)) - (not (exit-p (continuation-dest last-cont))) + (not (typep (continuation-dest last-cont) + '(or exit creturn))) (null (continuation-lexenv-uses last-cont))) (assert (null (find-uses next-cont))) (when (continuation-dest last-cont) @@ -752,7 +753,11 @@ ;; cross-compiler can't fold it because the ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host - (fboundp (combination-fun-source-name node))) + (or (fboundp (combination-fun-source-name node)) + (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%" + (combination-fun-source-name node) + (mapcar #'continuation-value args)) + nil))) (constant-fold-call node) (return-from ir1-optimize-combination))) @@ -784,16 +789,16 @@ ;;; the NODE's CONT to be a dummy continuation to prevent the use from ;;; confusing things. ;;; -;;; Except when called during IR1 [FIXME: What does this mean? Except -;;; during IR1 conversion? What about IR1 optimization?], we delete -;;; the continuation if it has no other uses. (If it does have other -;;; uses, we reoptimize.) +;;; Except when called during IR1 convertion, we delete the +;;; continuation if it has no other uses. (If it does have other uses, +;;; we reoptimize.) ;;; ;;; Termination on the basis of a continuation type is ;;; inhibited when: ;;; -- The continuation is deleted (hence the assertion is spurious), or ;;; -- We are in IR1 conversion (where THE assertions are subject to -;;; weakening.) +;;; weakening.) FIXME: Now THE assertions are not weakened, but new +;;; uses can(?) be added later. -- APD, 2003-07-17 (defun maybe-terminate-block (node ir1-converting-not-optimizing-p) (declare (type (or basic-combination cast) node)) (let* ((block (node-block node)) @@ -846,14 +851,6 @@ ;;; ;;; We return the leaf referenced (NIL if not a leaf) and the ;;; FUN-INFO assigned. -;;; -;;; FIXME: The IR1-CONVERTING-NOT-OPTIMIZING-P argument is what the -;;; old CMU CL code called IR1-P, without explanation. My (WHN -;;; 2002-01-09) tentative understanding of it is that we can call this -;;; operation either in initial IR1 conversion or in later IR1 -;;; optimization, and it tells which is which. But it would be good -;;; for someone who really understands it to check whether this is -;;; really right. (defun recognize-known-call (call ir1-converting-not-optimizing-p) (declare (type combination call)) (let* ((ref (continuation-use (basic-combination-fun call))) @@ -934,7 +931,7 @@ ;; issue a full WARNING if the call ;; violates a DECLAIM FTYPE. :lossage-fun #'compiler-style-warn - :unwinnage-fun #'compiler-note) + :unwinnage-fun #'compiler-notify) (assert-call-type call type) (maybe-terminate-block call ir1-converting-not-optimizing-p) (recognize-known-call call ir1-converting-not-optimizing-p)) @@ -1254,18 +1251,74 @@ (reoptimize-continuation cont)))))) (values)))) +;;; Iteration variable: exactly one SETQ of the form: +;;; +;;; (let ((var initial)) +;;; ... +;;; (setq var (+ var step)) +;;; ...) +(defun maybe-infer-iteration-var-type (var initial-type) + (binding* ((sets (lambda-var-sets var) :exit-if-null) + (set (first sets)) + (() (null (rest sets)) :exit-if-null) + (set-use (principal-continuation-use (set-value set))) + (() (and (combination-p set-use) + (fun-info-p (combination-kind set-use)) + (eq (combination-fun-source-name set-use) '+)) + :exit-if-null) + (+-args (basic-combination-args set-use)) + (() (and (proper-list-of-length-p +-args 2 2) + (let ((first (principal-continuation-use + (first +-args)))) + (and (ref-p first) + (eq (ref-leaf first) var)))) + :exit-if-null) + (step-type (continuation-type (second +-args)))) + (when (and (numeric-type-p initial-type) + (numeric-type-p step-type) + (eq (numeric-type-class initial-type) + (numeric-type-class step-type)) + (eq (numeric-type-format initial-type) + (numeric-type-format step-type)) + (eq (numeric-type-complexp initial-type) + (numeric-type-complexp step-type))) + (multiple-value-bind (low high) + (cond ((csubtypep step-type (specifier-type '(real 0 *))) + (values (numeric-type-low initial-type) nil)) + ((csubtypep step-type (specifier-type '(real * 0))) + (values nil (numeric-type-high initial-type))) + (t + (values nil nil))) + (modified-numeric-type initial-type + :low low + :high high + :enumerable nil))))) +(deftransform + ((x y) * * :result result) + "check for iteration variable reoptimization" + (let ((dest (principal-continuation-end result)) + (use (principal-continuation-use x))) + (when (and (ref-p use) + (set-p dest) + (eq (ref-leaf use) + (set-var dest))) + (reoptimize-continuation (set-value dest)))) + (give-up-ir1-transform)) + ;;; Figure out the type of a LET variable that has sets. We compute -;;; the union of the initial value TYPE and the types of all the set +;;; the union of the INITIAL-TYPE and the types of all the set ;;; values and to a PROPAGATE-TO-REFS with this type. -(defun propagate-from-sets (var type) - (collect ((res type type-union)) +(defun propagate-from-sets (var initial-type) + (collect ((res initial-type type-union)) (dolist (set (basic-var-sets var)) (let ((type (continuation-type (set-value set)))) (res type) (when (node-reoptimize set) (derive-node-type set (make-single-value-type type)) (setf (node-reoptimize set) nil)))) - (propagate-to-refs var (res))) + (let ((res (res))) + (awhen (maybe-infer-iteration-var-type var initial-type) + (setq res (type-intersection res it))) + (propagate-to-refs var res))) (values)) ;;; If a LET variable, find the initial value's type and do @@ -1277,9 +1330,10 @@ (when (and (lambda-var-p var) (leaf-refs var)) (let ((home (lambda-var-home var))) (when (eq (functional-kind home) :let) - (let ((iv (let-var-initial-value var))) - (setf (continuation-reoptimize iv) nil) - (propagate-from-sets var (continuation-type iv))))))) + (let* ((initial-value (let-var-initial-value var)) + (initial-type (continuation-type initial-value))) + (setf (continuation-reoptimize initial-value) nil) + (propagate-from-sets var initial-type)))))) (derive-node-type node (make-single-value-type (continuation-type (set-value node)))) @@ -1526,19 +1580,16 @@ ;;; vars. (defun ir1-optimize-mv-bind (node) (declare (type mv-combination node)) - (let ((arg (first (basic-combination-args node))) - (vars (lambda-vars (combination-lambda node)))) - (multiple-value-bind (types nvals) - (values-types (continuation-derived-type arg)) - (unless (eq nvals :unknown) - (mapc (lambda (var type) - (if (basic-var-sets var) - (propagate-from-sets var type) - (propagate-to-refs var type))) - vars - (adjust-list types - (length vars) - (specifier-type 'null))))) + (let* ((arg (first (basic-combination-args node))) + (vars (lambda-vars (combination-lambda node))) + (n-vars (length vars)) + (types (values-type-in (continuation-derived-type arg) + n-vars))) + (loop for var in vars + and type in types + do (if (basic-var-sets var) + (propagate-from-sets var type) + (propagate-to-refs var type))) (setf (continuation-reoptimize arg) nil)) (values)) @@ -1734,6 +1785,8 @@ (declare (type cast cast)) (let* ((value (cast-value cast)) (value-type (continuation-derived-type value)) + (cont (node-cont cast)) + (dest (continuation-dest cont)) (atype (cast-asserted-type cast)) (int (values-type-intersection value-type atype))) (derive-node-type cast int) @@ -1763,24 +1816,40 @@ (when (eq (node-derived-type cast) *empty-type*) (maybe-terminate-block cast nil)) - (flet ((delete-cast () - (let ((cont (node-cont cast))) - (delete-filter cast cont value) - (reoptimize-continuation cont) - (when (continuation-single-value-p cont) - (note-single-valuified-continuation cont)) - (when (not (continuation-dest cont)) - (reoptimize-continuation-uses cont))))) - (cond - ((and (not do-not-optimize) - (values-subtypep value-type - (cast-asserted-type cast))) - (delete-cast) - (return-from ir1-optimize-cast t)) - ((and (cast-%type-check cast) - (values-subtypep value-type - (cast-type-to-check cast))) - (setf (cast-%type-check cast) nil))))) + (when (and (not do-not-optimize) + (values-subtypep value-type + (cast-asserted-type cast))) + (delete-filter cast cont value) + (reoptimize-continuation cont) + (when (continuation-single-value-p cont) + (note-single-valuified-continuation cont)) + (when (not dest) + (reoptimize-continuation-uses cont)) + (return-from ir1-optimize-cast t)) + + (when (and (not do-not-optimize) + (not (continuation-use value)) + dest) + (collect ((merges)) + (do-uses (use value) + (when (and (values-subtypep (node-derived-type use) atype) + (immediately-used-p value use)) + (ensure-block-start cont) + (delete-continuation-use use) + (add-continuation-use use cont) + (unlink-blocks (node-block use) (node-block cast)) + (link-blocks (node-block use) (continuation-block cont)) + (when (and (return-p dest) + (basic-combination-p use) + (eq (basic-combination-kind use) :local)) + (merges use)))) + (dolist (use (merges)) + (merge-tail-sets use)))) + + (when (and (cast-%type-check cast) + (values-subtypep value-type + (cast-type-to-check cast))) + (setf (cast-%type-check cast) nil))) (unless do-not-optimize (setf (node-reoptimize cast) nil)))