From 664ec74fa14d1f645ffbe8de60cb7e1ddbfde365 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 12 Mar 1993 15:35:50 +0000
Subject: [PATCH] Change block numbering to the one computed at ir2-conversion
 time & shared with profile info.

---
 compiler/debug-dump.lisp | 36 ++++++++++++++++++++----------------
 1 file changed, 20 insertions(+), 16 deletions(-)

diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp
index 3049a8d1b..3dc0d3a4e 100644
--- a/compiler/debug-dump.lisp
+++ b/compiler/debug-dump.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/debug-dump.lisp,v 1.31 1992/08/03 19:03:35 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.32 1993/03/12 15:35:50 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -158,21 +158,18 @@
   (undefined-value))
 
 
-;;; FIND-TLF-AND-BLOCK-NUMBERS  --  Internal
+;;; FIND-TLF-NUMBER  --  Internal
 ;;;
-;;;    Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
-;;; determining if all locations are in the same TLF.
+;;;    Scan all the blocks, determining if all locations are in the same TLF,
+;;; and returing it or NIL.
 ;;;
-(defun find-tlf-and-block-numbers (fun)
+(defun find-tlf-number (fun)
   (declare (type clambda fun))
-  (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
-	(num 0))
-    (declare (type index num) (type (or index null) res))
+  (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
+    (declare (type (or index null) res))
     (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 (source-path-tlf-number
 			(node-source-path
 			 (continuation-next
@@ -230,8 +227,13 @@
     (vector-push-extend
      (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
      *byte-buffer*)
-    (dolist (b valid-succ)
-      (write-var-integer (block-flag b) *byte-buffer*)))
+    (let ((base (block-number
+		 (node-block
+		  (lambda-bind (environment-function env))))))
+      (dolist (b valid-succ)
+	(write-var-integer
+	 (the index (- (block-number b) base))
+	 *byte-buffer*))))
   (undefined-value))
 
 
@@ -249,7 +251,7 @@
   (declare (type clambda fun) (type hash-table var-locs))
   (setf (fill-pointer *byte-buffer*) 0)
   (let ((*previous-location* 0)
-	(tlf-num (find-tlf-and-block-numbers fun))
+	(tlf-num (find-tlf-number fun))
 	(env (lambda-environment fun))
 	(prev-locs nil)
 	(prev-block nil))
@@ -575,9 +577,11 @@
 (defun compute-1-debug-function (fun var-locs)
   (declare (type clambda fun) (type hash-table var-locs))
   (let* ((dfun (dfun-from-fun fun))
-	 (level (cookie-debug
-		 (lexenv-cookie (node-lexenv (lambda-bind fun))))))
-
+	 (actual-level
+	  (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
+	 (level (if *collect-dynamic-statistics*
+		    (max actual-level 2)
+		    actual-level)))
     (cond ((zerop level))
 	  ((and (<= level 1)
 		(let ((od (lambda-optional-dispatch fun)))
-- 
GitLab