src/compiler/loop.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 ;;; **********************************************************************
  11 ;;;
  12 ;;; Stuff to annotate the flow graph with information about the loops in it.
  13 ;;;
  14 ;;; Written by Rob MacLachlan
  15 (in-package "SB-C")
  16
  17 ;;; FIND-DOMINATORS  --  Internal
  18 ;;;
  19 ;;; Find the immediate dominator of each block in COMPONENT.  If a
  20 ;;; block is not reachable from an entry point, then its immediate
  21 ;;; dominator will still be NIL when we are done.
  22 (defun find-dominators (component)
  23   (let ((head (loop-head (component-outer-loop component)))
  24         changed)
  25     (setf (block-dominator head) head)
  26     (unless (dfo-as-needed component)
  27       (number-blocks component))
  28     (labels ((intersect (block1 block2)
  29                (cond ((eq block1 block2) block1)
  30                      ((< (block-number block1) (block-number block2))
  31                       (intersect (block-dominator block1) block2))
  32                      (t
  33                       (intersect block1 (block-dominator block2))))))
  34       (loop
  35        (setq changed nil)
  36        (do-blocks (block component :tail)
  37          (let ((dom))
  38            (dolist (pred (block-pred block))
  39              (unless (null (block-dominator pred))
  40                (setq dom (if dom
  41                              (intersect pred dom)
  42                              pred))))
  43            (unless (eq (block-dominator block) dom)
  44              (setf (block-dominator block) dom)
  45              (setq changed t))))
  46        (unless changed (return))))
  47     (setf (block-dominator head) nil)
  48     (setf (component-dominators-computed component) t)))
  49
  50 (defun clear-dominators (component)
  51   (do-blocks (block component)
  52     (setf (block-dominator block) nil))
  53   (setf (component-dominators-computed component) nil))
  54
  55 ;;; DOMINATES-P  --  Internal
  56 ;;;
  57 ;;;    Return true if BLOCK1 dominates BLOCK2, false otherwise.
  58 (defun dominates-p (block1 block2)
  59   (cond ((null block2) nil)
  60         ((eq block1 block2) t)
  61         (t
  62          (dominates-p block1 (block-dominator block2)))))
  63
  64 ;;; LOOP-ANALYZE  --  Interface
  65 ;;;
  66 ;;; Set up the LOOP structures which describe the loops in the flow
  67 ;;; graph for COMPONENT.  We NIL out any existing loop information,
  68 ;;; and then scan through the blocks looking for blocks which are the
  69 ;;; destination of a retreating edge: an edge that goes backward in
  70 ;;; the DFO.  We then create LOOP structures to describe the loops
  71 ;;; that have those blocks as their heads.  If find the head of a
  72 ;;; strange loop, then we do some graph walking to find the other
  73 ;;; segments in the strange loop.  While we are finding the loop
  74 ;;; structures in reverse DFO, we walk it to initialize the block
  75 ;;; lists and initialize the nesting pointers. Then we assign loop depth.
  76 (defun loop-analyze (component)
  77   (let ((outer-loop (component-outer-loop component)))
  78     (do-blocks (block component :both)
  79       (setf (block-loop block) nil))
  80     (setf (loop-inferiors outer-loop) ())
  81     (setf (loop-blocks outer-loop) ())
  82     ;; By traversing in reverse depth first ordering, we guarantee
  83     ;; that inner loop heads will be discovered before their
  84     ;; superiors, since dominated nodes always have lower DFNs.
  85     (do-blocks-backwards (block component)
  86       (let ((number (block-number block)))
  87         (dolist (pred (block-pred block))
  88           (when (<= (block-number pred) number)
  89             (let ((loop (note-loop-head block component)))
  90               (when (eq (loop-kind loop) :strange)
  91                 (clear-flags component)
  92                 (setf (block-flag block) :good)
  93                 (dolist (succ (block-succ block))
  94                   (find-strange-loop-blocks succ block))
  95                 (find-strange-loop-segments block component))
  96               (find-loop-blocks loop)
  97               ;; Loops with no exits are unreachable by predecessor walk and
  98               ;; by definition belong to the component outer loop.
  99               (when (eq (loop-kind loop) :natural)
 100                 (unless (or (loop-exits loop)
 101                             (eq outer-loop loop))
 102                   (setf (loop-superior loop) outer-loop)
 103                   (push loop (loop-inferiors outer-loop)))))
 104             (return)))))
 105     ;; Remaining blocks belong to the outer loop.
 106     (find-loop-blocks outer-loop)
 107     (labels ((assign-depth (loop depth)
 108                (setf (loop-depth loop) depth)
 109                (dolist (inferior (loop-inferiors loop))
 110                  (assign-depth inferior (1+ depth)))))
 111       (assign-depth outer-loop 0))))
 112
 113 ;;; FIND-LOOP-BLOCKS  --  Internal
 114 ;;;
 115 ;;; This function initializes the block lists and inferiors of LOOP.
 116 ;;; When we are done, we scan the blocks looking for exits.  An exit
 117 ;;; is always a block that has a successor which doesn't have a LOOP
 118 ;;; assigned yet, since the target of the exit must be in a superior
 119 ;;; loop.
 120 ;;;
 121 ;;; We find the blocks by doing a backward walk from the tails of the
 122 ;;; loop and from any heads of nested loops.  The walks from inferior
 123 ;;; loop heads are necessary because the walks from the tails
 124 ;;; terminate when they encounter a block in an inferior loop.
 125 (defun find-loop-blocks (loop)
 126   (dolist (tail (loop-tail loop))
 127     (find-blocks-from-here tail loop))
 128   ;; For the outermost loop, new blocks can still be discovered by
 129   ;; walking back from natural loops with no exits.
 130   (when (eq (loop-kind loop) :outer)
 131     (dolist (sub-loop (loop-inferiors loop))
 132       (dolist (pred (block-pred (loop-head sub-loop)))
 133         (find-blocks-from-here pred loop))))
 134   (collect ((exits))
 135     (dolist (sub-loop (loop-inferiors loop))
 136       (dolist (exit (loop-exits sub-loop))
 137         (dolist (succ (block-succ exit))
 138           (unless (block-loop succ)
 139             (exits exit)
 140             (return)))))
 141
 142     (do ((block (loop-blocks loop) (block-loop-next block)))
 143         ((null block))
 144       (dolist (succ (block-succ block))
 145         (unless (block-loop succ)
 146           (exits block)
 147           (return))))
 148     (setf (loop-exits loop) (exits))))
 149
 150
 151 ;;; FIND-BLOCKS-FROM-HERE  --  Internal
 152 ;;;
 153 ;;; This function does a graph walk to find the blocks directly within
 154 ;;; LOOP that can be reached by a backward walk from BLOCK.  If BLOCK
 155 ;;; is already in LOOP or is not dominated by the LOOP-HEAD, then we
 156 ;;; return.  If another loop is already assigned to BLOCK, it must be
 157 ;;; an inferior loop.  If this loop doesn't have a superior yet, we
 158 ;;; record that it must be a direct inferior of LOOP, and recurse on
 159 ;;; the head of this loop's predecessor.  But if BLOCK's loop already
 160 ;;; has a superior, then we can directly recurse on its existing
 161 ;;; superior's head, since all predecessors of the head of BLOCK's
 162 ;;; loop are contained in its superior already.  Otherwise, we add the
 163 ;;; block to the BLOCKS for LOOP and recurse on its predecessors.
 164 (defun find-blocks-from-here (block loop)
 165   (when (and (not (eq (block-loop block) loop))
 166              (dominates-p (loop-head loop) block))
 167     (cond ((block-loop block)
 168            (let* ((inner (block-loop block))
 169                   (inner-superior (loop-superior inner)))
 170              (cond ((not inner-superior)
 171                     (setf (loop-superior inner) loop)
 172                     (push inner (loop-inferiors loop))
 173                     (dolist (pred (block-pred (loop-head inner)))
 174                       (find-blocks-from-here pred loop)))
 175                    ((not (eq inner-superior loop))
 176                     (find-blocks-from-here (loop-head inner-superior) loop)))))
 177           (t
 178            (setf (block-loop block) loop)
 179            (shiftf (block-loop-next block) (loop-blocks loop) block)
 180            (dolist (pred (block-pred block))
 181              (find-blocks-from-here pred loop))))))
 182
 183 ;;; NOTE-LOOP-HEAD  --  Internal
 184 ;;;
 185 ;;; Create a loop structure to describe the loop headed by the block
 186 ;;; HEAD.  If some retreating edge into the head is from a block which
 187 ;;; isn't dominated by the head, then we have the head of a strange
 188 ;;; loop segment.
 189 (defun note-loop-head (head component)
 190   (declare (ignore component))
 191   (let ((result (make-loop :head head
 192                            :kind :natural))
 193         (number (block-number head)))
 194     (dolist (pred (block-pred head))
 195       (when (<= (block-number pred) number)
 196         (if (dominates-p head pred)
 197             (push pred (loop-tail result))
 198             (setf (loop-kind result) :strange))))
 199     result))
 200
 201
 202 ;;; FIND-STRANGE-LOOP-BLOCKS  --  Internal
 203 ;;;
 204 ;;; Do a graph walk to find the blocks in the strange loop which HEAD
 205 ;;; is in.  BLOCK is the block we are currently at and COMPONENT is
 206 ;;; the component we are in.  We do a walk forward from block, using
 207 ;;; only edges which are not back edges.  We return true if there is a
 208 ;;; path from BLOCK to HEAD, false otherwise.  If the BLOCK-FLAG is
 209 ;;; true then we return.  We use two non-null values of FLAG to
 210 ;;; indicate whether a path from the BLOCK back to HEAD was found.
 211 (defun find-strange-loop-blocks (block head)
 212   (let ((flag (block-flag block)))
 213     (cond (flag
 214            (if (eq flag :good)
 215                t
 216                nil))
 217           (t
 218            (setf (block-flag block) :bad)
 219            (unless (dominates-p block head)
 220              (dolist (succ (block-succ block))
 221                (when (find-strange-loop-blocks succ head)
 222                  (setf (block-flag block) :good))))
 223            (eq (block-flag block) :good)))))
 224
 225 ;;; FIND-STRANGE-LOOP-SEGMENTS  --  Internal
 226 ;;;
 227 ;;; Do a graph walk to find the segments in the strange loop that has
 228 ;;; BLOCK in it.  We walk forward, looking only at blocks in the loop
 229 ;;; (flagged as :GOOD.)  Each block in the loop that has predecessors
 230 ;;; outside of the loop is the head of a segment.  We enter the LOOP
 231 ;;; structures in COMPONENT.
 232 (defun find-strange-loop-segments (block component)
 233   (when (eq (block-flag block) :good)
 234     (setf (block-flag block) :done)
 235     (unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
 236                    (block-pred block))
 237       (note-loop-head block component))
 238     (dolist (succ (block-succ block))
 239       (find-strange-loop-segments succ component))))