src/compiler/dfo.lisp

   1 ;;;; This file contains the code that finds the initial components and
   2 ;;;; DFO, and recomputes the DFO if it is invalidated.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!C")
  14
  15 ;;; Find the DFO for a component, deleting any unreached blocks and
  16 ;;; merging any other components we reach. We repeatedly iterate over
  17 ;;; the entry points, since new ones may show up during the walk.
  18 (declaim (ftype (function (component) (values)) find-dfo))
  19 (defun find-dfo (component)
  20   (clear-flags component)
  21   (setf (component-reanalyze component) nil)
  22   (let ((head (component-head component)))
  23     (do ()
  24         ((dolist (ep (block-succ head) t)
  25            (unless (block-flag ep)
  26              (find-dfo-aux ep head component)
  27              (return nil))))))
  28
  29   (let ((num 0))
  30     (declare (fixnum num))
  31     (do-blocks-backwards (block component :both)
  32       (if (block-flag block)
  33           (setf (block-number block) (incf num))
  34           (setf (block-delete-p block) t)))
  35     (do-blocks (block component)
  36       (unless (block-flag block)
  37         (delete-block block))))
  38   (values))
  39
  40 ;;; Move all the code and entry points from OLD to NEW. The code in
  41 ;;; OLD is inserted at the head of NEW. This is also called during LET
  42 ;;; conversion when we are about in insert the body of a LET in a
  43 ;;; different component. [A local call can be to a different component
  44 ;;; before FIND-INITIAL-DFO runs.]
  45 (declaim (ftype (function (component component) (values)) join-components))
  46 (defun join-components (new old)
  47   (aver (eq (component-kind new) (component-kind old)))
  48   (let ((old-head (component-head old))
  49         (old-tail (component-tail old))
  50         (head (component-head new))
  51         (tail (component-tail new)))
  52
  53     (do-blocks (block old)
  54       (setf (block-flag block) nil)
  55       (setf (block-component block) new))
  56
  57     (let ((old-next (block-next old-head))
  58           (old-last (block-prev old-tail))
  59           (next (block-next head)))
  60       (unless (eq old-next old-tail)
  61         (setf (block-next head) old-next)
  62         (setf (block-prev old-next) head)
  63
  64         (setf (block-prev next) old-last)
  65         (setf (block-next old-last) next))
  66
  67       (setf (block-next old-head) old-tail)
  68       (setf (block-prev old-tail) old-head))
  69
  70     (setf (component-lambdas new)
  71           (nconc (component-lambdas old) (component-lambdas new)))
  72     (setf (component-lambdas old) nil)
  73     (setf (component-new-funs new) (nconc (component-new-funs old)
  74                                           (component-new-funs new))
  75           (component-new-funs old) nil)
  76
  77     (dolist (xp (block-pred old-tail))
  78       (unlink-blocks xp old-tail)
  79       (link-blocks xp tail))
  80     (dolist (ep (block-succ old-head))
  81       (unlink-blocks old-head ep)
  82       (link-blocks head ep)))
  83   (values))
  84
  85 ;;; Do a depth-first walk from BLOCK, inserting ourself in the DFO
  86 ;;; after HEAD. If we somehow find ourselves in another component,
  87 ;;; then we join that component to our component.
  88 (declaim (ftype (function (cblock cblock component) (values)) find-dfo-aux))
  89 (defun find-dfo-aux (block head component)
  90   (unless (eq (block-component block) component)
  91     (join-components component (block-component block)))
  92
  93   (unless (block-flag block)
  94     (setf (block-flag block) t)
  95     (dolist (succ (block-succ block))
  96       (find-dfo-aux succ head component))
  97
  98     (remove-from-dfo block)
  99     (add-to-dfo block head))
 100   (values))
 101
 102 ;;; This function is called on each block by FIND-INITIAL-DFO-AUX
 103 ;;; before it walks the successors. It looks at the home lambda's bind
 104 ;;; block to see whether that block is in some other component:
 105
 106 ;;; -- If the block is in the initial component, then do
 107 ;;;    DFO-WALK-CALL-GRAPH on the home function to move it
 108 ;;;    into COMPONENT.
 109 ;;; -- If the block is in some other component, join COMPONENT into
 110 ;;;    it and return that component.
 111 ;;; -- If the home function is deleted, do nothing. BLOCK must
 112 ;;;    eventually be discovered to be unreachable as well. This can
 113 ;;;    happen when we have a NLX into a function with no references.
 114 ;;;    The escape function still has refs (in the deleted function).
 115 ;;;
 116 ;;; This ensures that all the blocks in a given environment will be in
 117 ;;; the same component, even when they might not seem reachable from
 118 ;;; the environment entry. Consider the case of code that is only
 119 ;;; reachable from a non-local exit.
 120 (defun walk-home-call-graph (block component)
 121   (declare (type cblock block) (type component component))
 122   (let ((home (block-home-lambda block)))
 123     (if (eq (functional-kind home) :deleted)
 124         component
 125         (let* ((bind-block (node-block (lambda-bind home)))
 126                (home-component (block-component bind-block)))
 127           (cond ((eq (component-kind home-component) :initial)
 128                  (dfo-scavenge-call-graph home component))
 129                 ((eq home-component component)
 130                  component)
 131                 (t
 132                  (join-components home-component component)
 133                  home-component))))))
 134
 135 ;;; This is somewhat similar to FIND-DFO-AUX, except that it merges
 136 ;;; the current component with any strange component, rather than the
 137 ;;; other way around. This is more efficient in the common case where
 138 ;;; the current component doesn't have much stuff in it.
 139 ;;;
 140 ;;; We return the current component as a result, allowing the caller
 141 ;;; to detect when the old current component has been merged with
 142 ;;; another.
 143 ;;;
 144 ;;; We walk blocks in initial components as though they were already
 145 ;;; in the current component, moving them to the current component in
 146 ;;; the process. The blocks are inserted at the head of the current
 147 ;;; component.
 148 (defun find-initial-dfo-aux (block component)
 149   (declare (type cblock block) (type component component))
 150   (let ((this (block-component block)))
 151     (cond
 152      ((not (or (eq this component)
 153                (eq (component-kind this) :initial)))
 154       (join-components this component)
 155       this)
 156      ((block-flag block) component)
 157      (t
 158       (setf (block-flag block) t)
 159       (let ((current (walk-home-call-graph block component)))
 160         (dolist (succ (block-succ block))
 161           (setq current (find-initial-dfo-aux succ current)))
 162
 163         (remove-from-dfo block)
 164         (add-to-dfo block (component-head current))
 165         current)))))
 166
 167 ;;; Return a list of all the home lambdas that reference FUN (may
 168 ;;; contain duplications).
 169 ;;;
 170 ;;; References to functions which local call analysis could not (or
 171 ;;; were chosen not) to local call convert will appear as references
 172 ;;; to XEP lambdas. We can ignore references to XEPs that appear in
 173 ;;; :TOPLEVEL components, since environment analysis goes to special
 174 ;;; effort to allow closing over of values from a separate top level
 175 ;;; component. (And now that HAS-EXTERNAL-REFERENCES-P-ness
 176 ;;; generalizes :TOPLEVEL-ness, we ignore those too.) All other
 177 ;;; references must cause components to be joined.
 178 ;;;
 179 ;;; References in deleted functions are also ignored, since this code
 180 ;;; will be deleted eventually.
 181 (defun find-reference-funs (fun)
 182   (collect ((res))
 183     (dolist (ref (leaf-refs fun))
 184       (let* ((home (node-home-lambda ref))
 185              (home-kind (functional-kind home))
 186              (home-externally-visible-p
 187               (or (eq home-kind :toplevel)
 188                   (functional-has-external-references-p home))))
 189         (unless (or (and home-externally-visible-p
 190                          (eq (functional-kind fun) :external))
 191                     (eq home-kind :deleted))
 192           (res home))))
 193     (res)))
 194
 195 ;;; Move the code for FUN and all functions called by it into
 196 ;;; COMPONENT. If FUN is already in COMPONENT, then we just return
 197 ;;; that component.
 198 ;;;
 199 ;;; If the function is in an initial component, then we move its head
 200 ;;; and tail to COMPONENT and add it to COMPONENT's lambdas. It is
 201 ;;; harmless to move the tail (even though the return might be
 202 ;;; unreachable) because if the return is unreachable it (and its
 203 ;;; successor link) will be deleted in the post-deletion pass.
 204 ;;;
 205 ;;; We then do a FIND-DFO-AUX starting at the head of FUN. If this
 206 ;;; flow-graph walk encounters another component (which can only
 207 ;;; happen due to a non-local exit), then we move code into that
 208 ;;; component instead. We then recurse on all functions called from
 209 ;;; FUN, moving code into whichever component the preceding call
 210 ;;; returned.
 211 ;;;
 212 ;;; If FUN is in the initial component, but the BLOCK-FLAG is set in
 213 ;;; the bind block, then we just return COMPONENT, since we must have
 214 ;;; already reached this function in the current walk (or the
 215 ;;; component would have been changed).
 216 ;;;
 217 ;;; If the function is an XEP, then we also walk all functions that
 218 ;;; contain references to the XEP. This is done so that environment
 219 ;;; analysis doesn't need to cross component boundaries. This also
 220 ;;; ensures that conversion of a full call to a local call won't
 221 ;;; result in a need to join components, since the components will
 222 ;;; already be one.
 223 (defun dfo-scavenge-call-graph (fun component)
 224   (declare (type clambda fun) (type component component))
 225   (/show "entering DFO-SCAVENGE-CALL-GRAPH" fun component)
 226   (let* ((bind-block (node-block (lambda-bind fun)))
 227          (old-lambda-component (block-component bind-block))
 228          (return (lambda-return fun)))
 229     (cond
 230      ((eq old-lambda-component component)
 231       (/show "LAMBDA is already in COMPONENT")
 232       component)
 233      ((not (eq (component-kind old-lambda-component) :initial))
 234       (/show "joining COMPONENTs")
 235       (join-components old-lambda-component component)
 236       old-lambda-component)
 237      ((block-flag bind-block)
 238       (/show "do-nothing (BLOCK-FLAG BIND-BLOCK) case")
 239       component)
 240      (t
 241       (/show "full scavenge case")
 242       (push fun (component-lambdas component))
 243       (setf (component-lambdas old-lambda-component)
 244             (delete fun (component-lambdas old-lambda-component)))
 245       (link-blocks (component-head component) bind-block)
 246       (unlink-blocks (component-head old-lambda-component) bind-block)
 247       (when return
 248         (let ((return-block (node-block return)))
 249           (link-blocks return-block (component-tail component))
 250           (unlink-blocks return-block (component-tail old-lambda-component))))
 251
 252       (/show (functional-kind fun))
 253       (/show (lambda-calls fun))
 254       (when (eq (functional-kind fun) :external)
 255         (/show (find-reference-funs fun)))
 256
 257       (let ((calls (if (eq (functional-kind fun) :external)
 258                        (append (find-reference-funs fun)
 259                                (lambda-calls fun))
 260                        (lambda-calls fun))))
 261         (do ((res (find-initial-dfo-aux bind-block component)
 262                   (dfo-scavenge-call-graph (first funs) res))
 263              (funs calls (rest funs)))
 264             ((null funs) res)
 265           (declare (type component res))))))))
 266
 267 ;;; Return true if FUN is either an XEP or has EXITS to some of its
 268 ;;; ENTRIES.
 269 (defun has-xep-or-nlx (fun)
 270   (declare (type clambda fun))
 271   (or (eq (functional-kind fun) :external)
 272       (let ((entries (lambda-entries fun)))
 273         (and entries
 274              (find-if #'entry-exits entries)))))
 275
 276 ;;; Compute the result of FIND-INITIAL-DFO given the list of all
 277 ;;; resulting components. Components with a :TOPLEVEL lambda, but no
 278 ;;; normal XEPs or potential non-local exits are marked as :TOPLEVEL.
 279 ;;; If there is a :TOPLEVEL lambda, and also a normal XEP, then we
 280 ;;; treat the component as normal, but also return such components in
 281 ;;; a list as the third value. Components with no entry of any sort
 282 ;;; are deleted.
 283 (defun separate-toplevelish-components (components)
 284   (declare (list components))
 285   (collect ((real)
 286             (top)
 287             (real-top))
 288     (dolist (component components)
 289       (unless (eq (block-next (component-head component))
 290                   (component-tail component))
 291         (let* ((funs (component-lambdas component))
 292                (has-top (find :toplevel funs :key #'functional-kind))
 293                (has-external-references
 294                 (some #'functional-has-external-references-p funs)))
 295           (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
 296                  ;; is newer than the rest of this function, and
 297                  ;; doesn't really seem to fit into its mindset. Here
 298                  ;; we mark components which contain such FUNCTIONs
 299                  ;; them as :COMPLEX-TOPLEVEL, since they do get
 300                  ;; executed at run time, and since it's not valid to
 301                  ;; delete them just because they don't have any
 302                  ;; references from pure :TOPLEVEL components. -- WHN
 303                  has-external-references
 304                  (setf (component-kind component) :complex-toplevel)
 305                  (real component)
 306                  (real-top component))
 307                 ((or (some #'has-xep-or-nlx funs)
 308                      (and has-top (rest funs)))
 309                  (setf (component-name component)
 310                        (find-component-name component))
 311                  (real component)
 312                  (when has-top
 313                    (setf (component-kind component) :complex-toplevel)
 314                    (real-top component)))
 315                 (has-top
 316                  (setf (component-kind component) :toplevel)
 317                  (setf (component-name component) "top level form")
 318                  (top component))
 319                 (t
 320                  (delete-component component))))))
 321
 322     (values (real) (top) (real-top))))
 323
 324 ;; COMPONENTs want strings for names, LEAF-DEBUG-NAMEs mightn't be
 325 ;; strings..
 326 (defun component-name-from-functional-debug-name (functional)
 327   (declare (type functional functional))
 328   (let ((leaf-debug-name (leaf-debug-name functional)))
 329     (the simple-string
 330       (if (stringp leaf-debug-name)
 331           leaf-debug-name
 332           (debug-namify "function ~S" leaf-debug-name)))))
 333
 334 ;;; Given a list of top level lambdas, return
 335 ;;;   (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS).
 336 ;;; Each of the three values returned is a list of COMPONENTs:
 337 ;;;   NONTOP-COMPONENTS = non-top-level-ish COMPONENTs;
 338 ;;;   TOP-COMPONENTS = top-level-ish COMPONENTs;
 339 ;;;   HAIRY-TOP-COMPONENTS = a subset of NONTOP-COMPONENTS, those
 340 ;;;    elements which include a top-level-ish lambda.
 341 ;;;
 342 ;;; We assign the DFO for each component, and delete any unreachable
 343 ;;; blocks. We assume that the FLAGS have already been cleared.
 344 (defun find-initial-dfo (toplevel-lambdas)
 345   (declare (list toplevel-lambdas))
 346   (/show "entering FIND-INITIAL-DFO" toplevel-lambdas)
 347   (collect ((components))
 348     ;; We iterate over the lambdas in each initial component, trying
 349     ;; to put each function in its own component, but joining it to
 350     ;; an existing component if we find that there are references
 351     ;; between them. Any code that is left in an initial component
 352     ;; must be unreachable, so we can delete it. Stray links to the
 353     ;; initial component tail (due NIL function terminated blocks)
 354     ;; are moved to the appropriate newc component tail.
 355     (dolist (toplevel-lambda toplevel-lambdas)
 356       (/show toplevel-lambda)
 357       (let* ((block (node-block (lambda-bind toplevel-lambda)))
 358              (old-component (block-component block))
 359              (old-component-lambdas (component-lambdas old-component))
 360              (new-component nil))
 361         (/show old-component old-component-lambdas)
 362         (aver (member toplevel-lambda old-component-lambdas))
 363         (dolist (component-lambda old-component-lambdas)
 364           (/show component-lambda)
 365           (aver (member (functional-kind component-lambda)
 366                         '(:optional :external :toplevel nil :escape
 367                                     :cleanup)))
 368           (unless new-component
 369             (setf new-component (make-empty-component))
 370             (setf (component-name new-component)
 371                   ;; This isn't necessarily an ideal name for the
 372                   ;; component, since it might end up with multiple
 373                   ;; lambdas in it, not just this one, but it does
 374                   ;; seem a better name than just "<unknown>".
 375                   (component-name-from-functional-debug-name
 376                    component-lambda)))
 377           (let ((res (dfo-scavenge-call-graph component-lambda new-component)))
 378             (when (eq res new-component)
 379               (/show "saving" new-component (component-lambdas new-component))
 380               (aver (not (position new-component (components))))
 381               (components new-component)
 382               (setq new-component nil))))
 383         (when (eq (component-kind old-component) :initial)
 384           (aver (null (component-lambdas old-component)))
 385           (/show "clearing/deleting OLD-COMPONENT because KIND=:INITIAL")
 386           (let ((tail (component-tail old-component)))
 387             (dolist (pred (block-pred tail))
 388               (let ((pred-component (block-component pred)))
 389                 (unless (eq pred-component old-component)
 390                   (unlink-blocks pred tail)
 391                   (link-blocks pred (component-tail pred-component))))))
 392           (delete-component old-component))))
 393
 394     ;; When we are done, we assign DFNs.
 395     (dolist (component (components))
 396       (let ((num 0))
 397         (declare (fixnum num))
 398         (do-blocks-backwards (block component :both)
 399           (setf (block-number block) (incf num)))))
 400
 401     ;; Pull out top-level-ish code.
 402     (separate-toplevelish-components (components))))
 403 \f
 404 ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
 405 (defun merge-1-tl-lambda (result-lambda lambda)
 406   (declare (type clambda result-lambda lambda))
 407
 408   ;; Delete the lambda, and combine the LETs and entries.
 409   (setf (functional-kind lambda) :deleted)
 410   (dolist (let (lambda-lets lambda))
 411     (setf (lambda-home let) result-lambda)
 412     (setf (lambda-physenv let) (lambda-physenv result-lambda))
 413     (push let (lambda-lets result-lambda)))
 414   (setf (lambda-entries result-lambda)
 415         (nconc (lambda-entries result-lambda)
 416                (lambda-entries lambda)))
 417
 418   (let* ((bind (lambda-bind lambda))
 419          (bind-block (node-block bind))
 420          (component (block-component bind-block))
 421          (result-component
 422           (block-component (node-block (lambda-bind result-lambda))))
 423          (result-return-block (node-block (lambda-return result-lambda))))
 424
 425     ;; Move blocks into the new COMPONENT, and move any nodes directly
 426     ;; in the old LAMBDA into the new one (with LETs implicitly moved
 427     ;; by changing their home.)
 428     (do-blocks (block component)
 429       (do-nodes (node cont block)
 430         (let ((lexenv (node-lexenv node)))
 431           (when (eq (lexenv-lambda lexenv) lambda)
 432             (setf (lexenv-lambda lexenv) result-lambda))))
 433       (setf (block-component block) result-component))
 434
 435     ;; Splice the blocks into the new DFO, and unlink them from the
 436     ;; old component head and tail. Non-return blocks that jump to the
 437     ;; tail (NIL-returning calls) are switched to go to the new tail.
 438     (let* ((head (component-head component))
 439            (first (block-next head))
 440            (tail (component-tail component))
 441            (last (block-prev tail))
 442            (prev (block-prev result-return-block)))
 443       (setf (block-next prev) first)
 444       (setf (block-prev first) prev)
 445       (setf (block-next last) result-return-block)
 446       (setf (block-prev result-return-block) last)
 447       (dolist (succ (block-succ head))
 448         (unlink-blocks head succ))
 449       (dolist (pred (block-pred tail))
 450         (unlink-blocks pred tail)
 451         (let ((last (block-last pred)))
 452           (unless (return-p last)
 453             (aver (basic-combination-p last))
 454             (link-blocks pred (component-tail result-component))))))
 455
 456     (let ((lambdas (component-lambdas component)))
 457       (aver (and (null (rest lambdas))
 458                  (eq (first lambdas) lambda))))
 459
 460     ;; Switch the end of the code from the return block to the start of
 461     ;; the next chunk.
 462     (dolist (pred (block-pred result-return-block))
 463       (unlink-blocks pred result-return-block)
 464       (link-blocks pred bind-block))
 465     (unlink-node bind)
 466
 467     ;; If there is a return, then delete it (making the preceding node
 468     ;; the last node) and link the block to the result return. There
 469     ;; is always a preceding REF NIL node in top level lambdas.
 470     (let ((return (lambda-return lambda)))
 471       (when return
 472         (let ((return-block (node-block return))
 473               (result (return-result return)))
 474           (setf (block-last return-block) (continuation-use result))
 475           (flush-dest result)
 476           (delete-continuation result)
 477           (link-blocks return-block result-return-block))))))
 478
 479 ;;; Given a non-empty list of top level LAMBDAs, smash them into a
 480 ;;; top level lambda and component, returning these as values. We use
 481 ;;; the first lambda and its component, putting the other code in that
 482 ;;; component and deleting the other lambdas.
 483 (defun merge-toplevel-lambdas (lambdas)
 484   (declare (cons lambdas))
 485   (let* ((result-lambda (first lambdas))
 486          (result-return (lambda-return result-lambda)))
 487     (cond
 488      (result-return
 489
 490       ;; Make sure the result's return node starts a block so that we
 491       ;; can splice code in before it.
 492       (let ((prev (node-prev
 493                    (continuation-use
 494                     (return-result result-return)))))
 495         (when (continuation-use prev)
 496           (node-ends-block (continuation-use prev)))
 497         (do-uses (use prev)
 498           (let ((new (make-continuation)))
 499             (delete-continuation-use use)
 500             (add-continuation-use use new))))
 501
 502       (dolist (lambda (rest lambdas))
 503         (merge-1-tl-lambda result-lambda lambda)))
 504      (t
 505       (dolist (lambda (rest lambdas))
 506         (setf (functional-entry-function lambda) nil)
 507         (delete-component
 508          (block-component
 509           (node-block (lambda-bind lambda)))))))
 510
 511     (values (block-component (node-block (lambda-bind result-lambda)))
 512             result-lambda)))