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 8a9ce7247ba76ef3c48bf49beed7cfdba5c93d11..7da2e54ea18d47a6642927fc6cb6e1e24c8a690f 100644 (file)
--- 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 bc09511d6b35953ac4e016f36de81edac137d928..afeee25ecc77b59db16e7ccb40745bda898f9cac 100644 (file)
--- 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)))))
 \f
 ;;;; 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)))))
-\f 
+ 
   (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)))))
 \f
 ;;;; Variables and assignment
 
@@ -356,7 +350,7 @@ ARBITRARY:  The expression may be executed more than once.  It
             bound
             context))))))
 \f
-;;;; 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))))))))
 \f
 ;;;; 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))))))))
 \f
 ;;;; 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)))))))\f
+                  (scode/make-evaluation nexpr
+                                         (scode/make-the-environment)
+                                         (eq? context 'ARBITRARY)
+                                         expr)))))))))
+\f
 ;;;; Dispatch
 
 (define canonicalize/expression

diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
index fb6e1ca00197f71148b4ed356eee459d5e6fd08c..642933ad754b1800ff50e8f51cdaa4a8ae84af8f 100644 (file)
--- 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)))
-\f
+
 (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)))))))))
 \f
 (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 5ee0da96577379b4d52176b3f804fd983faefd6e..37c93b7d5b7854f0bf711339987c2ecaf1cc3f96 100644 (file)
--- 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