From ff6b1cfd1f4d68fad9a521d605ae08886f9bb304 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 11 Dec 1991 16:52:24 +0000
Subject: [PATCH] Delete all unreferenced functions after cleanup generation
 (including :OPTIONAL entries, etc.) Changed to set NODE-TAIL-P to T instead
 of a tail set.

---
 compiler/envanal.lisp | 33 ++++++++++++++++++++++++---------
 1 file changed, 24 insertions(+), 9 deletions(-)

diff --git a/compiler/envanal.lisp b/compiler/envanal.lisp
index 703720987..7256d769d 100644
--- a/compiler/envanal.lisp
+++ b/compiler/envanal.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/envanal.lisp,v 1.19 1991/12/08 17:23:41 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/envanal.lisp,v 1.20 1991/12/11 16:52:24 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -30,6 +30,9 @@
 ;;;  2] Find all values that need to be closed over by each environment.
 ;;;  3] Scan the blocks in the component closing over non-local-exit
 ;;;     continuations.
+;;;  4] Delete all non-top-level functions with no references.  This should
+;;;     only get functions with non-NULL kinds, since normal functions are
+;;;     deleted when their references go to zero.
 ;;;
 (defun environment-analyze (component)
   (declare (type component component))
@@ -44,6 +47,15 @@
   (find-non-local-exits component)
   (find-cleanup-points component)
   (tail-annotate component)
+
+  (dolist (fun (component-lambdas component))
+    (when (null (leaf-refs fun))
+      (let ((kind (functional-kind fun)))
+	(unless (eq kind :top-level)
+	  (assert (member kind '(:optional :cleanup :escape)))
+	  (setf (functional-kind fun) nil)
+	  (delete-lambda fun)))))
+
   (undefined-value))
 
 
@@ -287,6 +299,9 @@
 ;;; Unwind-Protect cleanup functions.  If we don't actually have to do
 ;;; anything, then we don't insert any cleanup code.
 ;;;
+;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
+;;; local call.
+;;;
 ;;;    We don't need to adjust the ending cleanup of the cleanup block, since
 ;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
 ;;; scanned.
@@ -317,6 +332,7 @@
 	       (code `(%lexical-exit-breakup ',nlx)))))))
 
       (when (code)
+	(assert (not (node-tail-p (block-last block1))))
 	(insert-cleanup-code block1 block2
 			     (block-last block1)
 			     `(progn ,@(code)))
@@ -357,20 +373,19 @@
 ;;;
 ;;;    Mark all tail-recursive uses of function result continuations with the
 ;;; corresponding tail-set.  Nodes whose type is NIL (i.e. don't return) such
-;;; as calls to ERROR are never annotated as tail, so as to preserve debugging
-;;; information.
+;;; as calls to ERROR are never annotated as tail in order to preserve
+;;; debugging information.
 ;;;
 (defun tail-annotate (component)
   (declare (type component component))
   (dolist (fun (component-lambdas component))
     (let ((ret (lambda-return fun)))
       (when ret
-	(let ((result (return-result ret))
-	      (tails (lambda-tail-set fun)))
+	(let ((result (return-result ret)))
 	  (do-uses (use result)
 	    (when (and (immediately-used-p result use)
-		       (or (not (eq (node-derived-type use) *empty-type*))
-			   (not (basic-combination-p use))
-			   (eq (basic-combination-kind use) :local)))
-	      (setf (node-tail-p use) tails)))))))
+		     (or (not (eq (node-derived-type use) *empty-type*))
+			 (not (basic-combination-p use))
+			 (eq (basic-combination-kind use) :local)))
+		(setf (node-tail-p use) t)))))))
   (undefined-value))
-- 
GitLab