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