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 ;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has
  47 ;;; been changed.
  48 (defun merge-stacks (early late)
  49   (declare (type list early late))
  50   (cond ((null early) late)
  51         ((null late) early)
  52         ((tailp early late) late)
  53         ((tailp late early) early)
  54         ;; FIXME
  55         (t (bug "Lexical unwinding of UVL stack is not implemented."))))
  56
  57 ;;; Update information on stacks of unknown-values LVARs on the
  58 ;;; boundaries of BLOCK. Return true if the start stack has been
  59 ;;; changed.
  60 (defun stack-update (block)
  61   (declare (type cblock block))
  62   (declare (optimize (debug 3)))
  63   (let* ((2block (block-info block))
  64          (end (ir2-block-end-stack 2block))
  65          (new-end end)
  66          (cleanup (block-end-cleanup block))
  67          (found-similar-p nil))
  68     (declare (ignore #-nil cleanup))
  69     (dolist (succ (block-succ block))
  70       #+nil
  71       (when (and (< block succ)
  72                  (eq cleanup (block-end-cleanup succ)))
  73         (setq found-similar-p t))
  74       (setq new-end (merge-stacks new-end (ir2-block-start-stack (block-info succ)))))
  75     (unless found-similar-p
  76       (map-block-nlxes (lambda (nlx-info)
  77                          (let* ((nle (nlx-info-target nlx-info))
  78                                 (nle-start-stack (ir2-block-start-stack
  79                                                   (block-info nle)))
  80                                 (exit-lvar (nlx-info-lvar nlx-info)))
  81                            (when (eq exit-lvar (car nle-start-stack))
  82                              (pop nle-start-stack))
  83                            (setq new-end (merge-stacks new-end
  84                                                        nle-start-stack))))
  85                        block))
  86
  87     (setf (ir2-block-end-stack 2block) new-end)
  88     (let ((start new-end))
  89       (dolist (push (reverse (ir2-block-pushed 2block)))
  90         (if (eq (car start) push)
  91             (pop start)
  92             (aver (not (member push start)))))
  93
  94       (dolist (pop (reverse (ir2-block-popped 2block)))
  95         (push pop start))
  96
  97       (cond ((equal-but-no-car-recursion start
  98                                          (ir2-block-start-stack 2block))
  99              nil)
 100             (t
 101              (setf (ir2-block-start-stack 2block) start)
 102              t)))))
 103
 104 ;;; Do stack annotation for any values generators in Block that were
 105 ;;; unreached by all walks (i.e. the lvar isn't live at the point that
 106 ;;; it is generated.)  This will only happen when the values receiver cannot be
 107 ;;; reached from this particular generator (due to an unconditional control
 108 ;;; transfer.)
 109 ;;;
 110 ;;; What we do is push on the End-Stack all lvars in Pushed that
 111 ;;; aren't already present in the End-Stack. When we find any pushed
 112 ;;; lvar that isn't live, it must be the case that all lvars
 113 ;;; pushed after (on top of) it aren't live.
 114 ;;;
 115 ;;; If we see a pushed lvar that is the LVAR of a tail call, then we
 116 ;;; ignore it, since the tail call didn't actually push anything. The
 117 ;;; tail call must always the last in the block.
 118 ;;;
 119 ;;; [This function also fixes End-Stack in NLEs.]
 120 (defun annotate-dead-values (block)
 121   (declare (type cblock block))
 122   (let* ((2block (block-info block))
 123          (stack (ir2-block-end-stack 2block))
 124          (last (block-last block))
 125          (tailp-lvar (if (node-tail-p last) (node-lvar last))))
 126     (do ((pushes (ir2-block-pushed 2block) (rest pushes))
 127          (popping nil))
 128         ((null pushes))
 129       (let ((push (first pushes)))
 130         (cond ((member push stack)
 131                (aver (not popping)))
 132               ((eq push tailp-lvar)
 133                (aver (null (rest pushes))))
 134               (t
 135                (push push (ir2-block-end-stack 2block))
 136                (setq popping t))))))
 137
 138   (values))
 139
 140 ;;; For every NLE block push all LVARs that are live in its ENTRY to
 141 ;;; its start stack. (We cannot pop unused LVARs on a control transfer
 142 ;;; to an NLE block, so we must do it later.)
 143 (defun fix-nle-block-stacks (component)
 144   (declare (type component component))
 145   (dolist (block (block-succ (component-head component)))
 146     (let ((start-node (block-start-node block)))
 147       (unless (bind-p start-node)
 148         (let* ((2block (block-info block))
 149                (start-stack (block-start-stack 2block))
 150                (nlx-ref (ctran-next (node-next start-node)))
 151                (nlx-info (constant-value (ref-leaf nlx-ref)))
 152                (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info)))
 153                (entry-block (node-block mess-up))
 154                (entry-stack (ir2-block-start-stack (block-info entry-block)))
 155                (exit-lvar (nlx-info-lvar nlx-info)))
 156           (when (and exit-lvar
 157                      (eq exit-lvar (car start-stack)))
 158             (when *check-consistency*
 159               (aver (not (memq exit-lvar entry-stack))))
 160             (push exit-lvar entry-stack))
 161           (when *check-consistency*
 162             (aver (subsetp start-stack entry-stack)))
 163           (setf (ir2-block-start-stack 2block) entry-stack)
 164           (setf (ir2-block-end-stack 2block) entry-stack)
 165                                         ; ANNOTATE-DEAD-VALUES will do the rest
 166           )))))
 167 \f
 168 ;;; This is called when we discover that the stack-top unknown-values
 169 ;;; lvar at the end of BLOCK1 is different from that at the start of
 170 ;;; BLOCK2 (its successor).
 171 ;;;
 172 ;;; We insert a call to a funny function in a new cleanup block
 173 ;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
 174 ;;; LTN have already run, we must do make an IR2 block, then do
 175 ;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new
 176 ;;; block. The new block is inserted after BLOCK1 in the emit order.
 177 ;;;
 178 ;;; If the control transfer between BLOCK1 and BLOCK2 represents a
 179 ;;; tail-recursive return or a non-local exit, then the cleanup code
 180 ;;; will never actually be executed. It doesn't seem to be worth the
 181 ;;; risk of trying to optimize this, since this rarely happens and
 182 ;;; wastes only space.
 183 (defun discard-unused-values (block1 block2)
 184   (declare (type cblock block1 block2))
 185   (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
 186          (block2-stack (ir2-block-start-stack (block-info block2)))
 187          (last-popped (elt block1-stack
 188                            (- (length block1-stack)
 189                               (length block2-stack)
 190                               1))))
 191     (aver (tailp block2-stack block1-stack))
 192
 193     (let* ((block (insert-cleanup-code block1 block2
 194                                        (block-start-node block2)
 195                                        `(%pop-values ',last-popped)))
 196            (2block (make-ir2-block block)))
 197       (setf (block-info block) 2block)
 198       (add-to-emit-order 2block (block-info block1))
 199       (ltn-analyze-belated-block block)))
 200
 201   (values))
 202 \f
 203 ;;;; stack analysis
 204
 205 ;;; Return a list of all the blocks containing genuine uses of one of
 206 ;;; the RECEIVERS. Exits are excluded, since they don't drop through
 207 ;;; to the receiver.
 208 (defun find-values-generators (receivers)
 209   (declare (list receivers))
 210   (collect ((res nil adjoin))
 211     (dolist (rec receivers)
 212       (dolist (pop (ir2-block-popped (block-info rec)))
 213         (do-uses (use pop)
 214           (unless (exit-p use)
 215             (res (node-block use))))))
 216     (res)))
 217
 218 ;;; Analyze the use of unknown-values lvars in COMPONENT, inserting
 219 ;;; cleanup code to discard values that are generated but never
 220 ;;; received. This phase doesn't need to be run when Values-Receivers
 221 ;;; is null, i.e. there are no unknown-values lvars used across block
 222 ;;; boundaries.
 223 ;;;
 224 ;;; Do the backward graph walk, starting at each values receiver. We
 225 ;;; ignore receivers that already have a non-null START-STACK. These
 226 ;;; are nested values receivers that have already been reached on
 227 ;;; another walk. We don't want to clobber that result with our null
 228 ;;; initial stack.
 229 (defun stack-analyze (component)
 230   (declare (type component component))
 231   (let* ((2comp (component-info component))
 232          (receivers (ir2-component-values-receivers 2comp))
 233          (generators (find-values-generators receivers)))
 234
 235     (dolist (block generators)
 236       (find-pushed-lvars block))
 237
 238     (loop for did-something = nil
 239           do (do-blocks-backwards (block component)
 240                (when (stack-update block)
 241                  (setq did-something t)))
 242           while did-something)
 243
 244     (when *check-consistency*
 245       (dolist (block (block-succ (component-head component)))
 246         (when (bind-p (block-start-node block))
 247           (aver (null (ir2-block-start-stack (block-info block)))))))
 248
 249     (dolist (block generators)
 250       (annotate-dead-values block))
 251
 252     (do-blocks (block component)
 253       (let ((top (car (ir2-block-end-stack (block-info block)))))
 254         (dolist (succ (block-succ block))
 255           (when (and (block-start succ)
 256                      (not (eq (car (ir2-block-start-stack (block-info succ)))
 257                               top)))
 258             (discard-unused-values block succ))))))
 259
 260   (values))