diff --git a/compiler/tn.lisp b/compiler/tn.lisp index fdfeb267b9dbba4b24cd826c62167a9cb6152e7d..3cf87c0b2226b18f2a7f2090daea660b86835775 100644 --- a/compiler/tn.lisp +++ b/compiler/tn.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/tn.lisp,v 1.12 1991/02/20 14:59:52 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/tn.lisp,v 1.13 1991/11/13 19:36:23 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -56,25 +56,47 @@ ;;; properly packed TNs. ;;; (defun delete-unreferenced-tns (component) - (macrolet ((frob (name) - `(let ((prev nil)) - (do ((tn ,name (tn-next tn))) - ((null tn)) - (cond ((or (tn-reads tn) - (tn-writes tn) - (member (tn-kind tn) - '(:component :specified-save))) - (setq prev tn)) - (t - (if prev - (setf (tn-next prev) (tn-next tn)) - (setf ,name (tn-next tn))) - (setf (tn-offset tn) nil))))))) - (let ((2comp (component-info component))) - (frob (ir2-component-normal-tns 2comp)) - (frob (ir2-component-restricted-tns 2comp)) - (frob (ir2-component-wired-tns 2comp)) - (frob (ir2-component-alias-tns 2comp)))) + (let ((2comp (component-info component))) + (labels ((delete-some (getter setter) + (let ((prev nil)) + (do ((tn (funcall getter 2comp) (tn-next tn))) + ((null tn)) + (let ((kind (tn-kind tn))) + (cond + ((or (tn-reads tn) (tn-writes tn) + (eq kind :component)) + (setq prev tn)) + ((eq kind :specified-save) + (let ((actual (tn-save-tn tn))) + (unless (or (tn-reads actual) (tn-writes actual) + (eq (tn-kind actual) :component)) + (delete-1 tn prev setter)))) + (t + (delete-1 tn prev setter))))))) + (delete-1 (tn prev setter) + (if prev + (setf (tn-next prev) (tn-next tn)) + (funcall setter (tn-next tn) 2comp)) + (setf (tn-offset tn) nil) + (case (tn-kind tn) + (:environment + (clear-live tn #'ir2-environment-live-tns + #'(setf ir2-environment-live-tns))) + (:debug-environment + (clear-live tn #'ir2-environment-debug-live-tns + #'(setf ir2-environment-debug-live-tns))))) + (clear-live (tn getter setter) + (let ((env (environment-info (tn-environment tn)))) + (funcall setter (delete tn (funcall getter env)) env)))) + (declare (inline delete-some delete-1 clear-live)) + (delete-some #'ir2-component-normal-tns + #'(setf ir2-component-normal-tns)) + (delete-some #'ir2-component-restricted-tns + #'(setf ir2-component-restricted-tns)) + (delete-some #'ir2-component-wired-tns + #'(setf ir2-component-wired-tns)) + (delete-some #'ir2-component-alias-tns + #'(setf ir2-component-alias-tns)))) (undefined-value))