- (let ((new (make-empty-component)))
- (dolist (tll lambdas)
- (let ((component (block-component (node-block (lambda-bind tll)))))
- (dolist (fun (component-lambdas component))
- (aver (member (functional-kind fun)
- '(:optional :external :toplevel 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)
- (aver (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))
+ ;; 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.
+ (dolist (toplevel-lambda toplevel-lambdas)
+ (/show toplevel-lambda)
+ (let* ((block (node-block (lambda-bind toplevel-lambda)))
+ (old-component (block-component block))
+ (old-component-lambdas (component-lambdas old-component))
+ (new-component nil))
+ (/show old-component old-component-lambdas)
+ (aver (member toplevel-lambda old-component-lambdas))
+ (dolist (component-lambda old-component-lambdas)
+ (/show component-lambda)
+ (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-call-graph component-lambda new-component)))
+ (when (eq res new-component)
+ (/show "saving" new-component (component-lambdas 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)))
+ (/show "clearing/deleting OLD-COMPONENT because KIND=:INITIAL")
+ (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))))
+
+ ;; When we are done, we assign DFNs.
+ (dolist (component (components))