NEW-DBG-EXPRESSIONs now have a pointer to the scode for their

containing combination.  This is to assist in creating
NEW-DBG-CONTINUATIONs for continuations that did not previously exist
in the user's program.

diff --git a/v8/src/compiler/midend/dbgstr.scm b/v8/src/compiler/midend/dbgstr.scm
index 22f958fe67fc0d2d7fb293d17c901c71794ba383..efcb1b737098d166c4c9ef2c771d1a8ccd333be2 100644 (file)
--- a/v8/src/compiler/midend/dbgstr.scm
+++ b/v8/src/compiler/midend/dbgstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dbgstr.scm,v 1.16 1995/07/27 14:25:55 adams Exp $
+$Id: dbgstr.scm,v 1.17 1995/08/18 23:53:54 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -41,8 +41,8 @@ MIT in each case. |#
       ((ucode-primitive string->symbol)
        "#[(runtime compiler-info)new-dbg-expression]"))
      (conc-name new-dbg-expression/)
-     (constructor new-dbg-expression/make (source-code))
-     (constructor new-dbg-expression/make2 (source-code block))
+     (constructor new-dbg-expression/make (source-code outer))
+     (constructor new-dbg-expression/make2 (source-code block outer))
      (print-procedure
       (standard-unparser-method 'NEW-DBG-EXPRESSION
        (lambda (expr port)
@@ -50,12 +50,14 @@ MIT in each case. |#
          (display (new-dbg-expression/source-code expr) port)))))
   (block false read-only false)
   (label false)
-  (source-code false))
+  (source-code false)                  ; SCode
+  (outer false))                       ; SCode countaining form, or #F
 
 
 (define (new-dbg-expression/new-block dbg-expr block*)
   (new-dbg-expression/make2 (new-dbg-expression/source-code dbg-expr)
-                           block*))
+                           block*
+                           (new-dbg-expression/outer dbg-expr)))
 
 (define-structure
     (new-dbg-procedure
@@ -211,20 +213,29 @@ MIT in each case. |#
                  element)))))
 
 (define (new-dbg-continuation->old-dbg-continuation label frame-size new-info)
-  frame-size
+  frame-size                           ; ignored
   (and new-info
-       (new-dbg-continuation/outer new-info)
+       ;;(new-dbg-continuation/outer new-info)
        (new-dbg-continuation/inner new-info)
-       (let ((aggregate
-             (new-dbg-expression/source-code
-              (new-dbg-continuation/outer new-info)))
-            (element
-             (new-dbg-expression/source-code
-              (new-dbg-continuation/inner new-info))))      
-        (set-new-dbg-continuation/label! new-info label)
-        (set-new-dbg-continuation/outer! new-info aggregate)
-        (set-new-dbg-continuation/inner! new-info element)
-        new-info)))
+       (let* ((element
+              (new-dbg-expression/source-code
+               (new-dbg-continuation/inner new-info)))
+             (aggregate
+              ;; This condition is true when a user level form has internal
+              ;; invisible continuations
+              (if (or (not (new-dbg-continuation/outer new-info))
+                      (eq? (new-dbg-continuation/outer new-info)
+                           (new-dbg-continuation/inner new-info)))
+                  (new-dbg-expression/outer
+                   (new-dbg-continuation/inner new-info))
+                  (new-dbg-expression/source-code
+                   (new-dbg-continuation/outer new-info)))))
+        (and aggregate
+             (begin
+               (set-new-dbg-continuation/label! new-info label)
+               (set-new-dbg-continuation/outer! new-info aggregate)
+               (set-new-dbg-continuation/inner! new-info element)
+               new-info)))))
 
 \f
 (define (new-dbg-form/block object)

diff --git a/v8/src/compiler/midend/expand.scm b/v8/src/compiler/midend/expand.scm
index e763deb7056e3fee2c38a32a3b7b53456e666754..c786031e90a24efa7a8af33d3c2da87ef63e5aee 100644 (file)
--- a/v8/src/compiler/midend/expand.scm
+++ b/v8/src/compiler/midend/expand.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: expand.scm,v 1.5 1995/04/29 00:57:30 adams Exp $
+$Id: expand.scm,v 1.6 1995/08/18 23:53:47 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -97,7 +97,8 @@ MIT in each case. |#
         (expand/remember*
          new-form
          (new-dbg-expression/make2 false
-                                   (new-dbg-procedure/block info))))))
+                                   (new-dbg-procedure/block info)
+                                   (new-dbg-procedure/outer info))))))
 
 (define-expander LET (bindings body)
   (expand/let* expand/letify bindings body))

