From 521316ca3c35de330bb8a6fc538dd49d96858577 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 10 Aug 2001 17:11:15 +0000
Subject: [PATCH] Redesign compiled-code debugging information so that it is
 keyed.  The key in the .com file and the key in the .bci file must match, or
 the .bci file will be ignored.

---
 v7/src/compiler/base/asstop.scm |  61 +++++---
 v7/src/compiler/base/make.scm   |   9 +-
 v7/src/compiler/base/toplev.scm |  78 +++++-----
 v7/src/runtime/conpar.scm       |  30 ++--
 v7/src/runtime/infstr.scm       | 205 ++++++++++++++++++++----
 v7/src/runtime/infutl.scm       | 266 ++++++++++++++------------------
 v7/src/runtime/runtime.pkg      |   8 +-
 7 files changed, 391 insertions(+), 266 deletions(-)

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index a99b14835..f1933ff64 100644
--- a/v7/src/compiler/base/asstop.scm
+++ b/v7/src/compiler/base/asstop.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: asstop.scm,v 1.11 1999/01/02 06:06:43 cph Exp $
+$Id: asstop.scm,v 1.12 2001/08/10 17:10:28 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Assembler and Linker top level
@@ -229,44 +230,58 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	       *label-bindings*
 	       (last-reference *external-labels*))))
 	 (cond ((eq? pathname 'KEEP)	; for dynamic execution
-		info)
+		(vector 'DEBUGGING-INFO-WRAPPER
+			2
+			#f
+			#f
+			#f
+			info))
 	       ((eq? pathname 'RECURSIVE) ; recursive compilation
 		(set! *recursive-compilation-results*
 		      (cons (vector *recursive-compilation-number*
 				    info
 				    *code-vector*)
 			    *recursive-compilation-results*))
-		(cons *info-output-filename* *recursive-compilation-number*))
+		(vector 'DEBUGGING-INFO-WRAPPER
+			2
+			*debugging-key*
+			*info-output-filename*
+			*recursive-compilation-number*
+			#f))
 	       (else
 		(compiler:dump-info-file
-		 (let ((others (recursive-compilation-results)))
-		   (if (null? others)
-		       info
-		       (list->vector
-			(cons info
-			      (map (lambda (other) (vector-ref other 1))
-				   others)))))
+		 (vector 'DEBUGGING-FILE-WRAPPER
+			 2
+			 *debugging-key*
+			 (list->vector
+			  (cons info
+				(map (lambda (other) (vector-ref other 1))
+				     (recursive-compilation-results)))))
 		 pathname)
-		*info-output-filename*)))))))
+		(vector 'DEBUGGING-INFO-WRAPPER
+			2
+			*debugging-key*
+			*info-output-filename*
+			0
+			#f))))))))
 
 (define (recursive-compilation-results)
   (sort *recursive-compilation-results*
-	(lambda (x y)
-	  (< (vector-ref x 0)
-	     (vector-ref y 0)))))
+    (lambda (x y)
+      (fix:< (vector-ref x 0) (vector-ref y 0)))))
 
 ;;; Various ways of dumping an info file
 
 (define (compiler:dump-inf-file binf pathname)
-  (fasdump binf pathname true)
+  (fasdump binf pathname #t)
   (announce-info-files pathname))
 
 (define (compiler:dump-bif/bsm-files binf pathname)
   (let ((bif-path (pathname-new-type pathname "bif"))
 	(bsm-path (pathname-new-type pathname "bsm")))
     (let ((bsm (split-inf-structure! binf bsm-path)))
-      (fasdump binf bif-path true)
-      (fasdump bsm bsm-path true))
+      (fasdump binf bif-path #t)
+      (fasdump bsm bsm-path #t))
     (announce-info-files bif-path bsm-path)))
   
 (define (compiler:dump-bci/bcs-files binf pathname)
@@ -275,20 +290,20 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (let ((bsm (split-inf-structure! binf bcs-path)))
       (call-with-temporary-filename
 	(lambda (bif-name)
-	  (fasdump binf bif-name true)
+	  (fasdump binf bif-name #t)
 	  (compress bif-name bci-path)))
       (call-with-temporary-filename
 	(lambda (bsm-name)
-	  (fasdump bsm bsm-name true)
+	  (fasdump bsm bsm-name #t)
 	  (compress bsm-name bcs-path))))
     (announce-info-files bci-path bcs-path)))
   
 (define (compiler:dump-bci-file binf pathname)
   (let ((bci-path (pathname-new-type pathname "bci")))
-    (split-inf-structure! binf false)
+    (split-inf-structure! binf #f)
     (call-with-temporary-filename
       (lambda (bif-name)
-	(fasdump binf bif-name true)
+	(fasdump binf bif-name #t)
 	(compress bif-name bci-path)))
     (announce-info-files bci-path)))
 
diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm
index a61336ff1..d0c55e16d 100644
--- a/v7/src/compiler/base/make.scm
+++ b/v7/src/compiler/base/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 4.110 1999/01/03 05:23:02 cph Exp $
+$Id: make.scm,v 4.111 2001/08/10 17:11:15 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Compiler: System Construction
@@ -39,4 +40,4 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 				'INITIALIZE-PACKAGE!)))))
     (initialize-package! '(COMPILER MACROS))
     (initialize-package! '(COMPILER DECLARATIONS)))
-  (add-identification! (string-append "Liar (" architecture-name ")") 4 110))
\ No newline at end of file
+  (add-identification! (string-append "Liar (" architecture-name ")") 4 111))
\ No newline at end of file
diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index e5bceb08e..c871e709a 100644
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 4.59 2000/01/10 03:47:47 cph Exp $
+$Id: toplev.scm,v 4.60 2001/08/10 17:10:33 cph Exp $
 
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Compiler Top Level
@@ -100,7 +101,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (let ((kernel
 	 (lambda (source-file)
 	   (with-values
-	       (lambda () (sf/pathname-defaulting source-file false false))
+	       (lambda () (sf/pathname-defaulting source-file #f #f))
 	     (lambda (source-pathname bin-pathname spec-pathname)
 	       ;; Maybe this should be done only if scode-file
 	       ;; does not exist or is older than source-file.
@@ -125,7 +126,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	(compiler-pathnames
 	 input-string
 	 (and (not (default-object? output-string)) output-string)
-	 (make-pathname false false false false "bin" 'NEWEST)
+	 (make-pathname #f #f #f #f "bin" 'NEWEST)
 	 (lambda (input-pathname output-pathname)
 	   (maybe-open-file
 	    compiler:generate-rtl-files?
@@ -134,17 +135,21 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	      (maybe-open-file compiler:generate-lap-files?
 			       (pathname-new-type output-pathname "lap")
 			       (lambda (lap-output-port)
-				 (compile-scode/internal
-				  (compiler-fasload input-pathname)
-				  (pathname-new-type output-pathname "inf")
-				  rtl-output-port
-				  lap-output-port)))))))
+				 (fluid-let ((*debugging-key*
+					      (random-byte-vector 32)))
+				   (compile-scode/internal
+				    (compiler-fasload input-pathname)
+				    (pathname-new-type output-pathname "inf")
+				    rtl-output-port
+				    lap-output-port))))))))
 	unspecific)))
 
+(define *debugging-key*)
+
 (define (maybe-open-file open? pathname receiver)
   (if open?
       (call-with-output-file pathname receiver)
-      (receiver false)))
+      (receiver #f)))
 
 (define (compiler-pathnames input-string output-string default transform)
   (let* ((core
@@ -214,15 +219,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    (procedure-environment procedure)))
 
 (define (compile-scode/no-file scode keep-debugging-info?)
-  (fluid-let ((compiler:noisy? false)
+  (fluid-let ((compiler:noisy? #f)
 	      (*info-output-filename* keep-debugging-info?))
     (compile-scode/internal/hook
      (lambda ()
-       (compile-scode/internal scode
-			       *info-output-filename*)))))
+       (compile-scode/internal scode keep-debugging-info?)))))
 
 (define (compiler:batch-compile input #!optional output)
-  (fluid-let ((compiler:batch-mode? true))
+  (fluid-let ((compiler:batch-mode? #t))
     (bind-condition-handler (list condition-type:error)
 	compiler:batch-error-handler
       (lambda ()
@@ -235,7 +239,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (fresh-line port)
     (write-condition-report condition port)
     (newline port))
-  (compiler:abort false))
+  (compiler:abort #f))
 
 (define (compiler:abort value)
   (if (not compiler:abort-handled?)
@@ -250,11 +254,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (call-with-current-continuation
      (lambda (abort-compilation)
        (fluid-let ((compiler:abort-continuation abort-compilation)
-		   (compiler:abort-handled? true))
+		   (compiler:abort-handled? #t))
 	 (real-kernel input-string))))))
 
-(define compiler:batch-mode? false)
-(define compiler:abort-handled? false)
+(define compiler:batch-mode? #f)
+(define compiler:abort-handled? #f)
 (define compiler:abort-continuation)
 
 (define (compile-recursively scode procedure-result? procedure-name)
@@ -328,9 +332,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define *process-time*)
 (define *real-time*)
 
-(define *info-output-filename* false)
-(define *rtl-output-port* false)
-(define *lap-output-port* false)
+(define *info-output-filename* #f)
+(define *rtl-output-port* #f)
+(define *lap-output-port* #f)
 
 ;; First set: input to compilation
 ;; Last used: phase/canonicalize-scode
@@ -417,7 +421,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  (run-compiler))
 	(fluid-let ((*recursive-compilation-number* 0)
 		    (*recursive-compilation-count* 1)
-		    (*procedure-result?* false)
+		    (*procedure-result?* #f)
 		    (*remote-links* '())
 		    (*process-time* 0)
 		    (*real-time* 0))
@@ -459,7 +463,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (compiler:reset!)
   (set! *recursive-compilation-number* 0)
   (set! *recursive-compilation-count* 1)
-  (set! *procedure-result?* false)
+  (set! *procedure-result?* #f)
   (set! *remote-links* '())
   (set! *process-time* 0)
   (set! *real-time* 0)
@@ -503,12 +507,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 				wrapper)
   (let ((info-output-pathname
 	 (if (default-object? info-output-pathname)
-	     false
+	     #f
 	     info-output-pathname))
 	(rtl-output-port
-	 (if (default-object? rtl-output-port) false rtl-output-port))
+	 (if (default-object? rtl-output-port) #f rtl-output-port))
 	(lap-output-port
-	 (if (default-object? lap-output-port) false lap-output-port))
+	 (if (default-object? lap-output-port) #f lap-output-port))
 	(wrapper
 	 (if (default-object? wrapper) in-compiler wrapper)))
     (fluid-let ((*info-output-filename*
@@ -821,7 +825,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  (set! *rtl-graphs* rgraphs)
 	  unspecific))
       (if *procedure-result?*
-	  (set! *rtl-expression* false))
+	  (set! *rtl-expression* #f))
       (set! label->object
 	    (make/label->object *rtl-expression*
 				*rtl-procedures*
@@ -918,14 +922,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (phase/rtl-optimization-cleanup)
   (if (not compiler:preserve-data-structures?)
       (for-each (lambda (rgraph)
-		  (set-rgraph-bblocks! rgraph false)
+		  (set-rgraph-bblocks! rgraph #f)
 		  ;; **** this slot is reused. ****
-		  ;;(set-rgraph-register-bblock! rgraph false)
-		  (set-rgraph-register-crosses-call?! rgraph false)
-		  (set-rgraph-register-n-deaths! rgraph false)
-		  (set-rgraph-register-live-length! rgraph false)
-		  (set-rgraph-register-n-refs! rgraph false)
-		  (set-rgraph-register-known-values! rgraph false))
+		  ;;(set-rgraph-register-bblock! rgraph #f)
+		  (set-rgraph-register-crosses-call?! rgraph #f)
+		  (set-rgraph-register-n-deaths! rgraph #f)
+		  (set-rgraph-register-live-length! rgraph #f)
+		  (set-rgraph-register-n-refs! rgraph #f)
+		  (set-rgraph-register-known-values! rgraph #f))
 		*rtl-graphs*)))
 
 (define (phase/rtl-file-output scode port)
@@ -962,7 +966,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		    (vector environment-label free-ref-label n-sections))
 	      unspecific))
 	  (begin
-	    (let ((prefix (generate-lap *rtl-graphs* *remote-links* false)))
+	    (let ((prefix (generate-lap *rtl-graphs* *remote-links* #f)))
 	      (node-insert-snode! (rtl-expr/entry-node *rtl-root*)
 				  (make-sblock prefix)))
 	    (set! *entry-label* (rtl-expr/label *rtl-root*))
@@ -1001,7 +1005,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (compiler-phase "LAP File Output"
     (lambda ()
       (fluid-let ((*unparser-radix* 16)
-		  (*unparse-uninterned-symbols-by-name?* true))
+		  (*unparse-uninterned-symbols-by-name?* #t))
 	(with-output-to-port port
 	  (lambda ()
 	    (write-string "LAP for object ")
diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm
index bc1252beb..981244447 100644
--- a/v7/src/runtime/conpar.scm
+++ b/v7/src/runtime/conpar.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: conpar.scm,v 14.38 1999/02/24 21:23:46 cph Exp $
+$Id: conpar.scm,v 14.39 2001/08/10 17:09:13 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Continuation Parser
@@ -991,20 +992,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	   (write-string "within ")
 	   (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index)))
 	     (write block)
-	     (let loop ((info (compiled-code-block/debugging-info block)))
-	       (cond ((null? info)
-		      #f)
-		     ((string? info)
-		      (begin
-			(write-string " (")
-			(write-string info)
-			(write-string ")")))
-		     ((not (pair? info))
-		      #f)
-		     ((string? (car info))
-		      (loop (car info)))
-		     (else
-		      (loop (cdr info)))))))
+	     (call-with-values
+		 (lambda () (compiled-code-block/filename-and-index block))
+	       (lambda (filename index)
+		 index
+		 (if filename
+		     (begin
+		       (write-string " (")
+		       (write-string filename)
+		       (write-string ")")))))))
 	  ((3)				; probably compiled-code
 	   (write-string " at an unknown compiled-code location."))
 	  ((4)				; builtin (i.e. hook)
diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm
index 199790570..9e33cfa10 100644
--- a/v7/src/runtime/infstr.scm
+++ b/v7/src/runtime/infstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infstr.scm,v 1.10 2001/03/21 19:15:10 cph Exp $
+$Id: infstr.scm,v 1.11 2001/08/10 17:09:18 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -44,10 +44,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    ((ucode-primitive string->symbol)
 		     "#[(runtime compiler-info)dbg-info]"))
 		   (conc-name dbg-info/))
-  (expression false read-only true)	;dbg-expression
-  (procedures false read-only true)	;vector of dbg-procedure
-  (continuations false read-only true)	;vector of dbg-continuation
-  (labels/desc false read-only false)	;vector of dbg-label, sorted by offset
+  (expression #f read-only #t)		;dbg-expression
+  (procedures #f read-only #t)		;vector of dbg-procedure
+  (continuations #f read-only #t)	;vector of dbg-continuation
+  (labels/desc #f read-only #f)		;vector of dbg-label, sorted by offset
   )
 
 (define (dbg-info/labels dbg-info)
@@ -66,8 +66,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    ((ucode-primitive string->symbol)
 		     "#[(runtime compiler-info)dbg-expression]"))
 		   (conc-name dbg-expression/))
-  (block false read-only true)		;dbg-block
-  (label false)				;dbg-label
+  (block #f read-only #t)		;dbg-block
+  (label #f)				;dbg-label
   )
 
 (define-integrable (dbg-expression/label-offset expression)
@@ -83,16 +83,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    (block label type name required optional rest auxiliary
 			   source-code))
 		   (conc-name dbg-procedure/))
-  (block false read-only true)		;dbg-block
-  (label false)				;dbg-label
-  (type false read-only true)
-  (name false read-only true)		;procedure's name
-  (required false read-only true)	;names of required arguments
-  (optional false read-only true)	;names of optional arguments
-  (rest false read-only true)		;name of rest argument, or #F
-  (auxiliary false read-only true)	;names of internal definitions
-  (external-label false)		;for closure, external entry
-  (source-code false read-only true)	;SCode
+  (block #f read-only #t)		;dbg-block
+  (label #f)				;dbg-label
+  (type #f read-only #t)
+  (name #f read-only #t)		;procedure's name
+  (required #f read-only #t)		;names of required arguments
+  (optional #f read-only #t)		;names of optional arguments
+  (rest #f read-only #t)		;name of rest argument, or #F
+  (auxiliary #f read-only #t)		;names of internal definitions
+  (external-label #f)			;for closure, external entry
+  (source-code #f read-only #t)		;SCode
   )
 
 (define (dbg-procedure/label-offset procedure)
@@ -109,11 +109,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    ((ucode-primitive string->symbol)
 		     "#[(runtime compiler-info)dbg-continuation]"))
 		   (conc-name dbg-continuation/))
-  (block false read-only true)		;dbg-block
-  (label false)				;dbg-label
-  (type false read-only true)
-  (offset false read-only true)		;difference between sp and block
-  (source-code false read-only true)
+  (block #f read-only #t)		;dbg-block
+  (label #f)				;dbg-label
+  (type #f read-only #t)
+  (offset #f read-only #t)		;difference between sp and block
+  (source-code #f read-only #t)
   )
 
 (define-integrable (dbg-continuation/label-offset continuation)
@@ -131,12 +131,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    make-dbg-block
 		    (type parent original-parent layout stack-link))
 		   (conc-name dbg-block/))
-  (type false read-only true)		;continuation, stack, closure, ic
-  (parent false read-only true)		;parent block, or #F
-  (original-parent false read-only true) ;for closures, closing block
-  (layout false read-only true)		;vector of names, except #F for ic
-  (stack-link false read-only true)	;next block on stack, or #F
-  (procedure false)			;procedure which this is block of
+  (type #f read-only #t)		;continuation, stack, closure, ic
+  (parent #f read-only #t)		;parent block, or #F
+  (original-parent #f read-only #t)	;for closures, closing block
+  (layout #f read-only #t)		;vector of names, except #F for ic
+  (stack-link #f read-only #t)		;next block on stack, or #F
+  (procedure #f)			;procedure which this is block of
   )
 
 (define-structure (dbg-variable
@@ -145,8 +145,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    ((ucode-primitive string->symbol)
 		     "#[(runtime compiler-info)dbg-variable]"))
 		   (conc-name dbg-variable/))
-  (name false read-only true)		;symbol
-  (type false read-only true)		;normal, cell, integrated
+  (name #f read-only #t)		;symbol
+  (type #f read-only #t)		;normal, cell, integrated
   value					;for integrated, the value
   )
 
@@ -220,9 +220,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		     "#[(runtime compiler-info)dbg-label]"))
 		   (constructor make-dbg-label (name offset))
 		   (conc-name dbg-label-1/))
-  (name false)				;a string, primary name
-  (offset false read-only true)		;mach. dependent offset into code block
-  (external? false)			;if true, can have pointer to this
+  (name #f)				;a string, primary name
+  (offset #f read-only #t)		;mach. dependent offset into code block
+  (external? #f)			;if true, can have pointer to this
   (names (list name))			;names of all labels at this offset
   )
 
@@ -239,4 +239,141 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	    (not (negative? offset))
 	    (negative? offset))
 	(set-cdr! label (- offset))))
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+;;;; Debugging-info wrappers
+
+(define (compiled-code-block/debugging-wrapper block)
+  (let ((wrapper (compiled-code-block/debugging-info block)))
+    (if (debugging-wrapper? wrapper)
+	wrapper
+	(let ((wrapper (convert-old-debugging-wrapper wrapper)))
+	  (if wrapper
+	      (set-compiled-code-block/debugging-info! block wrapper))
+	  wrapper))))
+
+(define (debugging-wrapper? wrapper)
+  (and (vector? wrapper)
+       (fix:= (vector-length wrapper) 6)
+       (eq? (vector-ref wrapper 0) 'DEBUGGING-INFO-WRAPPER)
+       (or (fix:= (vector-ref wrapper 1) 1)
+	   (fix:= (vector-ref wrapper 1) 2))
+       (or (and (not (vector-ref wrapper 2))
+		(not (vector-ref wrapper 3))
+		(not (vector-ref wrapper 4))
+		(dbg-info? (vector-ref wrapper 5)))
+	   (and (if (fix:= (vector-ref wrapper 1) 1)
+		    (not (vector-ref wrapper 2))
+		    (dbg-info-key? (vector-ref wrapper 2)))
+		(debug-info-pathname? (vector-ref wrapper 3))
+		(index-fixnum? (vector-ref wrapper 4))
+		(or (not (vector-ref wrapper 5))
+		    (dbg-info? (vector-ref wrapper 5)))))))
+
+(define (debugging-wrapper/version wrapper)
+  (vector-ref wrapper 1))
+
+(define (debugging-wrapper/key wrapper)
+  (vector-ref wrapper 2))
+
+(define (debugging-wrapper/pathname wrapper)
+  (vector-ref wrapper 3))
+
+(define (set-debugging-wrapper/pathname! wrapper pathname)
+  (vector-set! wrapper 3 pathname))
+
+(define (debugging-wrapper/index wrapper)
+  (vector-ref wrapper 4))
+
+(define (debugging-wrapper/info wrapper)
+  (vector-ref wrapper 5))
+
+(define (set-debugging-wrapper/info! wrapper info)
+  (vector-set! wrapper 5 info))
+
+(define (convert-old-debugging-wrapper wrapper)
+  (let ((make-wrapper
+	 (lambda (pathname index info)
+	   (vector 'DEBUGGING-INFO-WRAPPER 1 #f pathname index info))))
+    (cond ((dbg-info? wrapper)
+	   (make-wrapper #f #f wrapper))
+	  ((debug-info-pathname? wrapper)
+	   (make-wrapper wrapper 0 #f))
+	  ((and (pair? wrapper)
+		(debug-info-pathname? (car wrapper))
+		(dbg-info? (cdr wrapper)))
+	   (make-wrapper (car wrapper) 0 (cdr wrapper)))
+	  ((and (pair? wrapper)
+		(debug-info-pathname? (car wrapper))
+		(index-fixnum? (cdr wrapper))
+		(fix:> (cdr wrapper) 0))
+	   (make-wrapper (car wrapper) (cdr wrapper) #f))
+	  ((and (pair? wrapper)
+		(pair? (car wrapper))
+		(debug-info-pathname? (caar wrapper))
+		(index-fixnum? (cdar wrapper))
+		(fix:> (cdar wrapper) 0)
+		(dbg-info? (cdr wrapper)))
+	   (make-wrapper (caar wrapper) (cdar wrapper) (cdr wrapper)))
+	  (else #f))))
+
+(define (debugging-file-wrapper? wrapper)
+  (and (vector? wrapper)
+       (fix:= (vector-length wrapper) 4)
+       (eq? (vector-ref wrapper 0) 'DEBUGGING-FILE-WRAPPER)
+       (or (and (fix:= (vector-ref wrapper 1) 1)
+		(not (vector-ref wrapper 2)))
+	   (and (fix:= (vector-ref wrapper 1) 2)
+		(dbg-info-key? (vector-ref wrapper 2))))
+       (let ((info (vector-ref wrapper 3)))
+	 (let ((n (vector-length info)))
+	   (and (fix:>= n 1)
+		(let loop ((i 0))
+		  (or (fix:= i n)
+		      (and (dbg-info? (vector-ref info i))
+			   (loop (fix:+ i 1))))))))))
+
+(define (debugging-file-wrapper/version wrapper)
+  (vector-ref wrapper 1))
+
+(define (debugging-file-wrapper/key wrapper)
+  (vector-ref wrapper 2))
+
+(define (debugging-file-wrapper/info wrapper)
+  (vector-ref wrapper 3))
+
+(define (canonicalize-file-wrapper wrapper)
+  (cond ((debugging-file-wrapper? wrapper)
+	 wrapper)
+	((dbg-info? wrapper)
+	 (vector 'DEBUGGING-FILE-WRAPPER 1 #f (vector wrapper)))
+	((and (vector? wrapper)
+	      (let ((n (vector-length wrapper)))
+		(and (fix:>= n 1)
+		     (let loop ((i 0))
+		       (or (fix:= i n)
+			   (and (dbg-info? (vector-ref wrapper i))
+				(loop (fix:+ i 1))))))))
+	 (vector 'DEBUGGING-FILE-WRAPPER 1 #f wrapper))
+	(else #f)))
+
+(define (get-wrapped-dbg-info file-wrapper wrapper)
+  (and (let ((k1 (debugging-wrapper/key wrapper))
+	     (k2 (debugging-file-wrapper/key file-wrapper)))
+	 (or (and k1 k2 (dbg-info-key=? k1 k2))
+	     (and (not k1) (not k2))))
+       (let ((v (debugging-file-wrapper/info file-wrapper))
+	     (index (debugging-wrapper/index wrapper)))
+	 (and (fix:< index (vector-length v))
+	      (vector-ref v index)))))
+
+(define (dbg-info-key? object)
+  (and (string? object)
+       (fix:= (string-length object) 32)))
+
+(define (dbg-info-key=? a b)
+  (string=? a b))
+
+(define (debug-info-pathname? object)
+  (or (pathname? object)
+      (string? object)))
\ No newline at end of file
diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index da06e31d1..31f125d66 100644
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.64 2001/03/21 19:15:12 cph Exp $
+$Id: infutl.scm,v 1.65 2001/08/10 17:09:23 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -34,7 +34,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  (,lambda-tag:let . LET)
 	  (,lambda-tag:fluid-let . FLUID-LET)
 	  (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
-  (set! blocks-with-memoized-debugging-info (make-population))
+  (set! wrappers-with-memoized-debugging-info (make-population))
   (add-secondary-gc-daemon! discard-debugging-info!)
   (initialize-uncompressed-files!)
   (add-event-receiver! event:after-restore initialize-uncompressed-files!)
@@ -42,43 +42,24 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (add-gc-daemon! clean-uncompressed-files!))
 
 (define (compiled-code-block/dbg-info block demand-load?)
-  (let ((old-info (compiled-code-block/debugging-info block)))
-    (cond ((dbg-info? old-info)
-	   old-info)
-	  ((and (pair? old-info) (dbg-info? (car old-info)))
-	   (car old-info))
-	  (demand-load?
-	   (let ((dbg-info (read-debugging-info old-info)))
-	     (if dbg-info (memoize-debugging-info! block dbg-info))
-	     dbg-info))
-	  (else #f))))
-
-(define (discard-debugging-info!)
-  (without-interrupts
-   (lambda ()
-     (map-over-population! blocks-with-memoized-debugging-info
-			   discard-block-debugging-info!)
-     (set! blocks-with-memoized-debugging-info (make-population))
-     unspecific)))
-
-(define (read-debugging-info descriptor)
-  (cond ((debug-info-pathname? descriptor)
-	 (let ((binf (read-binf-file descriptor)))
-	   (and binf
-		(if (dbg-info? binf)
-		    binf
-		    (and (vector? binf)
-			 (not (zero? (vector-length binf)))
-			 (vector-ref binf 0))))))
-	((and (pair? descriptor)
-	      (debug-info-pathname? (car descriptor))
-	      (exact-nonnegative-integer? (cdr descriptor)))
-	 (let ((binf (read-binf-file (car descriptor))))
-	   (and binf
-		(vector? binf)
-		(< (cdr descriptor) (vector-length binf))
-		(vector-ref binf (cdr descriptor)))))
-	(else #f)))
+  (let ((wrapper (compiled-code-block/debugging-wrapper block)))
+    (and wrapper
+	 (or (debugging-wrapper/info wrapper)
+	     (and demand-load?
+		  (read-debugging-info wrapper))))))
+
+(define (read-debugging-info wrapper)
+  (let ((pathname (debugging-wrapper/pathname wrapper)))
+    (and pathname
+	 (let ((file-wrapper (read-binf-file pathname)))
+	   (and file-wrapper
+		(let ((file-wrapper (canonicalize-file-wrapper file-wrapper)))
+		  (and file-wrapper
+		       (let ((info
+			      (get-wrapped-dbg-info file-wrapper wrapper)))
+			 (if info
+			     (memoize-debugging-info! wrapper info))
+			 info))))))))
 
 (define (read-binf-file pathname)
   (let ((pathname (canonicalize-debug-info-pathname pathname)))
@@ -101,30 +82,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		(if (> time* time)
 		    (loop (cdr left) time* file* receiver*)
 		    (loop (cdr left) time file receiver))))))))
-
-(define (memoize-debugging-info! block dbg-info)
+
+(define (memoize-debugging-info! wrapper info)
   (without-interrupts
    (lambda ()
-     (let ((old-info (compiled-code-block/debugging-info block)))
-       (if (not (and (pair? old-info) (dbg-info? (car old-info))))
-	   (begin
-	     (set-compiled-code-block/debugging-info! block
-						      (cons dbg-info old-info))
-	     (add-to-population! blocks-with-memoized-debugging-info
-				 block)))))))
-
-(define (un-memoize-debugging-info! block)
+     (set-debugging-wrapper/info! wrapper info)
+     (add-to-population! wrappers-with-memoized-debugging-info wrapper))))
+
+(define (discard-debugging-info!)
   (without-interrupts
    (lambda ()
-     (discard-block-debugging-info! block)
-     (remove-from-population! blocks-with-memoized-debugging-info block))))
-
-(define (discard-block-debugging-info! block)
-  (let ((old-info (compiled-code-block/debugging-info block)))
-    (if (and (pair? old-info) (dbg-info? (car old-info)))
-	(set-compiled-code-block/debugging-info! block (cdr old-info)))))
+     (map-over-population! wrappers-with-memoized-debugging-info
+       (lambda (wrapper)
+	 (set-debugging-wrapper/info! wrapper #f)))
+     (set! wrappers-with-memoized-debugging-info (make-population))
+     unspecific)))
 
-(define blocks-with-memoized-debugging-info)
+(define wrappers-with-memoized-debugging-info)
 
 (define (compiled-entry/dbg-object entry #!optional demand-load?)
   (let ((block (compiled-entry/block entry))
@@ -174,16 +148,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (compiled-code-block/filename-and-index (compiled-entry/block entry)))
 
 (define (compiled-code-block/filename-and-index block)
-  (let loop ((info (compiled-code-block/debugging-info block)))
-    (cond ((debug-info-pathname? info)
-	   (values (canonicalize-debug-info-filename info) #f))
-	  ((not (pair? info)) (values #f #f))
-	  ((dbg-info? (car info)) (loop (cdr info)))
-	  ((debug-info-pathname? (car info))
-	   (values (canonicalize-debug-info-filename (car info))
-		   (and (exact-nonnegative-integer? (cdr info))
-			(cdr info))))
-	  (else (values #f #f)))))
+  (let ((wrapper (compiled-code-block/debugging-wrapper block)))
+    (if wrapper
+	(let ((pathname (debugging-wrapper/pathname wrapper)))
+	  (if pathname
+	      (values (canonicalize-debug-info-filename pathname)
+		      (debugging-wrapper/index wrapper))
+	      (values #f #f)))
+	(values #f #f))))
 
 (define (dbg-labels/find-offset labels offset)
   (vector-binary-search labels < dbg-label/offset offset))
@@ -208,55 +180,57 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  (else (error "Illegal dbg-info-vector" info)))))
 
 (define (fasload/update-debugging-info! value com-pathname)
-  (let ((process-block
-	 (lambda (block)
-	   (let ((binf-filename
-		  (process-binf-filename
-		   (compiled-code-block/debugging-info block)
-		   com-pathname)))
-	     (set-compiled-code-block/debugging-info! block binf-filename)
-	     binf-filename)))
-	(process-subblocks
-	 (lambda (blocks start binf-filename)
-	   (let ((end (vector-length blocks)))
-	     (let loop ((index start))
-	       (if (< index end)
-		   (begin
-		     (set-car! (compiled-code-block/debugging-info
-				(vector-ref blocks index))
-			       binf-filename)
-		     (loop (1+ index)))))))))
-
-    (cond ((compiled-code-address? value)
-	   (let ((binf-filename
-		  (process-block (compiled-code-address->block value)))
-		 (blocks (load/purification-root value)))
-	     (if (vector? blocks)
-		 (process-subblocks blocks 0 binf-filename))))
-	  ((and (comment? value)
-		(dbg-info-vector? (comment-text value)))
-	   (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
-	     (process-subblocks blocks
-				1
-				(process-block (vector-ref blocks 0))))))))
-
-(define (process-binf-filename binf-filename com-pathname)
-  (and binf-filename
-       (rewrite-directory
-	(let ((binf-pathname (merge-pathnames binf-filename))
-	      (com-pathname (merge-pathnames com-pathname)))
-	  (if (and (equal? (pathname-name binf-pathname)
-			   (pathname-name com-pathname))
-		   (not (equal? (pathname-type binf-pathname)
-				(pathname-type com-pathname)))
-		   (equal? (pathname-version binf-pathname)
-			   (pathname-version com-pathname)))
-	      (pathname-new-type com-pathname (pathname-type binf-pathname))
-	      binf-pathname)))))
-
-(define (debug-info-pathname? object)
-  (or (pathname? object)
-      (string? object)))
+  (cond ((compiled-code-address? value)
+	 (fasload-update-internal (compiled-code-address->block value)
+				  (let ((blocks
+					 (load/purification-root value)))
+				    (and (vector? blocks)
+					 blocks))
+				  0
+				  com-pathname))
+	((and (comment? value)
+	      (dbg-info-vector? (comment-text value)))
+	 (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
+	   (fasload-update-internal (vector-ref blocks 0)
+				    blocks
+				    1
+				    com-pathname)))))
+
+(define (fasload-update-internal block blocks start com-pathname)
+  (let ((wrapper (compiled-code-block/debugging-wrapper block)))
+    (if wrapper
+	(let ((pathname (debugging-wrapper/pathname wrapper)))
+	  (if pathname
+	      (let ((pathname*
+		     (fasload-compute-pathname pathname com-pathname)))
+		(set-debugging-wrapper/pathname! wrapper pathname*)
+		(if blocks
+		    (fasload-update-sub-blocks blocks start
+					       pathname pathname*))))))))
+
+(define (fasload-compute-pathname pathname com-pathname)
+  (rewrite-directory
+   (let ((pathname (merge-pathnames pathname))
+	 (com-pathname (merge-pathnames com-pathname)))
+     (if (and (equal? (pathname-name pathname)
+		      (pathname-name com-pathname))
+	      (not (equal? (pathname-type pathname)
+			   (pathname-type com-pathname)))
+	      (equal? (pathname-version pathname)
+		      (pathname-version com-pathname)))
+	 (pathname-new-type com-pathname (pathname-type pathname))
+	 pathname))))
+
+(define (fasload-update-sub-blocks blocks start pathname pathname*)
+  (let ((n (vector-length blocks)))
+    (do ((i start (fix:+ i 1)))
+	((fix:= i n))
+      (let ((wrapper
+	     (compiled-code-block/debugging-wrapper (vector-ref blocks i))))
+	(if (and wrapper
+		 (pathname? (debugging-wrapper/pathname wrapper))
+		 (pathname=? (debugging-wrapper/pathname wrapper) pathname))
+	    (set-debugging-wrapper/pathname! wrapper pathname*))))))
 
 (define directory-rewriting-rules
   '())
@@ -442,37 +416,33 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (let* ((infpath (merge-pathnames inffile))
 	 (bifpath (pathname-new-type infpath "bif"))
 	 (bsmpath (pathname-new-type infpath "bsm")))
-    (let ((binf (fasload infpath)))
-      (inf-structure->bif/bsm binf bifpath bsmpath))))
+    (let ((file-info (fasload infpath)))
+      (inf-structure->bif/bsm file-info bifpath bsmpath))))
 
-(define (inf-structure->bif/bsm binf bifpath bsmpath)
+(define (inf-structure->bif/bsm file-info bifpath bsmpath)
   (let ((bifpath (merge-pathnames bifpath))
 	(bsmpath (and bsmpath (merge-pathnames bsmpath))))
-    (let ((bsm (split-inf-structure! binf bsmpath)))
-      (fasdump binf bifpath #t)
-      (if bsmpath
-	  (fasdump bsm bsmpath #t)))))
-
-(define (split-inf-structure! binf bsmpath)
-  (let ((bsmname (and bsmpath (->namestring bsmpath))))
-    (cond ((dbg-info? binf)
-	   (let ((labels (dbg-info/labels/desc binf)))
-	     (set-dbg-info/labels/desc! binf bsmname)
-	     labels))
-	  ((vector? binf)
-	   (let ((n (vector-length binf)))
-	     (let ((bsm (make-vector n)))
-	       (do ((i 0 (fix:+ i 1)))
-		   ((fix:= i n))
-		 (let ((dbg-info (vector-ref binf i)))
-		   (let ((labels (dbg-info/labels/desc dbg-info)))
-		     (vector-set! bsm i labels)
-		     (set-dbg-info/labels/desc!
-		      dbg-info
-		      (and bsmname (cons bsmname i))))))
-	       bsm)))
-	  (else 
-	   (error "Unknown inf format:" binf)))))
+    (call-with-values (lambda () (split-inf-structure! file-info bsmpath))
+      (lambda (file-wrapper bsm)
+	(fasdump file-wrapper bifpath #t)
+	(if bsmpath (fasdump bsm bsmpath #t))))))
+
+(define (split-inf-structure! file-info bsmpath)
+  (let ((file-wrapper (canonicalize-file-wrapper file-info))
+	(bsmname (and bsmpath (->namestring bsmpath))))
+    (if (not file-wrapper)
+	(error "Unknown debugging-file format:" file-info))
+    (let ((info (debugging-file-wrapper/info file-wrapper)))
+      (let ((n (vector-length info)))
+	(let ((bsm (make-vector n)))
+	  (do ((i 0 (fix:+ i 1)))
+	      ((fix:= i n))
+	    (let ((dbg-info (vector-ref info i)))
+	      (let ((labels (dbg-info/labels/desc dbg-info)))
+		(vector-set! bsm i labels)
+		(set-dbg-info/labels/desc! dbg-info
+					   (and bsmname (cons bsmname i))))))
+	  (values file-wrapper bsm))))))
 
 ;;;; UNCOMPRESS
 ;;;  A simple extractor for compressed binary info files.
@@ -581,7 +551,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;;
 ;; This version is written for speed:
 ;;
-;;  . The main speed gain is from is by buffering the input.  This version
+;;  . The main speed gain is from buffering the input.  This version
 ;;    is about 10 times faster than the above version on files, and about
 ;;    1.5 times faster than the above version called on custom input
 ;;    operations.
@@ -594,8 +564,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;;    is `single-threaded'.  This prevents the compiler from
 ;;    cellifying the variables.
 ;;
-;;  . Some of the drudge in passing all of the state is handed over to the
-;;    compiler by making the procedures internal to PARSE-COMMAND.
+;;  . Some of the drudgery of passing all of the state is handed over
+;;    to the compiler by making the procedures internal to PARSE-COMMAND.
 ;;
 ;;  . The main loop (PARSE-COMMAND) is `restartable'.  This allows the
 ;;    parsing operation to determine if enough input or output buffer is
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f29e6fb55..1ea6475e5 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.371 2001/08/03 20:29:54 cph Exp $
+$Id: runtime.pkg,v 14.372 2001/08/10 17:09:28 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -357,6 +357,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (export ()
 	  *save-uncompressed-files?*
 	  *uncompressed-file-lifetime*
+	  compiled-code-block/filename-and-index
+	  compiled-entry/filename-and-index
 	  compiled-entry/block
 	  compiled-entry/dbg-object
 	  compiled-entry/offset
@@ -409,12 +411,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  dbg-procedure/block
 	  dbg-procedure/source-code
 	  dbg-expression?)
-  (export (runtime unparser)
-	  compiled-entry/filename-and-index)
   (export (runtime compress)
 	  uncompress-internal)
   (export (runtime options)
 	  with-directory-rewriting-rule)
+  (export (runtime continuation-parser)
+	  )
   (initialization (initialize-package!)))
 
 (define-package (runtime console-i/o-port)
-- 
2.25.1