src/compiler/control.lisp

   1 ;;;; This file contains the control analysis pass in the compiler. This
   2 ;;;; pass determines the order in which the IR2 blocks are to be
   3 ;;;; emitted, attempting to minimize the associated branching costs.
   4 ;;;;
   5 ;;;; At this point, we commit to generating IR2 (and ultimately
   6 ;;;; assembler) for reachable blocks. Before this phase there might be
   7 ;;;; blocks that are unreachable but still appear in the DFO, due in
   8 ;;;; inadequate optimization, etc.
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  13 ;;;; This software is derived from the CMU CL system, which was
  14 ;;;; written at Carnegie Mellon University and released into the
  15 ;;;; public domain. The software is in the public domain and is
  16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  17 ;;;; files for more information.
  18
  19 (in-package "SB!C")
  20
  21 (file-comment
  22   "$Header$")
  23
  24 ;;; Insert Block in the emission order after the block After.
  25 (defun add-to-emit-order (block after)
  26   (declare (type block-annotation block after))
  27   (let ((next (block-annotation-next after)))
  28     (setf (block-annotation-next after) block)
  29     (setf (block-annotation-prev block) after)
  30     (setf (block-annotation-next block) next)
  31     (setf (block-annotation-prev next) block))
  32   (values))
  33
  34 ;;; If Block looks like the head of a loop, then attempt to rotate it.
  35 ;;; A block looks like a loop head if the number of some predecessor
  36 ;;; is less than the block's number. Since blocks are numbered in
  37 ;;; reverse DFN, this will identify loop heads in a reducible flow
  38 ;;; graph.
  39 ;;;
  40 ;;; When we find a suspected loop head, we scan back from the tail to
  41 ;;; find an alternate loop head. This substitution preserves the
  42 ;;; correctness of the walk, since the old head can be reached from
  43 ;;; the new head. We determine the new head by scanning as far back as
  44 ;;; we can find increasing block numbers. Beats me if this is in
  45 ;;; general optimal, but it works in simple cases.
  46 ;;;
  47 ;;; This optimization is inhibited in functions with NLX EPs, since it
  48 ;;; is hard to do this without possibly messing up the special-case
  49 ;;; walking from NLX EPs described in CONTROL-ANALYZE-1-FUN. We also
  50 ;;; suppress rotation of loop heads which are the start of a function
  51 ;;; (i.e. tail calls), as the debugger wants functions to start at the
  52 ;;; start.
  53 (defun find-rotated-loop-head (block)
  54   (declare (type cblock block))
  55   (let* ((num (block-number block))
  56          (env (block-environment block))
  57          (pred (dolist (pred (block-pred block) nil)
  58                  (when (and (not (block-flag pred))
  59                             (eq (block-environment pred) env)
  60                             (< (block-number pred) num))
  61                    (return pred)))))
  62     (cond
  63      ((and pred
  64            (not (environment-nlx-info env))
  65            (not (eq (node-block (lambda-bind (block-home-lambda block)))
  66                     block)))
  67       (let ((current pred)
  68             (current-num (block-number pred)))
  69         (block DONE
  70           (loop
  71             (dolist (pred (block-pred current) (return-from DONE))
  72               (when (eq pred block)
  73                 (return-from DONE))
  74               (when (and (not (block-flag pred))
  75                          (eq (block-environment pred) env)
  76                          (> (block-number pred) current-num))
  77                 (setq current pred   current-num (block-number pred))
  78                 (return)))))
  79         (assert (not (block-flag current)))
  80         current))
  81      (t
  82       block))))
  83
  84 ;;; Do a graph walk linking blocks into the emit order as we go. We call
  85 ;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
  86 ;;;
  87 ;;; We treat blocks ending in tail local calls to other environments
  88 ;;; specially. We can't walked the called function immediately, since it is in
  89 ;;; a different function and we must keep the code for a function contiguous.
  90 ;;; Instead, we return the function that we want to call so that it can be
  91 ;;; walked as soon as possible, which is hopefully immediately.
  92 ;;;
  93 ;;; If any of the recursive calls ends in a tail local call, then we return
  94 ;;; the last such function, since it is the only one we can possibly drop
  95 ;;; through to. (But it doesn't have to be from the last block walked, since
  96 ;;; that call might not have added anything.)
  97 ;;;
  98 ;;; We defer walking successors whose successor is the component tail (end
  99 ;;; in an error, NLX or tail full call.)  This is to discourage making error
 100 ;;; code the drop-through.
 101 (defun control-analyze-block (block tail block-info-constructor)
 102   (declare (type cblock block) (type block-annotation tail))
 103   (unless (block-flag block)
 104     (let ((block (find-rotated-loop-head block)))
 105       (setf (block-flag block) t)
 106       (assert (and (block-component block) (not (block-delete-p block))))
 107       (add-to-emit-order (or (block-info block)
 108                              (setf (block-info block)
 109                                    (funcall block-info-constructor block)))
 110                          (block-annotation-prev tail))
 111
 112       (let ((last (block-last block)))
 113         (cond ((and (combination-p last) (node-tail-p last)
 114                     (eq (basic-combination-kind last) :local)
 115                     (not (eq (node-environment last)
 116                              (lambda-environment (combination-lambda last)))))
 117                (combination-lambda last))
 118               (t
 119                (let ((component-tail (component-tail (block-component block)))
 120                      (block-succ (block-succ block))
 121                      (fun nil))
 122                  (dolist (succ block-succ)
 123                    (unless (eq (first (block-succ succ)) component-tail)
 124                      (let ((res (control-analyze-block
 125                                  succ tail block-info-constructor)))
 126                        (when res (setq fun res)))))
 127                  (dolist (succ block-succ)
 128                    (control-analyze-block succ tail block-info-constructor))
 129                  fun)))))))
 130
 131 ;;; Analyze all of the NLX EPs first to ensure that code reachable only from
 132 ;;; a NLX is emitted contiguously with the code reachable from the Bind. Code
 133 ;;; reachable from the Bind is inserted *before* the NLX code so that the Bind
 134 ;;; marks the beginning of the code for the function. If the walks from NLX
 135 ;;; EPs reach the bind block, then we just move it to the beginning.
 136 ;;;
 137 ;;; If the walk from the bind node encountered a tail local call, then we
 138 ;;; start over again there to help the call drop through. Of course, it will
 139 ;;; never get a drop-through if either function has NLX code.
 140 (defun control-analyze-1-fun (fun component block-info-constructor)
 141   (declare (type clambda fun) (type component component))
 142   (let* ((tail-block (block-info (component-tail component)))
 143          (prev-block (block-annotation-prev tail-block))
 144          (bind-block (node-block (lambda-bind fun))))
 145     (unless (block-flag bind-block)
 146       (dolist (nlx (environment-nlx-info (lambda-environment fun)))
 147         (control-analyze-block (nlx-info-target nlx) tail-block
 148                                block-info-constructor))
 149       (cond
 150        ((block-flag bind-block)
 151         (let* ((block-note (block-info bind-block))
 152                (prev (block-annotation-prev block-note))
 153                (next (block-annotation-next block-note)))
 154           (setf (block-annotation-prev next) prev)
 155           (setf (block-annotation-next prev) next)
 156           (add-to-emit-order block-note prev-block)))
 157        (t
 158         (let ((new-fun (control-analyze-block bind-block
 159                                               (block-annotation-next
 160                                                prev-block)
 161                                               block-info-constructor)))
 162           (when new-fun
 163             (control-analyze-1-fun new-fun component
 164                                    block-info-constructor)))))))
 165   (values))
 166
 167 ;;; Do control analysis on Component, finding the emit order. Our only
 168 ;;; cleverness here is that we walk XEP's first to increase the probability
 169 ;;; that the tail call will be a drop-through.
 170 ;;;
 171 ;;; When we are done, we delete blocks that weren't reached by the walk.
 172 ;;; Some return blocks are made unreachable by LTN without setting
 173 ;;; COMPONENT-REANALYZE. We remove all deleted blocks from the IR2-COMPONENT
 174 ;;; VALUES-RECEIVERS to keep stack analysis from getting confused.
 175 (defevent control-deleted-block "control analysis deleted dead block")
 176 (defun control-analyze (component block-info-constructor)
 177   (declare (type component component)
 178            (type function block-info-constructor))
 179   (let* ((head (component-head component))
 180          (head-block (funcall block-info-constructor head))
 181          (tail (component-tail component))
 182          (tail-block (funcall block-info-constructor tail)))
 183     (setf (block-info head) head-block)
 184     (setf (block-info tail) tail-block)
 185     (setf (block-annotation-prev tail-block) head-block)
 186     (setf (block-annotation-next head-block) tail-block)
 187
 188     (clear-flags component)
 189
 190     (dolist (fun (component-lambdas component))
 191       (when (external-entry-point-p fun)
 192         (control-analyze-1-fun fun component block-info-constructor)))
 193
 194     (dolist (fun (component-lambdas component))
 195       (control-analyze-1-fun fun component block-info-constructor))
 196
 197     (do-blocks (block component)
 198       (unless (block-flag block)
 199         (event control-deleted-block (continuation-next (block-start block)))
 200         (delete-block block))))
 201
 202   (let ((2comp (component-info component)))
 203     (when (ir2-component-p 2comp)
 204       ;; If it's not an ir2-component, don't worry about it.
 205       (setf (ir2-component-values-receivers 2comp)
 206             (delete-if-not #'block-component
 207                            (ir2-component-values-receivers 2comp)))))
 208
 209   (values))