diff --git a/compiler/tn.lisp b/compiler/tn.lisp index 3cf87c0b2226b18f2a7f2090daea660b86835775..313e7bcd01926fb7c56c852dc4ee425d5dae6473 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.13 1991/11/13 19:36:23 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/tn.lisp,v 1.14 1991/11/18 15:50:08 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -53,26 +53,28 @@ ;;; ;;; Remove all TNs with no references from the lists of unpacked TNs. We ;;; null out the Offset so that nobody will mistake deleted wired TNs for -;;; properly packed TNs. +;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs +;;; aren't considered to be unreferenced. ;;; (defun delete-unreferenced-tns (component) - (let ((2comp (component-info component))) + (let* ((2comp (component-info component)) + (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp)) + :element-type 'bit :initial-element 0))) (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))))))) + (cond + ((or (used-p tn) + (and (eq (tn-kind tn) :specified-save) + (used-p (tn-save-tn tn)))) + (setq prev tn)) + (t + (delete-1 tn prev setter)))))) + (used-p (tn) + (or (tn-reads tn) (tn-writes tn) + (member (tn-kind tn) '(:component :environment)) + (not (zerop (sbit aliases (tn-number tn)))))) (delete-1 (tn prev setter) (if prev (setf (tn-next prev) (tn-next tn)) @@ -88,15 +90,18 @@ (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)) + (declare (inline used-p delete-some delete-1 clear-live)) + (delete-some #'ir2-component-alias-tns + #'(setf ir2-component-alias-tns)) + (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn))) + ((null tn)) + (setf (sbit aliases (tn-number (tn-save-tn tn))) 1)) (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)))) + #'(setf ir2-component-wired-tns)))) (undefined-value))