diff --git a/v8/src/compiler/midend/inlate.scm b/v8/src/compiler/midend/inlate.scm
index 5340858a76b4c17268a03bbbc7b31cbce3abf0d4..b9087dce633e7c2f1294d3c30cef38226dda4467 100644 (file)
--- a/v8/src/compiler/midend/inlate.scm
+++ b/v8/src/compiler/midend/inlate.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: inlate.scm,v 1.5 1995/07/08 15:01:34 adams Exp $
+$Id: inlate.scm,v 1.6 1995/08/18 23:54:03 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -38,19 +38,19 @@ MIT in each case. |#
 (declare (usual-integrations))
 \f
 (define (inlate/top-level scode)
-  (inlate/remember (inlate/scode scode)
-                  (new-dbg-expression/make scode)))
+  (inlate/remember (inlate/scode scode #F)
+                  (new-dbg-expression/make scode #F)))
 
 (define-macro (define-inlator scode-type components . body)
   (let ((proc-name (symbol-append 'INLATE/ scode-type))
        (destructor (symbol-append scode-type '-COMPONENTS)))
-    `(define ,proc-name
-       (let ((handler (lambda ,components ,@body)))
-        (named-lambda (,proc-name form)
-          (inlate/remember (,destructor form handler)
-                           (new-dbg-expression/make form)))))))
+    `(DEFINE ,proc-name
+       (NAMED-LAMBDA (,proc-name FORM OUTER-FORM)
+        (LET ((HANDLER (LAMBDA ,components ,@body)))
+          (INLATE/REMEMBER (,destructor FORM HANDLER)
+                           (NEW-DBG-EXPRESSION/MAKE FORM OUTER-FORM)))))))
 
-(define (inlate/sequence+ form)
+(define (inlate/sequence+ form outer-form)
   ;; Kludge
   (if (not (open-block? form))
       (inlate/sequence form)
@@ -59,11 +59,13 @@ MIT in each case. |#
         (if (sequence? form*)
             (beginnify
              (inlate/map-declarations
-              (map inlate/scode (sequence-actions form*))))
-            (inlate/scode form*)))
-       (new-dbg-expression/make form))))
+              (map (lambda (action) (inlate/scode action form))
+                   (sequence-actions form*))))
+            (inlate/scode form* form)))
+       (new-dbg-expression/make form outer-form))))
 
-(define (inlate/constant object)
+(define (inlate/constant object outer-form)
+  outer-form
   `(QUOTE ,(if (unassigned-reference-trap? object) %unassigned object)))
 
 (define (inlate/map-declarations exprs)
@@ -80,15 +82,16 @@ MIT in each case. |#
   `(LOOKUP ,name))
 
 (define-inlator ASSIGNMENT (name svalue)
-  `(SET! ,name ,(inlate/scode svalue)))
+  `(SET! ,name ,(inlate/scode svalue form)))
 
 (define-inlator DEFINITION (name svalue)
-  `(DEFINE ,name ,(inlate/scode svalue)))
+  `(DEFINE ,name ,(inlate/scode svalue form)))
 
 (define-inlator THE-ENVIRONMENT ()
   `(THE-ENVIRONMENT))
 
-(define (inlate/lambda form)
+(define (inlate/lambda form outer-form)
+  outer-form                           ; ignored
   (lambda-components form
     (lambda (name req opt rest aux decls sbody)
       name                             ; Not used
@@ -105,7 +108,7 @@ MIT in each case. |#
                          (cons '#!AUX aux))))
             (new
              `(LAMBDA ,(cons (new-continuation-variable) lambda-list)
-                ,(let ((body (inlate/scode sbody)))
+                ,(let ((body (inlate/scode sbody #F)))
                    (if (null? decls)
                        body
                        (beginnify
@@ -134,8 +137,8 @@ MIT in each case. |#
 |#
 \f
 (define-inlator IN-PACKAGE (environment expression)
-  `(IN-PACKAGE ,(inlate/scode environment)
-     ,(inlate/scode expression)))
+  `(IN-PACKAGE ,(inlate/scode environment form)
+     ,(inlate/scode expression #F)))
 
 (define-inlator COMBINATION (rator rands)
   (let-syntax ((ucode-primitive
@@ -153,31 +156,34 @@ MIT in each case. |#
               (not (null? (cdr rands)))
               (symbol? (cadr rands)))
          `(UNASSIGNED? ,(cadr rands))
-         `(CALL ,(inlate/scode rator)
+         `(CALL ,(inlate/scode rator form)
                 (QUOTE #F)             ; continuation
-                ,@(map inlate/scode rands))))))
+                ,@(map (lambda (rand) (inlate/scode rand form))
+                       rands))))))
 
 (define-inlator COMMENT (text body)
   text                                 ; ignored
-  (inlate/scode body))
+  (inlate/scode body form))
 
 (define-inlator SEQUENCE (actions)
-  (beginnify (map inlate/scode actions)))
+  (beginnify
+   (map (lambda (action) (inlate/scode action form))
+       actions)))
      
 (define-inlator CONDITIONAL (pred conseq alt)
-  `(IF ,(inlate/scode pred)
-       ,(inlate/scode conseq)
-       ,(inlate/scode alt)))
+  `(IF ,(inlate/scode pred form)
+       ,(inlate/scode conseq form)
+       ,(inlate/scode alt form)))
 
 (define-inlator DISJUNCTION (pred alt)
-  `(OR ,(inlate/scode pred)
-       ,(inlate/scode alt)))
+  `(OR ,(inlate/scode pred form)
+       ,(inlate/scode alt form)))
 
 (define-inlator ACCESS (environment name)
-  `(ACCESS ,name ,(inlate/scode environment)))
+  `(ACCESS ,name ,(inlate/scode environment form)))
 
 (define-inlator DELAY (expression)
-  `(DELAY ,(inlate/scode expression)))
+  `(DELAY ,(inlate/scode expression form)))
 \f
 (define inlate/scode
   (let ((dispatch-vector
@@ -187,8 +193,8 @@ MIT in each case. |#
        ((dispatch-entry
          (macro (type handler)
            `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type)
-                         (LAMBDA (EXPR)
-                           (,handler EXPR))))))
+                         (LAMBDA (EXPR OUTER-FORM)
+                           (,handler EXPR OUTER-FORM))))))
 
       (let-syntax
          ((dispatch-entries
@@ -220,9 +226,10 @@ MIT in each case. |#
        (dispatch-entries (lambda lexpr extended-lambda) inlate/lambda)
        (dispatch-entries (sequence-2 sequence-3) inlate/sequence+))
 
-      (named-lambda (inlate/expression expression)
+      (named-lambda (inlate/expression expression outer-form)
        ((vector-ref dispatch-vector (object-type expression))
-        expression)))))
+        expression
+        outer-form)))))
 
 ;; Utilities