X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=25b0b69e8702027d735ec0b86bd39afd98ce300a;hb=ea36d3d79b9dfe3598faca5e267efd5980b94d4a;hp=27fdf2e8d4ff101201d652929e9fbf8814b0cdcc;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 27fdf2e..25b0b69 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -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))) @@ -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))))) @@ -756,10 +760,11 @@ (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, @@ -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)) @@ -1517,4 +1575,4 @@ `(lambda (val ,@dummies) (declare (ignore ,@dummies)) val)) - 'nil)) + nil))