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