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 set of blocks that dominates each block in COMPONENT.  We
  20 ;;; assume that the DOMINATORS for each block is initially NIL, which
  21 ;;; serves to represent the set of all blocks.  If a block is not
  22 ;;; reachable from an entry point, then its dominators will still be
  23 ;;; NIL when we are done.
  24 (defun find-dominators (component)
  25   (let ((head (loop-head (component-outer-loop component)))
  26         changed)
  27     (let ((set (make-sset)))
  28       (sset-adjoin head set)
  29       (setf (block-dominators head) set))
  30     (loop
  31      (setq changed nil)
  32      (do-blocks (block component :tail)
  33        (let ((dom (block-dominators block)))
  34          (when dom (sset-delete block dom))
  35          (dolist (pred (block-pred block))
  36            (let ((pdom (block-dominators pred)))
  37              (when pdom
  38                (if dom
  39                    (when (sset-intersection dom pdom)
  40                      (setq changed t))
  41                    (setq dom (copy-sset pdom) changed t)))))
  42          (setf (block-dominators block) dom)
  43          (when dom (sset-adjoin block dom))))
  44      (unless changed (return)))))
  45
  46
  47 ;;; DOMINATES-P  --  Internal
  48 ;;;
  49 ;;;    Return true if BLOCK1 dominates BLOCK2, false otherwise.
  50 (defun dominates-p (block1 block2)
  51   (let ((set (block-dominators block2)))
  52     (if set
  53         (sset-member block1 set)
  54         t)))
  55
  56 ;;; LOOP-ANALYZE  --  Interface
  57 ;;;
  58 ;;; Set up the LOOP structures which describe the loops in the flow
  59 ;;; graph for COMPONENT.  We NIL out any existing loop information,
  60 ;;; and then scan through the blocks looking for blocks which are the
  61 ;;; destination of a retreating edge: an edge that goes backward in
  62 ;;; the DFO.  We then create LOOP structures to describe the loops
  63 ;;; that have those blocks as their heads.  If find the head of a
  64 ;;; strange loop, then we do some graph walking to find the other
  65 ;;; segments in the strange loop.  After we have found the loop
  66 ;;; structure, we walk it to initialize the block lists.
  67 (defun loop-analyze (component)
  68   (let ((loop (component-outer-loop component)))
  69     (do-blocks (block component :both)
  70       (setf (block-loop block) nil))
  71     (setf (loop-inferiors loop) ())
  72     (setf (loop-blocks loop) nil)
  73     (do-blocks (block component)
  74       (let ((number (block-number block)))
  75         (dolist (pred (block-pred block))
  76           (when (<= (block-number pred) number)
  77             (when (note-loop-head block component)
  78               (clear-flags component)
  79               (setf (block-flag block) :good)
  80               (dolist (succ (block-succ block))
  81                 (find-strange-loop-blocks succ block))
  82               (find-strange-loop-segments block component))
  83             (return)))))
  84     (find-loop-blocks (component-outer-loop component))))
  85
  86
  87 ;;; FIND-LOOP-BLOCKS  --  Internal
  88 ;;;
  89 ;;; This function initializes the block lists for LOOP and the loops
  90 ;;; nested within it.  We recursively descend into the loop nesting
  91 ;;; and place the blocks in the appropriate loop on the way up.  When
  92 ;;; we are done, we scan the blocks looking for exits.  An exit is
  93 ;;; always a block that has a successor which doesn't have a LOOP
  94 ;;; assigned yet, since the target of the exit must be in a superior
  95 ;;; loop.
  96 ;;;
  97 ;;; We find the blocks by doing a forward walk from the head of the
  98 ;;; loop and from any exits of nested loops.  The walks from inferior
  99 ;;; loop exits are necessary because the walks from the head terminate
 100 ;;; when they encounter a block in an inferior loop.
 101 (defun find-loop-blocks (loop)
 102   (dolist (sub-loop (loop-inferiors loop))
 103     (find-loop-blocks sub-loop))
 104
 105   (find-blocks-from-here (loop-head loop) loop)
 106   (dolist (sub-loop (loop-inferiors loop))
 107     (dolist (exit (loop-exits sub-loop))
 108       (dolist (succ (block-succ exit))
 109         (find-blocks-from-here succ loop))))
 110
 111   (collect ((exits))
 112     (dolist (sub-loop (loop-inferiors loop))
 113       (dolist (exit (loop-exits sub-loop))
 114         (dolist (succ (block-succ exit))
 115           (unless (block-loop succ)
 116             (exits exit)
 117             (return)))))
 118
 119     (do ((block (loop-blocks loop) (block-loop-next block)))
 120         ((null block))
 121       (dolist (succ (block-succ block))
 122         (unless (block-loop succ)
 123           (exits block)
 124           (return))))
 125     (setf (loop-exits loop) (exits))))
 126
 127
 128 ;;; FIND-BLOCKS-FROM-HERE  --  Internal
 129 ;;;
 130 ;;; This function does a graph walk to find the blocks directly within
 131 ;;; LOOP that can be reached by a forward walk from BLOCK.  If BLOCK
 132 ;;; is already in a loop or is not dominated by the LOOP-HEAD, then we
 133 ;;; return.  Otherwise, we add the block to the BLOCKS for LOOP and
 134 ;;; recurse on its successors.
 135 (defun find-blocks-from-here (block loop)
 136   (when (and (not (block-loop block))
 137              (dominates-p (loop-head loop) block))
 138     (setf (block-loop block) loop)
 139     (shiftf (block-loop-next block) (loop-blocks loop) block)
 140     (dolist (succ (block-succ block))
 141       (find-blocks-from-here succ loop))))
 142
 143
 144 ;;; NOTE-LOOP-HEAD  --  Internal
 145 ;;;
 146 ;;; Create a loop structure to describe the loop headed by the block
 147 ;;; HEAD.  If there is one already, just return.  If some retreating
 148 ;;; edge into the head is from a block which isn't dominated by the
 149 ;;; head, then we have the head of a strange loop segment.  We return
 150 ;;; true if HEAD is part of a newly discovered strange loop.
 151 (defun note-loop-head (head component)
 152   (let ((superior (find-superior head (component-outer-loop component))))
 153     (unless (eq (loop-head superior) head)
 154       (let ((result (make-loop :head head
 155                                :kind :natural
 156                                :superior superior
 157                                :depth (1+ (loop-depth superior))))
 158             (number (block-number head)))
 159         (push result (loop-inferiors superior))
 160         (dolist (pred (block-pred head))
 161           (when (<= (block-number pred) number)
 162             (if (dominates-p head pred)
 163                 (push pred (loop-tail result))
 164                 (setf (loop-kind result) :strange))))
 165         (eq (loop-kind result) :strange)))))
 166
 167
 168 ;;; FIND-SUPERIOR  --  Internal
 169 ;;;
 170 ;;; Find the loop which would be the superior of a loop headed by
 171 ;;; HEAD.  If there is already a loop with that head, then return that
 172 ;;; loop.
 173 (defun find-superior (head loop)
 174   (if (eq (loop-head loop) head)
 175       loop
 176       (dolist (inferior (loop-inferiors loop) loop)
 177         (when (dominates-p (loop-head inferior) head)
 178           (return (find-superior head inferior))))))
 179
 180
 181 ;;; FIND-STRANGE-LOOP-BLOCKS  --  Internal
 182 ;;;
 183 ;;; Do a graph walk to find the blocks in the strange loop which HEAD
 184 ;;; is in.  BLOCK is the block we are currently at and COMPONENT is
 185 ;;; the component we are in.  We do a walk forward from block, using
 186 ;;; only edges which are not back edges.  We return true if there is a
 187 ;;; path from BLOCK to HEAD, false otherwise.  If the BLOCK-FLAG is
 188 ;;; true then we return.  We use two non-null values of FLAG to
 189 ;;; indicate whether a path from the BLOCK back to HEAD was found.
 190 (defun find-strange-loop-blocks (block head)
 191   (let ((flag (block-flag block)))
 192     (cond (flag
 193            (if (eq flag :good)
 194                t
 195                nil))
 196           (t
 197            (setf (block-flag block) :bad)
 198            (unless (dominates-p block head)
 199              (dolist (succ (block-succ block))
 200                (when (find-strange-loop-blocks succ head)
 201                  (setf (block-flag block) :good))))
 202            (eq (block-flag block) :good)))))
 203
 204 ;;; FIND-STRANGE-LOOP-SEGMENTS  --  Internal
 205 ;;;
 206 ;;; Do a graph walk to find the segments in the strange loop that has
 207 ;;; BLOCK in it.  We walk forward, looking only at blocks in the loop
 208 ;;; (flagged as :GOOD.)  Each block in the loop that has predecessors
 209 ;;; outside of the loop is the head of a segment.  We enter the LOOP
 210 ;;; structures in COMPONENT.
 211 (defun find-strange-loop-segments (block component)
 212   (when (eq (block-flag block) :good)
 213     (setf (block-flag block) :done)
 214     (unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
 215                    (block-pred block))
 216       (note-loop-head block component))
 217     (dolist (succ (block-succ block))
 218       (find-strange-loop-segments succ component))))