src/compiler/stack.lisp

   1 ;;;; This file implements the stack analysis phase in the compiler. We
   2 ;;;; do a graph walk to determine which unknown-values continuations
   3 ;;;; are on the stack at each point in the program, and then we insert
   4 ;;;; cleanup code to pop off unused values.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!C")
  16 \f
  17 ;;; Scan through Block looking for uses of :Unknown continuations that have
  18 ;;; their Dest outside of the block. We do some checking to verify the
  19 ;;; invariant that all pushes come after the last pop.
  20 (defun find-pushed-continuations (block)
  21   (let* ((2block (block-info block))
  22          (popped (ir2-block-popped 2block))
  23          (last-pop (if popped
  24                        (continuation-dest (car (last popped)))
  25                        nil)))
  26     (collect ((pushed))
  27       (let ((saw-last nil))
  28         (do-nodes (node cont block)
  29           (when (eq node last-pop)
  30             (setq saw-last t))
  31
  32           (let ((dest (continuation-dest cont))
  33                 (2cont (continuation-info cont)))
  34             (when (and dest
  35                        (not (eq (node-block dest) block))
  36                        2cont
  37                        (eq (ir2-continuation-kind 2cont) :unknown))
  38               (aver (or saw-last (not last-pop)))
  39               (pushed cont)))))
  40
  41       (setf (ir2-block-pushed 2block) (pushed))))
  42   (values))
  43 \f
  44 ;;;; annotation graph walk
  45
  46 ;;; Do a backward walk in the flow graph simulating the run-time stack of
  47 ;;; unknown-values continuations and annotating the blocks with the result.
  48 ;;;
  49 ;;; Block is the block that is currently being walked and Stack is the stack
  50 ;;; of unknown-values continuations in effect immediately after block. We
  51 ;;; simulate the stack by popping off the unknown-values generated by this
  52 ;;; block (if any) and pushing the continuations for values received by this
  53 ;;; block. (The role of push and pop are interchanged because we are doing a
  54 ;;; backward walk.)
  55 ;;;
  56 ;;; If we run into a values generator whose continuation isn't on stack top,
  57 ;;; then the receiver hasn't yet been reached on any walk to this use. In this
  58 ;;; case, we ignore the push for now, counting on Annotate-Dead-Values to clean
  59 ;;; it up if we discover that it isn't reachable at all.
  60 ;;;
  61 ;;; If our final stack isn't empty, then we walk all the predecessor blocks
  62 ;;; that don't have all the continuations that we have on our Start-Stack on
  63 ;;; their End-Stack. This is our termination condition for the graph walk. We
  64 ;;; put the test around the recursive call so that the initial call to this
  65 ;;; function will do something even though there isn't initially anything on
  66 ;;; the stack.
  67 ;;;
  68 ;;; We can use the tailp test, since the only time we want to bottom out
  69 ;;; with a non-empty stack is when we intersect with another path from the same
  70 ;;; top-level call to this function that has more values receivers on that
  71 ;;; path. When we bottom out in this way, we are counting on
  72 ;;; DISCARD-UNUSED-VALUES doing its thing.
  73 ;;;
  74 ;;; When we do recurse, we check that predecessor's END-STACK is a
  75 ;;; subsequence of our START-STACK. There may be extra stuff on the top
  76 ;;; of our stack because the last path to the predecessor may have discarded
  77 ;;; some values that we use. There may be extra stuff on the bottom of our
  78 ;;; stack because this walk may be from a values receiver whose lifetime
  79 ;;; encloses that of the previous walk.
  80 ;;;
  81 ;;; If a predecessor block is the component head, then it must be the case
  82 ;;; that this is a NLX entry stub. If so, we just stop our walk, since the
  83 ;;; stack at the exit point doesn't have anything to do with our stack.
  84 (defun stack-simulation-walk (block stack)
  85   (declare (type cblock block) (list stack))
  86   (let ((2block (block-info block)))
  87     (setf (ir2-block-end-stack 2block) stack)
  88     (let ((new-stack stack))
  89       (dolist (push (reverse (ir2-block-pushed 2block)))
  90         (if (eq (car new-stack) push)
  91             (pop new-stack)
  92             (aver (not (member push new-stack)))))
  93
  94       (dolist (pop (reverse (ir2-block-popped 2block)))
  95         (push pop new-stack))
  96
  97       (setf (ir2-block-start-stack 2block) new-stack)
  98
  99       (when new-stack
 100         (dolist (pred (block-pred block))
 101           (if (eq pred (component-head (block-component block)))
 102               (aver (find block
 103                           (environment-nlx-info (block-environment block))
 104                           :key #'nlx-info-target))
 105               (let ((pred-stack (ir2-block-end-stack (block-info pred))))
 106                 (unless (tailp new-stack pred-stack)
 107                   (aver (search pred-stack new-stack))
 108                   (stack-simulation-walk pred new-stack))))))))
 109
 110   (values))
 111
 112 ;;; Do stack annotation for any values generators in Block that were
 113 ;;; unreached by all walks (i.e. the continuation isn't live at the point that
 114 ;;; it is generated.)  This will only happen when the values receiver cannot be
 115 ;;; reached from this particular generator (due to an unconditional control
 116 ;;; transfer.)
 117 ;;;
 118 ;;; What we do is push on the End-Stack all continuations in Pushed that
 119 ;;; aren't already present in the End-Stack. When we find any pushed
 120 ;;; continuation that isn't live, it must be the case that all continuations
 121 ;;; pushed after (on top of) it aren't live.
 122 ;;;
 123 ;;; If we see a pushed continuation that is the CONT of a tail call, then we
 124 ;;; ignore it, since the tail call didn't actually push anything. The tail
 125 ;;; call must always the last in the block.
 126 (defun annotate-dead-values (block)
 127   (declare (type cblock block))
 128   (let* ((2block (block-info block))
 129          (stack (ir2-block-end-stack 2block))
 130          (last (block-last block))
 131          (tailp-cont (if (node-tail-p last) (node-cont last))))
 132     (do ((pushes (ir2-block-pushed 2block) (rest pushes))
 133          (popping nil))
 134         ((null pushes))
 135       (let ((push (first pushes)))
 136         (cond ((member push stack)
 137                (aver (not popping)))
 138               ((eq push tailp-cont)
 139                (aver (null (rest pushes))))
 140               (t
 141                (push push (ir2-block-end-stack 2block))
 142                (setq popping t))))))
 143
 144   (values))
 145 \f
 146 ;;; This is called when we discover that the stack-top unknown-values
 147 ;;; continuation at the end of BLOCK1 is different from that at the
 148 ;;; start of BLOCK2 (its successor).
 149 ;;;
 150 ;;; We insert a call to a funny function in a new cleanup block
 151 ;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
 152 ;;; LTN have already run, we must do make an IR2 block, then do
 153 ;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new block.
 154 ;;; The new block is inserted after BLOCK1 in the emit order.
 155 ;;;
 156 ;;; If the control transfer between BLOCK1 and BLOCK2 represents a
 157 ;;; tail-recursive return (:DELETED IR2-continuation) or a non-local
 158 ;;; exit, then the cleanup code will never actually be executed. It
 159 ;;; doesn't seem to be worth the risk of trying to optimize this,
 160 ;;; since this rarely happens and wastes only space.
 161 (defun discard-unused-values (block1 block2)
 162   (declare (type cblock block1 block2))
 163   (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
 164          (block2-stack (ir2-block-start-stack (block-info block2)))
 165          (last-popped (elt block1-stack
 166                            (- (length block1-stack)
 167                               (length block2-stack)
 168                               1))))
 169     (aver (tailp block2-stack block1-stack))
 170
 171     (let* ((block (insert-cleanup-code block1 block2
 172                                        (continuation-next (block-start block2))
 173                                        `(%pop-values ',last-popped)))
 174            (2block (make-ir2-block block)))
 175       (setf (block-info block) 2block)
 176       (add-to-emit-order 2block (block-info block1))
 177       (ltn-analyze-belated-block block)))
 178
 179   (values))
 180 \f
 181 ;;;; stack analysis
 182
 183 ;;; Return a list of all the blocks containing genuine uses of one of the
 184 ;;; Receivers. Exits are excluded, since they don't drop through to the
 185 ;;; receiver.
 186 (defun find-values-generators (receivers)
 187   (declare (list receivers))
 188   (collect ((res nil adjoin))
 189     (dolist (rec receivers)
 190       (dolist (pop (ir2-block-popped (block-info rec)))
 191         (do-uses (use pop)
 192           (unless (exit-p use)
 193             (res (node-block use))))))
 194     (res)))
 195
 196 ;;; Analyze the use of unknown-values continuations in Component, inserting
 197 ;;; cleanup code to discard values that are generated but never received. This
 198 ;;; phase doesn't need to be run when Values-Receivers is null, i.e. there are
 199 ;;; no unknown-values continuations used across block boundaries.
 200 ;;;
 201 ;;; Do the backward graph walk, starting at each values receiver. We ignore
 202 ;;; receivers that already have a non-null Start-Stack. These are nested
 203 ;;; values receivers that have already been reached on another walk. We don't
 204 ;;; want to clobber that result with our null initial stack.
 205 (defun stack-analyze (component)
 206   (declare (type component component))
 207   (let* ((2comp (component-info component))
 208          (receivers (ir2-component-values-receivers 2comp))
 209          (generators (find-values-generators receivers)))
 210
 211     (dolist (block generators)
 212       (find-pushed-continuations block))
 213
 214     (dolist (block receivers)
 215       (unless (ir2-block-start-stack (block-info block))
 216         (stack-simulation-walk block ())))
 217
 218     (dolist (block generators)
 219       (annotate-dead-values block))
 220
 221     (do-blocks (block component)
 222       (let ((top (car (ir2-block-end-stack (block-info block)))))
 223         (dolist (succ (block-succ block))
 224           (when (and (block-start succ)
 225                      (not (eq (car (ir2-block-start-stack (block-info succ)))
 226                               top)))
 227             (discard-unused-values block succ))))))
 228
 229   (values))