From a0a40bc3eb3572f24869a4f0e7af7ac1a54fde6a Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Fri, 14 Jul 1995 01:00:34 +0000
Subject: [PATCH] Blew away old dbg info generation.  Added code to `link'
 variable access paths that have elements thata re labels or constants in the
 compiled code block.

---
 v8/src/compiler/base/infnew.scm | 348 ++++++++------------------------
 1 file changed, 84 insertions(+), 264 deletions(-)

diff --git a/v8/src/compiler/base/infnew.scm b/v8/src/compiler/base/infnew.scm
index b02db120d..7fa2f6aa1 100644
--- a/v8/src/compiler/base/infnew.scm
+++ b/v8/src/compiler/base/infnew.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infnew.scm,v 1.4 1995/02/28 01:17:31 adams Exp $
+$Id: infnew.scm,v 1.5 1995/07/14 01:00:34 adams Exp $
 
 Copyright (c) 1988-1994 Massachusetts Institute of Technology
 
@@ -37,214 +37,8 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define (info-generation-phase-1 expression procedures)
-  (fluid-let ((*integrated-variables* '()))
-    (set-expression-debugging-info!
-     expression
-     (make-dbg-expression (block->dbg-block (expression-block expression))
-			  (expression-label expression)))
-    (for-each
-     (lambda (procedure)
-       (if (procedure-continuation? procedure)
-	   (set-continuation/debugging-info!
-	    procedure
-	    (let ((block (block->dbg-block (continuation/block procedure))))
-	      (let ((continuation
-		     (make-dbg-continuation
-		      block
-		      (continuation/label procedure)
-		      (enumeration/index->name continuation-types
-					       (continuation/type procedure))
-		      (continuation/offset procedure)
-		      (continuation/debugging-info procedure))))
-		(set-dbg-block/procedure! block continuation)
-		continuation)))
-	   (set-procedure-debugging-info!
-	    procedure
-	    (let ((block (block->dbg-block (procedure-block procedure))))
-	      (let ((procedure
-		     (make-dbg-procedure
-		      block
-		      (procedure-label procedure)
-		      (procedure/type procedure)
-		      (procedure-name procedure)
-		      (map variable->dbg-variable
-			   (cdr (procedure-original-required procedure)))
-		      (map variable->dbg-variable
-			   (procedure-original-optional procedure))
-		      (let ((rest (procedure-original-rest procedure)))
-			(and rest (variable->dbg-variable rest)))
-		      (map variable->dbg-variable (procedure-names procedure))
-		      (procedure-debugging-info procedure))))
-		(set-dbg-block/procedure! block procedure)
-		procedure)))))
-     procedures)
-    (for-each process-integrated-variable! *integrated-variables*)))
-
-(define (generated-dbg-continuation context label)
-  (let ((block
-	 (make-dbg-block/continuation (reference-context/block context)
-				      false)))
-    (let ((continuation
-	   (make-dbg-continuation block
-				  label
-				  'GENERATED
-				  (reference-context/offset context)
-				  false)))
-      (set-dbg-block/procedure! block continuation)
-      continuation)))
-
-(define (block->dbg-block block)
-  (and block
-       (or (block-debugging-info block)
-	   (let ((dbg-block
-		  (enumeration-case block-type (block-type block)
-		    ((STACK) (stack-block->dbg-block block))
-		    ((CONTINUATION) (continuation-block->dbg-block block))
-		    ((CLOSURE) (closure-block->dbg-block block))
-		    ((IC) (ic-block->dbg-block block))
-		    (else
-		     (error "BLOCK->DBG-BLOCK: Illegal block type" block)))))
-	     (set-block-debugging-info! block dbg-block)
-	     dbg-block))))
-
-(define (stack-block->dbg-block block)
-  (let ((parent (block-parent block))
-	(frame-size (block-frame-size block))
-	(procedure (block-procedure block)))
-    (let ((layout (make-layout frame-size)))
-      (for-each (lambda (variable)
-		  (if (not (continuation-variable? variable))
-		      (layout-set! layout
-				   (variable-normal-offset variable)
-				   (variable->dbg-variable variable))))
-		(block-bound-variables block))
-      (if (procedure/closure? procedure)
-	  (if (closure-procedure-needs-operator? procedure)
-	      (layout-set! layout
-			   (procedure-closure-offset procedure)
-			   dbg-block-name/normal-closure))
-	  (if (stack-block/static-link? block)
-	      (layout-set! layout
-			   (-1+ frame-size)
-			   dbg-block-name/static-link)))
-      (make-dbg-block 'STACK
-		      (block->dbg-block parent)
-		      (if (procedure/closure? procedure)
-			  (block->dbg-block
-			   (reference-context/block
-			    (procedure-closure-context procedure)))
-			  (block->dbg-block
-			   (procedure-target-block procedure)))
-		      layout
-		      (block->dbg-block (block-stack-link block))))))
-
-(define (continuation-block->dbg-block block)
-  (make-dbg-block/continuation
-   (block-parent block)
-   (continuation/always-known-operator? (block-procedure block))))
-
-(define (make-dbg-block/continuation parent always-known?)
-  (let ((dbg-parent (block->dbg-block parent)))
-    (make-dbg-block
-     'CONTINUATION
-     dbg-parent
-     false
-     (let ((names
-	    (append (if always-known?
-			'()
-			(list dbg-block-name/return-address))
-		    (if (block/dynamic-link? parent)
-			(list dbg-block-name/dynamic-link)
-			'())
-		    (if (ic-block? parent)
-			(list dbg-block-name/ic-parent)
-			'()))))
-       (let ((layout (make-layout (length names))))
-	 (do ((names names (cdr names))
-	      (index 0 (1+ index)))
-	     ((null? names))
-	   (layout-set! layout index (car names)))
-	 layout))
-     dbg-parent)))
-
-(define (closure-block->dbg-block block)
-  (let ((parent (block-parent block))
-	(start-offset
-	 (closure-object-first-offset
-	  (block-entry-number (block-shared-block block))))
-	(offsets
-	 (map (lambda (offset)
-		(cons (car offset)
-		      (- (cdr offset)
-			 (closure-block-first-offset block))))
-	      (block-closure-offsets block))))
-    (let ((layout (make-layout (1+ (apply max (map cdr offsets))))))
-      (for-each (lambda (offset)
-		  (layout-set! layout
-			       (cdr offset)
-			       (variable->dbg-variable (car offset))))
-		offsets)
-      (if (and parent (ic-block/use-lookup? parent))
-	  (layout-set! layout 0 dbg-block-name/ic-parent))
-      (make-dbg-block 'CLOSURE (block->dbg-block parent) false
-		      (cons start-offset layout)
-		      false))))
-
-(define (ic-block->dbg-block block)
-  (make-dbg-block 'IC (block->dbg-block (block-parent block))
-		  false false false))
-
-(define-integrable (make-layout length)
-  (make-vector length false))
-
-(define (layout-set! layout index name)
-  (let ((name* (vector-ref layout index)))
-    (if name* (error "LAYOUT-SET!: reusing layout slot" name* name)))
-  (vector-set! layout index name)
-  unspecific)
-
-(define *integrated-variables*)
-
-(define (variable->dbg-variable variable)
-  (or (lvalue-get variable dbg-variable-tag)
-      (let ((integrated? (lvalue-integrated? variable))
-	    (indirection (variable-indirection variable)))
-	(let ((dbg-variable
-	       (make-dbg-variable
-		(variable-name variable)
-		(cond (integrated? 'INTEGRATED)
-		      (indirection 'INDIRECTED)
-		      ((variable-in-cell? variable) 'CELL)
-		      (else 'NORMAL))
-		(cond (integrated?
-		       (lvalue-known-value variable))
-		      (indirection
-		       ;; This currently does not examine whether it is a
-		       ;; simple indirection, or a closure indirection.
-		       ;; The value displayed will be incorrect if it
-		       ;; is a closure indirection, but...
-		       (variable->dbg-variable (car indirection)))
-		      (else
-		       false)))))
-	  (if integrated?
-	      (set! *integrated-variables*
-		    (cons dbg-variable *integrated-variables*)))
-	  (lvalue-put! variable dbg-variable-tag dbg-variable)
-	  dbg-variable))))
-
-(define dbg-variable-tag
-  "dbg-variable-tag")
-
-(define (process-integrated-variable! variable)
-  (set-dbg-variable/value!
-   variable
-   (let ((rvalue (dbg-variable/value variable)))
-     (cond ((rvalue/constant? rvalue) (constant-value rvalue))
-	   ((rvalue/procedure? rvalue) (procedure-debugging-info rvalue))
-	   (else (error "Illegal variable value" rvalue))))))
-
 (define (info-generation-phase-2 expression procedures continuations)
+  ;; (values expression prcoedures continuations)
   (define (debug-info selector object)
     (or (selector object)
 	(begin
@@ -255,12 +49,11 @@ MIT in each case. |#
    (and expression (debug-info rtl-expr/debugging-info expression))
    (list-transform-negative
        (map (lambda (procedure)
-	      (let ((info
-		     (debug-info rtl-procedure/debugging-info procedure)))
+	      (let ((info (debug-info rtl-procedure/debugging-info procedure)))
 		(and info
-		     (set-dbg-procedure/external-label!
-		      info
-		      (rtl-procedure/%external-label procedure))
+		     ;;(set-dbg-procedure/external-label!
+		     ;; info
+		     ;; (rtl-procedure/%external-label procedure))
 		     info)))
 	    procedures)
      false?)
@@ -271,60 +64,87 @@ MIT in each case. |#
      false?)))
 
 (define (info-generation-phase-3 expression procedures continuations
-				 label-bindings external-labels)
+				 label-bindings external-labels
+				 constant-offset-map)
   (let ((label-bindings (labels->dbg-labels label-bindings))
-	(no-datum '(NO-DATUM)))
-    (let ((labels (make-string-hash-table)))
-      (for-each (lambda (label-binding)
-		  (for-each (lambda (key)
-			      (let ((datum
-				     (hash-table/get labels key no-datum)))
-				(if (not (eq? datum no-datum))
-				    (error "Redefining label:" key datum)))
-			      (hash-table/put! labels
-					       key
-					       (cdr label-binding)))
-			    (car label-binding)))
-		label-bindings)
-      (let ((map-label/fail
-	     (lambda (label)
-	       (let ((key (system-pair-car label)))
-		 (let ((datum (hash-table/get labels key no-datum)))
-		   (if (eq? datum no-datum)
-		       (error "Missing label:" key))
-		   datum))))
-	    (map-label/false
-	     (lambda (label)
-	       (hash-table/get labels (system-pair-car label) #f))))
-	(for-each (lambda (label)
-		    (set-dbg-label/external?! (map-label/fail label) true))
-		  external-labels)
-	(if expression
-	    (set-dbg-expression/label!
-	     expression
-	     (map-label/fail (dbg-expression/label expression))))
-	(for-each
-	 (lambda (procedure)
-	   (let* ((internal-label (dbg-procedure/label procedure))
-		  (mapped-label (map-label/false internal-label)))
-	     (set-dbg-procedure/label! procedure mapped-label)
-	     (cond ((dbg-procedure/external-label procedure)
-		    => (lambda (label)
-			 (set-dbg-procedure/external-label!
-			  procedure
-			  (map-label/fail label))))
-		   ((not mapped-label)
-		    (error "Missing label" internal-label)))))
-	 procedures)
-	(for-each
-	 (lambda (continuation)
-	   (set-dbg-continuation/label!
-	    continuation
-	    (map-label/fail (dbg-continuation/label continuation))))
-	 continuations)))
+	(no-datum '(NO-DATUM))
+	(labels (make-string-hash-table))
+	(blocks-seen (make-eq-hash-table)))
+    (define (initialize-label label-binding)
+      (for-each (lambda (key)
+		  (let ((datum (hash-table/get labels key no-datum)))
+		    (if (not (eq? datum no-datum))
+			(error "Redefining label:" key datum)))
+		  (hash-table/put! labels key (cdr label-binding)))
+	(car label-binding)))
+    (define (map-label/fail label)
+      (let ((key (system-pair-car label)))
+	(let ((datum (hash-table/get labels key no-datum)))
+	  (if (eq? datum no-datum)
+	      (error "Missing label:" key))
+	  datum)))
+    (define (map-label/false label)
+      (hash-table/get labels (system-pair-car label) #f))
+
+    (define (map-block block)
+      ;; Rewrite path elements that are defined in terms of the compiled code
+      ;; block - i.e. things which are labels or constants in the
+      ;; constants block.
+      (if (new-dbg-block? block)
+	  (begin
+	    (map-block (new-dbg-block/parent block))
+	    (for-each-vector-element  (new-dbg-block/variables block)
+	      (lambda (var)
+		(define (map-path! path)
+		  (cond  ((not (pair? path)))
+			 ((and (eq? (caar path) 'CC-ENTRY)
+			       (symbol? (cdar path)))
+			  (let ((label  (map-label/fail (cdr (car path)))))
+			    (if (dbg-label/external? label)
+				(set-cdr! (car path) (dbg-label/offset label))
+				(set-new-dbg-variable/path! var #F)))
+			  (map-path! (cdr path)))
+			 ((and (eq? (caar path) 'INTEGRATED)
+			       (not (interned-symbol? (cdar path)))
+			       (constant-offset-map (cdar path)))
+			  => (lambda (offset)
+			       (set-car! path (cons 'CONSTANT-BLOCK offset))
+			       (map-path! (cdr path))))
+			 (else (map-path! (cdr path)))))
+		(if (new-dbg-variable? var)
+		    (map-path! (new-dbg-variable/path var))))))))
+    (for-each initialize-label label-bindings)
+    (for-each (lambda (label)
+		(set-dbg-label/external?! (map-label/fail label) true))
+      external-labels)
+    (if expression
+	(set-dbg-expression/label!
+	 expression
+	 (map-label/fail (dbg-expression/label expression))))
+    (for-each
+	(lambda (procedure)
+	  (let* ((internal-label (new-dbg-procedure/label procedure))
+		 (mapped-label   (map-label/false internal-label)))
+	    (set-new-dbg-procedure/label! procedure mapped-label)
+	    (cond ;;((dbg-procedure/external-label procedure)
+	          ;; => (lambda (label)
+	          ;;	 (set-dbg-procedure/external-label!
+	          ;;	  procedure
+	          ;;	  (map-label/fail label))))
+	          ((not mapped-label)
+	           (error "Missing label" internal-label)))
+	    (map-block (new-dbg-procedure/block procedure))))
+      procedures)
+    (for-each
+	(lambda (continuation)
+	  (set-dbg-continuation/label!
+	   continuation
+	   (map-label/fail (dbg-continuation/label continuation)))
+	  (map-block (dbg-continuation/block continuation)))
+      continuations)
     (make-dbg-info
      expression
-     (list->vector (sort procedures dbg-procedure<?))
+     (list->vector (sort procedures new-dbg-procedure<?))
      (list->vector (sort continuations dbg-continuation<?))
      (list->vector (map cdr label-bindings)))))
 
-- 
2.25.1