From: Chris Hanson Date: Tue, 15 Aug 1989 12:59:19 +0000 (+0000) Subject: Canonicalization of expressions causes certain expressions to be X-Git-Tag: 20090517-FFI~11824 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=65dc163a82c2baa68a49e8e54a8387bbefe39dac;p=mit-scheme.git Canonicalization of expressions causes certain expressions to be rewritten in a form that is unsuitable for use as the debugging source code. Change the canonicalization code to save the original code. Change the fg-generator to use the original code as the debugging source instead of the code that it is compiling. --- diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm index 8a9ce7247..7da2e54ea 100644 --- a/v7/src/compiler/base/scode.scm +++ b/v7/src/compiler/base/scode.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.6 1989/04/15 18:06:27 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.7 1989/08/15 12:58:32 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -82,11 +82,27 @@ MIT in each case. |# (recvr (scode/quotation-expression quot))) (define comment-tag:directive - (intern "#[(compiler)comment-tag:directive")) + (intern "#[(compiler)comment-tag:directive]")) + +(define (scode/make-directive code directive original-code) + (scode/make-comment + (list comment-tag:directive + directive + (scode/original-expression original-code)) + code)) + +(define (scode/original-expression scode) + (if (and (scode/comment? scode) + (scode/comment-directive? (scode/comment-text scode))) + (caddr (scode/comment-text scode)) + scode)) + +(define (scode/comment-directive? text . kinds) + (and (pair? text) + (eq? (car text) comment-tag:directive) + (or (null? kinds) + (memq (caadr text) kinds)))) -(define (scode/make-directive directive code) - (scode/make-comment (list comment-tag:directive directive) - code)) (define (scode/make-let names values . body) (scan-defines (scode/make-sequence body) (lambda (auxiliary declarations body) diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm index bc09511d6..afeee25ec 100644 --- a/v7/src/compiler/fggen/canon.scm +++ b/v7/src/compiler/fggen/canon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.4 1989/04/15 18:05:43 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.5 1989/08/15 12:58:56 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -53,7 +53,7 @@ All levels except HYBRID treat all packages uniformly. NONE: no optimization is to be performed. LOW: variable manipulation and closure operations in package bodies - are translated into explicit primitive calls (to + are translated into explicit primitive calls (to LEXICAL-REFERENCE, etc.) HYBRID: once-only? package bodies are treated as in HIGH below. @@ -109,7 +109,8 @@ ARBITRARY: The expression may be executed more than once. It 'FIRST-CLASS)))) (if (canout-needs? result) (canonicalize/bind-environment (canout-expr result) - (scode/make-the-environment)) + (scode/make-the-environment) + expression) (canout-expr result))))) (define (canonicalize/optimization-low? context) @@ -168,29 +169,34 @@ ARBITRARY: The expression may be executed more than once. It (canonicalize/expression a bound context) (canonicalize/expression b bound context) (canonicalize/expression c bound context))))) + +(define canonicalize/constant + canonicalize/trivial) + +(define (canonicalize/error operator operands bound context) + (canonicalize/combine-binary scode/make-combination + (canonicalize/expression operator bound context) + (combine-list + (list (canonicalize/expression (car operands) bound context) + (canonicalize/expression (cadr operands) bound context) + (canonicalize/trivial (caddr operands) bound context))))) ;;;; Caching first class environments (define environment-variable (intern "#[environment]")) -(define (scode/comment-directive? text . kinds) - (and (pair? text) - (eq? (car text) comment-tag:directive) - (pair? (cdr text)) - (pair? (cadr text)) - (memq (caadr text) kinds))) - -(define (canonicalize/bind-environment body exp) +(define (canonicalize/bind-environment body exp original-expression) (define (normal) (scode/make-directive - '(PROCESSED) (scode/make-combination (scode/make-lambda lambda-tag:let (list environment-variable) '() false '() '() body) - (list exp)))) + (list exp)) + '(PROCESSED) + original-expression)) (define (comment body recvr) (scode/comment-components @@ -209,7 +215,7 @@ ARBITRARY: The expression may be executed more than once. It (recvr (scode/quotation-expression (car operands))) (normal)))) (normal))))) - + (cond ((scode/variable? body) (let ((name (scode/variable-name body))) (if (eq? name environment-variable) @@ -239,18 +245,6 @@ ARBITRARY: The expression may be executed more than once. It (canonicalize/combine-binary cons (car elements) (combine-list (cdr elements))))) - -;;; Expressions - -(define canonicalize/constant canonicalize/trivial) - -(define (canonicalize/error operator operands bound context) - (canonicalize/combine-binary scode/make-combination - (canonicalize/expression operator bound context) - (combine-list - (list (canonicalize/expression (car operands) bound context) - (canonicalize/expression (cadr operands) bound context) - (canonicalize/trivial (caddr operands) bound context))))) ;;;; Variables and assignment @@ -356,7 +350,7 @@ ARBITRARY: The expression may be executed more than once. It bound context)))))) -;;;; Harier expressions +;;;; Hairier expressions (let-syntax ((is-operator? (macro (value name) @@ -429,31 +423,34 @@ ARBITRARY: The expression may be executed more than once. It (if (scode/the-environment? (cadr operands)) (make-canout (scode/make-directive - (cadr text) (scode/make-combination operator (list (car operands) - (scode/make-variable environment-variable)))) + (scode/make-variable environment-variable))) + (cadr text) + (caddr text)) false true false) (make-canout expr true true false)))))))) ;;;; Utility for hairy expressions -(define (scode/make-evaluation exp env arbitrary?) +(define (scode/make-evaluation exp env arbitrary? original-expression) (define (default) (scode/make-directive - '(PROCESSED) (scode/make-combination (ucode-primitive SCODE-EVAL) - (list (let ((nexp (scode/make-directive - '(COMPILE) - (scode/make-quotation exp)))) + (list (let ((nexp + (scode/make-directive + '(COMPILE) + (scode/make-quotation exp) original-expression))) (if arbitrary? (scode/make-combination (scode/make-absolute-reference 'COPY-PROGRAM) (list nexp)) nexp)) - env)))) + env)) + '(PROCESSED) + original-expression)) (cond ((scode/the-environment? exp) env) @@ -499,11 +496,11 @@ ARBITRARY: The expression may be executed more than once. It (define (good expr) (canonicalize/combine-unary (lambda (env) - (scode/make-evaluation - expr - env - (and (not (eq? context 'TOP-LEVEL)) - (not (eq? context 'ONCE-ONLY))))) + (scode/make-evaluation expr + env + (and (not (eq? context 'TOP-LEVEL)) + (not (eq? context 'ONCE-ONLY))) + expr)) nenv)) (cond ((canout-splice? nexpr) @@ -514,65 +511,68 @@ ARBITRARY: The expression may be executed more than once. It ((canonicalize/optimization-low? context) (canonicalize/combine-unary (lambda (exp) - (canonicalize/bind-environment - (canout-expr nexpr) - exp)) + (canonicalize/bind-environment (canout-expr nexpr) + exp + expr)) nenv)) ((not (canout-needs? nexpr)) (good (canout-expr nexpr))) (else - (good (canonicalize/bind-environment - (canout-expr nexpr) - (scode/make-the-environment))))))))) + (good + (canonicalize/bind-environment (canout-expr nexpr) + (scode/make-the-environment) + expr)))))))) ;;;; Hair cubed (define (canonicalize/lambda* expr bound context) (scode/lambda-components expr - (lambda (name required optional rest auxiliary decls body) - (define (wrap code) - (make-canout - (scode/make-directive '(ENCLOSE) - (scode/make-combination (ucode-primitive SCODE-EVAL) - (list (scode/make-quotation - (scode/make-lambda - name required optional rest '() decls code)) - (scode/make-variable environment-variable)))) - false true false)) - - (define (reprocess body) - (let* ((nbody (canonicalize/expression - body '() - (if (canonicalize/optimization-low? context) - 'FIRST-CLASS - 'TOP-LEVEL))) - (nexpr (canonicalize/bind-environment - (canout-expr nbody) - (scode/make-the-environment)))) - (wrap (if (canonicalize/optimization-low? context) + (lambda (name required optional rest auxiliary decls body) + (define (wrap code) + (make-canout + (scode/make-directive + (scode/make-combination (ucode-primitive SCODE-EVAL) + (list (scode/make-quotation + (scode/make-lambda + name required optional rest '() decls code)) + (scode/make-variable environment-variable))) + '(ENCLOSE) + expr) + false true false)) + (let ((nbody + (canonicalize/expression + body + (append required optional + (if rest (list rest) '()) + auxiliary bound) + context))) + (if (canout-safe? nbody) + (make-canout + (scode/make-lambda name required optional rest auxiliary + decls + (canout-expr nbody)) + true + (canout-needs? nbody) + (canout-splice? nbody)) + (let* ((nbody + (canonicalize/expression + (unscan-defines auxiliary decls (canout-expr nbody)) + '() + (if (canonicalize/optimization-low? context) + 'FIRST-CLASS + 'TOP-LEVEL))) + (nexpr + (canonicalize/bind-environment (canout-expr nbody) + (scode/make-the-environment) + body))) + (wrap + (if (canonicalize/optimization-low? context) nexpr - (scode/make-evaluation - nexpr - (scode/make-the-environment) - (eq? context 'ARBITRARY)))))) - - (let ((nbody - (canonicalize/expression - body - (append required optional - (if rest (list rest) '()) - auxiliary bound) - context))) - (if (not (canout-safe? nbody)) - (reprocess - (unscan-defines auxiliary decls (canout-expr nbody))) - (make-canout - (scode/make-lambda name required optional rest auxiliary - decls - (canout-expr nbody)) - true - (canout-needs? nbody) - (canout-splice? nbody))))))) + (scode/make-evaluation nexpr + (scode/make-the-environment) + (eq? context 'ARBITRARY) + expr))))))))) + ;;;; Dispatch (define canonicalize/expression diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index fb6e1ca00..642933ad7 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.17 1989/08/10 11:49:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.18 1989/08/15 12:58:45 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -174,7 +174,7 @@ MIT in each case. |# (make-subproblem (scfg*scfg->scfg! scfg (subproblem-prefix subproblem)) (subproblem-continuation subproblem) (subproblem-rvalue subproblem))) - + (define *virtual-continuations*) (define (virtual-continuation/make block parent type debugging) @@ -196,9 +196,15 @@ MIT in each case. |# (define wrapper/subproblem/value (wrapper/subproblem continuation-type/value)) +(define (make-continuation-debugging-info type expression . rest) + (list->vector (cons* type (scode/original-expression expression) rest))) + (define (generator/subproblem wrapper) - (lambda (block continuation expression debugging) - (wrapper block continuation debugging + (lambda (block continuation expression debugging-type . rest) + (wrapper block + continuation + (and debugging-type + (apply make-continuation-debugging-info debugging-type rest)) (lambda (continuation) (generate/expression block continuation expression))))) @@ -334,24 +340,24 @@ MIT in each case. |# (scode/lambda-components expression (lambda (name required optional rest auxiliary declarations body) (transmit-values (parse-procedure-body auxiliary body) - (lambda (names values body) + (lambda (names values body*) (let ((block (make-block block 'PROCEDURE))) (let ((continuation (make-continuation-variable block)) - (required (make-variables block required)) - (optional (make-variables block optional)) - (rest (and rest (make-variable block rest))) + (required* (make-variables block required)) + (optional* (make-variables block optional)) + (rest* (and rest (make-variable block rest))) (names (make-variables block names))) (set-continuation-variable/type! continuation continuation-type) (set-block-bound-variables! block `(,continuation - ,@required - ,@optional - ,@(if rest (list rest) '()) + ,@required* + ,@optional* + ,@(if rest* (list rest*) '()) ,@names)) (let ((procedure (make-procedure continuation-type/procedure - block name (cons continuation required) optional rest + block name (cons continuation required*) optional* rest* names (map (lambda (value) @@ -364,10 +370,18 @@ MIT in each case. |# value false))) values) - (generate/body block continuation declarations body)))) + (generate/body block continuation declarations body*)))) (if closure-block (set-procedure-closure-context! procedure closure-block)) - (set-procedure-debugging-info! procedure expression) + (set-procedure-debugging-info! + procedure + (if (and + (scode/comment? body) + (scode/comment-directive? (scode/comment-text body))) + (scode/make-lambda name required optional rest auxiliary + declarations + (caddr (scode/comment-text body))) + expression)) procedure))))))))) (define (parse-procedure-body auxiliary body) @@ -440,8 +454,8 @@ MIT in each case. |# (generate/subproblem/effect block continuation action - (vector continuation-type - expression)))) + continuation-type + expression))) (do-result (lambda (expression) (generate/expression block continuation expression)))) @@ -461,11 +475,11 @@ MIT in each case. |# (scode/conditional-components expression (lambda (predicate consequent alternative) (let ((predicate - (generate/subproblem/predicate - block - continuation - predicate - (vector 'CONDITIONAL-DECIDE expression)))) + (generate/subproblem/predicate block + continuation + predicate + 'CONDITIONAL-DECIDE + expression))) (let ((simple (lambda (hooks branch) ((continuation/case continuation @@ -520,7 +534,9 @@ MIT in each case. |# (wrapper/subproblem/value block continuation - (vector 'COMBINATION-OPERAND expression 0) + (make-continuation-debugging-info 'COMBINATION-OPERAND + expression + 0) (lambda (continuation*) (if (scode/lambda? operator) (generate/lambda* block @@ -534,11 +550,12 @@ MIT in each case. |# (let loop ((operands operands) (index 1)) (if (null? operands) '() - (cons (generate/subproblem/value - block - continuation - (car operands) - (vector 'COMBINATION-OPERAND expression index)) + (cons (generate/subproblem/value block + continuation + (car operands) + 'COMBINATION-OPERAND + expression + index) (loop (cdr operands) (1+ index))))) push)))) ((continuation/case continuation @@ -556,11 +573,12 @@ MIT in each case. |# (lambda () (if (eq? not operator) (pcfg*pcfg->pcfg! - (generate/subproblem/predicate - block - continuation - (car operands) - (vector 'COMBINATION-OPERAND expression 1)) + (generate/subproblem/predicate block + continuation + (car operands) + 'COMBINATION-OPERAND + expression + 1) (generate/expression block continuation false) (generate/expression block continuation true)) (with-reified-continuation block @@ -587,11 +605,11 @@ MIT in each case. |# (define (generate/assignment* maker find-name continuation-type block continuation expression name value) (let ((subproblem - (generate/subproblem/value - block - continuation - value - (vector continuation-type expression)))) + (generate/subproblem/value block + continuation + value + continuation-type + expression))) (scfg-append! (if (subproblem-canonical? subproblem) (make-scfg @@ -692,10 +710,8 @@ MIT in each case. |# (define (generate/comment block continuation comment) (scode/comment-components comment (lambda (text expression) - (if (or (not (pair? text)) - (not (eq? (car text) comment-tag:directive)) - (null? (cdr text)) - (not (pair? (cadr text)))) (generate/expression block continuation expression) + (if (not (scode/comment-directive? text)) + (generate/expression block continuation expression) (case (caadr text) ((PROCESSED) (generate/expression block continuation expression)) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 5ee0da965..37c93b7d5 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.47 1989/08/11 02:30:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.48 1989/08/15 12:59:19 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (Motorola MC68020)" 4 47 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 48 '())) \ No newline at end of file