From dafdbb63884e1e8c6b04d862b9494c0e75c5dc40 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 27 Jul 1995 21:03:12 +0000
Subject: [PATCH] The debugging information have been completely overhauled for
 the new compiler.

Compiled files (.com files) now countain a COMPILED-MODULE object.
Debugging information is accessed by a DBG-LOCATOR, and the located
files must contains a DBG-WRAPPER with corresponding timestamps.
These objects also contain a version which allows safe extension of
the dbg information.

DBG-BLOCKs now contain access paths which describe how to find the
value for the bindings (they used to describe the inverse, i.e. the
layout of the object).

DBG-PROCEDURES have been streamlined to get lambda list information
from the source code.

DBG-VARIABLES are implemented as pairs to save on storage.

Improved error message for ENVIRONMENT-* operations.

Now there is only one kind of compiled environment which contains a
root object and a DBG-BLOCK.  The access paths in the DBG-BLOCK are
relative to the root object.

The access paths are evaluated by a stack machine which understands a
fixed vocabulary of operations and 1- and 2- place primitives.

CCENV/LOOKUP and CCENV/ASSIGN! now give an unbound variable error if
he variable is not bound.  They used to return an unavailable
object (currently the symbol "??").

CCENV/ARGUMENTS tries to be clever with #!OPTIONAL arguements - an
assignment trap (i.e. default-object?)  determines the number of
arguments provided that the previous argument is either required or
available.
---
 v8/src/runtime/infstr.scm | 293 ++++++++++----------
 v8/src/runtime/infutl.scm | 562 +++++++++++++++++++-------------------
 v8/src/runtime/make.scm   |  11 +-
 3 files changed, 441 insertions(+), 425 deletions(-)

diff --git a/v8/src/runtime/infstr.scm b/v8/src/runtime/infstr.scm
index 59a95d802..3d78bd9d9 100644
--- a/v8/src/runtime/infstr.scm
+++ b/v8/src/runtime/infstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: infstr.scm,v 1.8 1992/12/03 03:18:37 cph Exp $
+$Id: infstr.scm,v 1.9 1995/07/27 20:59:16 adams Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1995 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -37,18 +37,90 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define-integrable (make-dbg-info-vector info-vector)
-  (cons dbg-info-vector-tag info-vector))
+;;;; Compiled files
+;;
+;; A COMPILED-MODULE structure is the thing that lives in a .com file.
+;; It contains everything that the system needs to know to load and
+;; execute the file.  Note that having a data structure rather than an
+;; scode expression complicates the boot process as make.scm must be
+;; an scode (or compiled) expression.  This can be fixed by editing
+;; the make.com file or by -fasl-ing a .bin file that evals the
+;; module's expression.
+
+(define-structure
+    (compiled-module
+     (type vector)
+     (named
+      ((ucode-primitive string->symbol)
+       "#[(runtime compiler-info)compiled-module]"))
+     (conc-name compiled-module/)
+     (constructor make-compiled-module
+		  (expression all-compiled-code-blocks
+		   dbg-locator purification-root)))
+  (version compiled-module-format:current-version read-only true)
+  (expression false read-only true)	;top level expression of file
+  (all-compiled-code-blocks false)	;in a vector
+  (dbg-locator false)			;how to find debugging info
+  (purification-root false)		;what should be purified?
+  (linkage 'EXECUTE)			;How to link it? (not used yet)
+  (extra false))
+
+(define compiled-module-format:current-version 0)
+(define compiled-module-format:oldest-acceptable-version 0)
+
+;; A compiled code block's debugging-info slot contains one of
+;;  (1) A DBG-INFO object.
+;;  (1) A pair (dbg-locator . recursive-compilation-number-or-0).  This pair
+;;      is called a `descriptor' in infutl.scm.
+;;  (2) A pair of a (dbg-info . `(2)'), while the dbg info is in core.
+;;  (3) something else => no info
+;; All of the compiled code blocks in a compiled file structurally share
+;; the same DBG-LOCATOR which is also accessible from the COMPILED-MODULE.
+
+(define-structure
+    (dbg-locator
+     (type vector)
+     (named
+      ((ucode-primitive string->symbol)
+       "#[(runtime compiler-info)dbg-locator]"))
+     (constructor make-dbg-locator (file timestamp))
+     (conc-name dbg-locator/)
+     (print-procedure
+      (standard-unparser-method 'DBG-LOCATOR
+	(lambda (locator port)
+	  (write-char #\space port)
+	  (write (->namestring (dbg-locator/file locator)) port)))))
+
+  (file false)				;pathname or canonicalized string
+  (timestamp false read-only true)
+  (status false))			;for system bookkeeping
+
+
+;; Any debugging information that is fasdumped to a file has a
+;; DBG-WRAPPER around it.  The purpose of this is to ensure that
+;; debugging information comes from the same compilation as the
+;; dbg-locator (EQUAL? timestamps), and is in an acceptable format.
+
+(define-structure (dbg-wrapper
+		   (type vector)
+		   (named
+		    ((ucode-primitive string->symbol)
+		     "#[(runtime compiler-info)dbg-wrapper]"))
+		   (constructor make-dbg-wrapper (objects timestamp))
+		   (conc-name dbg-wrapper/))
+  (objects false read-only true) ;a vector indexed by
+  (timestamp false read-only true)
+  (format-version dbg-format:current-version read-only true))
 
-(define (dbg-info-vector? object)
-  (and (pair? object) (eq? (car object) dbg-info-vector-tag)))
 
-(define-integrable (dbg-info-vector/items info-vector)
-  (cdr info-vector))
+;; Change these when the format of any DBG-* object changes, or the path
+;; language is extended.
 
-(define-integrable dbg-info-vector-tag
-  ((ucode-primitive string->symbol)
-   "#[(runtime compiler-info)dbg-info-vector-tag]"))
+(define dbg-format:current-version 0)
+(define dbg-format:oldest-acceptable-version 0)
+
+;; A DBG-INFO holds the information pertaining to a single compiled code
+;; block.
 
 (define-structure (dbg-info
 		   (type vector)
@@ -59,57 +131,43 @@ MIT in each case. |#
   (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
-  )
-
-(define (dbg-info/labels dbg-info)
-  (let ((labels/desc (dbg-info/labels/desc dbg-info)))
-    (if (vector? labels/desc)
-	labels/desc
-	(let ((labels (read-labels labels/desc)))
-	  (and labels
-	       (begin
-		 (set-dbg-info/labels/desc! dbg-info labels)
-		 labels))))))
+  ;; vector of dbg-label, sorted by offset, or 'DUMPED-SEPARATELY, or #F if
+  ;; not dumped at all.
+  (labels/desc false read-only false))
 
 (define-structure (dbg-expression
 		   (type vector)
 		   (named
 		    ((ucode-primitive string->symbol)
-		     "#[(runtime compiler-info)dbg-expression]"))
+		     "#[(runtime compiler-info)new-dbg-expression]"))
 		   (conc-name dbg-expression/))
-  (block false read-only true)		;dbg-block
+  (block false)				;dbg-block
   (label false)				;dbg-label
-  )
+  (source-code false))
 
 (define-integrable (dbg-expression/label-offset expression)
   (dbg-label/offset (dbg-expression/label expression)))
 
