From 49abe894b2f385af85b4ae75fedc380c9ad09b3f Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 23 Jul 1990 14:12:54 +0000
Subject: [PATCH] Misc changes for new lexenv structure.  Only dump TNs as
 always-live if they are args, otherwise use the lexenv to tell whether they
 are in scope at any given point.

---
 compiler/debug-dump.lisp | 52 ++++++++++++++++++++++++----------------
 1 file changed, 31 insertions(+), 21 deletions(-)

diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp
index e99282bd8..20cee4cfa 100644
--- a/compiler/debug-dump.lisp
+++ b/compiler/debug-dump.lisp
@@ -61,24 +61,27 @@
 (proclaim '(inline ir2-block-environment))
 (defun ir2-block-environment (2block)
   (declare (type ir2-block 2block))
-  (lambda-environment (block-lambda (ir2-block-block 2block))))
+  (block-environment (ir2-block-block 2block)))
 
 
 ;;; COMPUTE-LIVE-VARS  --  Internal
 ;;;
 ;;;    Given a local conflicts vector and an IR2 block to represent the set of
 ;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
-;;; compute a bit-vector representing the set of live variables.
+;;; compute a bit-vector representing the set of live variables.  If the TN is
+;;; environment-live, we only mark it as live when it is in scope at Node.
 ;;;
-(defun compute-live-vars (live block var-locs)
+(defun compute-live-vars (live node block var-locs)
   (declare (type ir2-block block) (type local-tn-bit-vector live)
-	   (type hash-table var-locs))
+	   (type hash-table var-locs) (type node node))
   (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
 			 :element-type 'bit
 			 :initial-element 0)))
     (do-live-tns (tn live block)
       (let ((leaf (tn-leaf tn)))
-	(when (lambda-var-p leaf)
+	(when (and (lambda-var-p leaf)
+		   (or (not (eq (tn-kind tn) :environment))
+		       (rassoc leaf (lexenv-variables (node-lexenv node)))))
 	  (let ((num (gethash leaf var-locs)))
 	    (when num
 	      (setf (sbit res num) 1))))))
@@ -109,12 +112,13 @@
   (let ((loc (label-location label)))
     (write-var-integer (- loc *previous-location*) *byte-buffer*)
     (setq *previous-location* loc))
+
+  (let ((path (node-source-path node)))
+    (unless tlf-num
+      (write-var-integer (source-path-tlf-number path) *byte-buffer*))
+    (write-var-integer (source-path-form-number path) *byte-buffer*))
   
-  (unless tlf-num
-    (write-var-integer (node-tlf-number node) *byte-buffer*))
-  (write-var-integer (first (node-source-path node)) *byte-buffer*)
-  
-  (write-packed-bit-vector (compute-live-vars live block var-locs)
+  (write-packed-bit-vector (compute-live-vars live node block var-locs)
 			   *byte-buffer*)
   
   (undefined-value))
@@ -146,19 +150,24 @@
 ;;;
 (defun find-tlf-and-block-numbers (fun)
   (declare (type clambda fun))
-  (let ((res (node-tlf-number (lambda-bind fun)))
+  (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
 	(num 0))
     (do-environment-ir2-blocks (2block (lambda-environment fun))
       (let ((block (ir2-block-block 2block)))
 	(when (eq (block-info block) 2block)
 	  (setf (block-flag block) num)
 	  (incf num)
-	  (unless (eql (node-tlf-number (continuation-next (block-start block)))
+	  (unless (eql (source-path-tlf-number
+			(node-source-path
+			 (continuation-next
+			  (block-start block))))
 		       res)
 	    (setq res nil)))
 	
 	(dolist (loc (ir2-block-locations 2block))
-	  (unless (eql (node-tlf-number (vop-node (location-info-vop loc)))
+	  (unless (eql (source-path-tlf-number
+			(node-source-path
+			 (vop-node (location-info-vop loc))))
 		       res)
 	    (setq res nil)))))
     res))
@@ -194,8 +203,7 @@
 	 (valid-succ
 	  (if (and succ
 		   (or (eq (car succ) tail)
-		       (not (eq (lambda-environment (block-lambda (car succ)))
-				env))))
+		       (not (eq (block-environment (car succ)) env))))
 	      ()
 	      succ)))
     (vector-push-extend
@@ -277,7 +285,7 @@
 		       (setf (debug-source-from res) name)
 		       (when (eq name :lisp)
 			 (setf (debug-source-name res)
-			       (cadr (aref (file-info-forms x) 0))))))
+			       (aref (file-info-forms x) 0)))))
 		res))
 	  (source-info-files info)))
 
@@ -306,7 +314,7 @@
 	(coerce seq 'simple-vector))))
 
 
-;;;; Locations:
+;;;; Variables:
 
 ;;; TN-SC-OFFSET  --  Internal
 ;;;
@@ -324,8 +332,9 @@
 ;;; makes Var's name unique in the function.  Buffer is the vector we stick the
 ;;; result in.
 ;;;
-(defun dump-1-variable (var tn id buffer)
-  (declare (type lambda-var var) (type tn tn) (type unsigned-byte id))
+(defun dump-1-variable (fun var tn id buffer)
+  (declare (type lambda-var var) (type tn tn) (type unsigned-byte id)
+	   (type clambda fun))
   (let* ((name (leaf-name var))
 	 (package (symbol-package name))
 	 (package-p (and package (not (eq package *package*))))
@@ -335,7 +344,8 @@
       (setq flags (logior flags compiled-debug-variable-uninterned)))
     (when package-p
       (setq flags (logior flags compiled-debug-variable-packaged)))
-    (when (eq (tn-kind tn) :environment)
+    (when (and (eq (tn-kind tn) :environment)
+	       (eq (lambda-var-home var) fun))
       (setq flags (logior flags compiled-debug-variable-environment-live)))
     (when save-tn
       (setq flags (logior flags compiled-debug-variable-save-loc-p)))
@@ -397,7 +407,7 @@
 		 (incf id))
 		(t
 		 (setq id 0  prev-name name)))
-	  (dump-1-variable var (cdr x) id *byte-buffer*)
+	  (dump-1-variable fun var (cdr x) id *byte-buffer*)
 	  (setf (gethash var var-locs) i))
 	(incf i)))
 
-- 
GitLab