Forked from
cmucl / cmucl
4717 commits behind the upstream repository.
-
gerd authored
'(lambda (c) (declare (optimize (speed 3) (debug 1))) (flet ((%f18 () -36)) (flet ((%f13 () (let () (block b8 (return-from b8 c))))) (%f18))))) => error nil is not an integer, in dump-1-variable Found by Paul Dietz. This is caused by a lambda-var being passed to dump-1-variable which hasn't been packed, and so has a null tn-offset. A ref to this lambda-var remains at this point because it is referenced from a different component. The ref is deleted when that component is compiled. The problem is that there shouldn't have been two components to begin with, which we prevent by recording additional DFO dependencies for closed-over variables and entries. Port from SBCL, basically. Does not require a bootstrap file, but a full build is necessary due to the renamed clambda structure slot. * src/compiler/dfo.lisp (dfo-walk-call-graph): Process new dfo dependencies. * src/compiler/node.lisp (clambda): Rename slot `calls' to `dfo-dependencies'. * src/compiler/locall.lisp (convert-call, convert-mv-call): Call note-dfo-dependency. (merge-lets): Change for new clambda slot name. (unconvert-tail-calls): Handle the case of non-clambdas in the dfo dependencies. * src/compiler/ir1util.lisp (continuation-home-lambda) (note-dfo-dependency): New functions. * src/compiler/ir1tran.lisp (ir1-convert-variable) (return-from, go, setq): Call note-dfo-dependency. * src/compiler/xref.lisp (lambda-called-p): New function. (prettiest-caller-name): Use lambda-called-p instead of lambda-calls.
gerd authored'(lambda (c) (declare (optimize (speed 3) (debug 1))) (flet ((%f18 () -36)) (flet ((%f13 () (let () (block b8 (return-from b8 c))))) (%f18))))) => error nil is not an integer, in dump-1-variable Found by Paul Dietz. This is caused by a lambda-var being passed to dump-1-variable which hasn't been packed, and so has a null tn-offset. A ref to this lambda-var remains at this point because it is referenced from a different component. The ref is deleted when that component is compiled. The problem is that there shouldn't have been two components to begin with, which we prevent by recording additional DFO dependencies for closed-over variables and entries. Port from SBCL, basically. Does not require a bootstrap file, but a full build is necessary due to the renamed clambda structure slot. * src/compiler/dfo.lisp (dfo-walk-call-graph): Process new dfo dependencies. * src/compiler/node.lisp (clambda): Rename slot `calls' to `dfo-dependencies'. * src/compiler/locall.lisp (convert-call, convert-mv-call): Call note-dfo-dependency. (merge-lets): Change for new clambda slot name. (unconvert-tail-calls): Handle the case of non-clambdas in the dfo dependencies. * src/compiler/ir1util.lisp (continuation-home-lambda) (note-dfo-dependency): New functions. * src/compiler/ir1tran.lisp (ir1-convert-variable) (return-from, go, setq): Call note-dfo-dependency. * src/compiler/xref.lisp (lambda-called-p): New function. (prettiest-caller-name): Use lambda-called-p instead of lambda-calls.
dfo.lisp 18.27 KiB
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dfo.lisp,v 1.27 2003/10/02 19:23:11 gerd Rel $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the code that finds the initial components and DFO,
;;; and recomputes the DFO if it is invalidated.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package "C")
;;; Find-DFO -- Interface
;;;
;;; Find the DFO for a component, deleting any unreached blocks and merging
;;; any other components we reach. We repeatedly iterate over the entry
;;; points, since new ones may show up during the walk.
;;;
(defun find-dfo (component)
(declare (type component component))
(clear-flags component)
(setf (component-reanalyze component) nil)
(let ((head (component-head component)))
(do ()
((dolist (ep (block-succ head) t)
(unless (block-flag ep)
(find-dfo-aux ep head component)
(return nil))))))
(let ((num 0))
(declare (fixnum num))
(do-blocks-backwards (block component :both)
(if (block-flag block)
(setf (block-number block) (incf num))
(setf (block-delete-p block) t)))
(do-blocks (block component)
(unless (block-flag block)
(delete-block block)))))
;;; Join-Components -- Interface
;;;
;;; Move all the code and entry points from Old to New. The code in Old is
;;; inserted at the head of New. This is also called during let conversion
;;; when we are about in insert the body of a let in a different component. [A
;;; local call can be to a different component before FIND-INITIAL-DFO runs.]
;;;
(defun join-components (new old)
(declare (type component new old))
(assert (eq (component-kind new) (component-kind old)))
(let ((old-head (component-head old))
(old-tail (component-tail old))
(head (component-head new))
(tail (component-tail new)))
(do-blocks (block old)
(setf (block-flag block) nil)
(setf (block-component block) new))
(let ((old-next (block-next old-head))
(old-last (block-prev old-tail))
(next (block-next head)))
(unless (eq old-next old-tail)
(setf (block-next head) old-next)
(setf (block-prev old-next) head)
(setf (block-prev next) old-last)
(setf (block-next old-last) next))
(setf (block-next old-head) old-tail)
(setf (block-prev old-tail) old-head))
(setf (component-lambdas new)
(nconc (component-lambdas old) (component-lambdas new)))
(setf (component-lambdas old) ())
(setf (component-new-functions new)
(nconc (component-new-functions old) (component-new-functions new)))
(setf (component-new-functions old) ())
(dolist (xp (block-pred old-tail))
(unlink-blocks xp old-tail)
(link-blocks xp tail))
(dolist (ep (block-succ old-head))
(unlink-blocks old-head ep)
(link-blocks head ep))))
;;; Find-DFO-Aux -- Internal
;;;
;;; Do a depth-first walk from Block, inserting ourself in the DFO after
;;; Head. If we somehow find ourselves in another component, then we join that
;;; component to our component.
;;;
(defun find-dfo-aux (block head component)
(declare (type cblock block head) (type component component))
(unless (eq (block-component block) component)
(join-components component (block-component block)))
(unless (block-flag block)
(setf (block-flag block) t)
(dolist (succ (block-succ block))
(find-dfo-aux succ head component))
(remove-from-dfo block)
(add-to-dfo block head)))
;;; Walk-Home-Call-Graph -- Internal
;;;
;;; This function is called on each block by Find-Initial-DFO-Aux before it
;;; walks the successors. It looks at the home lambda's bind block to see if
;;; that block is in some other component:
;;; -- If the block is in the initial component, then do DFO-Walk-Call-Graph on
;;; the home function to move it into component.
;;; -- If the block is in some other component, join Component into it and
;;; return that component.
;;; -- If the home function is deleted, do nothing. Block must eventually be
;;; discovered to be unreachable as well. This can happen when we have a
;;; NLX into a function with no references. The escape function still has
;;; refs (in the deleted function).
;;;
;;; This ensures that all the blocks in a given environment will be in the same
;;; component, even when they might not seem reachable from the environment
;;; entry. Consider the case of code that is only reachable from a non-local
;;; exit.
;;;
(defun walk-home-call-graph (block component)
(declare (type cblock block) (type component component))
(let ((home (block-home-lambda block)))
(if (eq (functional-kind home) :deleted)
component
(let* ((bind-block (node-block (lambda-bind home)))
(home-component (block-component bind-block)))
(cond ((eq (component-kind home-component) :initial)
(dfo-walk-call-graph home component))
((eq home-component component)
component)
(t
(join-components home-component component)
home-component))))))
;;; Find-Initial-DFO-Aux -- Internal
;;;
;;; Somewhat similar to Find-DFO-Aux, except that it merges the current
;;; component with any strange component, rather than the other way around.
;;; This is more efficient in the common case where the current component
;;; doesn't have much stuff in it.
;;;
;;; We return the current component as a result, allowing the caller to
;;; detect when the old current component has been merged with another.
;;;
;;; We walk blocks in initial components as though they were already in the
;;; current component, moving them to the current component in the process.
;;; The blocks are inserted at the head of the current component.
;;;
(defun find-initial-dfo-aux (block component)
(declare (type cblock block) (type component component))
(let ((this (block-component block)))
(cond
((not (or (eq this component)
(eq (component-kind this) :initial)))
(join-components this component)
this)
((block-flag block) component)
(t
(setf (block-flag block) t)
(let ((current (walk-home-call-graph block component)))
(dolist (succ (block-succ block))
(setq current (find-initial-dfo-aux succ current)))
(remove-from-dfo block)
(add-to-dfo block (component-head current))
current)))))
;;; Find-Reference-Functions -- Internal
;;;
;;; Return a list of all the home lambdas that reference Fun (may contain
;;; duplications).
;;;
;;; References to functions which local call analysis could not (or were
;;; chosen not) to local call convert will appear as references to XEP lambdas.
;;; We can ignore references to XEPs that appear in :TOP-LEVEL components,
;;; since environment analysis goes to special effort to allow closing over of
;;; values from a separate top-level component. All other references must
;;; cause components to be joined.
;;;
;;; References in deleted functions are also ignored, since this code will be
;;; deleted eventually.
;;;
(defun find-reference-functions (fun)
(collect ((res))
(dolist (ref (leaf-refs fun))
(let* ((home (node-home-lambda ref))
(home-kind (functional-kind home)))
(unless (or (and (eq home-kind :top-level)
(eq (functional-kind fun) :external))
(eq home-kind :deleted))
(res home))))
(res)))
;;; DFO-Walk-Call-Graph -- Internal
;;;
;;; Move the code for Fun and all functions called by it into Component. If
;;; Fun is already in Component, then we just return that component.
;;;
;;; If the function is in an initial component, then we move its head and
;;; tail to Component and add it to Component's lambdas. It is harmless to
;;; move the tail (even though the return might be unreachable) because if the
;;; return is unreachable it (and its successor link) will be deleted in the
;;; post-deletion pass.
;;;
;;; We then do a Find-DFO-Aux starting at the head of Fun. If this
;;; flow-graph walk encounters another component (which can only happen due to
;;; a non-local exit), then we move code into that component instead. We then
;;; recurse on all functions called from Fun, moving code into whichever
;;; component the preceding call returned.
;;;
;;; If Fun is in the initial component, but the Block-Flag is set in the
;;; bind block, then we just return Component, since we must have already
;;; reached this function in the current walk (or the component would have been
;;; changed).
;;;
;;; If the function is an XEP, then we also walk all functions that contain
;;; references to the XEP. This is done so that environment analysis doesn't
;;; need to cross component boundries. This also ensures that conversion of a
;;; full call to a local call won't result in a need to join components, since
;;; the components will already be one.
;;;
(defun dfo-walk-call-graph (fun component)
(declare (type clambda fun) (type component component))
(let* ((bind-block (node-block (lambda-bind fun)))
(this (block-component bind-block))
(return (lambda-return fun)))
(cond ((eq this component)
component)
((not (eq (component-kind this) :initial))
(join-components this component)
this)
((block-flag bind-block)
component)
(t
(push fun (component-lambdas component))
(setf (component-lambdas this)
(delete fun (component-lambdas this)))
(link-blocks (component-head component) bind-block)
(unlink-blocks (component-head this) bind-block)
(when return
(let ((return-block (node-block return)))
(link-blocks return-block (component-tail component))
(unlink-blocks return-block (component-tail this))))
(let ((res (find-initial-dfo-aux bind-block component)))
(declare (type component res))
(flet ((walk (clambda)
(unless (eq (lambda-kind clambda) :deleted)
(let ((home (lambda-home clambda)))
(setq res (dfo-walk-call-graph home res))))))
(dolist (dd (lambda-dfo-dependencies fun))
(etypecase dd
(clambda
(walk dd))
(lambda-var
(unless (null (lambda-var-refs dd))
(walk (lambda-home (lambda-var-home dd)))))
(entry
(walk (node-home-lambda dd)))))
(when (eq (lambda-kind fun) :external)
(dolist (lambda (find-reference-functions fun))
(walk lambda))))
res)))))
;;; HAS-XEP-OR-NLX -- Internal
;;;
;;; Return true if Fun is either an XEP or has EXITS to some of its ENTRIES.
;;;
(defun has-xep-or-nlx (fun)
(declare (type clambda fun))
(or (eq (functional-kind fun) :external)
(let ((entries (lambda-entries fun)))
(and entries
(find-if #'entry-exits entries)))))
;;; FIND-TOP-LEVEL-COMPONENTS -- Internal
;;;
;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting
;;; components. Components with a :TOP-LEVEL lambda, but no normal XEPs or
;;; potential non-local exits are marked as :TOP-LEVEL. If there is a
;;; :TOP-LEVEL lambda, and also a normal XEP, then we treat the component as
;;; normal, but also return such components in a list as the third value.
;;; Components with no entry of any sort are deleted.
;;;
(defun find-top-level-components (components)
(declare (list components))
(collect ((real)
(top)
(real-top))
(dolist (com components)
(unless (eq (block-next (component-head com)) (component-tail com))
(let* ((funs (component-lambdas com))
(has-top (find :top-level funs :key #'functional-kind)))
(cond ((or (find-if #'has-xep-or-nlx funs)
(and has-top (rest funs)))
(setf (component-name com) (find-component-name com))
(real com)
(when has-top
(setf (component-kind com) :complex-top-level)
(real-top com)))
(has-top
(setf (component-kind com) :top-level)
(setf (component-name com) "Top-Level Form")
(top com))
(t
(delete-component com))))))
(values (real) (top) (real-top))))
;;; Find-Initial-DFO -- Interface
;;;
;;; Given a list of top-level lambdas, return three lists of components
;;; representing the actual component division:
;;; 1] the non-top-level components,
;;; 2] and the second is the top-level components, and
;;; 3] Components in [1] that also have a top-level lambda.
;;;
;;; We assign the DFO for each component, and delete any unreachable blocks.
;;; We assume that the Flags have already been cleared.
;;;
;;; We iterate over the lambdas in each initial component, trying to put
;;; each function in its own component, but joining it to an existing component
;;; if we find that there are references between them. Any code that is left
;;; in an initial component must be unreachable, so we can delete it. Stray
;;; links to the initial component tail (due NIL function terminated blocks)
;;; are moved to the appropriate newc component tail.
;;;
;;; When we are done, we assign DFNs and call FIND-TOP-LEVEL-COMPONENTS to
;;; pull out top-level code.
;;;
(defun find-initial-dfo (lambdas)
(declare (list lambdas))
(collect ((components))
(let ((new (make-empty-component)))
(dolist (tll lambdas)
(let ((component (block-component (node-block (lambda-bind tll)))))
(dolist (fun (component-lambdas component))
(assert (member (functional-kind fun)
'(:optional :external :top-level nil :escape
:cleanup)))
(let ((res (dfo-walk-call-graph fun new)))
(when (eq res new)
(components new)
(setq new (make-empty-component)))))
(when (eq (component-kind component) :initial)
(assert (null (component-lambdas component)))
(let ((tail (component-tail component)))
(dolist (pred (block-pred tail))
(let ((pred-component (block-component pred)))
(unless (eq pred-component component)
(unlink-blocks pred tail)
(link-blocks pred (component-tail pred-component))))))
(delete-component component)))))
(dolist (com (components))
(let ((num 0))
(declare (fixnum num))
(do-blocks-backwards (block com :both)
(setf (block-number block) (incf num)))))
(find-top-level-components (components))))
;;; MERGE-1-TL-LAMBDA -- Internal
;;;
;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
;;;
(defun merge-1-tl-lambda (result-lambda lambda)
(declare (type clambda result-lambda lambda))
;;
;; Delete the lambda, and combine the lets and entries.
(setf (functional-kind lambda) :deleted)
(dolist (let (lambda-lets lambda))
(setf (lambda-home let) result-lambda)
(setf (lambda-environment let) (lambda-environment result-lambda))
(push let (lambda-lets result-lambda)))
(setf (lambda-entries result-lambda)
(nconc (lambda-entries result-lambda)
(lambda-entries lambda)))
(let* ((bind (lambda-bind lambda))
(bind-block (node-block bind))
(component (block-component bind-block))
(result-component
(block-component (node-block (lambda-bind result-lambda))))
(result-return-block (node-block (lambda-return result-lambda))))
;;
;; Move blocks into the new component, and move any nodes directly in
;; the old lambda into the new one (lets implicitly moved by changing
;; their home.)
(do-blocks (block component)
(do-nodes (node cont block)
(let ((lexenv (node-lexenv node)))
(when (eq (lexenv-lambda lexenv) lambda)
(setf (lexenv-lambda lexenv) result-lambda))))
(setf (block-component block) result-component))
;;
;; Splice the blocks into the new DFO, and unlink them from the old
;; component head and tail. Non-return blocks that jump to the tail
;; (NIL returning calls) are switched to go to the new tail.
(let* ((head (component-head component))
(first (block-next head))
(tail (component-tail component))
(last (block-prev tail))
(prev (block-prev result-return-block)))
(setf (block-next prev) first)
(setf (block-prev first) prev)
(setf (block-next last) result-return-block)
(setf (block-prev result-return-block) last)
(dolist (succ (block-succ head))
(unlink-blocks head succ))
(dolist (pred (block-pred tail))
(unlink-blocks pred tail)
(let ((last (block-last pred)))
(unless (return-p last)
(assert (basic-combination-p last))
(link-blocks pred (component-tail result-component))))))
(let ((lambdas (component-lambdas component)))
(assert (and (null (rest lambdas))
(eq (first lambdas) lambda))))
;;
;; Switch the end of the code from the return block to the start of
;; the next chunk.
(dolist (pred (block-pred result-return-block))
(unlink-blocks pred result-return-block)
(link-blocks pred bind-block))
(unlink-node bind)
;;
;; If there is a return, then delete it (making the preceding node the
;; last node) and link the block to the result return. There is always a
;; preceding REF NIL node in top-level lambdas.
(let ((return (lambda-return lambda)))
(when return
(let ((return-block (node-block return))
(result (return-result return)))
(setf (block-last return-block) (continuation-use result))
(flush-dest result)
(delete-continuation result)
(link-blocks return-block result-return-block))))))
;;; MERGE-TOP-LEVEL-LAMBDAS -- Interface
;;;
;;; Given a non-empty list of top-level lambdas, smash them into a top-level
;;; lambda and component, returning these as values. We use the first lambda
;;; and its component, putting the other code in that component and deleting
;;; the other lambdas.
;;;
(defun merge-top-level-lambdas (lambdas)
(declare (cons lambdas))
(let* ((result-lambda (first lambdas))
(result-return (lambda-return result-lambda)))
(cond
(result-return
;;
;; Make sure the result's return node starts a block so that we can
;; splice code in before it.
(let ((prev (node-prev
(continuation-use
(return-result result-return)))))
(when (continuation-use prev)
(node-ends-block (continuation-use prev)))
(do-uses (use prev)
(let ((new (make-continuation)))
(delete-continuation-use use)
(add-continuation-use use new))))
(dolist (lambda (rest lambdas))
(merge-1-tl-lambda result-lambda lambda)))
(t
(dolist (lambda (rest lambdas))
(setf (functional-entry-function lambda) nil)
(delete-component
(block-component
(node-block (lambda-bind lambda)))))))
(values (block-component (node-block (lambda-bind result-lambda)))
result-lambda)))