From 88456ae9b43af51c765dcab911685f0a5f6d0935 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 14 Nov 1990 20:24:55 +0000
Subject: [PATCH] In the lifetime post-pass, added stuff to ensure that all
 results are marked as live before we start the ref-scan for the VOP.  This is
 necessary to ensure the correct conflicts with dead results, especially in
 the presence of results with :FROM specs.

---
 compiler/life.lisp | 213 ++++++++++++++++++++++++++++-----------------
 1 file changed, 135 insertions(+), 78 deletions(-)

diff --git a/compiler/life.lisp b/compiler/life.lisp
index 2a679e717..0fe5d88d4 100644
--- a/compiler/life.lisp
+++ b/compiler/life.lisp
@@ -650,6 +650,41 @@
     (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
       (return nil))))
 
+;;; MAKE-DEBUG-ENVIRONMENT-TNS-LIVE  --  Internal
+;;;
+;;; If the block has no successors, or its successor is the component tail,
+;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
+;;; they appeared to be live.  This ensures that these TNs are considered to be
+;;; live throughout blocks that read them, but don't have any interesting
+;;; successors (such as a return or tail call.)  In this case, we set the
+;;; corresponding bit in LIVE-IN as well.
+;;;
+(defun make-debug-environment-tns-live (block live-bits live-list)
+  (let* ((1block (ir2-block-block block))
+	 (live-in (ir2-block-live-in block))
+	 (succ (block-succ 1block))
+	 (next (ir2-block-next block)))
+    (when (and next
+	       (not (eq (ir2-block-block next) 1block))
+	       (or (null succ)
+		   (eq (first succ)
+		       (component-tail (block-component 1block)))))
+      (do ((conf (ir2-block-global-tns block)
+		 (global-conflicts-next conf)))
+	  ((null conf))
+	(let* ((tn (global-conflicts-tn conf))
+	       (num (global-conflicts-number conf)))
+	  (when (and num (zerop (sbit live-bits num))
+		     (eq (tn-kind tn) :debug-environment)
+		     (eq (tn-environment tn) (block-environment 1block))
+		     (saved-after-read tn block))
+	    (note-conflicts live-bits live-list tn num)
+	    (setf (sbit live-bits num) 1)
+	    (push-in tn-next* tn live-list)
+	    (setf (sbit live-in num) 1))))))
+  
+  (values live-bits live-list))
+
 
 ;;; Compute-Initial-Conflicts  --  Internal
 ;;;
@@ -660,12 +695,11 @@
 ;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
 ;;; TN to the live list.
 ;;;
-;;; If the block has no successors, or its successor is the component tail,
-;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
-;;; they appeared to be live.  This ensures that these TNs are considered to be
-;;; live throughout blocks that read them, but don't have any interesting
-;;; successors (such as a return or tail call.)  In this case, we set the
-;;; corresponding bit in LIVE-IN as well.
+;;; If a :MORE result is not live, we effectively fake a read to it.  This is
+;;; part of the action described in ENSURE-RESULTS-LIVE.
+;;;
+;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
+;;; environment TNs appear live when appropriate, even when they aren't.
 ;;;
 ;;; ### Note: we alias the global-conflicts-conflicts here as the
 ;;; tn-local-conflicts.
