X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=35720894ff38948146f6700881528b85f4ae792a;hb=ba38798a5ca26b90647a1993f348806cb32f2d1b;hp=2f2755fcd7b021f744f63a89863a5b6a9bc5927d;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 2f2755f..3572089 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -15,24 +15,22 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; interface for obtaining results of constant folding -;;; Return true if the sole use of Cont is a reference to a constant leaf. -(declaim (ftype (function (continuation) boolean) constant-continuation-p)) -(defun constant-continuation-p (cont) - (let ((use (continuation-use cont))) - (and (ref-p use) - (constant-p (ref-leaf use))))) +;;; Return true for a CONTINUATION whose sole use is a reference to a +;;; constant leaf. +(defun constant-continuation-p (thing) + (and (continuation-p thing) + (let ((use (continuation-use thing))) + (and (ref-p use) + (constant-p (ref-leaf use)))))) ;;; Return the constant value for a continuation whose only use is a ;;; 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 @@ -58,9 +56,9 @@ (node-derived-type (continuation-use cont))))) ;;; Our best guess for the type of this continuation's value. Note -;;; that this may be Values or Function type, which cannot be passed +;;; that this may be VALUES or FUNCTION type, which cannot be passed ;;; as an argument to the normal type operations. See -;;; Continuation-Type. This may be called on deleted continuations, +;;; CONTINUATION-TYPE. This may be called on deleted continuations, ;;; always returning *. ;;; ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the @@ -86,6 +84,18 @@ (cond ((values-subtypep proven asserted) (setf (continuation-%type-check cont) nil) (setf (continuation-%derived-type cont) proven)) + ((and (values-subtypep proven (specifier-type 'function)) + (values-subtypep asserted (specifier-type 'function))) + ;; It's physically impossible for a runtime type check to + ;; distinguish between the various subtypes of FUNCTION, so + ;; it'd be pointless to do more type checks here. + (setf (continuation-%type-check cont) nil) + (setf (continuation-%derived-type cont) + ;; FIXME: This should depend on optimization + ;; policy. This is for SPEED > SAFETY: + #+nil (values-type-intersection asserted proven) + ;; and this is for SAFETY >= SPEED: + #-nil proven)) (t (unless (or (continuation-%type-check cont) (not (continuation-dest cont)) @@ -161,18 +171,18 @@ (eq int *empty-type*) (not (eq rtype *empty-type*))) (let ((*compiler-error-context* node)) - (compiler-warning + (compiler-warn "New inferred type ~S conflicts with old type:~ - ~% ~S~%*** Bug?" + ~% ~S~%*** possible internal error? Please report this." (type-specifier rtype) (type-specifier node-type)))) (setf (node-derived-type node) int) (reoptimize-continuation (node-cont node)))))) (values)) -;;; Similar to Derive-Node-Type, but asserts that it is an error for -;;; Cont's value not to be typep to Type. If we improve the assertion, -;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new -;;; assertion will be checked. +;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an +;;; error for CONT's value not to be TYPEP to TYPE. If we improve the +;;; assertion, we set TYPE-CHECK and TYPE-ASSERTED to guarantee that +;;; the new assertion will be checked. (defun assert-continuation-type (cont type) (declare (type continuation cont) (type ctype type)) (let ((cont-type (continuation-asserted-type cont))) @@ -187,28 +197,28 @@ (reoptimize-continuation cont))))) (values)) -;;; Assert that Call is to a function of the specified Type. It is +;;; Assert that CALL is to a function of the specified TYPE. It is ;;; assumed that the call is legal and has only constants in the ;;; keyword positions. (defun assert-call-type (call type) - (declare (type combination call) (type function-type type)) - (derive-node-type call (function-type-returns type)) + (declare (type combination call) (type fun-type type)) + (derive-node-type call (fun-type-returns type)) (let ((args (combination-args call))) - (dolist (req (function-type-required type)) + (dolist (req (fun-type-required type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) (assert-continuation-type arg req))) - (dolist (opt (function-type-optional type)) + (dolist (opt (fun-type-optional type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) (assert-continuation-type arg opt))) - (let ((rest (function-type-rest type))) + (let ((rest (fun-type-rest type))) (when rest (dolist (arg args) (assert-continuation-type arg rest)))) - (dolist (key (function-type-keywords type)) + (dolist (key (fun-type-keywords type)) (let ((name (key-info-name key))) (do ((arg args (cddr arg))) ((null arg)) @@ -219,30 +229,37 @@ ;;;; IR1-OPTIMIZE -;;; Do one forward pass over Component, deleting unreachable blocks +;;; Do one forward pass over COMPONENT, deleting unreachable blocks ;;; and doing IR1 optimizations. We can ignore all blocks that don't -;;; have the Reoptimize flag set. If Component-Reoptimize is true when +;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when ;;; we are done, then another iteration would be beneficial. -;;; -;;; We delete blocks when there is either no predecessor or the block -;;; is in a lambda that has been deleted. These blocks would -;;; eventually be deleted by DFO recomputation, but doing it here -;;; immediately makes the effect available to IR1 optimization. (defun ir1-optimize (component) (declare (type component component)) (setf (component-reoptimize component) nil) (do-blocks (block component) (cond ((or (block-delete-p block) - (null (block-pred block)) - (eq (functional-kind (block-home-lambda block)) :deleted)) + (null (block-pred block))) (delete-block block)) + ((eq (functional-kind (block-home-lambda block)) :deleted) + ;; Preserve the BLOCK-SUCC invariant that almost every block has + ;; one successor (and a block with DELETE-P set is an acceptable + ;; exception). + (labels ((mark-blocks (block) + (dolist (pred (block-pred block)) + (when (and (not (block-delete-p pred)) + (eq (functional-kind (block-home-lambda pred)) + :deleted)) + (setf (block-delete-p pred) t) + (mark-blocks pred))))) + (mark-blocks block) + (delete-block block))) (t (loop (let ((succ (block-succ block))) (unless (and succ (null (rest succ))) (return))) - + (let ((last (block-last block))) (typecase last (cif @@ -252,56 +269,66 @@ (exit (when (maybe-delete-exit last) (return))))) - - (unless (join-successor-if-possible block) + + (unless (join-successor-if-possible block) (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)) + ;; We delete blocks when there is either no predecessor or the + ;; block is in a lambda that has been deleted. These blocks + ;; would eventually be deleted by DFO recomputation, but doing + ;; it here immediately makes the effect available to IR1 + ;; optimization. (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)) -;;; Loop over the nodes in Block, looking for stuff that needs to be -;;; optimized. We dispatch off of the type of each node with its -;;; reoptimize flag set: - -;;; -- 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. +;;; Loop over the nodes in BLOCK, acting on (and clearing) REOPTIMIZE +;;; flags. ;;; -;;; 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 although they are cleared here, REOPTIMIZE flags might +;;; still be set upon return from this function, meaning that further +;;; optimization is wanted (as a consequence of optimizations we did). (defun ir1-optimize-block (block) (declare (type cblock block)) + ;; We clear the node and block REOPTIMIZE flags before doing the + ;; optimization, not after. This ensures that the node or block will + ;; be reoptimized if necessary. (setf (block-reoptimize block) nil) (do-nodes (node cont block :restart-p t) (when (node-reoptimize node) + ;; As above, we clear the node REOPTIMIZE flag before optimizing. (setf (node-reoptimize node) nil) (typecase node (ref) (combination + ;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever + ;; the function changes, and call IR1-OPTIMIZE-COMBINATION if + ;; any argument changes. (ir1-optimize-combination node)) (cif (ir1-optimize-if node)) (creturn + ;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into + ;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to + ;; clear the flag itself. -- WHN 2002-02-02, quoting original + ;; CMU CL comments (setf (node-reoptimize node) t) (ir1-optimize-return node)) (mv-combination (ir1-optimize-mv-combination node)) (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. (let ((value (exit-value node))) (when value (derive-node-type node (continuation-derived-type value))))) @@ -309,22 +336,8 @@ (ir1-optimize-set node))))) (values)) -;;; 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. -;;; 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. -;;; 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. +;;; Try to join with a successor block. If we succeed, we return true, +;;; otherwise false. (defun join-successor-if-possible (block) (declare (type cblock block)) (let ((next (first (block-succ block)))) @@ -332,24 +345,42 @@ (let* ((last (block-last block)) (last-cont (node-cont last)) (next-cont (block-start next))) - (cond ((or (rest (block-pred next)) - (not (eq (continuation-use last-cont) last)) - (eq next block) - (not (eq (block-end-cleanup block) - (block-start-cleanup next))) - (not (eq (block-home-lambda block) - (block-home-lambda next)))) + (cond (;; We cannot combine with a successor block if: + (or + ;; The successor has more than one predecessor. + (rest (block-pred next)) + ;; The last node's CONT is also used somewhere else. + (not (eq (continuation-use last-cont) last)) + ;; The successor is the current block (infinite loop). + (eq next block) + ;; The next block has a different cleanup, and thus + ;; we may want to insert cleanup code between the + ;; two blocks at some point. + (not (eq (block-end-cleanup block) + (block-start-cleanup next))) + ;; The next block has a different home lambda, and + ;; thus the control transfer is a non-local exit. + (not (eq (block-home-lambda block) + (block-home-lambda next)))) nil) + ;; Joining is easy when the successor's START + ;; continuation is the same from our LAST's CONT. ((eq last-cont next-cont) (join-blocks block next) t) + ;; If they differ, then we can still join when the last + ;; continuation has no next and the next continuation + ;; has no uses. ((and (null (block-start-uses next)) (eq (continuation-kind last-cont) :inside-block)) + ;; In this case, we replace the next + ;; continuation with the last before joining the blocks. (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) @@ -360,9 +391,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)) @@ -395,13 +426,9 @@ (values)) -;;; Delete any nodes in Block whose value is unused and have no -;;; side-effects. We can delete sets of lexical variables when the set +;;; Delete any nodes in BLOCK whose value is unused and which 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.] (defun flush-dead-code (block) (declare (type cblock block)) (do-nodes-backwards (node cont block) @@ -412,9 +439,14 @@ (unlink-node node)) (combination (let ((info (combination-kind node))) - (when (function-info-p info) - (let ((attr (function-info-attributes info))) + (when (fun-info-p info) + (let ((attr (fun-info-attributes info))) (when (and (ir1-attributep attr flushable) + ;; ### For now, don't delete potentially + ;; flushable calls when they have the CALL + ;; attribute. Someday we should look at the + ;; functional args to determine if they have + ;; any side effects. (not (ir1-attributep attr call))) (flush-dest (combination-fun node)) (dolist (arg (combination-args node)) @@ -448,19 +480,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))) @@ -468,8 +502,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))))) @@ -481,21 +515,22 @@ (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))) - (funs (tail-set-functions tails))) + (funs (tail-set-funs tails))) (collect ((res *empty-type* values-type-union)) (dolist (fun funs) (let ((return (lambda-return fun))) @@ -507,7 +542,7 @@ (when (type/= (res) (tail-set-type tails)) (setf (tail-set-type tails) (res)) - (dolist (fun (tail-set-functions tails)) + (dolist (fun (tail-set-funs tails)) (dolist (ref (leaf-refs fun)) (reoptimize-continuation (node-cont ref))))))) @@ -538,7 +573,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))))) @@ -546,13 +581,13 @@ (flush-dest test) (when (rest (block-succ block)) (unlink-blocks block victim)) - (setf (component-reanalyze (block-component (node-block node))) t) + (setf (component-reanalyze (node-component node)) t) (unlink-node node)))) (values)) -;;; Create a new copy of an IF Node that tests the value of the node -;;; Use. The test must have >1 use, and must be immediately used by -;;; Use. Node must be the only node in its block (implying that +;;; Create a new copy of an IF node that tests the value of the node +;;; USE. The test must have >1 use, and must be immediately used by +;;; USE. NODE must be the only node in its block (implying that ;;; block-start = if-test). ;;; ;;; This optimization has an effect semantically similar to the @@ -566,7 +601,7 @@ ;;; become unreachable, resulting in a spurious note. (defun convert-if-if (use node) (declare (type node use) (type cif node)) - (with-ir1-environment node + (with-ir1-environment-from-node node (let* ((block (node-block node)) (test (if-test node)) (cblock (if-consequent node)) @@ -578,7 +613,7 @@ :consequent cblock :alternative ablock)) (new-block (continuation-starts-block new-cont))) - (prev-link new-node new-cont) + (link-node-to-previous-continuation new-node new-cont) (setf (continuation-dest new-cont) new-node) (add-continuation-use new-node dummy-cont) (setf (block-last new-block) new-node) @@ -603,14 +638,16 @@ ;;; This function attempts to delete an exit node, returning true if ;;; it deletes the block as a consequence: -;;; -- If the exit is degenerate (has no Entry), then we don't do anything, -;;; since there is nothing to be done. -;;; -- If the exit node and its Entry have the same home lambda then we know -;;; the exit is local, and can delete the exit. We change uses of the -;;; Exit-Value to be uses of the original continuation, then unlink the -;;; node. If the exit is to a TR context, then we must do MERGE-TAIL-SETS -;;; on any local calls which delivered their value to this exit. -;;; -- If there is no value (as in a GO), then we skip the value semantics. +;;; -- If the exit is degenerate (has no ENTRY), then we don't do +;;; anything, since there is nothing to be done. +;;; -- If the exit node and its ENTRY have the same home lambda then +;;; we know the exit is local, and can delete the exit. We change +;;; uses of the Exit-Value to be uses of the original continuation, +;;; then unlink the node. If the exit is to a TR context, then we +;;; must do MERGE-TAIL-SETS on any local calls which delivered +;;; their value to this exit. +;;; -- If there is no value (as in a GO), then we skip the value +;;; semantics. ;;; ;;; This function is also called by environment analysis, since it ;;; wants all exits to be optimized even if normal optimization was @@ -642,11 +679,11 @@ #!+sb-show (defvar *show-transforms-p* nil) -;;; Do IR1 optimizations on a Combination node. +;;; Do IR1 optimizations on a COMBINATION node. (declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node) (when (continuation-reoptimize (basic-combination-fun node)) - (propagate-function-change node)) + (propagate-fun-change node)) (let ((args (basic-combination-args node)) (kind (basic-combination-kind node))) (case kind @@ -664,7 +701,7 @@ (when arg (setf (continuation-reoptimize arg) nil))) - (let ((attr (function-info-attributes kind))) + (let ((attr (fun-info-attributes kind))) (when (and (ir1-attributep attr foldable) ;; KLUDGE: The next test could be made more sensitive, ;; only suppressing constant-folding of functions with @@ -682,26 +719,24 @@ ;; cross-compiler can't fold it because the ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host - (let* ((ref (continuation-use (combination-fun node))) - (fun (leaf-name (ref-leaf ref)))) - (fboundp fun))) + (fboundp (combination-fun-source-name node))) (constant-fold-call node) (return-from ir1-optimize-combination))) - (let ((fun (function-info-derive-type kind))) + (let ((fun (fun-info-derive-type kind))) (when fun (let ((res (funcall fun node))) (when res (derive-node-type node res) (maybe-terminate-block node nil))))) - (let ((fun (function-info-optimizer kind))) + (let ((fun (fun-info-optimizer kind))) (unless (and fun (funcall fun node)) - (dolist (x (function-info-transforms kind)) + (dolist (x (fun-info-transforms kind)) #!+sb-show (when *show-transforms-p* (let* ((cont (basic-combination-fun node)) - (fname (continuation-function-name cont t))) + (fname (continuation-fun-name cont t))) (/show "trying transform" x (transform-function x) "for" fname))) (unless (ir1-transform node x) #!+sb-show @@ -711,37 +746,39 @@ (values)) -;;; If Call is to a function that doesn't return (i.e. return type is +;;; If CALL is to a function that doesn't return (i.e. return type is ;;; NIL), then terminate the block there, and link it to the component ;;; tail. We also change the call's CONT to be a dummy continuation to ;;; prevent the use from confusing things. ;;; -;;; Except when called during IR1, we delete the continuation if it -;;; has no other uses. (If it does have other uses, we reoptimize.) +;;; 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.) ;;; ;;; Termination on the basis of a continuation type assertion 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.) -(defun maybe-terminate-block (call ir1-p) +(defun maybe-terminate-block (call ir1-converting-not-optimizing-p) (declare (type basic-combination call)) (let* ((block (node-block call)) (cont (node-cont call)) (tail (component-tail (block-component block))) (succ (first (block-succ block)))) (unless (or (and (eq call (block-last block)) (eq succ tail)) - (block-delete-p block) - *converting-for-interpreter*) + (block-delete-p block)) (when (or (and (eq (continuation-asserted-type cont) *empty-type*) - (not (or ir1-p (eq (continuation-kind cont) :deleted)))) + (not (or ir1-converting-not-optimizing-p + (eq (continuation-kind cont) :deleted)))) (eq (node-derived-type call) *empty-type*)) - (cond (ir1-p + (cond (ir1-converting-not-optimizing-p (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))))) @@ -754,37 +791,42 @@ (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: -;;; -- 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, -;;; since this function has already been converted. Local call analysis -;;; will duplicate the definition if necessary. We claim that the parent -;;; form is LABELS for context declarations, since we don't want it to be -;;; considered a real global function. -;;; -- In addition to a direct check for the function name in the table, we -;;; also must check for slot accessors. If the function is a slot accessor, -;;; then we set the combination kind to the function info of %Slot-Setter or -;;; %Slot-Accessor, as appropriate. -;;; -- If it is a known function, mark it as such by setting the Kind. +;;; 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-FUN 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, since this function has already been +;;; converted. Local call analysis will duplicate the definition +;;; if necessary. We claim that the parent form is LABELS for +;;; context declarations, since we don't want it to be considered +;;; a real global function. +;;; -- If it is a known function, mark it as such by setting the KIND. ;;; ;;; We return the leaf referenced (NIL if not a leaf) and the -;;; function-info assigned. -(defun recognize-known-call (call ir1-p) +;;; 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))) (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (and (defined-function-p leaf) - (not (byte-compiling))) - (defined-function-inlinep leaf) + (inlinep (if (defined-fun-p leaf) + (defined-fun-inlinep leaf) :no-chance))) (cond ((eq inlinep :notinline) (values nil nil)) @@ -795,34 +837,32 @@ (:inline t) (:no-chance nil) ((nil :maybe-inline) (policy call (zerop space)))) - (defined-function-inline-expansion leaf) - (let ((fun (defined-function-functional leaf))) + (defined-fun-p leaf) + (defined-fun-inline-expansion leaf) + (let ((fun (defined-fun-functional leaf))) (or (not fun) (and (eq inlinep :inline) (functional-kind fun)))) (inline-expansion-ok call)) - (flet ((frob () + (flet (;; FIXME: Is this what the old CMU CL internal documentation + ;; called semi-inlining? A more descriptive name would + ;; be nice. -- WHN 2002-01-07 + (frob () (let ((res (ir1-convert-lambda-for-defun - (defined-function-inline-expansion leaf) + (defined-fun-inline-expansion leaf) leaf t #'ir1-convert-inline-lambda))) - (setf (defined-function-functional leaf) res) + (setf (defined-fun-functional leaf) res) (change-ref-leaf ref res)))) - (if ir1-p + (if ir1-converting-not-optimizing-p (frob) - (with-ir1-environment call + (with-ir1-environment-from-node call (frob) - (local-call-analyze *current-component*)))) + (locall-analyze-component *current-component*)))) (values (ref-leaf (continuation-use (basic-combination-fun call))) nil)) (t - (let* ((name (leaf-name leaf)) - (info (info :function :info - (if (slot-accessor-p leaf) - (if (consp name) - '%slot-setter - '%slot-accessor) - name)))) + (let ((info (info :function :info (leaf-source-name leaf)))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) @@ -834,33 +874,49 @@ ;;; syntax check, arg/result type processing, but still call ;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda, ;;; and that checking is done by local call analysis. -(defun validate-call-type (call type ir1-p) +(defun validate-call-type (call type ir1-converting-not-optimizing-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)))) - (recognize-known-call call ir1-p)) - ((valid-function-use call type - :argument-test #'always-subtypep - :result-test #'always-subtypep - :error-function #'compiler-warning - :warning-function #'compiler-note) + (cond ((not (fun-type-p type)) + (aver (multiple-value-bind (val win) + (csubtypep type (specifier-type 'function)) + (or val (not win)))) + (recognize-known-call call ir1-converting-not-optimizing-p)) + ((valid-fun-use call type + :argument-test #'always-subtypep + :result-test #'always-subtypep + ;; KLUDGE: Common Lisp is such a dynamic + ;; language that all we can do here in + ;; general is issue a STYLE-WARNING. It + ;; would be nice to issue a full WARNING + ;; in the special case of of type + ;; mismatches within a compilation unit + ;; (as in section 3.2.2.3 of the spec) + ;; but at least as of sbcl-0.6.11, we + ;; don't keep track of whether the + ;; mismatched data came from the same + ;; compilation unit, so we can't do that. + ;; -- WHN 2001-02-11 + ;; + ;; FIXME: Actually, I think we could + ;; issue a full WARNING if the call + ;; violates a DECLAIM FTYPE. + :lossage-fun #'compiler-style-warn + :unwinnage-fun #'compiler-note) (assert-call-type call type) - (maybe-terminate-block call ir1-p) - (recognize-known-call call ir1-p)) + (maybe-terminate-block call ir1-converting-not-optimizing-p) + (recognize-known-call call ir1-converting-not-optimizing-p)) (t (setf (combination-kind call) :error) (values nil nil)))) ;;; This is called by IR1-OPTIMIZE when the function for a call has -;;; changed. If the call is local, we try to let-convert it, and +;;; changed. If the call is local, we try to LET-convert it, and ;;; derive the result type. If it is a :FULL call, we validate it ;;; against the type, which recognizes known calls, does inline ;;; expansion, etc. If a call to a predicate in a non-conditional ;;; position or to a function with a source transform, then we ;;; reconvert the form to give IR1 another chance. -(defun propagate-function-change (call) +(defun propagate-fun-change (call) (declare (type combination call)) (let ((*compiler-error-context* call) (fun-cont (basic-combination-fun call))) @@ -879,29 +935,41 @@ (continuation-use (basic-combination-fun call)) call)) ((not leaf)) - ((or (info :function :source-transform (leaf-name leaf)) + ((or (info :function :source-transform (leaf-source-name leaf)) (and info - (ir1-attributep (function-info-attributes info) + (ir1-attributep (fun-info-attributes info) predicate) (let ((dest (continuation-dest (node-cont call)))) (and dest (not (if-p dest)))))) - (let ((name (leaf-name leaf))) - (when (symbolp name) - (let ((dums (loop repeat (length (combination-args call)) - collect (gensym)))) - (transform-call call - `(lambda ,dums - (,name ,@dums)))))))))))) + (when (and (leaf-has-source-name-p leaf) + ;; FIXME: This SYMBOLP is part of a literal + ;; translation of a test in the old CMU CL + ;; source, and it's not quite clear what + ;; the old source meant. Did it mean "has a + ;; valid name"? Or did it mean "is an + ;; ordinary function name, not a SETF + ;; function"? Either way, the old CMU CL + ;; code probably didn't deal with SETF + ;; functions correctly, and neither does + ;; this new SBCL code, and that should be fixed. + (symbolp (leaf-source-name leaf))) + (let ((dummies (make-gensym-list (length + (combination-args call))))) + (transform-call call + `(lambda ,dummies + (,(leaf-source-name leaf) + ,@dummies)) + (leaf-source-name leaf)))))))))) (values)) ;;;; known function optimization -;;; Add a failed optimization note to FAILED-OPTIMZATIONS for Node, -;;; Fun and Args. If there is already a note for Node and Transform, +;;; Add a failed optimization note to FAILED-OPTIMZATIONS for NODE, +;;; FUN and ARGS. If there is already a note for NODE and TRANSFORM, ;;; replace it, otherwise add a new one. (defun record-optimization-failure (node transform args) (declare (type combination node) (type transform transform) - (type (or function-type list) args)) + (type (or fun-type list) args)) (let* ((table (component-failed-optimizations *component-being-compiled*)) (found (assoc transform (gethash node table)))) (if found @@ -920,32 +988,19 @@ (declare (type combination node) (type transform transform)) (let* ((type (transform-type transform)) (fun (transform-function transform)) - (constrained (function-type-p type)) + (constrained (fun-type-p type)) (table (component-failed-optimizations *component-being-compiled*)) (flame (if (transform-important transform) - (policy node (>= speed brevity)) - (policy node (> speed brevity)))) + (policy node (>= speed inhibit-warnings)) + (policy node (> speed inhibit-warnings)))) (*compiler-error-context* node)) - (cond ((not (member (transform-when transform) - (if *byte-compiling* - '(:byte :both) - '(:native :both)))) - ;; FIXME: Make sure that there's a transform for - ;; (MEMBER SYMBOL ..) into MEMQ. - ;; FIXME: Note that when/if I make SHARE operation to shared - ;; constant data between objects in the system, remember that a - ;; SHAREd list, or other SHAREd compound object, can be processed - ;; recursively, so that e.g. the two lists above can share their - ;; '(:BOTH) tail sublists. - (let ((when (transform-when transform))) - (not (or (eq when :both) - (eq when (if *byte-compiling* :byte :native))))) - t) - ((or (not constrained) - (valid-function-use node type :strict-result t)) + (cond ((or (not constrained) + (valid-fun-use node type :strict-result t)) (multiple-value-bind (severity args) (catch 'give-up-ir1-transform - (transform-call node (funcall fun node)) + (transform-call node + (funcall fun node) + (combination-fun-source-name node)) (values :none nil)) (ecase severity (:none @@ -954,7 +1009,7 @@ (:aborted (setf (combination-kind node) :error) (when args - (apply #'compiler-warning args)) + (apply #'compiler-warn args)) (remhash node table) nil) (:failure @@ -963,88 +1018,148 @@ (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)) + (valid-fun-use node + type + :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) +;;; +;;; We require the original function source name in order to generate +;;; a meaningful debug name for the lambda we set up. (It'd be +;;; possible to do this starting from debug names as well as source +;;; names, but as of sbcl-0.7.1.5, there was no need for this +;;; generality, since source names are always known to our callers.) +(defun transform-call (node res source-name) (declare (type combination node) (list res)) - (with-ir1-environment node - (let ((new-fun (ir1-convert-inline-lambda res)) - (ref (continuation-use (combination-fun node)))) - (change-ref-leaf ref new-fun) - (setf (combination-kind node) :full) - (local-call-analyze *current-component*))) + (aver (and (legal-fun-name-p source-name) + (not (eql source-name '.anonymous.)))) + (with-ir1-environment-from-node node + (let ((new-fun (ir1-convert-inline-lambda + res + :debug-name (debug-namify "LAMBDA-inlined ~A" + (as-debug-name + source-name + "")))) + (ref (continuation-use (combination-fun node)))) + (change-ref-leaf ref new-fun) + (setf (combination-kind node) :full) + (locall-analyze-component *current-component*))) (values)) ;;; Replace a call to a foldable function of constant arguments with ;;; the result of evaluating the form. We insert the resulting ;;; constant node after the call, stealing the call's continuation. We -;;; give the call a continuation with no Dest, which should cause it +;;; give the call a continuation with no DEST, which should cause it ;;; and its arguments to go away. If there is an error during the ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. ;;; ;;; If there is more than one value, then we transform the call into a -;;; values form. +;;; VALUES form. (defun constant-fold-call (call) - (declare (type combination call)) - (let* ((args (mapcar #'continuation-value (combination-args call))) - (ref (continuation-use (combination-fun call))) - (fun (leaf-name (ref-leaf ref)))) - + (let ((args (mapcar #'continuation-value (combination-args call))) + (fun-name (combination-fun-source-name call))) (multiple-value-bind (values win) - (careful-call fun args call "constant folding") + (careful-call fun-name args call "constant folding") (if (not win) - (setf (combination-kind call) :error) - (let ((dummies (loop repeat (length args) - collect (gensym)))) - (transform-call - call - `(lambda ,dummies - (declare (ignore ,@dummies)) - (values ,@(mapcar #'(lambda (x) `',x) values)))))))) - + (setf (combination-kind call) :error) + (let ((dummies (make-gensym-list (length args)))) + (transform-call + call + `(lambda ,dummies + (declare (ignore ,@dummies)) + (values ,@(mapcar (lambda (x) `',x) values))) + fun-name))))) (values)) ;;;; local call optimization -;;; Propagate Type to Leaf and its Refs, marking things changed. If +;;; Propagate TYPE to LEAF and its REFS, marking things changed. If ;;; the leaf type is a function type, then just leave it alone, since ;;; TYPE is never going to be more specific than that (and ;;; TYPE-INTERSECTION would choke.) (defun propagate-to-refs (leaf type) (declare (type leaf leaf) (type ctype type)) (let ((var-type (leaf-type leaf))) - (unless (function-type-p var-type) - (let ((int (type-intersection var-type type))) + (unless (fun-type-p var-type) + (let ((int (type-approx-intersection2 var-type type))) (when (type/= int var-type) (setf (leaf-type leaf) int) (dolist (ref (leaf-refs leaf)) @@ -1087,12 +1202,11 @@ ((or constant functional) t) (lambda-var (null (lambda-var-sets leaf))) - (defined-function - (not (eq (defined-function-inlinep leaf) :notinline))) + (defined-fun + (not (eq (defined-fun-inlinep leaf) :notinline))) (global-var (case (global-var-kind leaf) - (:global-function t) - (:constant t)))))) + (:global-function t)))))) ;;; If we have a non-set LET var with a single use, then (if possible) ;;; replace the variable reference's CONT with the arg continuation. @@ -1105,8 +1219,8 @@ ;;; would be NIL. ;;; -- the var's DEST has a different policy than the ARG's (think safety). ;;; -;;; We change the Ref to be a reference to NIL with unused value, and -;;; let it be flushed as dead code. A side-effect of this substitution +;;; We change the REF to be a reference to NIL with unused value, and +;;; let it be flushed as dead code. A side effect of this substitution ;;; is to delete the variable. (defun substitute-single-use-continuation (arg var) (declare (type continuation arg) (type lambda-var var)) @@ -1125,10 +1239,10 @@ cont-atype (continuation-asserted-type arg)) *empty-type*)) - (eq (lexenv-cookie (node-lexenv dest)) - (lexenv-cookie (node-lexenv (continuation-dest arg))))) - (assert (member (continuation-kind arg) - '(:block-start :deleted-block-start :inside-block))) + (eq (lexenv-policy (node-lexenv dest)) + (lexenv-policy (node-lexenv (continuation-dest arg))))) + (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)) @@ -1140,22 +1254,22 @@ ;;; any unreferenced variables. Note that FLUSH-DEAD-CODE will come ;;; along right away and delete the REF and then the lambda, since we ;;; flush the FUN continuation. -(defun delete-let (fun) - (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) - (note-unreferenced-vars fun) - (let ((call (let-combination fun))) +(defun delete-let (clambda) + (declare (type clambda clambda)) + (aver (functional-letlike-p clambda)) + (note-unreferenced-vars clambda) + (let ((call (let-combination clambda))) (flush-dest (basic-combination-fun call)) (unlink-node call) - (unlink-node (lambda-bind fun)) - (setf (lambda-bind fun) nil)) + (unlink-node (lambda-bind clambda)) + (setf (lambda-bind clambda) nil)) (values)) ;;; This function is called when one of the arguments to a LET ;;; changes. We look at each changed argument. If the corresponding ;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we ;;; consider substituting for the variable, and also propagate -;;; derived-type information for the arg to all the Var's refs. +;;; derived-type information for the arg to all the VAR's refs. ;;; ;;; Substitution is inhibited when the arg leaf's derived type isn't a ;;; subtype of the argument's asserted type. This prevents type @@ -1164,7 +1278,7 @@ ;;; ;;; Substitution of individual references is inhibited if the ;;; reference is in a different component from the home. This can only -;;; happen with closures over top-level lambda vars. In such cases, +;;; happen with closures over top level lambda vars. In such cases, ;;; the references may have already been compiled, and thus can't be ;;; retroactively modified. ;;; @@ -1172,7 +1286,7 @@ ;;; are done, then we delete the LET. ;;; ;;; Note that we are responsible for clearing the -;;; Continuation-Reoptimize flags. +;;; CONTINUATION-REOPTIMIZE flags. (defun propagate-let-args (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (combination-args call) @@ -1189,20 +1303,17 @@ (values-subtypep (leaf-type leaf) (continuation-asserted-type arg))) (propagate-to-refs var (continuation-type arg)) - (let ((this-comp (block-component (node-block use)))) + (let ((use-component (node-component use))) (substitute-leaf-if - #'(lambda (ref) - (cond ((eq (block-component (node-block ref)) - this-comp) - t) - (t - (assert (eq (functional-kind (lambda-home fun)) - :top-level)) - nil))) + (lambda (ref) + (cond ((eq (node-component ref) use-component) + t) + (t + (aver (lambda-toplevelish-p (lambda-home fun))) + nil))) leaf var)) t))))) ((and (null (rest (leaf-refs var))) - (not *byte-compiling*) (substitute-single-use-continuation arg var))) (t (propagate-to-refs var (continuation-type arg)))))) @@ -1227,14 +1338,14 @@ (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) - (unless (or (functional-entry-function fun) + (unless (or (functional-entry-fun fun) (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) - (union (mapcar #'(lambda (arg var) - (when (and arg - (continuation-reoptimize arg) - (null (basic-var-sets var))) - (continuation-type arg))) + (union (mapcar (lambda (arg var) + (when (and arg + (continuation-reoptimize arg) + (null (basic-var-sets var))) + (continuation-type arg))) (basic-combination-args call) vars)) (this-ref (continuation-use (basic-combination-fun call)))) @@ -1247,16 +1358,16 @@ (let ((dest (continuation-dest (node-cont ref)))) (unless (or (eq ref this-ref) (not dest)) (setq union - (mapcar #'(lambda (this-arg old) - (when old - (setf (continuation-reoptimize this-arg) nil) - (type-union (continuation-type this-arg) old))) + (mapcar (lambda (this-arg old) + (when old + (setf (continuation-reoptimize this-arg) nil) + (type-union (continuation-type this-arg) old))) (basic-combination-args dest) union))))) - (mapc #'(lambda (var type) - (when type - (propagate-to-refs var type))) + (mapc (lambda (var type) + (when type + (propagate-to-refs var type))) vars union))) (values)) @@ -1293,8 +1404,8 @@ (when fun-changed (setf (continuation-reoptimize fun) nil) (let ((type (continuation-type fun))) - (when (function-type-p type) - (derive-node-type node (function-type-returns type)))) + (when (fun-type-p type) + (derive-node-type node (fun-type-returns type)))) (maybe-terminate-block node nil) (let ((use (continuation-use fun))) (when (and (ref-p use) (functional-p (ref-leaf use))) @@ -1302,7 +1413,7 @@ (when (eq (basic-combination-kind node) :local) (maybe-let-convert (ref-leaf use)))))) (unless (or (eq (basic-combination-kind node) :local) - (eq (continuation-function-name fun) '%throw)) + (eq (continuation-fun-name fun) '%throw)) (ir1-optimize-mv-call node)) (dolist (arg args) (setf (continuation-reoptimize arg) nil)))) @@ -1318,11 +1429,11 @@ (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 + (mapc (lambda (var type) + (if (basic-var-sets var) + (propagate-from-sets var type) + (propagate-to-refs var type))) + vars (append types (make-list (max (- (length vars) nvals) 0) :initial-element (specifier-type 'null)))))) @@ -1367,7 +1478,7 @@ (return-from ir1-optimize-mv-call)) (multiple-value-bind (min max) - (function-type-nargs (continuation-type fun)) + (fun-type-nargs (continuation-type fun)) (let ((total-nvals (multiple-value-bind (types nvals) (values-types (continuation-derived-type (first args))) @@ -1376,14 +1487,14 @@ (when total-nvals (when (and min (< total-nvals min)) - (compiler-warning + (compiler-warn "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ at least ~R." total-nvals min) (setf (basic-combination-kind node) :error) (return-from ir1-optimize-mv-call)) (when (and max (> total-nvals max)) - (compiler-warning + (compiler-warn "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ at most ~R." total-nvals max) @@ -1391,21 +1502,22 @@ (return-from ir1-optimize-mv-call))) (let ((count (cond (total-nvals) - ((and (policy node (zerop safety)) (eql min max)) + ((and (policy node (zerop safety)) + (eql min max)) min) (t nil)))) (when count - (with-ir1-environment node - (let* ((dums (loop repeat count collect (gensym))) + (with-ir1-environment-from-node node + (let* ((dums (make-gensym-list count)) (ignore (gensym)) (fun (ir1-convert-lambda `(lambda (&optional ,@dums &rest ,ignore) (declare (ignore ,ignore)) (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) - (assert (eq (basic-combination-kind node) :full)) - (local-call-analyze *current-component*) - (assert (eq (basic-combination-kind node) :local))))))))) + (aver (eq (basic-combination-kind node) :full)) + (locall-analyze-component *current-component*) + (aver (eq (basic-combination-kind node) :local))))))))) (values)) ;;; If we see: @@ -1428,7 +1540,7 @@ (let* ((arg (first (basic-combination-args call))) (use (continuation-use arg))) (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) + (eq (continuation-fun-name (combination-fun use)) 'values)) (let* ((fun (combination-lambda call)) (vars (lambda-vars fun)) @@ -1439,7 +1551,7 @@ (mapc #'flush-dest (subseq vals nvars)) (setq vals (subseq vals 0 nvars))) ((< nvals nvars) - (with-ir1-environment use + (with-ir1-environment-from-node use (let ((node-prev (node-prev use))) (setf (node-prev use) nil) (setf (continuation-next node-prev) nil) @@ -1450,7 +1562,8 @@ do (reference-constant prev cont nil) (res cont)) (setq vals (res))) - (prev-link use (car (last vals))))))) + (link-node-to-previous-continuation use + (car (last vals))))))) (setf (combination-args use) vals) (flush-dest (combination-fun use)) (let ((fun-cont (basic-combination-fun call))) @@ -1478,10 +1591,10 @@ (defoptimizer (values-list optimizer) ((list) node) (let ((use (continuation-use list))) (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) + (eq (continuation-fun-name (combination-fun use)) 'list)) (change-ref-leaf (continuation-use (combination-fun node)) - (find-free-function 'values "in a strange place")) + (find-free-fun 'values "in a strange place")) (setf (combination-kind node) :full) (let ((args (combination-args use))) (dolist (arg args) @@ -1500,9 +1613,8 @@ (give-up-ir1-transform)) (setf (node-derived-type node) *wild-type*) (if vals - (let ((dummies (loop repeat (1- (length vals)) - collect (gensym)))) + (let ((dummies (make-gensym-list (length (cdr vals))))) `(lambda (val ,@dummies) (declare (ignore ,@dummies)) val)) - 'nil)) + nil))