From 7bf41c7b5062bad1f87c2a334a8efdaf6daf96d7 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 5 Aug 1991 15:51:28 +0000
Subject: [PATCH] Fixed some bugs with multi-location load-tn packing. Changed
 find-load-tn-target to only accept targets in the same SC, not ones in the
 same SB. Added some load-tn packing debugging code.

---
 compiler/pack.lisp | 57 +++++++++++++++++++++++++++++++++-------------
 1 file changed, 41 insertions(+), 16 deletions(-)

diff --git a/compiler/pack.lisp b/compiler/pack.lisp
index ac93cb9b1..6252fce4a 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.39 1991/07/17 23:05:34 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.40 1991/08/05 15:51:28 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1019,9 +1019,12 @@
       (fill (finite-sb-live-tns sb) nil)))
 
   (do-live-tns (tn (ir2-block-live-in block) block)
-    (let ((sb (sc-sb (tn-sc tn))))
+    (let* ((sc (tn-sc tn))
+	   (sb (sc-sb sc)))
       (when (eq (sb-kind sb) :finite)
-	(setf (svref (finite-sb-live-tns sb) (tn-offset tn)) tn))))
+	(loop for offset from (tn-offset tn)
+	      repeat (sc-element-size sc) do
+	  (setf (svref (finite-sb-live-tns sb) offset) tn)))))
 
   (setq *live-block* block)
   (setq *live-vop* (ir2-block-last-vop block))
@@ -1046,22 +1049,36 @@
        (do ((res (vop-results vop) (tn-ref-across res)))
 	   ((null res))
 	 (let* ((tn (tn-ref-tn res))
-		(sb (sc-sb (tn-sc tn))))
+		(sc (tn-sc tn))
+		(sb (sc-sb sc)))
 	   (when (eq (sb-kind sb) :finite)
-	     (setf (svref (finite-sb-live-tns sb) (tn-offset tn))
-		   nil)))))
+	     (loop for offset from (tn-offset tn)
+	           repeat (sc-element-size sc) do
+	       (setf (svref (finite-sb-live-tns sb) offset) nil))))))
     (do ((ref (vop-refs current) (tn-ref-next-ref ref)))
 	((null ref))
+      (let ((ltn (tn-ref-load-tn ref)))
+	(when ltn
+	  (let* ((sc (tn-sc ltn))
+		 (sb (sc-sb sc)))
+	    (when (eq (sb-kind sb) :finite)
+	      (let ((tns (finite-sb-live-tns sb)))
+		(loop for offset from (tn-offset ltn)
+		      repeat (sc-element-size sc) do
+		  (assert (null (svref tns offset)))))))))
+
       (let* ((tn (tn-ref-tn ref))
-	     (sb (sc-sb (tn-sc tn))))
+	     (sc (tn-sc tn))
+	     (sb (sc-sb sc)))
 	(when (eq (sb-kind sb) :finite)
-	  (let ((tns (finite-sb-live-tns sb))
-		(offset (tn-offset tn)))
-	    (if (tn-ref-write-p ref)
-		(setf (svref tns offset) nil)
-		(let ((old (svref tns offset)))
-		  (assert (or (null old) (eq old tn)) (old tn))
-		  (setf (svref tns offset) tn))))))))
+	  (let ((tns (finite-sb-live-tns sb)))
+	    (loop for offset from (tn-offset tn)
+	          repeat (sc-element-size sc) do
+	      (if (tn-ref-write-p ref)
+		  (setf (svref tns offset) nil)
+		  (let ((old (svref tns offset)))
+		    (assert (or (null old) (eq old tn)) (old tn))
+		    (setf (svref tns offset) tn)))))))))
 
   (setq *live-vop* vop)
   (undefined-value))
@@ -1159,13 +1176,19 @@
 ;;; packed, and try that location.  There isn't any need to chain down the
 ;;; target path, since everything is packed now.
 ;;;
+;;;    We require the target to be in SC (and not merely to overlap with SC).
+;;; This prevents SC information from being lost in load TNs (we won't pack a
+;;; load TN in ANY-REG when it is targeted to a DESCRIPTOR-REG.)  This
+;;; shouldn't hurt the code as long as all relevant overlapping SCs are allowed
+;;; in the operand SC restriction.
+;;;
 (defun find-load-tn-target (op sc)
   (declare (inline member))
   (let ((target (tn-ref-target op)))
     (when target
       (let* ((tn (tn-ref-tn target))
 	     (loc (tn-offset tn)))
-	(if (and (eq (sc-sb sc) (sc-sb (tn-sc tn)))
+	(if (and (eq (tn-sc tn) sc)
 		 (member (the index loc) (sc-locations sc))
 		 (not (load-tn-conflicts-in-sc op sc loc nil)))
 	    loc
@@ -1231,12 +1254,14 @@
   (let ((sb (sc-sb sc))
 	(normal-tns (ir2-component-normal-tns
 		     (component-info *compile-component*)))
+	(node (vop-node (tn-ref-vop op)))
 	(fallback nil))
     (flet ((unpack-em (victims)
 	     (unless *repack-blocks*
 	       (setq *repack-blocks* (make-hash-table :test #'eq)))
 	     (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t)
 	     (dolist (victim victims)
+	       (event unpack-tn node)
 	       (unpack-tn victim))
 	     (throw 'unpacked-tn nil)))
       (dolist (loc (sc-locations sc))
@@ -1261,7 +1286,7 @@
 			 (setq fallback (list conf)))))))))
       
       (when fallback
-	(event unpack-fallback)
+	(event unpack-fallback node)
 	(unpack-em fallback))))
 
   nil)
-- 
GitLab