@@ -673,6 +707,7 @@
 (defun compute-initial-conflicts (block)
   (declare (type ir2-block block))
   (let* ((live-in (ir2-block-live-in block))
+	 (ltns (ir2-block-local-tns block))
 	 (live-bits (bit-vector-copy live-in))
 	 (live-list nil))
 
@@ -681,50 +716,58 @@
 	((null conf))
       (let ((bits (global-conflicts-conflicts conf))
 	    (tn (global-conflicts-tn conf))
-	    (num (global-conflicts-number conf)))
+	    (num (global-conflicts-number conf))
+	    (kind (global-conflicts-kind conf)))
 	(setf (tn-local-number tn) num)
-	(unless (eq (global-conflicts-kind conf) :live)
-	  (unless (zerop (sbit live-bits num))
-	    (bit-vector-replace bits live-bits)
-	    (setf (sbit bits num) 0)
-	    (push-in tn-next* tn live-list))
+	(unless (eq kind :live)
+	  (cond ((not (zerop (sbit live-bits num)))
+		 (bit-vector-replace bits live-bits)
+		 (setf (sbit bits num) 0)
+		 (push-in tn-next* tn live-list))
+		((and (eq (svref ltns num) :more)
+		      (eq kind :write))
+		 (note-conflicts live-bits live-list tn num)
+		 (setf (sbit live-bits num) 1)
+		 (push-in tn-next* tn live-list)
+		 (setf (sbit live-in num) 1)))
+
 	  (setf (tn-local-conflicts tn) bits))))
 
-    (let* ((1block (ir2-block-block block))
-	   (succ (block-succ 1block))
-	   (next (ir2-block-next block)))
-      (when (and next
-		 (not (eq (ir2-block-block next) 1block))
-		 (or (null succ)
-		     (eq (first succ)
-			 (component-tail (block-component 1block)))))
-	(do ((conf (ir2-block-global-tns block)
-		   (global-conflicts-next conf)))
-	    ((null conf))
-	  (let* ((tn (global-conflicts-tn conf))
-		 (num (global-conflicts-number conf)))
-	    (when (and num (zerop (sbit live-bits num))
-		       (eq (tn-kind tn) :debug-environment)
-		       (eq (tn-environment tn) (block-environment 1block))
-		       (saved-after-read tn block))
-	      (note-conflicts live-bits live-list tn num)
-	      (setf (sbit live-bits num) 1)
-	      (push-in tn-next* tn live-list)
-	      (setf (sbit live-in num) 1))))))
-
-    (values live-bits live-list)))
+    (make-debug-environment-tns-live block live-bits live-list)))
+
+
+;;; DO-SAVE-P-STUFF  --  Internal
+;;;
+;;;    A function called in Conflict-Analyze-1-Block when we have a VOP with
+;;; SAVE-P true.  We compute the save-set, and if :FORCE-TO-STACK, force all
+;;; the live TNs to be stack environment TNs.
+;;;
+(defun do-save-p-stuff (vop block live-bits)
+  (declare (type vop vop) (type ir2-block block)
+	   (type local-tn-bit-vector live-bits))
+  (let ((ss (compute-save-set vop live-bits)))
+    (setf (vop-save-set vop) ss)
+    (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
+      (do-live-tns (tn ss block)
+	(unless (eq (tn-kind tn) :component)
+	  (force-tn-to-stack tn)
+	  (unless (eq (tn-kind tn) :environment)
+	    (convert-to-environment-tn
+	     tn
+	     (block-environment (ir2-block-block block))))))))
+  (undefined-value))
 
 
 (eval-when (compile eval)
 
 ;;; Frob-More-TNs  --  Internal
 ;;;
-;;;    Used in the guts of Conflict-Analyze-1-Block to simultaneously do
-;;; something to all of the TNs referenced by a big more arg.  We have to treat
-;;; these TNs specially, since when we set or clear the bit in the live TNs,
-;;; the represents a change in the liveness of all the more TNs.  If we
-;;; iterated as normal, the next more ref would be thought to be not live when
-;;; it was, etc.  We return true if there where more TNs.
+;;;    Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs
+;;; referenced by a big more arg.  We have to treat these TNs specially, since
+;;; when we set or clear the bit in the live TNs, the represents a change in
+;;; the liveness of all the more TNs.  If we iterated as normal, the next more
+;;; ref would be thought to be not live when it was, etc.  We return true if
+;;; there where more TNs.
 ;;;
 (defmacro frob-more-tns (action)
   `(when (eq (svref ltns num) :more)
@@ -736,6 +779,53 @@
 	 ,action))
      t))
 
+;;; SCAN-VOP-REFS  --  Internal
+;;;
+;;;    	Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
+;;; current VOP.  This macro shamelessly references free variables in C-A-1-B.
+;;;
+(defmacro scan-vop-refs ()
+  '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+       ((null ref))
+     (let* ((tn (tn-ref-tn ref))
+	    (num (tn-local-number tn)))
+       (cond
+	((not num))
+	((not (zerop (sbit live-bits num)))
+	 (when (tn-ref-write-p ref)
+	   (setf (sbit live-bits num) 0)
+	   (deletef-in tn-next* live-list tn)
+	   (when (frob-more-tns (deletef-in tn-next* live-list mtn))
+	     (return))))
+	(t
+	 (assert (not (tn-ref-write-p ref)))
+	 (note-conflicts live-bits live-list tn num)
+	 (frob-more-tns (note-conflicts live-bits live-list mtn num))
+	 (setf (sbit live-bits num) 1)
+	 (push-in tn-next* tn live-list)
+	 (when (frob-more-tns (push-in tn-next* mtn live-list))
+	   (return)))))))
+
+;;; ENSURE-RESULTS-LIVE  --  Internal
+;;;
+;;;    This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
+;;; VOP's results, and make any dead ones live.  This is necessary, since even
+;;; though a result is dead after the VOP, it may be in use for an extended
+;;; period within the VOP (especially if it has :FROM specified.)  During this
+;;; interval, temporaries must be noted to conflict with the result.  More
+;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
+;;;
+(defmacro ensure-results-live ()
+  '(do ((res (vop-results vop) (tn-ref-across res)))
+       ((null res))
+     (let* ((tn (tn-ref-tn res))
+	    (num (tn-local-number tn)))
+       (when (and num (zerop (sbit live-bits num)))
+	 (unless (eq (svref ltns num) :more)
+	   (note-conflicts live-bits live-list tn num)
+	   (setf (sbit live-bits num) 1)
+	   (push-in tn-next* tn live-list))))))
+
 ); Eval-When (Compile Eval)
 
 
@@ -751,46 +841,13 @@
       (live-bits live-list)
       (compute-initial-conflicts block)
     (let ((ltns (ir2-block-local-tns block)))
-      
       (do ((vop (ir2-block-last-vop block)
 		(vop-prev vop)))
 	  ((null vop))
-	
-	(let ((save-p (vop-info-save-p (vop-info vop))))
-	  (when save-p
-	    (let ((ss (compute-save-set vop live-bits)))
-	      (setf (vop-save-set vop) ss)
-	      (when (eq save-p :force-to-stack)
-		(do-live-tns (tn ss block)
-		  (unless (eq (tn-kind tn) :component)
-		    (force-tn-to-stack tn)
-		    (unless (eq (tn-kind tn) :environment)
-		      (convert-to-environment-tn
-		       tn
-		       (block-environment (ir2-block-block block))))))))))
-	
-	(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-	    ((null ref))
-	  (let* ((tn (tn-ref-tn ref))
-		 (num (tn-local-number tn)))
-	    
-	    (cond
-	     ((not num))
-	     ((not (zerop (sbit live-bits num)))
-	      (when (tn-ref-write-p ref)
-		(setf (sbit live-bits num) 0)
-		(deletef-in tn-next* live-list tn)
-		(when (frob-more-tns (deletef-in tn-next* live-list mtn))
-		  (return))))
-	     ((tn-ref-write-p ref)
-	      (note-conflicts live-bits live-list tn num))
-	     (t
-	      (note-conflicts live-bits live-list tn num)
-	      (frob-more-tns (note-conflicts live-bits live-list mtn num))
-	      (setf (sbit live-bits num) 1)
-	      (push-in tn-next* tn live-list)
-	      (when (frob-more-tns (push-in tn-next* mtn live-list))
-		(return))))))))))
+	(when (vop-info-save-p (vop-info vop))
+	  (do-save-p-stuff vop block live-bits))
+	(ensure-results-live)
+	(scan-vop-refs)))))
 
 
 ;;; Lifetime-Post-Pass  --  Internal
-- 
GitLab