src/compiler/control.lisp

   1 ;;;; This file contains the control analysis pass in the compiler.
   2 ;;;; This 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 ;;; Insert BLOCK in the emission order after the block AFTER.
  22 (defun add-to-emit-order (block after)
  23   (declare (type block-annotation block after))
  24   (let ((next (block-annotation-next after)))
  25     (setf (block-annotation-next after) block)
  26     (setf (block-annotation-prev block) after)
  27     (setf (block-annotation-next block) next)
  28     (setf (block-annotation-prev next) block))
  29   (values))
  30
  31 ;;; If BLOCK looks like the head of a loop, then attempt to rotate it.
  32 ;;; A block looks like a loop head if the number of some predecessor
  33 ;;; is less than the block's number. Since blocks are numbered in
  34 ;;; reverse DFN, this will identify loop heads in a reducible flow
  35 ;;; graph.
  36 ;;;
  37 ;;; When we find a suspected loop head, we scan back from the tail to
  38 ;;; find an alternate loop head. This substitution preserves the
  39 ;;; correctness of the walk, since the old head can be reached from
  40 ;;; the new head. We determine the new head by scanning as far back as
  41 ;;; we can find increasing block numbers. Beats me if this is in
  42 ;;; general optimal, but it works in simple cases.
  43 ;;;
  44 ;;; This optimization is inhibited in functions with NLX EPs, since it
  45 ;;; is hard to do this without possibly messing up the special-case
  46 ;;; walking from NLX EPs described in CONTROL-ANALYZE-1-FUN. We also
  47 ;;; suppress rotation of loop heads which are the start of a function
  48 ;;; (i.e. tail calls), as the debugger wants functions to start at the
  49 ;;; start.
  50 ;;;
  51 ;;; The rotation also is not done if the back edge identified in the
  52 ;;; first step originates from a block that has more than one successor.
  53 ;;; This matches loops that have their terminating condition tested at
  54 ;;; the end, for which the original block order already minimizes the
  55 ;;; number of branches: the back edge starts at a conditional branch at
  56 ;;; the loop's tail and no other branches are needed. We used not to
  57 ;;; test for this situation, rotating these loops, too, resulting in
  58 ;;; machine code that looked like this
  59 ;;;       jump to L1
  60 ;;;   L0: body of loop
  61 ;;;       conditionally branch to L2 if the loop should terminate
  62 ;;;   L1: jump to L0
  63 ;;;   L2:
  64 ;;; which is ugly, and larger and often slower than what is generated
  65 ;;; when not rotating these loops.
  66 (defun find-rotated-loop-head (block)
  67   (declare (type cblock block))
  68   (let* ((num (block-number block))
  69          (env (block-physenv block))
  70          (pred (dolist (pred (block-pred block) nil)
  71                  (when (and (not (block-flag pred))
  72                             (eq (block-physenv pred) env)
  73                             (< (block-number pred) num))
  74                    (return pred)))))
  75     (cond
  76      ((and pred
  77            (not (physenv-nlx-info env))
  78            (not (eq (lambda-block (block-home-lambda block)) block))
  79            (null (cdr (block-succ pred))))
  80       (let ((current pred)
  81             (current-num (block-number pred)))
  82         (block DONE
  83           (loop
  84             (dolist (pred (block-pred current) (return-from DONE))
  85               (when (eq pred block)
  86                 (return-from DONE))
  87               (when (and (not (block-flag pred))
  88                          (eq (block-physenv pred) env)
  89                          (> (block-number pred) current-num))
  90                 (setq current pred   current-num (block-number pred))
  91                 (return)))))
  92         (aver (not (block-flag current)))
  93         current))
  94      (t
  95       block))))
  96
  97 ;;; Do a graph walk linking blocks into the emit order as we go. We
  98 ;;; call FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
  99 ;;;
 100 ;;; We treat blocks ending in tail local calls to other environments
 101 ;;; specially. We can't walked the called function immediately, since
 102 ;;; it is in a different function and we must keep the code for a
 103 ;;; function contiguous. Instead, we return the function that we want
 104 ;;; to call so that it can be walked as soon as possible, which is
 105 ;;; hopefully immediately.
 106 ;;;
 107 ;;; If any of the recursive calls ends in a tail local call, then we
 108 ;;; return the last such function, since it is the only one we can
 109 ;;; possibly drop through to. (But it doesn't have to be from the last
 110 ;;; block walked, since that call might not have added anything.)
 111 ;;;
 112 ;;; We defer walking successors whose successor is the component tail
 113 ;;; (end in an error, NLX or tail full call.) This is to discourage
 114 ;;; making error code the drop-through.
 115 (defun control-analyze-block (block tail block-info-constructor)
 116   (declare (type cblock block)
 117            (type block-annotation tail)
 118            (type function block-info-constructor))
 119   (unless (block-flag block)
 120     (let ((block (find-rotated-loop-head block)))
 121       (setf (block-flag block) t)
 122       (aver (and (block-component block) (not (block-delete-p block))))
 123       (add-to-emit-order (or (block-info block)
 124                              (setf (block-info block)
 125                                    (funcall block-info-constructor block)))
 126                          (block-annotation-prev tail))
 127
 128       (let ((last (block-last block)))
 129         (cond ((and (combination-p last) (node-tail-p last)
 130                     (eq (basic-combination-kind last) :local)
 131                     (not (eq (node-physenv last)
 132                              (lambda-physenv (combination-lambda last)))))
 133                (combination-lambda last))
 134               (t
 135                (let ((component-tail (component-tail (block-component block)))
 136                      (block-succ (block-succ block))
 137                      (fun nil))
 138                  (dolist (succ block-succ)
 139                    (unless (eq (first (block-succ succ)) component-tail)
 140                      (let ((res (control-analyze-block
 141                                  succ tail block-info-constructor)))
 142                        (when res (setq fun res)))))
 143                  (dolist (succ block-succ)
 144                    (control-analyze-block succ tail block-info-constructor))
 145                  fun)))))))
 146
 147 ;;; Analyze all of the NLX EPs first to ensure that code reachable
 148 ;;; only from a NLX is emitted contiguously with the code reachable
 149 ;;; from the BIND. Code reachable from the BIND is inserted *before*
 150 ;;; the NLX code so that the BIND marks the beginning of the code for
 151 ;;; the function. If the walks from NLX EPs reach the BIND block, then
 152 ;;; we just move it to the beginning.
 153 ;;;
 154 ;;; If the walk from the BIND node encountered a tail local call, then
 155 ;;; we start over again there to help the call drop through. Of
 156 ;;; course, it will never get a drop-through if either function has
 157 ;;; NLX code.
 158 (defun control-analyze-1-fun (fun component block-info-constructor)
 159   (declare (type clambda fun)
 160            (type component component)
 161            (type function block-info-constructor))
 162   (let* ((tail-block (block-info (component-tail component)))
 163          (prev-block (block-annotation-prev tail-block))
 164          (bind-block (node-block (lambda-bind fun))))
 165     (unless (block-flag bind-block)
 166       (dolist (nlx (physenv-nlx-info (lambda-physenv fun)))
 167         (control-analyze-block (nlx-info-target nlx) tail-block
 168                                block-info-constructor))
 169       (cond
 170        ((block-flag bind-block)
 171         (let* ((block-note (block-info bind-block))
 172                (prev (block-annotation-prev block-note))
 173                (next (block-annotation-next block-note)))
 174           (setf (block-annotation-prev next) prev)
 175           (setf (block-annotation-next prev) next)
 176           (add-to-emit-order block-note prev-block)))
 177        (t
 178         (let ((new-fun (control-analyze-block bind-block
 179                                               (block-annotation-next
 180                                                prev-block)
 181                                               block-info-constructor)))
 182           (when new-fun
 183             (control-analyze-1-fun new-fun component
 184                                    block-info-constructor)))))))
 185   (values))
 186
 187 ;;; Do control analysis on COMPONENT, finding the emit order. Our only
 188 ;;; cleverness here is that we walk XEP's first to increase the
 189 ;;; probability that the tail call will be a drop-through.
 190 ;;;
 191 ;;; When we are done, we delete blocks that weren't reached by the
 192 ;;; walk. Some return blocks are made unreachable by LTN without
 193 ;;; setting COMPONENT-REANALYZE. We remove all deleted blocks from the
 194 ;;; IR2-COMPONENT VALUES-RECEIVERS to keep stack analysis from getting
 195 ;;; confused.
 196 (defevent control-deleted-block "control analysis deleted dead block")
 197 (defun control-analyze (component block-info-constructor)
 198   (declare (type component component)
 199            (type function block-info-constructor))
 200   (let* ((head (component-head component))
 201          (head-block (funcall block-info-constructor head))
 202          (tail (component-tail component))
 203          (tail-block (funcall block-info-constructor tail)))
 204     (setf (block-info head) head-block)
 205     (setf (block-info tail) tail-block)
 206     (setf (block-annotation-prev tail-block) head-block)
 207     (setf (block-annotation-next head-block) tail-block)
 208
 209     (clear-flags component)
 210
 211     (dolist (fun (component-lambdas component))
 212       (when (xep-p fun)
 213         (control-analyze-1-fun fun component block-info-constructor)))
 214
 215     (dolist (fun (component-lambdas component))
 216       (control-analyze-1-fun fun component block-info-constructor))
 217
 218     (do-blocks (block component)
 219       (unless (block-flag block)
 220         (event control-deleted-block (block-start-node block))
 221         (delete-block block))))
 222
 223   (let ((2comp (component-info component)))
 224     (when (ir2-component-p 2comp)
 225       ;; If it's not an IR2-COMPONENT, don't worry about it.
 226       (setf (ir2-component-values-receivers 2comp)
 227             (delete-if-not #'block-component
 228                            (ir2-component-values-receivers 2comp)))))
 229
 230   (values))