From 659cfdb72e54eba232e1960111018048b5e04b37 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 26 Feb 1991 22:07:34 +0000
Subject: [PATCH] Revamped :save-once TN stuff to work now given the (long ago)
 change for local callers to directly write the variable location.  This
 lossage never manifested, because we never chose :save-once saving strategy
 (due to a recently fixed bug.)

---
 compiler/pack.lisp | 114 +++++++++++++++++++++++++++++----------------
 1 file changed, 75 insertions(+), 39 deletions(-)

diff --git a/compiler/pack.lisp b/compiler/pack.lisp
index 21b3b27b9..43452910f 100644
--- a/compiler/pack.lisp
+++ b/compiler/pack.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/pack.lisp,v 1.32 1991/02/25 18:12:16 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.33 1991/02/26 22:07:34 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -19,6 +19,12 @@
 ;;;
 (in-package 'c)
 
+;;; Some parameters controlling which optimizations we attempt (for debugging.)
+;;;
+(defparameter pack-assign-costs t)
+(defparameter pack-optimize-saves t)
+(defparameter pack-save-once t)
+
 
 ;;;; Conflict determination:
 
@@ -491,24 +497,67 @@
     (emit-operand-load node block save tn next)))
 
 
+;;; FIND-SINGLE-WRITER  --  Internal
+;;;
+;;;    Return a VOP after which is an o.k. place to save the value of TN.  For
+;;; correctness, it is only required that this location be after any possible
+;;; write and before any possible restore location.
+;;;
+;;;    In practice, we return the unique writer VOP, but give up if the TN is
+;;; ever read by a VOP with MOVE-ARGS :LOCAL-CALL.  This prevents us from being
+;;; confused by non-tail local calls.
+;;;
+;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, since they
+;;; will correspond to restores that we have already done.
+;;;
+(defun find-single-writer (tn)
+  (declare (type tn tn))
+  (do ((write (tn-writes tn) (tn-ref-next write))
+       (res nil))
+      ((null write)
+       (when (and res
+		  (loop for read = (tn-reads tn) then (tn-ref-next read)
+		        while read
+		        never (eq (vop-info-move-args
+				   (vop-info
+				    (tn-ref-vop read)))
+				  :local-call)))
+	 (tn-ref-vop res)))
+
+    (unless (eq (vop-info-name (vop-info (tn-ref-vop write)))
+		'move-operand)
+      (when res (return nil))
+      (setq res write))))
+
+
 ;;; Save-Single-Writer-TN  --  Internal
 ;;;
-;;;    For TNs that have a single writer, we save the TN at the writer, and
-;;; only restore after the call.
+;;;    Try to save TN at a single location.  If we succeed, return T, otherwise
+;;; NIL.
 ;;;
-(defun save-single-writer-tn (tn vop)
+(defun save-single-writer-tn (tn)
+  (declare (type tn tn))
   (let* ((old-save (tn-save-tn tn))
-	 (save (or old-save (pack-save-tn tn))))
+	 (save (or old-save (pack-save-tn tn)))
+	 (writer (find-single-writer tn)))
+    (when (and writer
+	       (or (not old-save)
+		   (eq (tn-kind old-save) :specified-save)))
+      (emit-operand-load (vop-node writer) (vop-block writer)
+			 tn save (vop-next writer))
+      (setf (tn-kind save) :save-once)
+      t)))
 
-    (when (or (not old-save)
-	      (eq (tn-kind old-save) :specified-save))
-      (let ((writer (tn-ref-vop (tn-writes tn))))
-	(emit-operand-load (vop-node writer) (vop-block writer)
-			   tn save (vop-next writer)))
-      (setf (tn-kind save) :save-once))
 
+;;; RESTORE-SINGLE-WRITER-TN  --  Internal
+;;;
+;;;    Restore a TN with a :SAVE-ONCE save TN.
+;;;
+(defun restore-single-writer-tn (tn vop)
+  (declare (type tn) (type vop vop))
+  (let ((save (tn-save-tn tn)))
+    (assert (eq (tn-kind save) :save-once))
     (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop)))
-
   (undefined-value))
 
 
@@ -519,12 +568,13 @@
 ;;;
 (defun basic-save-tn (tn vop)
   (declare (type tn tn) (type vop vop))
-  (let ((writes (tn-writes tn))
-	(save (tn-save-tn tn)))
-    (if (or (and save (eq (tn-kind save) :save-once))
-	    (and writes (null (tn-ref-next writes))))
-	(save-single-writer-tn tn vop)
-	(save-complex-writer-tn tn vop)))
+  (let ((save (tn-save-tn tn)))
+    (cond ((and save (eq (tn-kind save) :save-once))
+	   (restore-single-writer-tn tn vop))
+	  ((save-single-writer-tn tn)
+	   (restore-single-writer-tn tn vop))
+	  (t
+	   (save-complex-writer-tn tn vop))))
   (undefined-value))
 
 
@@ -548,13 +598,12 @@
 
 ;;;; Optimized saving:
 
+
 ;;; SAVE-IF-NECESSARY  --  Internal
 ;;;
 ;;;    Save TN if it isn't a single-writer TN that has already been saved.  If
 ;;; multi-write, we insert the save Before the specified VOP.  Context is a VOP
-;;; used to tell which node/block to use for the new VOP.  When looking for
-;;; writes, we have to ignore uses of MOVE-OPERAND, since they correspond to
-;;; restores that we have already done.
+;;; used to tell which node/block to use for the new VOP.
 ;;;
 (defun save-if-necessary (tn before context)
   (declare (type tn tn) (type (or vop null) before) (type vop context))
@@ -563,22 +612,9 @@
       (setf (tn-kind save) :save))
     (assert (member (tn-kind save) '(:save :save-once)))
     (unless (eq (tn-kind save) :save-once)
-      (let ((writer
-	     (do ((write (tn-writes tn) (tn-ref-next write))
-		  (res nil))
-		 ((null write) res)
-	       (unless (eq (vop-info-name (vop-info (tn-ref-vop write)))
-			   'move-operand)
-		 (when res (return nil))
-		 (setq res write)))))
-	(cond (writer
-	       (let ((vop (tn-ref-vop writer)))
-		 (emit-operand-load (vop-node vop) (vop-block vop)
-				    tn save (vop-next vop))
-		 (setf (tn-kind save) :save-once)))
-	      (t
-	       (emit-operand-load (vop-node context) (vop-block context)
-				  tn save before))))))
+      (or (save-single-writer-tn tn)
+	  (emit-operand-load (vop-node context) (vop-block context)
+			     tn save before))))
   (undefined-value))
 
 
@@ -1364,7 +1400,7 @@
     ;;
     ;; Assign costs to normal TNs so we know which ones should always be
     ;; packed on the stack.
-    (when optimize
+    (when (and optimize pack-assign-costs)
       (assign-tn-costs component))
     ;;
     ;; Pack normal TNs in the order that they appear in the code.  This
@@ -1391,7 +1427,7 @@
     ;; Do load TN packing and emit saves.
     (let ((*live-block* nil)
 	  (*live-vop* nil))
-      (cond (optimize
+      (cond ((and optimize pack-optimize-saves)
 	     (optimized-emit-saves component)
 	     (do-ir2-blocks (block component)
 	       (pack-load-tns block)))
-- 
GitLab