X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=25b0b69e8702027d735ec0b86bd39afd98ce300a;hb=31361af9eb64344f521abbb245ea784c76c746e5;hp=30a6a066f8c6f6e981ae8e7914629c4f9eab4b37;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 30a6a06..25b0b69 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -29,7 +29,7 @@ ;;; constant node. (declaim (ftype (function (continuation) t) continuation-value)) (defun continuation-value (cont) - (assert (constant-continuation-p cont)) + (aver (constant-continuation-p cont)) (constant-value (ref-leaf (continuation-use cont)))) ;;;; interface for obtaining results of type inference @@ -254,11 +254,11 @@ (return))) (when (and (block-reoptimize block) (block-component block)) - (assert (not (block-delete-p block))) + (aver (not (block-delete-p block))) (ir1-optimize-block block)) (when (and (block-flush-p block) (block-component block)) - (assert (not (block-delete-p block))) + (aver (not (block-delete-p block))) (flush-dead-code block))))) (values)) @@ -270,17 +270,17 @@ ;;; -- With a combination, we call Propagate-Function-Change whenever ;;; the function changes, and call IR1-Optimize-Combination if any ;;; argument changes. -;;; -- With an Exit, we derive the node's type from the Value's type. We don't -;;; propagate Cont's assertion to the Value, since if we did, this would -;;; move the checking of Cont's assertion to the exit. This wouldn't work -;;; with Catch and UWP, where the Exit node is just a placeholder for the -;;; actual unknown exit. +;;; -- With an Exit, we derive the node's type from the Value's type. +;;; We don't propagate Cont's assertion to the Value, since if we +;;; did, this would move the checking of Cont's assertion to the +;;; exit. This wouldn't work with Catch and UWP, where the Exit +;;; node is just a placeholder for the actual unknown exit. ;;; -;;; Note that we clear the node & block reoptimize flags *before* doing the -;;; optimization. This ensures that the node or block will be reoptimized if -;;; necessary. We leave the NODE-OPTIMIZE flag set going into -;;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to clear the flag -;;; itself. +;;; Note that we clear the node & block reoptimize flags *before* +;;; doing the optimization. This ensures that the node or block will +;;; be reoptimized if necessary. We leave the NODE-OPTIMIZE flag set +;;; going into IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to +;;; clear the flag itself. (defun ir1-optimize-block (block) (declare (type cblock block)) (setf (block-reoptimize block) nil) @@ -308,20 +308,20 @@ ;;; We cannot combine with a successor block if: ;;; 1. The successor has more than one predecessor. -;;; 2. The last node's Cont is also used somewhere else. +;;; 2. The last node's CONT is also used somewhere else. ;;; 3. The successor is the current block (infinite loop). -;;; 4. The next block has a different cleanup, and thus we may want to insert -;;; cleanup code between the two blocks at some point. +;;; 4. The next block has a different cleanup, and thus we may want to +;;; insert cleanup code between the two blocks at some point. ;;; 5. The next block has a different home lambda, and thus the control ;;; transfer is a non-local exit. ;;; ;;; If we succeed, we return true, otherwise false. ;;; -;;; Joining is easy when the successor's Start continuation is the same from -;;; our Last's Cont. If they differ, then we can still join when the last -;;; continuation has no next and the next continuation has no uses. In this -;;; case, we replace the next continuation with the last before joining the -;;; blocks. +;;; Joining is easy when the successor's Start continuation is the +;;; same from our Last's Cont. If they differ, then we can still join +;;; when the last continuation has no next and the next continuation +;;; has no uses. In this case, we replace the next continuation with +;;; the last before joining the blocks. (defun join-successor-if-possible (block) (declare (type cblock block)) (let ((next (first (block-succ block)))) @@ -343,10 +343,11 @@ ((and (null (block-start-uses next)) (eq (continuation-kind last-cont) :inside-block)) (let ((next-node (continuation-next next-cont))) - ;; If next-cont does have a dest, it must be unreachable, - ;; since there are no uses. DELETE-CONTINUATION will mark the - ;; dest block as delete-p [and also this block, unless it is - ;; no longer backward reachable from the dest block.] + ;; If next-cont does have a dest, it must be + ;; unreachable, since there are no uses. + ;; DELETE-CONTINUATION will mark the dest block as + ;; delete-p [and also this block, unless it is no + ;; longer backward reachable from the dest block.] (delete-continuation next-cont) (setf (node-prev next-node) last-cont) (setf (continuation-next last-cont) next-node) @@ -357,9 +358,9 @@ nil)))))) ;;; Join together two blocks which have the same ending/starting -;;; continuation. The code in Block2 is moved into Block1 and Block2 is -;;; deleted from the DFO. We combine the optimize flags for the two blocks so -;;; that any indicated optimization gets done. +;;; continuation. The code in Block2 is moved into Block1 and Block2 +;;; is deleted from the DFO. We combine the optimize flags for the two +;;; blocks so that any indicated optimization gets done. (defun join-blocks (block1 block2) (declare (type cblock block1 block2)) (let* ((last (block-last block2)) @@ -392,13 +393,13 @@ (values)) -;;; Delete any nodes in Block whose value is unused and have no +;;; Delete any nodes in BLOCK whose value is unused and have no ;;; side-effects. We can delete sets of lexical variables when the set ;;; variable has no references. ;;; -;;; [### For now, don't delete potentially flushable calls when they have the -;;; Call attribute. Someday we should look at the funcitonal args to determine -;;; if they have any side-effects.] +;;; [### For now, don't delete potentially flushable calls when they +;;; have the CALL attribute. Someday we should look at the funcitonal +;;; args to determine if they have any side-effects.] (defun flush-dead-code (block) (declare (type cblock block)) (do-nodes-backwards (node cont block) @@ -445,19 +446,21 @@ ;;;; local call return type propagation -;;; This function is called on RETURN nodes that have their REOPTIMIZE flag -;;; set. It iterates over the uses of the RESULT, looking for interesting -;;; stuff to update the TAIL-SET. If a use isn't a local call, then we union -;;; its type together with the types of other such uses. We assign to the -;;; RETURN-RESULT-TYPE the intersection of this type with the RESULT's asserted -;;; type. We can make this intersection now (potentially before type checking) -;;; because this assertion on the result will eventually be checked (if +;;; This function is called on RETURN nodes that have their REOPTIMIZE +;;; flag set. It iterates over the uses of the RESULT, looking for +;;; interesting stuff to update the TAIL-SET. If a use isn't a local +;;; call, then we union its type together with the types of other such +;;; uses. We assign to the RETURN-RESULT-TYPE the intersection of this +;;; type with the RESULT's asserted type. We can make this +;;; intersection now (potentially before type checking) because this +;;; assertion on the result will eventually be checked (if ;;; appropriate.) ;;; -;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV combination, -;;; which may change the succesor of the call to be the called function, and if -;;; so, checks if the call can become an assignment. If we convert to an -;;; assignment, we abort, since the RETURN has been deleted. +;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV +;;; combination, which may change the succesor of the call to be the +;;; called function, and if so, checks if the call can become an +;;; assignment. If we convert to an assignment, we abort, since the +;;; RETURN has been deleted. (defun find-result-type (node) (declare (type creturn node)) (let ((result (return-result node))) @@ -465,8 +468,8 @@ (do-uses (use result) (cond ((and (basic-combination-p use) (eq (basic-combination-kind use) :local)) - (assert (eq (lambda-tail-set (node-home-lambda use)) - (lambda-tail-set (combination-lambda use)))) + (aver (eq (lambda-tail-set (node-home-lambda use)) + (lambda-tail-set (combination-lambda use)))) (when (combination-p use) (when (nth-value 1 (maybe-convert-tail-local-call use)) (return-from find-result-type (values))))) @@ -478,17 +481,18 @@ (setf (return-result-type node) int)))) (values)) -;;; Do stuff to realize that something has changed about the value delivered -;;; to a return node. Since we consider the return values of all functions in -;;; the tail set to be equivalent, this amounts to bringing the entire tail set -;;; up to date. We iterate over the returns for all the functions in the tail -;;; set, reanalyzing them all (not treating Node specially.) +;;; Do stuff to realize that something has changed about the value +;;; delivered to a return node. Since we consider the return values of +;;; all functions in the tail set to be equivalent, this amounts to +;;; bringing the entire tail set up to date. We iterate over the +;;; returns for all the functions in the tail set, reanalyzing them +;;; all (not treating Node specially.) ;;; -;;; When we are done, we check whether the new type is different from the old -;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the -;;; continuations for references to functions in the tail set. This will cause -;;; IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the -;;; calls. +;;; When we are done, we check whether the new type is different from +;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize +;;; all the continuations for references to functions in the tail set. +;;; This will cause IR1-OPTIMIZE-COMBINATION to derive the new type as +;;; the results of the calls. (defun ir1-optimize-return (node) (declare (type creturn node)) (let* ((tails (lambda-tail-set (return-lambda node))) @@ -535,7 +539,7 @@ (if (continuation-value test) (if-alternative node) (if-consequent node))) - ((not (types-intersect type (specifier-type 'null))) + ((not (types-equal-or-intersect type (specifier-type 'null))) (if-alternative node)) ((type= type (specifier-type 'null)) (if-consequent node))))) @@ -737,8 +741,8 @@ (delete-continuation-use call) (cond ((block-last block) - (assert (and (eq (block-last block) call) - (eq (continuation-kind cont) :block-start)))) + (aver (and (eq (block-last block) call) + (eq (continuation-kind cont) :block-start)))) (t (setf (block-last block) call) (link-blocks block (continuation-starts-block cont))))) @@ -751,15 +755,16 @@ (unlink-blocks block (first (block-succ block))) (setf (component-reanalyze (block-component block)) t) - (assert (not (block-succ block))) + (aver (not (block-succ block))) (link-blocks block tail) (add-continuation-use call (make-continuation)) t)))) -;;; Called both by IR1 conversion and IR1 optimization when they have -;;; verified the type signature for the call, and are wondering if -;;; something should be done to special-case the call. If Call is a -;;; call to a global function, then see whether it defined or known: +;;; This is called both by IR1 conversion and IR1 optimization when +;;; they have verified the type signature for the call, and are +;;; wondering if something should be done to special-case the call. If +;;; Call is a call to a global function, then see whether it defined +;;; or known: ;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert the ;;; expansion and change the call to call it. Expansion is enabled if ;;; :INLINE or if space=0. If the FUNCTIONAL slot is true, we never expand, @@ -834,9 +839,9 @@ (defun validate-call-type (call type ir1-p) (declare (type combination call) (type ctype type)) (cond ((not (function-type-p type)) - (assert (multiple-value-bind (val win) - (csubtypep type (specifier-type 'function)) - (or val (not win)))) + (aver (multiple-value-bind (val win) + (csubtypep type (specifier-type 'function)) + (or val (not win)))) (recognize-known-call call ir1-p)) ((valid-function-use call type :argument-test #'always-subtypep @@ -976,36 +981,89 @@ (record-optimization-failure node transform args)) (setf (gethash node table) (remove transform (gethash node table) :key #'car))) - t)))) + t) + (:delayed + (remhash node table) + nil)))) ((and flame (valid-function-use node type - :argument-test #'types-intersect - :result-test #'values-types-intersect)) + :argument-test #'types-equal-or-intersect + :result-test + #'values-types-equal-or-intersect)) (record-optimization-failure node transform type) t) (t t)))) -;;; Just throw the severity and args... +;;; When we don't like an IR1 transform, we throw the severity/reason +;;; and args. +;;; +;;; GIVE-UP-IR1-TRANSFORM is used to throw out of an IR1 transform, +;;; aborting this attempt to transform the call, but admitting the +;;; possibility that this or some other transform will later succeed. +;;; If arguments are supplied, they are format arguments for an +;;; efficiency note. +;;; +;;; ABORT-IR1-TRANSFORM is used to throw out of an IR1 transform and +;;; force a normal call to the function at run time. No further +;;; optimizations will be attempted. +;;; +;;; DELAY-IR1-TRANSFORM is used to throw out of an IR1 transform, and +;;; delay the transform on the node until later. REASONS specifies +;;; when the transform will be later retried. The :OPTIMIZE reason +;;; causes the transform to be delayed until after the current IR1 +;;; optimization pass. The :CONSTRAINT reason causes the transform to +;;; be delayed until after constraint propagation. +;;; +;;; FIXME: Now (0.6.11.44) that there are 4 variants of this (GIVE-UP, +;;; ABORT, DELAY/:OPTIMIZE, DELAY/:CONSTRAINT) and we're starting to +;;; do CASE operations on the various REASON values, it might be a +;;; good idea to go OO, representing the reasons by objects, using +;;; CLOS methods on the objects instead of CASE, and (possibly) using +;;; SIGNAL instead of THROW. (declaim (ftype (function (&rest t) nil) give-up-ir1-transform)) (defun give-up-ir1-transform (&rest args) - #!+sb-doc - "This function is used to throw out of an IR1 transform, aborting this - attempt to transform the call, but admitting the possibility that this or - some other transform will later succeed. If arguments are supplied, they are - format arguments for an efficiency note." (throw 'give-up-ir1-transform (values :failure args))) (defun abort-ir1-transform (&rest args) - #!+sb-doc - "This function is used to throw out of an IR1 transform and force a normal - call to the function at run time. No further optimizations will be - attempted." (throw 'give-up-ir1-transform (values :aborted args))) - -;;; Take the lambda-expression Res, IR1 convert it in the proper +(defun delay-ir1-transform (node &rest reasons) + (let ((assoc (assoc node *delayed-ir1-transforms*))) + (cond ((not assoc) + (setf *delayed-ir1-transforms* + (acons node reasons *delayed-ir1-transforms*)) + (throw 'give-up-ir1-transform :delayed)) + ((cdr assoc) + (dolist (reason reasons) + (pushnew reason (cdr assoc))) + (throw 'give-up-ir1-transform :delayed))))) + +;;; Clear any delayed transform with no reasons - these should have +;;; been tried in the last pass. Then remove the reason from the +;;; delayed transform reasons, and if any become empty then set +;;; reoptimize flags for the node. Return true if any transforms are +;;; to be retried. +(defun retry-delayed-ir1-transforms (reason) + (setf *delayed-ir1-transforms* + (remove-if-not #'cdr *delayed-ir1-transforms*)) + (let ((reoptimize nil)) + (dolist (assoc *delayed-ir1-transforms*) + (let ((reasons (remove reason (cdr assoc)))) + (setf (cdr assoc) reasons) + (unless reasons + (let ((node (car assoc))) + (unless (node-deleted node) + (setf reoptimize t) + (setf (node-reoptimize node) t) + (let ((block (node-block node))) + (setf (block-reoptimize block) t) + (setf (component-reoptimize (block-component block)) t))))))) + reoptimize)) + + +;;; Take the lambda-expression RES, IR1 convert it in the proper ;;; environment, and then install it as the function for the call -;;; Node. We do local call analysis so that the new function is +;;; NODE. We do local call analysis so that the new function is ;;; integrated into the control flow. (defun transform-call (node res) (declare (type combination node) (list res)) @@ -1139,8 +1197,8 @@ *empty-type*)) (eq (lexenv-policy (node-lexenv dest)) (lexenv-policy (node-lexenv (continuation-dest arg))))) - (assert (member (continuation-kind arg) - '(:block-start :deleted-block-start :inside-block))) + (aver (member (continuation-kind arg) + '(:block-start :deleted-block-start :inside-block))) (assert-continuation-type arg cont-atype) (setf (node-derived-type ref) *wild-type*) (change-ref-leaf ref (find-constant nil)) @@ -1154,7 +1212,7 @@ ;;; flush the FUN continuation. (defun delete-let (fun) (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) + (aver (member (functional-kind fun) '(:let :mv-let))) (note-unreferenced-vars fun) (let ((call (let-combination fun))) (flush-dest (basic-combination-fun call)) @@ -1208,8 +1266,8 @@ this-comp) t) (t - (assert (eq (functional-kind (lambda-home fun)) - :top-level)) + (aver (eq (functional-kind (lambda-home fun)) + :top-level)) nil))) leaf var)) t))))) @@ -1416,9 +1474,9 @@ (declare (ignore ,ignore)) (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) - (assert (eq (basic-combination-kind node) :full)) + (aver (eq (basic-combination-kind node) :full)) (local-call-analyze *current-component*) - (assert (eq (basic-combination-kind node) :local))))))))) + (aver (eq (basic-combination-kind node) :local))))))))) (values)) ;;; If we see: @@ -1517,4 +1575,4 @@ `(lambda (val ,@dummies) (declare (ignore ,@dummies)) val)) - 'nil)) + nil))