+
 (define-structure (dbg-procedure
 		   (type vector)
 		   (named
 		    ((ucode-primitive string->symbol)
-		     "#[(runtime compiler-info)dbg-procedure]"))
-		   (constructor
-		    make-dbg-procedure
-		    (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
-  )
+		     "#[(runtime compiler-info)new-dbg-procedure]"))
+		   (conc-name dbg-procedure/)
+		   (constructor make-dbg-procedure (source-code))
+		   (constructor %make-dbg-procedure))
+  (block false read-only false)
+  (label false read-only false)
+  (source-code false read-only true))
+
+(define (dbg-procedure/name dbg-procedure)
+  (let ((scode  (dbg-procedure/source-code dbg-procedure)))
+    (lambda-name scode)))
 
 (define (dbg-procedure/label-offset procedure)
   (dbg-label/offset
-   (or (dbg-procedure/external-label procedure)
+   (or ;;(dbg-procedure/external-label procedure)
        (dbg-procedure/label procedure))))
 
 (define-integrable (dbg-procedure<? x y)
@@ -119,13 +177,13 @@ MIT in each case. |#
 		   (type vector)
 		   (named
 		    ((ucode-primitive string->symbol)
-		     "#[(runtime compiler-info)dbg-continuation]"))
+		     "#[(runtime compiler-info)new-dbg-continuation]"))
 		   (conc-name dbg-continuation/))
