Skip to content
Snippets Groups Projects
Commit ff6b1cfd authored by ram's avatar ram
Browse files

Delete all unreferenced functions after cleanup generation (including

:OPTIONAL entries, etc.)
Changed to set NODE-TAIL-P to T instead of a tail set.
parent 87834805
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -30,6 +30,9 @@
;;; 2] Find all values that need to be closed over by each environment. ;;; 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 ;;; 3] Scan the blocks in the component closing over non-local-exit
;;; continuations. ;;; 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) (defun environment-analyze (component)
(declare (type component component)) (declare (type component component))
...@@ -44,6 +47,15 @@ ...@@ -44,6 +47,15 @@
(find-non-local-exits component) (find-non-local-exits component)
(find-cleanup-points component) (find-cleanup-points component)
(tail-annotate 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)) (undefined-value))
...@@ -287,6 +299,9 @@ ...@@ -287,6 +299,9 @@
;;; Unwind-Protect cleanup functions. If we don't actually have to do ;;; Unwind-Protect cleanup functions. If we don't actually have to do
;;; anything, then we don't insert any cleanup code. ;;; 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 ;;; 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 ;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
;;; scanned. ;;; scanned.
...@@ -317,6 +332,7 @@ ...@@ -317,6 +332,7 @@
(code `(%lexical-exit-breakup ',nlx))))))) (code `(%lexical-exit-breakup ',nlx)))))))
(when (code) (when (code)
(assert (not (node-tail-p (block-last block1))))
(insert-cleanup-code block1 block2 (insert-cleanup-code block1 block2
(block-last block1) (block-last block1)
`(progn ,@(code))) `(progn ,@(code)))
...@@ -357,20 +373,19 @@ ...@@ -357,20 +373,19 @@
;;; ;;;
;;; Mark all tail-recursive uses of function result continuations with the ;;; 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 ;;; 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 ;;; as calls to ERROR are never annotated as tail in order to preserve
;;; information. ;;; debugging information.
;;; ;;;
(defun tail-annotate (component) (defun tail-annotate (component)
(declare (type component component)) (declare (type component component))
(dolist (fun (component-lambdas component)) (dolist (fun (component-lambdas component))
(let ((ret (lambda-return fun))) (let ((ret (lambda-return fun)))
(when ret (when ret
(let ((result (return-result ret)) (let ((result (return-result ret)))
(tails (lambda-tail-set fun)))
(do-uses (use result) (do-uses (use result)
(when (and (immediately-used-p result use) (when (and (immediately-used-p result use)
(or (not (eq (node-derived-type use) *empty-type*)) (or (not (eq (node-derived-type use) *empty-type*))
(not (basic-combination-p use)) (not (basic-combination-p use))
(eq (basic-combination-kind use) :local))) (eq (basic-combination-kind use) :local)))
(setf (node-tail-p use) tails))))))) (setf (node-tail-p use) t)))))))
(undefined-value)) (undefined-value))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment