From: Chris Hanson Date: Fri, 16 Dec 1988 13:37:12 +0000 (+0000) Subject: Add hooks for debugging info. X-Git-Tag: 20090517-FFI~12331 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=39a1d14b75a3053fd67442fcb51d2d7be9dde320;p=mit-scheme.git Add hooks for debugging info. --- diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index a6c945222..e6c961bd3 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.8 1988/12/15 17:17:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.9 1988/12/16 13:35:15 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -83,7 +83,7 @@ from the continuation, and then "glued" into place afterwards. applications ;list of applications lexically within this block interned-variables ;alist of interned SCode variable objects closure-offsets ;for closure block, alist of bound variable offsets - frame ;debugging information (???) + debugging-info ;dbg-block, if used stack-link ;for stack block, adjacent block on stack popping-limits ;for stack block (see continuation analysis) popping-limit ;for stack block (see continuation analysis) diff --git a/v7/src/compiler/base/contin.scm b/v7/src/compiler/base/contin.scm index 333494b88..e42791b81 100644 --- a/v7/src/compiler/base/contin.scm +++ b/v7/src/compiler/base/contin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.6 1988/12/12 21:51:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.7 1988/12/16 13:36:57 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -74,6 +74,9 @@ MIT in each case. |# (define-integrable set-continuation/offset! set-procedure-closure-offset!) (define-integrable continuation/passed-out? procedure-passed-out?) (define-integrable set-continuation/passed-out?! set-procedure-passed-out?!) +(define-integrable continuation/debugging-info procedure-debugging-info) +(define-integrable set-continuation/debugging-info! + set-procedure-debugging-info!) (define (continuation/register continuation) (or (procedure-register continuation) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index af0223dcb..ac00ce15e 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.9 1988/12/15 17:19:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.10 1988/12/16 13:35:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -68,6 +68,7 @@ MIT in each case. |# (variables ;variables which may be bound to this procedure (1) side-effects) ;classes of side-effects performed by this procedure properties ;random bits of information [assq list] + debugging-info ;[dbg-procedure or dbg-continuation] ) ;; (1) The first meaning is used during closure analysis. @@ -84,7 +85,7 @@ MIT in each case. |# (node->edge (cfg-entry-node scfg)) (list-copy required) (list-copy optional) rest (generate-label name) false false false false false - false false false false false false '() '() false))) + false false false false false false '() '() '() false))) (set! *procedures* (cons procedure *procedures*)) (set-block-procedure! block procedure) procedure)) diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm index bfde4334d..a1ca4088a 100644 --- a/v7/src/compiler/base/rvalue.scm +++ b/v7/src/compiler/base/rvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.4 1988/12/12 21:51:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.5 1988/12/16 13:36:35 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -169,7 +169,8 @@ MIT in each case. |# block continuation entry-edge - label) + label + debugging-info) (define *expressions*) @@ -177,7 +178,7 @@ MIT in each case. |# (let ((expression (make-rvalue expression-tag block continuation (node->edge (cfg-entry-node scfg)) - (generate-label 'EXPRESSION)))) + (generate-label 'EXPRESSION) false))) (set! *expressions* (cons expression *expressions*)) (set-block-procedure! block expression) expression)) diff --git a/v7/src/compiler/rtlbase/rtlobj.scm b/v7/src/compiler/rtlbase/rtlobj.scm index efdd0cdf7..ef7c76d3d 100644 --- a/v7/src/compiler/rtlbase/rtlobj.scm +++ b/v7/src/compiler/rtlbase/rtlobj.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.3 1988/06/14 08:37:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.4 1988/12/16 13:36:19 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -38,30 +38,26 @@ MIT in each case. |# (define-structure (rtl-expr (conc-name rtl-expr/) - (constructor make-rtl-expr (rgraph label entry-edge)) + (constructor make-rtl-expr + (rgraph label entry-edge debugging-info)) (print-procedure (standard-unparser "RTL-EXPR" (lambda (state expression) (unparse-object state (rtl-expr/label expression)))))) (rgraph false read-only true) (label false read-only true) - (entry-edge false read-only true)) - -(set-type-object-description! - rtl-expr - (lambda (expression) - `((RTL-EXPR/RGRAPH ,(rtl-expr/rgraph expression)) - (RTL-EXPR/LABEL ,(rtl-expr/label expression)) - (RTL-EXPR/ENTRY-EDGE ,(rtl-expr/entry-edge expression))))) + (entry-edge false read-only true) + (debugging-info false read-only true)) (define-integrable (rtl-expr/entry-node expression) (edge-right-node (rtl-expr/entry-edge expression))) - + (define-structure (rtl-procedure (conc-name rtl-procedure/) (constructor make-rtl-procedure (rgraph label entry-edge name n-required - n-optional rest? closure? type)) + n-optional rest? closure? type + debugging-info)) (print-procedure (standard-unparser "RTL-PROCEDURE" (lambda (state procedure) @@ -76,23 +72,8 @@ MIT in each case. |# (rest? false read-only true) (closure? false read-only true) (type false read-only true) - (%external-label false)) - -(set-type-object-description! - rtl-procedure - (lambda (procedure) - `((RTL-PROCEDURE/RGRAPH ,(rtl-procedure/rgraph procedure)) - (RTL-PROCEDURE/LABEL ,(rtl-procedure/label procedure)) - (RTL-PROCEDURE/ENTRY-EDGE ,(rtl-procedure/entry-edge procedure)) - (RTL-PROCEDURE/NAME ,(rtl-procedure/name procedure)) - (RTL-PROCEDURE/N-REQUIRED ,(rtl-procedure/n-required procedure)) - (RTL-PROCEDURE/N-OPTIONAL ,(rtl-procedure/n-optional procedure)) - (RTL-PROCEDURE/REST? ,(rtl-procedure/rest? procedure)) - (RTL-PROCEDURE/CLOSURE? ,(rtl-procedure/closure? procedure)) - (RTL-PROCEDURE/TYPE ,(rtl-procedure/type procedure)) - (RTL-PROCEDURE/%EXTERNAL-LABEL - ,(rtl-procedure/%external-label procedure))))) - + (%external-label false) + (debugging-info false read-only true)) (define-integrable (rtl-procedure/entry-node procedure) (edge-right-node (rtl-procedure/entry-edge procedure))) @@ -101,11 +82,11 @@ MIT in each case. |# (let ((label (generate-label (rtl-procedure/name procedure)))) (set-rtl-procedure/%external-label! procedure label) label))) - + (define-structure (rtl-continuation (conc-name rtl-continuation/) (constructor make-rtl-continuation - (rgraph label entry-edge)) + (rgraph label entry-edge debugging-info)) (print-procedure (standard-unparser "RTL-CONTINUATION" (lambda (state continuation) (unparse-object @@ -113,15 +94,8 @@ MIT in each case. |# (rtl-continuation/label continuation)))))) (rgraph false read-only true) (label false read-only true) - (entry-edge false read-only true)) - -(set-type-object-description! - rtl-continuation - (lambda (continuation) - `((RTL-CONTINUATION/RGRAPH ,(rtl-continuation/rgraph continuation)) - (RTL-CONTINUATION/LABEL ,(rtl-continuation/label continuation)) - (RTL-CONTINUATION/ENTRY-EDGE - ,(rtl-continuation/entry-edge continuation))))) + (entry-edge false read-only true) + (debugging-info false read-only true)) (define-integrable (rtl-continuation/entry-node continuation) (edge-right-node (rtl-continuation/entry-edge continuation))) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index f347240b6..c2d9e2072 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.13 1988/12/15 17:26:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.14 1988/12/16 13:37:12 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -82,20 +82,22 @@ MIT in each case. |# (cons continuation *queued-continuations*))))) (define (generate/expression expression) - (transmit-values - (generate/rgraph (expression-entry-node expression) generate/node) + (with-values + (lambda () + (generate/rgraph (expression-entry-node expression) generate/node)) (lambda (rgraph entry-edge) - (make-rtl-expr rgraph (expression-label expression) entry-edge)))) + (make-rtl-expr rgraph + (expression-label expression) + entry-edge + (expression-debugging-info expression))))) (define (generate/procedure procedure) - (transmit-values - (generate/rgraph - (procedure-entry-node procedure) - (lambda (node) - (generate/procedure-header - procedure - (generate/node node) - false))) + (with-values + (lambda () + (generate/rgraph + (procedure-entry-node procedure) + (lambda (node) + (generate/procedure-header procedure (generate/node node) false)))) (lambda (rgraph entry-edge) (make-rtl-procedure rgraph @@ -106,7 +108,8 @@ MIT in each case. |# (length (procedure-original-optional procedure)) (and (procedure-original-rest procedure) true) (and (procedure/closure? procedure) true) - (procedure/type procedure))))) + (procedure/type procedure) + (procedure-debugging-info procedure))))) (define (generate/procedure-entry/inline procedure) (generate/procedure-header procedure @@ -129,34 +132,38 @@ MIT in each case. |# (define (generate/continuation continuation) (let ((label (continuation/label continuation))) - (transmit-values - (generate/rgraph - (continuation/entry-node continuation) - (lambda (node) - (scfg-append! - (if (continuation/avoid-check? continuation) - (rtl:make-continuation-entry label) - (rtl:make-continuation-header label)) - (generate/continuation-entry/pop-extra continuation) - (enumeration-case continuation-type - (continuation/type continuation) - ((PUSH) - (rtl:make-push (rtl:make-fetch register:value))) - ((REGISTER) - (rtl:make-assignment (continuation/register continuation) - (rtl:make-fetch register:value))) - ((VALUE PREDICATE) - (if (continuation/ever-known-operator? continuation) - (rtl:make-assignment (continuation/register continuation) - (rtl:make-fetch register:value)) - (make-null-cfg))) - ((EFFECT) - (make-null-cfg)) - (else - (error "Illegal continuation type" continuation))) - (generate/node node)))) + (with-values + (lambda () + (generate/rgraph + (continuation/entry-node continuation) + (lambda (node) + (scfg-append! + (if (continuation/avoid-check? continuation) + (rtl:make-continuation-entry label) + (rtl:make-continuation-header label)) + (generate/continuation-entry/pop-extra continuation) + (enumeration-case continuation-type + (continuation/type continuation) + ((PUSH) + (rtl:make-push (rtl:make-fetch register:value))) + ((REGISTER) + (rtl:make-assignment (continuation/register continuation) + (rtl:make-fetch register:value))) + ((VALUE PREDICATE) + (if (continuation/ever-known-operator? continuation) + (rtl:make-assignment (continuation/register continuation) + (rtl:make-fetch register:value)) + (make-null-cfg))) + ((EFFECT) + (make-null-cfg)) + (else + (error "Illegal continuation type" continuation))) + (generate/node node))))) (lambda (rgraph entry-edge) - (make-rtl-continuation rgraph label entry-edge))))) + (make-rtl-continuation rgraph + label + entry-edge + (continuation/debugging-info continuation)))))) (define (generate/continuation-entry/pop-extra continuation) (let ((block (continuation/closing-block continuation))) @@ -222,7 +229,7 @@ MIT in each case. |# (fluid-let ((*current-rgraph* rgraph)) (with-new-node-marks (lambda () (generator node)))))))) (add-rgraph-entry-edge! rgraph entry-edge) - (return-2 rgraph entry-edge)))) + (values rgraph entry-edge)))) (define (node->rgraph node) (let ((color