-  (block false read-only true)		;dbg-block
+  (block false)				;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)
+  (outer false)				; source code
+  (inner false)				; source code
   )
 
 (define-integrable (dbg-continuation/label-offset continuation)
@@ -138,117 +196,56 @@ MIT in each case. |#
 		   (type vector)
 		   (named
 		    ((ucode-primitive string->symbol)
-		     "#[(runtime compiler-info)dbg-block]"))
-		   (constructor
-		    make-dbg-block
-		    (type parent original-parent layout stack-link))
+		     "#[(runtime compiler-info)new-dbg-block]"))
+		   (constructor make-dbg-block (type parent variables))
 		   (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
-  )
-
-(define-structure (dbg-variable
-		   (type vector)
-		   (named
-		    ((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
-  value					;for integrated, the value
+  (parent-path-prefix false)		;
+  (variables false read-only true)	;vector of variables, except #F for ic
+  (procedure false)			;procedure/entry which this is block of
   )
 
-(let-syntax
-    ((dbg-block-name
-      (macro (name)
-	(let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name)))
-	  `(DEFINE-INTEGRABLE ,symbol
-	     ',((ucode-primitive string->symbol)
-		(string-append "#[(runtime compiler-info)"
-			       (string-downcase (symbol->string symbol))
-			       "]")))))))
-  ;; Various names used in `layout' to identify things that wouldn't
-  ;; otherwise have names.
-  (dbg-block-name dynamic-link)
-  (dbg-block-name ic-parent)
-  (dbg-block-name normal-closure)
-  (dbg-block-name return-address)
-  (dbg-block-name static-link))
+;;(define-structure (dbg-variable
+;;		   (type vector)
+;;		   (named
+;;		    ((ucode-primitive string->symbol)
+;;		     "#[(runtime compiler-info)new-dbg-variable]"))
+;;		   (conc-name dbg-variable/))
+;;  (name false read-only true)		;symbol
+;;  (path false read-only true))
+
+;; Pairs are more compact 
+(define (dbg-variable? object)
+  (and (pair? object) (symbol? (car object))))
+
+(define-integrable (dbg-variable/make name) (cons name #F))
+(define-integrable (dbg-variable/name var) (car var))
+(define-integrable (dbg-variable/path var) (cdr var))
 
-(define (dbg-label/name label)
-  (cond ((dbg-label-2? label) (dbg-label-2/name label))
-	((dbg-label-1? label) (dbg-label-1/name label))
-	(else
-	 (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME))))
+(define-integrable (guarantee-dbg-label object procedure)
+  (if (not (pair? object))
+      (error:wrong-type-argument object "debugging label" procedure)))
+
+(define (make-dbg-label name offset)
+  (cons name offset))
 
-(define (set-dbg-label/name! label name)
-  (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name))
-	(else
-	 (error:wrong-type-argument label "debugging label"
-				    'SET-DBG-LABEL/NAME!))))
+(define (dbg-label/name label)
+  (guarantee-dbg-label label 'DBG-LABEL/NAME)
+  (car label))
 
 (define (dbg-label/offset label)
-  (cond ((dbg-label-2? label) (dbg-label-2/offset label))
-	((dbg-label-1? label) (dbg-label-1/offset label))
-	(else
-	 (error:wrong-type-argument label "debugging label"
-				    'DBG-LABEL/OFFSET))))
+  (guarantee-dbg-label label 'DBG-LABEL/OFFSET)
+  (abs (cdr label)))
 
 (define (dbg-label/external? label)
-  (cond ((dbg-label-2? label) (dbg-label-2/external? label))
-	((dbg-label-1? label) (dbg-label-1/external? label))
-	(else
-	 (error:wrong-type-argument label "debugging label"
-				    'DBG-LABEL/EXTERNAL?))))
+  (guarantee-dbg-label label DBG-LABEL/EXTERNAL?)
+  (negative? (cdr label)))
 
 (define (set-dbg-label/external?! label external?)
-  (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?))
-	((dbg-label-1? label) (set-dbg-label-1/external?! label external?))
-	(else
-	 (error:wrong-type-argument label "debugging label"
-				    'SET-DBG-LABEL/EXTERNAL?!))))
-
-(define (dbg-label/names label)
-  (cond ((dbg-label-2? label) (dbg-label-2/names label))
-	((dbg-label-1? label) (dbg-label-1/names label))
-	(else
-	 (error:wrong-type-argument label "debugging label"
-				    'DBG-LABEL/NAMES))))
-
-(define (set-dbg-label/names! label names)
-  (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names))
-	(else
-	 (error:wrong-type-argument label "debugging label"
-				    'SET-DBG-LABEL/NAMES!))))
-
-(define-structure (dbg-label-1
-		   (type vector)
-		   (named
-		    ((ucode-primitive string->symbol)
-		     "#[(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
-  (names (list name))			;names of all labels at this offset
-  )
-
-(define-integrable make-dbg-label-2 cons)
-(define-integrable dbg-label-2? pair?)
-(define-integrable dbg-label-2/name car)
-(define-integrable (dbg-label-2/offset label) (abs (cdr label)))
-(define-integrable (dbg-label-2/external? label) (negative? (cdr label)))
-(define-integrable (dbg-label-2/names label) (list (car label)))
-
-(define (set-dbg-label-2/external?! label external?)
-  (let ((offset (cdr label)))
-    (if (if external?
-	    (not (negative? offset))
-	    (negative? offset))
-	(set-cdr! label (- offset))))
+  (guarantee-dbg-label label 'SET-DBG-LABEL/EXTERNAL?!)
+  (let ((offset (abs (cdr label))))
+    (if external?
+	(set-cdr! label (- offset))
+	(set-cdr! label offset)))
   unspecific)
\ No newline at end of file
diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index 2a9798a7b..d093388cc 100644
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.58 1995/07/17 20:10:43 adams Exp $
+$Id: infutl.scm,v 1.59 1995/07/27 21:01:09 adams Exp $
 
-Copyright (c) 1988-94 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -48,10 +48,38 @@ MIT in each case. |#
 	  (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
   (set! blocks-with-memoized-debugging-info (make-population))
   (add-secondary-gc-daemon! discard-debugging-info!)
+  (let ((fasload-loader (cached-loader fasload-loader)))
+    (set! inf-load-types
+	  `(("inf" . ,fasload-loader)
+	    ("bif" . ,fasload-loader)
+	    ("bci" . ,(compressed-loader "bif" fasload-loader))))
+    (set! bsm-load-types
+	  `(("bsm" . ,fasload-loader)
+	    ("bcs" . ,(compressed-loader "bsm" fasload-loader)))))
+  (initialize-cached-files!)
   (initialize-uncompressed-files!)
   (add-event-receiver! event:after-restore initialize-uncompressed-files!)
   (add-event-receiver! event:before-exit delete-uncompressed-files!)
-  (add-gc-daemon! clean-uncompressed-files!))
+  (add-gc-daemon! clean-uncompressed-files!)
+  (add-gc-daemon! clean-cached-files!))
+
+(define inf-load-types)
+(define bsm-load-types)
+
+
+(define (compiled-code-block/dbg-descriptor block)
+  (let ((info (compiled-code-block/debugging-info block)))
+    (cond ((valid-dbg-descriptor? info)
+	   info)
+	  ((dbg-locator? info)
+	   (cons info 0))
+	  ((not (pair? info))
+	   false)
+	  ((valid-dbg-descriptor? (cdr info))
+	   (cdr info))
+	  ((dbg-locator? (cdr info))
+	   (cons (cdr info) 0))
+	  (else false))))
 
 (define (compiled-code-block/dbg-info block demand-load?)
   (let ((old-info (compiled-code-block/debugging-info block)))
@@ -60,12 +88,27 @@ MIT in each case. |#
 	  ((and (pair? old-info) (dbg-info? (car old-info)))
 	   (car old-info))
 	  (demand-load?
-	   (let ((dbg-info (read-debugging-info old-info)))
+	   (let ((dbg-info (read-debugging-info
+			    (compiled-code-block/dbg-descriptor block))))
 	     (if dbg-info (memoize-debugging-info! block dbg-info))
 	     dbg-info))
 	  (else
 	   false))))
 
+(define (compiled-code-block/labels block demand-load?)
+  (let ((info (compiled-code-block/dbg-info block demand-load?)))
+    (and info
+	 (let ((labels/desc (dbg-info/labels/desc info)))
+	   (if (vector? labels/desc)
+	       labels/desc
+	       (let ((labels
+		      (read-labels (compiled-code-block/dbg-descriptor block))))
+		 (and labels
+		      (begin
+			(set-dbg-info/labels/desc! info labels)
+			labels))))))))
+
+
 (define (discard-debugging-info!)
   (without-interrupts
    (lambda ()
@@ -74,39 +117,63 @@ MIT in each case. |#
      (set! blocks-with-memoized-debugging-info (make-population))
      unspecific)))
 
+(define (valid-dbg-descriptor? object)
+  (and (pair? object)
+       (dbg-locator? (car object))
+       (index-fixnum? (cdr object))))
+
 (define (read-debugging-info descriptor)
-  (cond ((string? 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)
-	      (string? (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
-	 false)))
+  (and (valid-dbg-descriptor? descriptor)
+       (let ((binf (read-dbg-file (car descriptor) inf-load-types)))
+	 (select-dbg-info descriptor binf))))
+
+(define (read-labels descriptor)
+  (and (valid-dbg-descriptor? descriptor)
+       (let ((binf (read-dbg-file (car descriptor) bsm-load-types)))
+	 (select-dbg-info descriptor binf))))
+      
+(define (select-dbg-info descriptor dbg-file-contents)
+  (let ((locator  (car descriptor))
+	(index    (cdr descriptor)))
+
+    (define (complain message . other-irritants)
+      (if (not (dbg-locator/status locator))
+	  (begin
+	    (apply warn
+		   (string-append "Bad debugging information: " message ":")
+		   locator
+		   other-irritants)
+	    (set-dbg-locator/status! locator 'BAD)))
+      #F)
+
+    (if (dbg-wrapper? dbg-file-contents)
+	(let ((compile-time (dbg-locator/timestamp locator))
+	      (dbg-time     (dbg-wrapper/timestamp dbg-file-contents))
+	      (objects      (dbg-wrapper/objects dbg-file-contents))
+	      (version      (dbg-wrapper/format-version dbg-file-contents)))
+	  (cond ((not (equal? compile-time dbg-time))
+		 (complain "mismatched timestamps" compile-time dbg-time))
+		((< version dbg-format:oldest-acceptable-version)
+		 (complain "obsolete format version" version))
+		((> version dbg-format:current-version)
+		 (complain "future format version!" version))
+		((or (not (vector? objects))
+		     (>= index (vector-length objects)))
+		 (complain "vector problem" index))
+		(else
+		 (vector-ref objects index))))
+	(complain "not `wrapped'"))))
+
+(define (read-dbg-file locator load-types)
+  (let ((pathname
+	 (canonicalize-debug-info-pathname (dbg-locator/file locator))))
+    (find-alternate-file-type pathname load-types)))
 
-(define (read-binf-file pathname)
-  (let ((pathname (canonicalize-debug-info-pathname pathname)))
-    (if (file-exists? pathname)
-	(fasload-loader (->namestring pathname))
-	(find-alternate-file-type pathname
-				  `(("inf" . ,fasload-loader)
-				    ("bif" . ,fasload-loader)
-				    ("bci" . ,(compressed-loader "bif")))))))
 
 (define (find-alternate-file-type base-pathname alist)
-  (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x) x)))
+  (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x t) t x)))
     (if (null? left)
-	(receiver file)
+	(receiver file time)
 	(let ((file* (pathname-new-type base-pathname (caar left)))
 	      (receiver* (cdar left)))
 	  (if (not (file-exists? file*))
@@ -165,7 +232,8 @@ MIT in each case. |#
 		     (find-procedure)))
 	       (lambda ()
 		 (let ((expression (dbg-info/expression dbg-info)))
-		   (if (= offset (dbg-expression/label-offset expression))
+		   (if (and expression
+			    (= offset (dbg-expression/label-offset expression)))
 		       expression
 		       (find-procedure))))
 	       (lambda ()
@@ -184,74 +252,33 @@ MIT in each case. |#
       (compiled-entry/offset (compiled-closure->entry entry))
       (compiled-code-address->offset entry)))
 
-(define (compiled-entry/filename entry)
-  (compiled-code-block/filename (compiled-entry/block entry)))
+(define (compiled-code-block/filename-and-index block)
+  ;; Values (filename block-number), either may be #F. For the unparser.
+  (let ((descriptor  (compiled-code-block/dbg-descriptor block)))
+    (if descriptor
+	(values (canonicalize-debug-info-pathname
+		 (dbg-locator/file (car descriptor)))
+		(cdr descriptor))
+	(values false false))))
 
-(define (compiled-code-block/filename block)
-  (let loop ((info (compiled-code-block/debugging-info block)))
-    (cond ((string? info) (values (canonicalize-debug-info-filename info) #f))
-	  ((not (pair? info)) (values false false))
-	  ((dbg-info? (car info)) (loop (cdr info)))
-	  ((string? (car info))
-	   (values (canonicalize-debug-info-filename (car info))
-		   (and (exact-nonnegative-integer? (cdr info))
-			(cdr info))))
-	  (else (values false false)))))
+(define (compiled-entry/filename-and-index entry)
+  (compiled-code-block/filename-and-index (compiled-entry/block entry)))
 
 (define (dbg-labels/find-offset labels offset)
   (vector-binary-search labels < dbg-label/offset offset))
-
-(define (dbg-info-vector/blocks-vector info)
-  (let ((items (dbg-info-vector/items info)))
-    (cond ((vector? items) items)
-	  ((and (pair? items)
-		(pair? (cdr items))
-		(vector? (cadr items)))
-	   (cadr items))
-	  (else (error "Illegal dbg-info-vector" info)))))
-
-(define (dbg-info-vector/purification-root info)
-  (let ((items (dbg-info-vector/items info)))
-    (cond ((vector? items) false)
-	  ((and (pair? items)
-		(eq? (car items) 'COMPILED-BY-PROCEDURES)
-		(pair? (cdr items))
-		(pair? (cddr items)))
-	   (caddr items))
-	  (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))))))))
+  (cond ((or (compiled-code-address? value)
+	     (and (comment? value)
+		  (compiled-code-address? (comment-expression value))))
+	 (warn "Recompile " com-pathname))
+	((compiled-module? value)
+	 (let* ((locator   (compiled-module/dbg-locator value))
+		(pathname  (dbg-locator/file locator)))
+	   (set-dbg-locator/file!
+	    locator
+	    (process-binf-filename pathname com-pathname))))
+	(else unspecific)))
 
 (define (process-binf-filename binf-filename com-pathname)
   (and binf-filename
@@ -266,7 +293,7 @@ MIT in each case. |#
 			   (pathname-version com-pathname)))
 	      (pathname-new-type com-pathname (pathname-type binf-pathname))
 	      binf-pathname)))))
-
+
 (define directory-rewriting-rules
   '())
 
@@ -331,47 +358,17 @@ MIT in each case. |#
 	 (if value
 	     (pathname-as-directory value)
 	     (system-library-directory-pathname "SRC"))))))
-
-(define-integrable (dbg-block/layout-first-offset block)
-  (let ((layout (dbg-block/layout block)))
-    (and (pair? layout) (car layout))))
-
-(define-integrable (dbg-block/layout-vector block)
-  (let ((layout (dbg-block/layout block)))
-    (if (pair? layout)
-	(cdr layout)
-	layout)))
-
-(define (dbg-block/dynamic-link-index block)
-  (vector-find-next-element (dbg-block/layout-vector block)
-			    dbg-block-name/dynamic-link))
-
-(define (dbg-block/ic-parent-index block)
-  (vector-find-next-element (dbg-block/layout-vector block)
-			    dbg-block-name/ic-parent))
-
-(define (dbg-block/normal-closure-index block)
-  (vector-find-next-element (dbg-block/layout-vector block)
-			    dbg-block-name/normal-closure))
-
-(define (dbg-block/return-address-index block)
-  (vector-find-next-element (dbg-block/layout-vector block)
-			    dbg-block-name/return-address))
-
-(define (dbg-block/static-link-index block)
-  (vector-find-next-element (dbg-block/layout-vector block)
-			    dbg-block-name/static-link))
-
-(define (dbg-block/find-name block name)
-  (let ((layout (dbg-block/layout-vector block)))
+
+(define (dbg-block/find-variable block name)
+  (let ((layout (dbg-block/variables block)))
     (let ((end (vector-length layout)))
       (let loop ((index 0))
 	(and (< index end)
-	     (if (let ((item (vector-ref layout index)))
-		   (and (dbg-variable? item)
-			(eq? name (dbg-variable/name item))))
-		 index
-		 (loop (1+ index))))))))
+	     (let ((item (vector-ref layout index)))
+	       (if (and (dbg-variable? item)
+			(eq? name (dbg-variable/name item)))
+		   item
+		   (loop (+ index 1)))))))))
 
 (define (compiled-procedure/name entry)
   (let ((procedure
@@ -403,49 +400,7 @@ MIT in each case. |#
 	       (and scode
 		    (lambda-body scode))))
 	entry)))
-
-;;; Support of BSM files
 
-(define (read-labels descriptor)
-  (cond ((string? descriptor)
-	 (let ((bsm (read-bsm-file descriptor)))
-	   (and bsm ;; bsm are either vectors of pairs or vectors of vectors
-		(if (vector? bsm)
-		    (let ((first (and (not (zero? (vector-length bsm)))
-				      (vector-ref bsm 0))))
-		      (cond ((pair? first) bsm)
-			    ((vector? first) first)
-			    (else false)))))))
-	((and (pair? descriptor)
-	      (string? (car descriptor))
-	      (exact-nonnegative-integer? (cdr descriptor)))
-	 (let ((bsm (read-bsm-file (car descriptor))))
-	   (and bsm
-		(vector? bsm)
-		(< (cdr descriptor) (vector-length bsm))
-		(vector-ref bsm (cdr descriptor)))))
-	(else
-	 false)))
-
-(define (read-bsm-file name)
-  (let ((pathname
-	 (let ((pathname
-		(canonicalize-debug-info-pathname
-		 (rewrite-directory (merge-pathnames name)))))
-	   (if (file-exists? pathname)
-	       pathname
-	       (let loop ((types '("bsm" "bcs")))
-		 (and (not (null? types))
-		      (let ((pathname
-			     (pathname-new-type pathname (car types))))
-			(if (file-exists? pathname)
-			    pathname
-			    (loop (cdr types))))))))))
-    (and pathname
-	 (if (equal? "bcs" (pathname-type pathname))
-	     ((compressed-loader "bsm") pathname)
-	     (fasload-loader pathname)))))
-
 ;;;; Splitting of info structures
 
 (define (inf->bif/bsm inffile)
@@ -456,6 +411,7 @@ MIT in each case. |#
       (inf-structure->bif/bsm binf bifpath bsmpath))))
 
 (define (inf-structure->bif/bsm binf bifpath bsmpath)
+  (error "Needs fixing")
   (let ((bifpath (merge-pathnames bifpath))
 	(bsmpath (and bsmpath (merge-pathnames bsmpath))))
     (let ((bsm (split-inf-structure! binf bsmpath)))
@@ -463,27 +419,20 @@ MIT in each case. |#
       (if bsmpath
 	  (fasdump bsm bsmpath true)))))
 
-(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)))))
-
+(define (split-inf-structure! binf replacement)
+  (cond ((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 replacement))))
+	     bsm)))
+	(else 
+	 (error "Unknown inf format:" binf))))
+
 ;;;; UNCOMPRESS
 ;;;  A simple extractor for compressed binary info files.
 
@@ -513,6 +462,7 @@ MIT in each case. |#
 	      (begin
 		(string-set! buffer i char)
 		(loop (fix:1+ i))))))))
+
 
 ;;  General version.
 ;;
@@ -717,58 +667,65 @@ MIT in each case. |#
 		(literal-command byte)
 		(copy-command byte)))))))
 
-(define (fasload-loader filename)
+(define (fasload-without-errors filename)
   (call-with-current-continuation
     (lambda (if-fail)
       (bind-condition-handler (list condition-type:fasload-band)
-        (lambda (condition) condition (if-fail false))
+	(lambda (condition) condition (if-fail false))
         (lambda () (fasload filename true))))))
 
-(define (compressed-loader uncompressed-type)
-  (lambda (compressed-file)
-    (lookup-uncompressed-file compressed-file fasload-loader
-      (lambda ()
-	(let ((load-compressed
-	       (lambda (temporary-file)
-		 (call-with-current-continuation
-		  (lambda (k)
-		    (uncompress-internal compressed-file
-					 temporary-file
-					 (lambda (message . irritants)
-					   message irritants
-					   (k #f)))
-		    (fasload-loader temporary-file))))))
-	  (case *save-uncompressed-files?*
-	    ((#F)
-	     (call-with-temporary-file-pathname load-compressed))
-	    ((AUTOMATIC)
-	     (call-with-uncompressed-file-pathname compressed-file
-						   load-compressed))
-	    (else
-	     (call-with-temporary-file-pathname
-	      (lambda (temporary-file)
-		(let ((result (load-compressed temporary-file))
-		      (uncompressed-file
-		       (pathname-new-type compressed-file uncompressed-type)))
-		  (delete-file-no-errors uncompressed-file)
-		  (if (call-with-current-continuation
-		       (lambda (k)
-			 (bind-condition-handler
-			     (list condition-type:file-error
-				   condition-type:port-error)
-			     (lambda (condition) condition (k #t))
-			   (lambda ()
-			     (rename-file temporary-file uncompressed-file)
-			     #f))))
-		      (call-with-current-continuation
-		       (lambda (k)
-			 (bind-condition-handler
-			     (list condition-type:file-error
-				   condition-type:port-error)
-			     (lambda (condition) condition (k unspecific))
-			   (lambda ()
-			     (copy-file temporary-file uncompressed-file))))))
-		  result))))))))))
+(define (fasload-loader filename file-time)
+  file-time				; ignored
+  (fasload-without-errors filename))
+
+(define (compressed-loader uncompressed-type uncompressed-loader)
+  (lambda (compressed-file compressed-time)
+    (lookup-uncompressed-file
+     compressed-file compressed-time uncompressed-loader
+     (lambda ()
+       (define (load-compressed temporary-file)
+	 (call-with-current-continuation
+	  (lambda (k)
+	    (uncompress-internal compressed-file
+				 temporary-file
+				 (lambda (message . irritants)
+				   message irritants
+				   (k #f)))
+	    (uncompressed-loader 
+	     temporary-file
+	     (file-modification-time-direct temporary-file)))))
+       (case *save-uncompressed-files?*
+	 ((#F)
+	  (call-with-temporary-file-pathname load-compressed))
+	 ((AUTOMATIC)
+	  (call-with-uncompressed-file-pathname compressed-file
+						compressed-time
+						load-compressed))
+	 (else
+	  (call-with-temporary-file-pathname
+	   (lambda (temporary-file)
+	     (let ((result (load-compressed temporary-file))
+		   (uncompressed-file
+		    (pathname-new-type compressed-file uncompressed-type)))
+	       (delete-file-no-errors uncompressed-file)
+	       (if (call-with-current-continuation
+		    (lambda (k)
+		      (bind-condition-handler
+		       (list condition-type:file-error
+			     condition-type:port-error)
+		       (lambda (condition) condition (k #t))
+		       (lambda ()
+			 (rename-file temporary-file uncompressed-file)
+			 #f))))
+		   (call-with-current-continuation
+		    (lambda (k)
+		      (bind-condition-handler
+		       (list condition-type:file-error
+			     condition-type:port-error)
+		       (lambda (condition) condition (k unspecific))
+		       (lambda ()
+			 (copy-file temporary-file uncompressed-file))))))
+	       result)))))))))
 
 (define (uncompress-internal ifile ofile if-fail)
   (call-with-binary-input-file (merge-pathnames ifile)
@@ -786,34 +743,51 @@ MIT in each case. |#
 		(uncompress-ports input output (fix:* (file-length ifile) 2))))
 	    (if-fail "Not a recognized compressed file:" ifile))))))
 
-(define (lookup-uncompressed-file compressed-file if-found if-not-found)
+(define-structure (file-entry
+		   (type vector)
+		   (conc-name file-entry/))
+  compressed-name
+  compressed-time
+  uncompressed-name
+  uncompressed-time
+  last-use-time)
+
+(define (lookup-uncompressed-file compressed-file compressed-time
+				  if-found if-not-found)
   (dynamic-wind
    (lambda ()
      (set-car! uncompressed-files (+ (car uncompressed-files) 1)))
    (lambda ()
      (let loop ((entries (cdr uncompressed-files)))
-       (cond ((null? entries)
-	      (if-not-found))
-	     ((and (pathname=? (caar entries) compressed-file)
-		   (cddar entries)
-		   (or (file-exists? (cadar entries))
-		       (begin
-			 (set-cdr! (cdar entries) #f)
-			 #f)))
-	      (dynamic-wind
-	       (lambda () unspecific)
-	       (lambda () (if-found (cadar entries)))
-	       (lambda () (set-cdr! (cdar entries) (real-time-clock)))))
-	     (else
-	      (loop (cdr entries))))))
+       (if (null? entries)
+	   (if-not-found)
+	   (let ((entry (car entries)))
+	     (if (and (pathname=? (file-entry/compressed-name entry)
+				  compressed-file)
+		      (file-entry/uncompressed-name entry)
+		      (= (file-entry/compressed-time entry) compressed-time)
+		      (or (file-exists? (file-entry/uncompressed-name entry))
+			  (begin
+			    (set-file-entry/uncompressed-name! entry #F)
+			    #f)))
+		 (dynamic-wind
+		  (lambda () unspecific)
+		  (lambda () (if-found (file-entry/uncompressed-name entry)
+				       (file-entry/uncompressed-time entry)))
+		  (lambda ()
+		    (set-file-entry/last-use-time! entry (real-time-clock))))
+		 (loop (cdr entries)))))))
    (lambda ()
      (set-car! uncompressed-files (- (car uncompressed-files) 1)))))
 
-(define (call-with-uncompressed-file-pathname compressed-file receiver)
+(define (call-with-uncompressed-file-pathname compressed-file compressed-time
+					      receiver)
   (let ((temporary-file (temporary-file-pathname)))
     (let ((entry
-	   (cons compressed-file
-		 (cons temporary-file (real-time-clock)))))
+	   (make-file-entry
+	    compressed-file compressed-time
+	    temporary-file  (file-modification-time-direct temporary-file)
+	    (real-time-clock))))
       (dynamic-wind
        (lambda () unspecific)
        (lambda ()
@@ -823,28 +797,32 @@ MIT in each case. |#
 		      (cons entry (cdr uncompressed-files)))))
 	 (receiver temporary-file))
        (lambda ()
-	 (set-cdr! (cdr entry) (real-time-clock)))))))
+	 (set-file-entry/last-use-time! entry (real-time-clock)))))))
 
 (define (delete-uncompressed-files!)
   (do ((entries (cdr uncompressed-files) (cdr entries)))
       ((null? entries) unspecific)
-    (deallocate-temporary-file (cadar entries))))
+    (let ((name (file-entry/uncompressed-name (car entries))))
+      (if name
+	  (deallocate-temporary-file name)))))
 
 (define (clean-uncompressed-files!)
   (if (= 0 (car uncompressed-files))
       (let ((time (real-time-clock)))
 	(let loop
 	    ((entries (cdr uncompressed-files))
-	     (prev uncompressed-files))
-	  (if (not (null? entries))
-	      (if (or (not (cddar entries))
-		      (< (- time (cddar entries))
-			 *uncompressed-file-lifetime*))
-		  (loop (cdr entries) entries)
-		  (begin
-		    (set-cdr! prev (cdr entries))
-		    (deallocate-temporary-file (cadar entries))
-		    (loop (cdr entries) prev))))))))
+	     (prev    uncompressed-files))
+	  (if (pair? entries)
+	      (let ((entry (car entries)))
+		(if (or (not (file-entry/uncompressed-name entry))
+			(< (- time (file-entry/last-use-time entry))
+			   *uncompressed-file-lifetime*))
+		    (loop (cdr entries) entries)
+		    (begin
+		      (set-cdr! prev (cdr entries))
+		      (deallocate-temporary-file
+		       (file-entry/uncompressed-name entry))
+		      (loop (cdr entries) prev)))))))))
 
 (define (initialize-uncompressed-files!)
   (set! uncompressed-files (list 0))
@@ -852,4 +830,38 @@ MIT in each case. |#
 
 (define *save-uncompressed-files?* 'AUTOMATIC)
 (define *uncompressed-file-lifetime* 300000)
-(define uncompressed-files)
\ No newline at end of file
+(define uncompressed-files)
+
+(define ((cached-loader loader) filename time)
+  (define (reload)
+    (let ((object  (loader filename time)))
+      (set-cdr! cached-files
+		(cons (cons filename (weak-cons object time))
+		      (cdr cached-files)))
+      object))
+  (if cached-files
+      (let ((entry (assoc filename (cdr cached-files))))
+	(if entry
+	    (let ((object  (weak-car (cdr entry)))
+		  (time*   (weak-cdr (cdr entry))))
+	      (if (and object (= time time*))
+		  object
+		  (reload)))
+	    (reload)))
+      (loader filename time)))
+
+(define (clean-cached-files!)
+  (let loop ((items  (cdr cached-files))
+	     (prev   cached-files))
+    (cond ((null? items))
+	  ((or (not (caar items))
+	       (not (weak-car (cdar items))))
+	   (set-cdr! prev (cdr items))
+	   (loop (cdr items) prev))
+	  (else
+	   (loop (cdr items) (cdr prev))))))
+
+(define (initialize-cached-files!)
+  (set! cached-files (list #F)))
+
+(define cached-files #F)
\ No newline at end of file
diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 21b93cce7..55ac91f37 100644
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.57 1995/04/13 22:24:53 cph Exp $
+$Id: make.scm,v 14.58 1995/07/27 21:03:12 adams Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -256,7 +256,12 @@ MIT in each case. |#
 	   false))))
 
 (define (eval object environment)
-  (let ((value (scode-eval object environment)))
+  (let ((value 
+	 (scode-eval
+	  (if (vector? object)		; compiled-module?
+	      (vector-ref object 2)	; compiled-module/expression
+	      object)
+	  environment)))
     (tty-write-string " evaluated")
     value))
 
@@ -489,6 +494,8 @@ MIT in each case. |#
 
 (let ((roots
        (list->vector
+	;; Make all debugging file names relative to runtime in scheme root
+        ;; directory.
 	((access with-directory-rewriting-rule
 		 (->environment '(RUNTIME COMPILER-INFO)))
 	 (working-directory-pathname)
-- 
2.25.1