From 536fb6fdcb1a66fd65c2b9eafb9a183f28a2fff6 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 2 Jan 1991 19:10:38 +0000 Subject: [PATCH] FIND-INITAL-DFO to delete components with no entry points, as this is necessary for some cases of dead code deletion (functions that are never called.) --- compiler/dfo.lisp | 40 ++++++++++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 12 deletions(-) diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp index 576e0df49..48946b2e6 100644 --- a/compiler/dfo.lisp +++ b/compiler/dfo.lisp @@ -260,13 +260,28 @@ (find-if #'entry-exits entries))))) +;;; DELETE-COMPONENT-BLOCKS -- Internal +;;; +;;; Delete all the blocks in Component. We scan first marking the blocks as +;;; delete-p to prevent weird stuff from being triggered by deletion. +;;; +(defun delete-component-blocks (component) + (declare (type component component)) + (do-blocks (block component) + (setf (block-delete-p block) t)) + (do-blocks (block component) + (delete-block block)) + (undefined-value)) + + ;;; FIND-TOP-LEVEL-COMPONENTS -- Internal ;;; ;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting -;;; components. Components that have 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. 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)) @@ -277,16 +292,19 @@ (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 ((and has-top (not (find-if #'has-xep-or-nlx funs))) + (cond ((find-if #'has-xep-or-nlx funs) + (setf (component-name com) (find-component-name com)) + (real com) + (when has-top (real-top com))) + (has-top (setf (component-kind com) :top-level) (setf (component-name com) "Top-Level Form") (top com)) (t - (setf (component-name com) (find-component-name com)) - (real com) - (when has-top (real-top com))))))) + (delete-component-blocks com)))))) + (values (real) (top) (real-top)))) - + ;;; Find-Initial-DFO -- Interface ;;; @@ -323,9 +341,7 @@ (when (eq res new) (components new) (setq new (make-empty-component))))) - - (do-blocks (block component) - (delete-block block))))) + (delete-component-blocks component)))) (dolist (com (components)) (let ((num 0)) -- GitLab