From 2aa332c9bb653403ccba44061aa57c57945acd8b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 17 Aug 1989 14:51:21 +0000 Subject: [PATCH] * 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. --- v7/src/runtime/infutl.scm | 58 +++++++++++++++++++++++++------------- v7/src/runtime/load.scm | 11 ++++++-- v7/src/runtime/runtime.pkg | 7 +++-- v7/src/runtime/scode.scm | 8 ++++-- v7/src/runtime/version.scm | 4 +-- v8/src/runtime/infutl.scm | 58 +++++++++++++++++++++++++------------- v8/src/runtime/load.scm | 11 ++++++-- v8/src/runtime/runtime.pkg | 7 +++-- 8 files changed, 112 insertions(+), 52 deletions(-) diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 35f2c526b..6e5a044ca 100644 --- 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))))) (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 9277f0057..2c3b6c9a5 100644 --- 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 62310ed8d..357ad308f 100644 --- 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 6f53db152..8e8f5c338 100644 --- 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 0055eb45b..38733da34 100644 --- 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 b6ed3a272..d68b60ab8 100644 --- 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))))) (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 778a2a259..5256f0981 100644 --- 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 064e1404d..758bf0077 100644 --- 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) -- 2.25.1