* Compiler now knows how to emit a different form of

`dbg-info-vector', which contains not only the compiled-code blocks
(as before), but also a pointer which is the root to be used if the
code is to be purified.  The runtime system needed to be changed to
accomodate this.

* Change default for `load-debugging-info-on-demand?' back to false.

* Fix `scode-constant?' to handle compiled-code-entry objects
correctly.

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 35f2c526b32ee9457e063eaf900e0b38b3eda394..6e5a044ca65dbdbf315ca991c04bcb4cfc95a25d 100644 (file)
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.9 1989/08/15 13:19:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.10 1989/08/17 14:51:05 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -72,11 +72,13 @@ MIT in each case. |#
         (let ((binf (read-binf-file descriptor)))
           (and binf (dbg-info? binf) binf)))   ((and (pair? descriptor)
              (string? (car descriptor))
-             (integer? (cdr descriptor)))
+             (integer? (cdr descriptor))
+             (not (negative? (cdr descriptor))))
         (let ((binf (read-binf-file (car descriptor))))
           (and binf
-               (dbg-info-vector? binf)
-               (vector-ref (dbg-info-vector/items binf) (cdr descriptor)))))
+               (vector? binf)
+               (< (cdr descriptor) (vector-length binf))
+               (vector-ref binf (cdr descriptor)))))
        (else
         false)))
 
@@ -137,7 +139,7 @@ MIT in each case. |#
                 false)))))))
 
 (define load-debugging-info-on-demand?
-  true)
+  false)
 
 (define (compiled-entry/block entry)
   (if (compiled-closure? entry)
@@ -153,17 +155,32 @@ MIT in each case. |#
   (let loop
       ((info
        (compiled-code-block/debugging-info (compiled-entry/block entry))))
-    (cond ((string? info)
-          info)
-         ((pair? info)
-          (cond ((string? (car info)) (car info))
-                ((dbg-info? (car info)) (loop (cdr info)))
-                (else false)))
-         (else
-          false))))
-
+    (cond ((string? info) info)
+         ((not (pair? info)) false)
+         ((string? (car info)) (car info))
+         ((dbg-info? (car info)) (loop (cdr info)))
+         (else false))))
 (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)))))
 \f
 (define (fasload/update-debugging-info! value com-pathname)
   (let ((process-block
@@ -179,12 +196,13 @@ MIT in each case. |#
                                                     com-pathname))))))))
     (cond ((compiled-code-address? value)
           (process-block (compiled-code-address->block value)))
-         ((comment? value)
-          (let ((text (comment-text value)))
-            (if (dbg-info-vector? text)
-                (for-each
-                 process-block
-                 (vector->list (dbg-info-vector/items text)))))))))
+         ((and (comment? value)
+               (dbg-info-vector? (comment-text value)))
+          (for-each
+           process-block
+           (vector->list
+            (dbg-info-vector/blocks-vector (comment-text value))))))))
+
 (define (process-binf-filename binf-filename com-pathname)
   (pathname->string
    (rewrite-directory

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 9277f0057df56d4a89cd73dd611931377f018d1f..2c3b6c9a5460be395aacfe7c0a5e564f0ff23241 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.7 1989/08/15 13:19:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.8 1989/08/17 14:51:08 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -155,7 +155,14 @@ MIT in each case. |#
             (let ((scode
                    (fasload/internal true-pathname
                                      load/suppress-loading-message?)))
-              (if purify? (purify scode))             scode)
+              (if purify?
+                  (purify
+                   (or (and (comment? scode)
+                            (let ((text (comment-text scode)))
+                              (and (dbg-info-vector? text)
+                                   (dbg-info-vector/purification-root text))))
+                       scode)))
+              scode)
             (if (eq? environment default-object)
                 (nearest-repl/environment)
                 environment)))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 62310ed8db20eda0c99581c044181109956ecfab..357ad308f69747e44e0297d4aff0cdb10db775ae 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.49 1989/08/15 13:20:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.50 1989/08/17 14:51:12 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -223,7 +223,10 @@ MIT in each case. |#
          compiled-procedure/lambda
          discard-debugging-info!
          load-debugging-info-on-demand?)
-  (export (runtime load)         fasload/update-debugging-info!)
+  (export (runtime load)
+         dbg-info-vector/purification-root
+         dbg-info-vector?
+         fasload/update-debugging-info!)
   (export (runtime debugger-command-loop)
          special-form-procedure-name?)
   (export (runtime environment)

diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm
index 6f53db152ae6917eccbe7c1d876c8db389c7e77e..8e8f5c338dd9303b84d1bed8563a6b2c1d500b18 100644 (file)
--- a/v7/src/runtime/scode.scm
+++ b/v7/src/runtime/scode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.5 1989/04/18 16:30:05 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.6 1989/08/17 14:51:17 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -45,7 +45,11 @@ MIT in each case. |#
 (define scode-constant/type-vector)
 
 (define (scode-constant? object)
-  (vector-ref scode-constant/type-vector (object-type object)))
+  (if (vector-ref scode-constant/type-vector (object-type object))
+      true
+      (and (compiled-code-address? object)
+          (not (eq? (compiled-entry-type object) 'COMPILED-EXPRESSION)))))
+
 (define (make-scode-constant/type-vector)
   (let ((type-vector (make-vector (microcode-type/code-limit) false)))
     (for-each (lambda (name)

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 0055eb45b5cf4a52c8dad47dec7f4f561d1f2623..38733da340b5e0e02539c3dd069abc2fa27d27e3 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.54 1989/08/15 13:20:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.55 1989/08/17 14:51:21 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 54))
+  (add-identification! "Runtime" 14 55))
 (define microcode-system)
 
 (define (snarf-microcode-version!)

diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index b6ed3a27206d3f49387d52e965924c93fcd7f0ad..d68b60ab85de43227d7b03bcb9aa995650a8d278 100644 (file)
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.9 1989/08/15 13:19:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.10 1989/08/17 14:51:05 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -72,11 +72,13 @@ MIT in each case. |#
         (let ((binf (read-binf-file descriptor)))
           (and binf (dbg-info? binf) binf)))   ((and (pair? descriptor)
              (string? (car descriptor))
-             (integer? (cdr descriptor)))
+             (integer? (cdr descriptor))
+             (not (negative? (cdr descriptor))))
         (let ((binf (read-binf-file (car descriptor))))
           (and binf
-               (dbg-info-vector? binf)
-               (vector-ref (dbg-info-vector/items binf) (cdr descriptor)))))
+               (vector? binf)
+               (< (cdr descriptor) (vector-length binf))
+               (vector-ref binf (cdr descriptor)))))
        (else
         false)))
 
@@ -137,7 +139,7 @@ MIT in each case. |#
                 false)))))))
 
 (define load-debugging-info-on-demand?
-  true)
+  false)
 
 (define (compiled-entry/block entry)
   (if (compiled-closure? entry)
@@ -153,17 +155,32 @@ MIT in each case. |#
   (let loop
       ((info
        (compiled-code-block/debugging-info (compiled-entry/block entry))))
-    (cond ((string? info)
-          info)
-         ((pair? info)
-          (cond ((string? (car info)) (car info))
-                ((dbg-info? (car info)) (loop (cdr info)))
-                (else false)))
-         (else
-          false))))
-
+    (cond ((string? info) info)
+         ((not (pair? info)) false)
+         ((string? (car info)) (car info))
+         ((dbg-info? (car info)) (loop (cdr info)))
+         (else false))))
 (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)))))
 \f
 (define (fasload/update-debugging-info! value com-pathname)
   (let ((process-block
@@ -179,12 +196,13 @@ MIT in each case. |#
                                                     com-pathname))))))))
     (cond ((compiled-code-address? value)
           (process-block (compiled-code-address->block value)))
-         ((comment? value)
-          (let ((text (comment-text value)))
-            (if (dbg-info-vector? text)
-                (for-each
-                 process-block
-                 (vector->list (dbg-info-vector/items text)))))))))
+         ((and (comment? value)
+               (dbg-info-vector? (comment-text value)))
+          (for-each
+           process-block
+           (vector->list
+            (dbg-info-vector/blocks-vector (comment-text value))))))))
+
 (define (process-binf-filename binf-filename com-pathname)
   (pathname->string
    (rewrite-directory

diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index 778a2a259bdf66becb5784c2e03d878741781757..5256f0981b53e741aea11fae2672bb6a3a1be85f 100644 (file)
--- a/v8/src/runtime/load.scm
+++ b/v8/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.7 1989/08/15 13:19:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.8 1989/08/17 14:51:08 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -155,7 +155,14 @@ MIT in each case. |#
             (let ((scode
                    (fasload/internal true-pathname
                                      load/suppress-loading-message?)))
-              (if purify? (purify scode))             scode)
+              (if purify?
+                  (purify
+                   (or (and (comment? scode)
+                            (let ((text (comment-text scode)))
+                              (and (dbg-info-vector? text)
+                                   (dbg-info-vector/purification-root text))))
+                       scode)))
+              scode)
             (if (eq? environment default-object)
                 (nearest-repl/environment)
                 environment)))

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 064e1404d7e9b3f22335cdca06e0d7595f875104..758bf0077d6bae386cc81e29df8655fc74ae93c6 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.49 1989/08/15 13:20:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.50 1989/08/17 14:51:12 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -223,7 +223,10 @@ MIT in each case. |#
          compiled-procedure/lambda
          discard-debugging-info!
          load-debugging-info-on-demand?)
-  (export (runtime load)         fasload/update-debugging-info!)
+  (export (runtime load)
+         dbg-info-vector/purification-root
+         dbg-info-vector?
+         fasload/update-debugging-info!)
   (export (runtime debugger-command-loop)
          special-form-procedure-name?)
   (export (runtime environment)