diff --git a/compiler/control.lisp b/compiler/control.lisp index 6474c9414408e39fb54f499ecbb7e6fc2a1c0089..25f6ff8667bd1820271632c160fe1dec713d42b5 100644 --- a/compiler/control.lisp +++ b/compiler/control.lisp @@ -23,8 +23,7 @@ ;;; Add-To-Emit-Order -- Interface ;;; -;;; Insert Block in the emission order after the block After. We also add -;;; the block to the IR2-Environment-Blocks. +;;; Insert Block in the emission order after the block After. ;;; (defun add-to-emit-order (block after) (declare (type ir2-block block after)) @@ -33,25 +32,22 @@ (setf (ir2-block-prev block) after) (setf (ir2-block-next block) next) (setf (ir2-block-prev next) block)) - - (let ((2env (environment-info - (lambda-environment - (block-lambda (ir2-block-block block)))))) - (push-in ir2-block-environment-next block (ir2-environment-blocks 2env))) - (undefined-value)) ;;; Control-Analyze-Block -- Internal ;;; ;;; Do a graph walk linking blocks into the emit order as we go. We treat -;;; blocks ending in TR nodes specially, since it may be that we want to go -;;; somewhere other than the return block. If tail-call-p, then we drop -;;; through to the head of the called function in a TR local calls (instead of -;;; to the return node.) +;;; blocks ending in tail local calls specially. We can't walked the called +;;; function immediately, since it is in a different function and we must keep +;;; the code for a function contiguous. Instead, we return the function that +;;; we want to call so that it can be walked as soon as possible, which is +;;; hopefully immediately. ;;; -;;; If the IR2 blocks haven't already been assigned, then we make them at -;;; this point. +;;; If any of the recursive calls ends in a tail local call, then we return +;;; the last such function, since it is the only one we can possibly drop +;;; through to. (But it doesn't have to be from the last block walked, since +;;; that call might not have added anything.) ;;; (defun control-analyze-block (block tail) (declare (type cblock block) (type ir2-block tail)) @@ -62,23 +58,16 @@ (setf (block-info block) (make-ir2-block block))) (ir2-block-prev tail)) - #|But not really... (let ((last (block-last block))) - (when (and (combination-p last) (node-tail-p last) - (eq (basic-combination-kind last) :local) - tail-call-p) - (control-analyze-block (node-block - (lambda-bind - (ref-leaf - (continuation-use - (basic-combination-fun last))))) - tail t))) - |# - - (dolist (succ (block-succ block)) - (control-analyze-block succ tail))) - - (undefined-value)) + (cond ((and (combination-p last) (node-tail-p last) + (eq (basic-combination-kind last) :local)) + (combination-lambda last)) + (t + (let ((fun nil)) + (dolist (succ (block-succ block)) + (let ((res (control-analyze-block succ tail))) + (when res (setq fun res)))) + fun)))))) ;;; CONTROL-ANALYZE-1-FUN -- Internal @@ -90,6 +79,10 @@ ;;; will never reach the bind block, so we will always get to insert it at the ;;; beginning. ;;; +;;; If the talk from the bind node encountered a tail local call, then we +;;; start over again there to help the call drop through. Of course, it will +;;; never get a drop-through if either function has NLX code. +;;; (defun control-analyze-1-fun (fun component) (declare (type clambda fun) (type component component)) (let* ((tail-block (block-info (component-tail component))) @@ -99,7 +92,10 @@ (dolist (nlx (environment-nlx-info (lambda-environment fun))) (control-analyze-block (nlx-info-target nlx) tail-block)) (assert (not (block-flag bind-block))) - (control-analyze-block bind-block (ir2-block-next prev-block)))) + (let ((new-fun (control-analyze-block bind-block + (ir2-block-next prev-block)))) + (when new-fun + (control-analyze-1-fun new-fun component))))) (undefined-value)) @@ -111,7 +107,9 @@ ;;; ;;; When we are done, we delete all blocks that weren't reached during our ;;; walk. This allows IR2 phases to assume that all IR1 blocks in the DFO have -;;; valid IR2 blocks in their Info. +;;; valid IR2 blocks in their Info. We delete all deleted blocks from the +;;; IR2-COMPONENT VALUES-GENERATORS and VALUES-RECEIVERS so that stack analysis +;;; won't get confused. ;;; (defun control-analyze (component) (let* ((head (component-head component)) @@ -136,4 +134,12 @@ (unless (block-flag block) (delete-block block)))) + (let ((2comp (component-info component))) + (setf (ir2-component-values-receivers 2comp) + (delete-if-not #'block-component + (ir2-component-values-receivers 2comp))) + (setf (ir2-component-values-generators 2comp) + (delete-if-not #'block-component + (ir2-component-values-generators 2comp)))) + (undefined-value))