src/compiler/stack.lisp

   1 ;;;; This file implements the stack analysis phase in the compiler. We
   2 ;;;; determine which unknown-values and stack continuations are on the
   3 ;;;; stack at each point in the program, and then we insert cleanup
   4 ;;;; code to remove 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 2lvar
  36                          (or (and (not (eq (node-block dest) block))
  37                                   (eq (ir2-lvar-kind 2lvar) :unknown))
  38                              (eq (ir2-lvar-kind 2lvar) :stack)))
  39                 (aver (or saw-last (not last-pop)))
  40                 (pushed lvar))))))
  41
  42       (setf (ir2-block-pushed 2block) (pushed))))
  43   (values))
  44 \f
  45 ;;;; Computation of live lvar sets
  46
  47 ;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has
  48 ;;; been changed.
  49 (defun merge-lvar-live-sets (early late)
  50   (declare (type list early late))
  51   ;; FIXME: O(N^2)
  52   (dolist (e late early)
  53     (pushnew e early)))
  54
  55 ;;; Update information on stacks of unknown-values and stack LVARs on
  56 ;;; the boundaries of BLOCK. Return true if the start stack has been
  57 ;;; changed.
  58 ;;;
  59 ;;; An LVAR is live at the end iff it is live at any of blocks which
  60 ;;; BLOCK can transfer control to, or it is a stack lvar kept live
  61 ;;; within the extent of its cleanup. There are two kind of control
  62 ;;; transfers: normal, expressed with BLOCK-SUCC, and NLX.  We also
  63 ;;; preserve any stack lvars on the stack when an lvar in a
  64 ;;; PRESERVE-INFO set (representing a stack allocated object, not
  65 ;;; necessarily a stack lvar) gets pushed on the stack. PUSHED does
  66 ;;; not track this set because it only tracks stack lvars to make
  67 ;;; liveness analysis feasible with conditional stack allocation. We
  68 ;;; must do this because stack allocated objects can't move; object
  69 ;;; identity must be preserved and we can't in general track all
  70 ;;; references.
  71 (defun update-lvar-live-sets (block)
  72   (declare (type cblock block))
  73   (let* ((2block (block-info block))
  74          (original-start (ir2-block-start-stack 2block))
  75          (end (ir2-block-end-stack 2block))
  76          (new-end end))
  77     (dolist (succ (block-succ block))
  78       (setq new-end (merge-lvar-live-sets new-end
  79                                           (ir2-block-start-stack (block-info succ)))))
  80     (do-nested-cleanups (cleanup block)
  81       (case (cleanup-kind cleanup)
  82         ((:block :tagbody :catch :unwind-protect)
  83          (dolist (nlx-info (cleanup-nlx-info cleanup))
  84            (let* ((target (nlx-info-target nlx-info))
  85                   (target-start-stack (ir2-block-start-stack
  86                                        (block-info target)))
  87                   (exit-lvar (nlx-info-lvar nlx-info))
  88                   (next-stack (if exit-lvar
  89                                   (remove exit-lvar target-start-stack)
  90                                   target-start-stack)))
  91              (setq new-end (merge-lvar-live-sets
  92                             new-end next-stack)))))
  93         (:dynamic-extent
  94          (let* ((dynamic-extent (cleanup-mess-up cleanup))
  95                 (info (dynamic-extent-info dynamic-extent)))
  96            (when info
  97              (pushnew info new-end))
  98            (dolist (preserve (dynamic-extent-preserve-info dynamic-extent))
  99              (when (memq preserve (ir2-block-stack-mess-up 2block))
 100                (pushnew preserve new-end)))))))
 101
 102     (setf (ir2-block-end-stack 2block) new-end)
 103
 104     (let ((start new-end))
 105       (setq start (set-difference start (ir2-block-pushed 2block)))
 106       (setq start (merge-lvar-live-sets start (ir2-block-popped 2block)))
 107
 108       (when *check-consistency*
 109         (aver (subsetp original-start start)))
 110       (cond ((subsetp start original-start)
 111              nil)
 112             (t
 113              (setf (ir2-block-start-stack 2block) start)
 114              t)))))
 115
 116 \f
 117 ;;;; Ordering of live lvar stacks
 118
 119 ;;; Do a forward walk in the flow graph and put LVARs on the start/end
 120 ;;; stacks of BLOCK in the right order. STACK is an already sorted
 121 ;;; stack coming from a predecessor of BLOCK. Because all LVARs live
 122 ;;; at the start of BLOCK are on STACK, we just need to remove dead
 123 ;;; LVARs. As an optimization we only do this above the top-most stack
 124 ;;; LVAR, since nothing allocated before it can be dead.
 125 (defun order-lvar-sets-walk (block stack)
 126   (unless (block-flag block)
 127     (setf (block-flag block) t)
 128     (let* ((2block (block-info block))
 129            (start (ir2-block-start-stack 2block))
 130            (start-stack
 131              (collect ((prefix))
 132                (do ((tail stack (cdr tail)))
 133                    ((null tail) (prefix))
 134                  (let ((lvar (car tail)))
 135                    (when (memq lvar start)
 136                      (when (eq (ir2-lvar-kind (lvar-info lvar)) :stack)
 137                        (return (append (prefix) tail)))
 138                      (prefix lvar)))))))
 139       (aver (subsetp start start-stack))
 140       (setf (ir2-block-start-stack 2block) start-stack)
 141
 142       (let* ((last (block-last block))
 143              (tailp-lvar (if (and (basic-combination-p last)
 144                                   (node-tail-p last))
 145                              (node-lvar last)))
 146              (end-stack start-stack))
 147         (dolist (pop (ir2-block-popped 2block))
 148           (aver (eq pop (car end-stack)))
 149           (pop end-stack))
 150         (dolist (push (ir2-block-pushed 2block))
 151           (aver (not (memq push end-stack)))
 152           (push push end-stack))
 153         (aver (subsetp (ir2-block-end-stack 2block) end-stack))
 154         (when (and tailp-lvar
 155                    (eq (ir2-lvar-kind (lvar-info tailp-lvar)) :unknown))
 156           (aver (eq tailp-lvar (first end-stack)))
 157           (pop end-stack))
 158         (setf (ir2-block-end-stack 2block) end-stack)
 159         (do-nested-cleanups (cleanup block)
 160           (dolist (nlx-info (cleanup-nlx-info cleanup))
 161             (order-lvar-sets-walk (nlx-info-target nlx-info)
 162                                   end-stack)))
 163         (dolist (succ (block-succ block))
 164           (order-lvar-sets-walk succ end-stack)))))
 165
 166   (values))
 167 \f
 168 ;;; Do a forward walk in the flow graph and insert calls to
 169 ;;; %DYNAMIC-EXTENT-START whenever we mess up the run-time stack by
 170 ;;; allocating a dynamic extent object. BLOCK is the block that is
 171 ;;; currently being walked and STACK is the stack of :STACK
 172 ;;; lvars. This allows cleanup code inserted by DISCARD-UNUSED-VALUES
 173 ;;; to reset the stack to the right place.
 174 (defun stack-mess-up-walk (block stack)
 175   (declare (type cblock block) (list stack))
 176   (unless (block-flag block)
 177     (setf (block-flag block) t)
 178     (setf (ir2-block-stack-mess-up (block-info block)) stack)
 179     (let ((2comp (component-info (block-component block))))
 180       (do-nodes (node lvar block)
 181         (let ((dynamic-extent
 182                 (typecase node
 183                   (enclose (enclose-dynamic-extent node))
 184                   (cdynamic-extent node)
 185                   (t (and lvar (lvar-dynamic-extent lvar))))))
 186           (when dynamic-extent
 187             (let ((info (dynamic-extent-info dynamic-extent)))
 188               (when info
 189                 (cond
 190                   ((eq info (first stack)))
 191                   ;; Preserve any intervening dynamic-extents.
 192                   ((memq info stack)
 193                    (do ((cleanup (node-enclosing-cleanup node)
 194                                  (node-enclosing-cleanup
 195                                   (cleanup-mess-up cleanup))))
 196                        ((null cleanup))
 197                      (when (eq (cleanup-kind cleanup) :dynamic-extent)
 198                        (let ((mess-up (cleanup-mess-up cleanup)))
 199                          (when (eq dynamic-extent mess-up)
 200                            (return))
 201                          (let ((preserve (dynamic-extent-info mess-up)))
 202                            (pushnew preserve
 203                                     (dynamic-extent-preserve-info dynamic-extent)))))))
 204                   (t
 205                    (pushnew block (ir2-component-stack-mess-ups 2comp))
 206                    (setf (ctran-next (node-prev node)) nil)
 207                    (let ((ctran (make-ctran)))
 208                      (with-ir1-environment-from-node node
 209                        (ir1-convert (node-prev node) ctran info
 210                                     '(%dynamic-extent-start)))
 211                      (link-node-to-previous-ctran node ctran))
 212                    (push info stack)))))))
 213         (when (entry-p node)
 214           (dolist (nlx-info (cleanup-nlx-info (entry-cleanup node)))
 215             (stack-mess-up-walk (nlx-info-target nlx-info) stack)))))
 216     (dolist (succ (block-succ block))
 217       (stack-mess-up-walk succ stack)))
 218
 219   (values))
 220 \f
 221 ;;; This is called when we discover that the stack-top unknown-values
 222 ;;; or stack lvar at the end of BLOCK1 is different from that at the
 223 ;;; start of BLOCK2 (its successor).
 224 ;;;
 225 ;;; We insert a call to a funny function in a new cleanup block
 226 ;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
 227 ;;; LTN have already run, we must do make an IR2 block, then do
 228 ;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new
 229 ;;; block. The new block is inserted after BLOCK1 in the emit order.
 230 ;;;
 231 ;;; If the control transfer between BLOCK1 and BLOCK2 represents a
 232 ;;; tail-recursive return or a non-local exit, then the cleanup code
 233 ;;; will never actually be executed. It doesn't seem to be worth the
 234 ;;; risk of trying to optimize this, since this rarely happens and
 235 ;;; wastes only space.
 236 (defun discard-unused-values (block1 block2)
 237   (declare (type cblock block1 block2))
 238   (let* ((end-stack (ir2-block-end-stack (block-info block1)))
 239          (start-stack (ir2-block-start-stack (block-info block2))))
 240     (collect ((cleanup-code))
 241       (labels ((find-popped (before after)
 242                  ;; Return (VALUES last-popped rest), where
 243                  ;; (EQ (FIRST rest) (FIRST after)) and
 244                  ;; (CDR (MEMBER last-popped BEFORE) = rest
 245                  (do ((first-preserved (car after))
 246                       (rest before (rest rest))
 247                       (last-popped nil (first rest)))
 248                      ((or (eq (first rest) first-preserved)
 249                           (null rest))
 250                       (when (null rest)
 251                         (aver (null after)))
 252                       (values last-popped rest))))
 253                (nip-values (before after qmoved)
 254                  (unless (equal before after)
 255                    (aver (eq (car before) (car after)))
 256                    (do ((before before (rest before))
 257                         (after after (rest after))
 258                         (last-moved nil (first before)))
 259                        ((neq (first before) (first after))
 260                         (multiple-value-bind (last-nipped rest)
 261                             (find-popped before after)
 262                           (cleanup-code
 263                            `(%nip-values ',last-nipped ',last-moved ,@qmoved))
 264                           (nip-values rest after qmoved)))
 265                      (aver (first before))
 266                      (push `',(first before) qmoved)))))
 267         (multiple-value-bind (last-popped rest)
 268             (find-popped end-stack start-stack)
 269           (when last-popped
 270             (cleanup-code `(%pop-values ',last-popped)))
 271           (when rest
 272             (nip-values rest start-stack '()))))
 273       (when (cleanup-code)
 274         (let* ((block (insert-cleanup-code (list block1) block2
 275                                            (block-start-node block2)
 276                                            `(progn ,@(cleanup-code))))
 277                (2block (make-ir2-block block)))
 278           (setf (block-info block) 2block)
 279           (add-to-emit-order 2block (block-info block1))
 280           (ltn-analyze-belated-block block)
 281           ;; Set the start and end stacks to make traces less
 282           ;; confusing.  Purely cosmetic.
 283           (setf (ir2-block-start-stack 2block) end-stack)
 284           (setf (ir2-block-end-stack 2block) start-stack)))))
 285
 286   (values))
 287 \f
 288 ;;;; stack analysis
 289
 290 ;;; Return a list of all the blocks containing genuine uses of one of
 291 ;;; the RECEIVERS. Exits are excluded, since they don't drop through
 292 ;;; to the receiver.
 293 (defun find-values-generators (receivers)
 294   (declare (list receivers))
 295   (collect ((res nil adjoin))
 296     (dolist (rec receivers)
 297       (dolist (pop (ir2-block-popped (block-info rec)))
 298         (do-uses (use pop)
 299           (unless (exit-p use)
 300             (res (node-block use))))))
 301     (res)))
 302
 303 ;;; Analyze the use of unknown-values and dynamic extents in
 304 ;;; COMPONENT, inserting cleanup code to discard values that are
 305 ;;; generated but never received and to set appropriate bounds for
 306 ;;; stack allocated objects. This phase doesn't need to be run when
 307 ;;; Values-Receivers is null and Stack-Allocates-P is false,
 308 ;;; i.e. there are no unknown-values lvars used across block
 309 ;;; boundaries and no stack allocated objects.
 310 (defun stack-analyze (component)
 311   (declare (type component component))
 312   (let* ((2comp (component-info component))
 313          (receivers (ir2-component-values-receivers 2comp))
 314          (generators (find-values-generators receivers)))
 315
 316     (when (ir2-component-stack-allocates-p 2comp)
 317       (clear-flags component)
 318       (dolist (ep (block-succ (component-head component)))
 319         (let ((start (block-start-node ep)))
 320           (when (and (bind-p start)
 321                      (some #'dynamic-extent-info
 322                            (lambda-dynamic-extents (bind-lambda start))))
 323             (stack-mess-up-walk ep ())))))
 324
 325     (dolist (block generators)
 326       (find-pushed-lvars block))
 327
 328     (dolist (block (ir2-component-stack-mess-ups 2comp))
 329       (unless (ir2-block-pushed (block-info block))
 330         (find-pushed-lvars block))))
 331
 332   ;; Compute sets of lvars.
 333   (loop for did-something = nil
 334      do (do-blocks-backwards (block component)
 335           (when (update-lvar-live-sets block)
 336             (setq did-something t)))
 337      while did-something)
 338
 339   (clear-flags component)
 340   (dolist (ep (block-succ (component-head component)))
 341     (when (bind-p (block-start-node ep))
 342       (order-lvar-sets-walk ep ())))
 343
 344   (do-blocks (block component)
 345     (let ((top (ir2-block-end-stack (block-info block))))
 346       (dolist (succ (block-succ block))
 347         (when (and (block-start succ)
 348                    (not (eq (ir2-block-start-stack (block-info succ))
 349                             top)))
 350           ;; Return resets the stack, so no need to clean anything.
 351           (let ((start (block-last succ)))
 352             (unless (and (return-p start)
 353                          (eq (block-start succ) (node-prev start)))
 354               (discard-unused-values block succ)))))))
 355
 356   (values))