- (home-kind (functional-kind home))
- (home-externally-visible-p
- (or (eq home-kind :toplevel)
- (functional-has-external-references-p home))))
- (unless (or (and home-externally-visible-p
- (eq (functional-kind fun) :external))
- (eq home-kind :deleted))
- (res home))))
+ (home-kind (functional-kind home))
+ (home-externally-visible-p
+ (or (eq home-kind :toplevel)
+ (functional-has-external-references-p home))))
+ (unless (or (and home-externally-visible-p
+ (eq (functional-kind fun) :external))
+ (eq home-kind :deleted))
+ (res home))))
- (declare (type component res))
- ;; Scavenge related lambdas.
- (labels ((scavenge-lambda (clambda)
- (setf res
- (dfo-scavenge-dependency-graph (lambda-home clambda)
- res)))
- (scavenge-possibly-deleted-lambda (clambda)
- (unless (eql (lambda-kind clambda) :deleted)
- (scavenge-lambda clambda)))
- ;; Scavenge call relationship.
- (scavenge-call (called-lambda)
- (scavenge-lambda called-lambda))
- ;; Scavenge closure over a variable: if CLAMBDA
- ;; refers to a variable whose home lambda is not
- ;; CLAMBDA, then the home lambda should be in the
- ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
- ;; CL, didn't do this, leading to the occasional
- ;; failure when physenv analysis, which is local to
- ;; each component, would bogusly conclude that a
- ;; closed-over variable was unused and thus delete
- ;; it. See e.g. cmucl-imp 2001-11-29.)
- (scavenge-closure-var (var)
- (unless (null (lambda-var-refs var)) ; unless var deleted
- (let ((var-home-home (lambda-home (lambda-var-home var))))
- (scavenge-possibly-deleted-lambda var-home-home))))
- ;; Scavenge closure over an entry for nonlocal exit.
- ;; This is basically parallel to closure over a
- ;; variable above.
- (scavenge-entry (entry)
- (declare (type entry entry))
- (let ((entry-home (node-home-lambda entry)))
- (scavenge-possibly-deleted-lambda entry-home))))
- (dolist (cc (lambda-calls-or-closes clambda))
- (etypecase cc
- (clambda (scavenge-call cc))
- (lambda-var (scavenge-closure-var cc))
- (entry (scavenge-entry cc))))
- (when (eq (lambda-kind clambda) :external)
- (mapc #'scavenge-call (find-reference-funs clambda))))
- ;; Voila.
- res)))))
+ (declare (type component res))
+ ;; Scavenge related lambdas.
+ (labels ((scavenge-lambda (clambda)
+ (setf res
+ (dfo-scavenge-dependency-graph (lambda-home clambda)
+ res)))
+ (scavenge-possibly-deleted-lambda (clambda)
+ (unless (eql (lambda-kind clambda) :deleted)
+ (scavenge-lambda clambda)))
+ ;; Scavenge call relationship.
+ (scavenge-call (called-lambda)
+ (scavenge-lambda called-lambda))
+ ;; Scavenge closure over a variable: if CLAMBDA
+ ;; refers to a variable whose home lambda is not
+ ;; CLAMBDA, then the home lambda should be in the
+ ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
+ ;; CL, didn't do this, leading to the occasional
+ ;; failure when physenv analysis, which is local to
+ ;; each component, would bogusly conclude that a
+ ;; closed-over variable was unused and thus delete
+ ;; it. See e.g. cmucl-imp 2001-11-29.)
+ (scavenge-closure-var (var)
+ (unless (null (lambda-var-refs var)) ; unless var deleted
+ (let ((var-home-home (lambda-home (lambda-var-home var))))
+ (scavenge-possibly-deleted-lambda var-home-home))))
+ ;; Scavenge closure over an entry for nonlocal exit.
+ ;; This is basically parallel to closure over a
+ ;; variable above.
+ (scavenge-entry (entry)
+ (declare (type entry entry))
+ (let ((entry-home (node-home-lambda entry)))
+ (scavenge-possibly-deleted-lambda entry-home))))
+ (dolist (cc (lambda-calls-or-closes clambda))
+ (etypecase cc
+ (clambda (scavenge-call cc))
+ (lambda-var (scavenge-closure-var cc))
+ (entry (scavenge-entry cc))))
+ (when (eq (lambda-kind clambda) :external)
+ (mapc #'scavenge-call (find-reference-funs clambda))))
+ ;; Voila.
+ res)))))
- (component-tail component))
- (let* ((funs (component-lambdas component))
- (has-top (find :toplevel funs :key #'functional-kind))
- (has-external-references
- (some #'functional-has-external-references-p funs)))
- (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
- ;; is newer than the rest of this function, and
- ;; doesn't really seem to fit into its mindset. Here
- ;; we mark components which contain such FUNCTIONs
- ;; them as :COMPLEX-TOPLEVEL, since they do get
- ;; executed at run time, and since it's not valid to
- ;; delete them just because they don't have any
- ;; references from pure :TOPLEVEL components. -- WHN
- has-external-references
- (setf (component-kind component) :complex-toplevel)
- (real component)
- (real-top component))
- ((or (some #'has-xep-or-nlx funs)
- (and has-top (rest funs)))
- (setf (component-name component)
- (find-component-name component))
- (real component)
- (when has-top
- (setf (component-kind component) :complex-toplevel)
- (real-top component)))
- (has-top
- (setf (component-kind component) :toplevel)
- (setf (component-name component) "top level form")
- (top component))
- (t
- (delete-component component))))))
+ (component-tail component))
+ (let* ((funs (component-lambdas component))
+ (has-top (find :toplevel funs :key #'functional-kind))
+ (has-external-references
+ (some #'functional-has-external-references-p funs)))
+ (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
+ ;; is newer than the rest of this function, and
+ ;; doesn't really seem to fit into its mindset. Here
+ ;; we mark components which contain such FUNCTIONs
+ ;; them as :COMPLEX-TOPLEVEL, since they do get
+ ;; executed at run time, and since it's not valid to
+ ;; delete them just because they don't have any
+ ;; references from pure :TOPLEVEL components. -- WHN
+ has-external-references
+ (setf (component-kind component) :complex-toplevel)
+ (real component)
+ (real-top component))
+ ((or (some #'has-xep-or-nlx funs)
+ (and has-top (rest funs)))
+ (setf (component-name component)
+ (find-component-name component))
+ (real component)
+ (when has-top
+ (setf (component-kind component) :complex-toplevel)
+ (real-top component)))
+ (has-top
+ (setf (component-kind component) :toplevel)
+ (setf (component-name component) "top level form")
+ (top component))
+ (t
+ (delete-component component))))))
- (old-component-lambdas (component-lambdas old-component))
- (new-component nil))
- (aver (member toplevel-lambda old-component-lambdas))
- (dolist (component-lambda old-component-lambdas)
- (aver (member (functional-kind component-lambda)
- '(:optional :external :toplevel nil :escape
- :cleanup)))
- (unless new-component
- (setf new-component (make-empty-component))
- (setf (component-name new-component)
- ;; This isn't necessarily an ideal name for the
- ;; component, since it might end up with multiple
- ;; lambdas in it, not just this one, but it does
- ;; seem a better name than just "<unknown>".
- (component-name-from-functional-debug-name
- component-lambda)))
- (let ((res (dfo-scavenge-dependency-graph component-lambda
- new-component)))
- (when (eq res new-component)
- (aver (not (position new-component (components))))
- (components new-component)
- (setq new-component nil))))
- (when (eq (component-kind old-component) :initial)
- (aver (null (component-lambdas old-component)))
- (let ((tail (component-tail old-component)))
- (dolist (pred (block-pred tail))
- (let ((pred-component (block-component pred)))
- (unless (eq pred-component old-component)
- (unlink-blocks pred tail)
- (link-blocks pred (component-tail pred-component))))))
- (delete-component old-component))))
+ (old-component-lambdas (component-lambdas old-component))
+ (new-component nil))
+ (aver (member toplevel-lambda old-component-lambdas))
+ (dolist (component-lambda old-component-lambdas)
+ (aver (member (functional-kind component-lambda)
+ '(:optional :external :toplevel nil :escape
+ :cleanup)))
+ (unless new-component
+ (setf new-component (make-empty-component))
+ (setf (component-name new-component)
+ ;; This isn't necessarily an ideal name for the
+ ;; component, since it might end up with multiple
+ ;; lambdas in it, not just this one, but it does
+ ;; seem a better name than just "<unknown>".
+ (leaf-debug-name component-lambda)))
+ (let ((res (dfo-scavenge-dependency-graph component-lambda
+ new-component)))
+ (when (eq res new-component)
+ (aver (not (position new-component (components))))
+ (components new-component)
+ (setq new-component nil))))
+ (when (eq (component-kind old-component) :initial)
+ (aver (null (component-lambdas old-component)))
+ (let ((tail (component-tail old-component)))
+ (dolist (pred (block-pred tail))
+ (let ((pred-component (block-component pred)))
+ (unless (eq pred-component old-component)
+ (unlink-blocks pred tail)
+ (link-blocks pred (component-tail pred-component))))))
+ (delete-component old-component))))