DBG-REDUCE now stored %stack-closure-ref (and also %read-closure-ref)

expressions in a compact form as this is the dominant expression kind.

CLOSCONV generates these expressions directly, and DBG-INFO/REMEMBER
converts others.  STACKOPT is modified to update the stack frame
ordering and INDEXIFY leaves them alone (the call to vectro-index
occurs in DBG info generation).

diff --git a/v8/src/compiler/midend/closconv.scm b/v8/src/compiler/midend/closconv.scm
index 0d74b3c24e5b1c0b4ef4b7abea1379681e502e61..7651fcc13a219d0da34f878588097075060337d4 100644 (file)
--- a/v8/src/compiler/midend/closconv.scm
+++ b/v8/src/compiler/midend/closconv.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: closconv.scm,v 1.8 1995/07/04 19:20:29 adams Exp $
+$Id: closconv.scm,v 1.9 1995/08/04 19:47:20 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -562,6 +562,9 @@ MIT in each case. |#
                          (QUOTE ,closed-over-names)
                          (QUOTE ,name))
                    (QUOTE ,name)))
+          (define (dbg-reference-expression)
+            (dbg/make-closure-ref %closure-ref
+                                  closure-name closed-over-names name))
           (define (self-reference-expression)
             `(LOOKUP ,closure-name))
           (define (rewrite-self-reference! ref)
@@ -572,7 +575,7 @@ MIT in each case. |#
           (dbg-info/remember name
                              (if (eq? binding self-binding)
                                  (self-reference-expression)
-                                 (reference-expression)))
+                                 (dbg-reference-expression)))
 
           (for-each (if (eq? (car free-ref) self-binding)
                         rewrite-self-reference!

diff --git a/v8/src/compiler/midend/dbgred.scm b/v8/src/compiler/midend/dbgred.scm
index adcd7f2d876a5898bb0d93981431cd562ec12d80..c1317eff109d45b12c905ddfcb7ffb7e4ae5b83b 100644 (file)
--- a/v8/src/compiler/midend/dbgred.scm
+++ b/v8/src/compiler/midend/dbgred.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dbgred.scm,v 1.11 1995/08/03 23:28:21 adams Exp $
+$Id: dbgred.scm,v 1.12 1995/08/04 19:48:50 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -196,7 +196,7 @@ reachable.
                  (let ((edge
                         (dbg-red/node/add-edge! node `(CC-ENTRY . ,name))))
                    (dbg-red/edge/statically-available! edge))
-                 (internal-warning "Node absent" node)))))
+                 (internal-warning "Node absent" name)))))
     bindings))
 
 (define-dbg-reducer IF (pred conseq alt)
@@ -424,11 +424,15 @@ reachable.
 
       (let walk ((expr expr))
        (cond ((symbol? expr) (add-reference! expr))
-             ((not (pair? expr)) unspecific)
              ((LOOKUP/? expr) (add-reference! (lookup/name expr)))
              ((QUOTE/? expr)  unspecific)
+             ((dbg/stack-closure-ref? expr)
+              (walk (vector-ref expr 1)))
+             ((dbg/heap-closure-ref? expr)
+              (walk (vector-ref expr 1)))
              ((CALL/? expr)
               (for-each walk (call/operands expr)))
+             ((not (pair? expr)) unspecific)
              (else ;;(pp expr)
                    unspecific))))
 
@@ -524,6 +528,7 @@ reachable.
 \f
 (define dbg-red/reconstruct-path
   (lambda (item graph env)
+
     (define (reconstruct-name item)
       (cond ((dbg-reduce/env/lookup env item)
             => (lambda (offset-or-name)
@@ -577,22 +582,20 @@ reachable.
                 `((INTEGRATED . ,(quote/text expr)))))
            ((LOOKUP/? expr) (reconstruct-name (lookup/name expr)))
            ((symbol? expr)  (reconstruct-name expr))
-           ((CALL/%stack-closure-ref? expr)
-            (let ((frame   (call/%stack-closure-ref/closure expr))
-                  (offset  (call/%stack-closure-ref/offset expr)))
-              (and (LOOKUP/? frame)
-                   (QUOTE/? offset)
-                   (eq? (lookup/name frame) (dbg-reduce/env/frame-name env))
-                   (list (dbgred/STACK (quote/text offset))))))
-           ((CALL/%heap-closure-ref? expr)
-            (let ((closure (call/%heap-closure-ref/closure expr))
-                  (offset  (call/%heap-closure-ref/offset expr)))
-              (let ((closure-path (reconstruct-expression closure)))
-                (and closure-path
-                     (QUOTE/? offset)
-                     (cons (dbgred/CLOSURE (+ (quote/text offset)
-                                              (rtlgen/closure-first-offset)))
-                           closure-path)))))
+           ((dbg/stack-closure-ref? expr)
+            (let ((frame   (vector-ref expr 1))
+                  (offset
+                   (vector-index (vector-ref expr 2) (vector-ref expr 3))))
+              (and (eq? frame (dbg-reduce/env/frame-name env))
+                   (list (dbgred/STACK offset)))))
+           ((dbg/heap-closure-ref? expr)
+            (let ((closure-path (reconstruct-expression (vector-ref expr 1)))
+                  (offset
+                   (vector-index (vector-ref expr 2) (vector-ref expr 3))))
+              (and closure-path
+                   (cons (dbgred/CLOSURE (+ offset
+                                            (rtlgen/closure-first-offset)))
+                         closure-path))))
            ((CALL/%multicell-ref? expr)
             (let ((cell-path
                    (reconstruct-expression (call/%multicell-ref/cell expr)))
@@ -605,6 +608,9 @@ reachable.
                           (vector-index (quote/text layout)
                                         (quote/text name)))
                          cell-path))))
+           ((or (CALL/%stack-closure-ref? expr)
+                (CALL/%heap-closure-ref? expr))
+            (internal-error "DBG expression should have been compressed" expr))
            ((and (pair? expr)
                  (eq? (car expr) 'CC-ENTRY))
             (list expr))
@@ -720,30 +726,71 @@ reachable.
 ;; tracking of representation and naming changes for generating debugging
 ;; info.
         
+;; Compact representation of closure reference expressions
+
+(define (dbg/make-closure-ref op closure elements-vector name)
+  (vector op closure elements-vector name))
+
+(define (dbg/stack-closure-ref? thing)
+  (and (vector? thing)
+       (eq? (vector-ref thing 0) %stack-closure-ref)))
+
+(define (dbg/heap-closure-ref? thing)
+  (and (vector? thing)
+       (eq? (vector-ref thing 0) %heap-closure-ref)))
+
+(define (dbg-red/compress-expression form)
+  (define (compress-closure-ref op)
+    ;; (CALL '%*-closure-ref '#F <closure> <index> 'name)
+    (let* ((closure (dbg-red/compress-expression (fourth form)))
+          (ix-expr (fifth form))
+          (name (quote/text (sixth form))))
+      (vector op closure (if (QUOTE/? ix-expr)
+                            (quote/text ix-expr)
+                            (quote/text (CALL/%vector-index/vector ix-expr)))
+             name)))
+
+  (define (compress-ordinary-call form)
+    (let ((exprs* (map dbg-red/compress-expression (call/operands form))))
+      (if (there-exists? exprs* false?)
+         #F
+         `(CALL ,(call/operator form) ,(call/continuation form) ,@exprs*))))
+
+  (cond ((QUOTE/? form) form)
+       ((symbol? form) form)
+       ((LOOKUP/? form) (lookup/name form))
+       ((and (CALL/? form)
+             (QUOTE/? (call/operator form)))
+        (let ((op (quote/text (call/operator form))))
+          (cond ((or (eq? op %stack-closure-ref)
+                     (eq? op %heap-closure-ref))
+                 (compress-closure-ref op))
+                ((hash-table/get *dbg-forbidden-operators* op #F) #F)
+                (else
+                 (compress-ordinary-call form)))))
+       (else #F)))
+
 (define *dbg-rewrites*)
 
 (define (dbg-info/make-rewrites)
   (cons 'HEAD '()))
 
-(define (dbg-info/remember from to)
-
-  (let ((to (if (LOOKUP/? to) (lookup/name to) to)))
-    (define (good)
-      (set-cdr! *dbg-rewrites*
-               (cons (vector from to) (cdr *dbg-rewrites*))))
-
-    (cond ((eq? from to))
-         ((CALL/? to)
-          (if (QUOTE/? (call/operator to))
-              (let ((op (quote/text (call/operator to))))
-                (cond ((hash-table/get *dbg-forbidden-operators* op #F))
-                      ((hash-table/get dbg-reduce/equivalent-operators op #F)
-                       (good))
-                      ((primitive-procedure? op))
-                      (else            ; a fakeprim
-                       (good))))))
-         ((continuation-variable? from))
-         (else (good)))))
+(define (dbg-info/remember from to*)
+  (define (good to)
+    (set-cdr! *dbg-rewrites*
+             (cons (vector from to) (cdr *dbg-rewrites*))))
+  (cond ((continuation-variable? from))
+       ((dbg/stack-closure-ref? to*) (good to*))
+       ((dbg/heap-closure-ref? to*) (good to*))
+       (else
+        (let ((to (dbg-red/compress-expression to*)))
+          (cond ((eq? from to))
+                ((false? to)
+                 #|(fluid-let ((*unparser-list-breadth-limit* 7)
+                             (*unparser-list-depth-limit* 6))
+                   (pp `(reject ,from ,to*)))|#)
+                (else (good to)))))))
+
 
 (define *dbg-forbidden-operators* (make-eq-hash-table))
 

diff --git a/v8/src/compiler/midend/indexify.scm b/v8/src/compiler/midend/indexify.scm
index 79c60d5177e47906e19cb8841593cc3afa10aaf5..3c45682f68f2e24d3cfcce807fcfc30a9965ad0e 100644 (file)
--- a/v8/src/compiler/midend/indexify.scm
+++ b/v8/src/compiler/midend/indexify.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: indexify.scm,v 1.4 1995/06/15 18:01:55 adams Exp $
+$Id: indexify.scm,v 1.5 1995/08/04 19:46:23 adams Exp $
 
-Copyright (c) 1994 Massachusetts Institute of Technology
+Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -127,12 +127,17 @@ MIT in each case. |#
 
 (define (indexify/do-dbg-info!)
   (define (rewrite-indexifies! expr)
-    (cond ((QUOTE/? expr))
+    (cond ((dbg/stack-closure-ref? expr)
+          (rewrite-indexifies! (vector-ref expr 1)))
+          ((dbg/heap-closure-ref? expr)
+          (rewrite-indexifies! (vector-ref expr 1)))
+         ((QUOTE/? expr))
          ((LOOKUP/? expr))
          ((and (CALL/? expr)
                (QUOTE/? (call/operator expr))
                (eq? %vector-index (quote/text (call/operator expr)))
                (for-all? (call/cont-and-operands expr) QUOTE/?))
+          (internal-error "%vector-index found in DBG info")
           (let ((rands (call/operands expr)))
             (form/rewrite! expr
               `(QUOTE ,(vector-index (QUOTE/text (first rands))

diff --git a/v8/src/compiler/midend/stackopt.scm b/v8/src/compiler/midend/stackopt.scm
index 846b7be26abf09b913ab7d0fbd00e4240bdfe9af..7fc189addf3ab5fc3cd74039b3c77069b9892958 100644 (file)
--- a/v8/src/compiler/midend/stackopt.scm
+++ b/v8/src/compiler/midend/stackopt.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: stackopt.scm,v 1.11 1995/08/03 00:17:40 adams Exp $
+$Id: stackopt.scm,v 1.12 1995/08/04 19:45:23 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -119,7 +119,10 @@ End of Big Note A |#
 
 \f
 (define (stackopt/top-level program)
-  (stackopt/expr false program))
+  (fluid-let ((stackopt/dbg-refs (stackopt/get-dbg-refs)))
+    (stackopt/expr false program)))
+
+(define stackopt/dbg-refs) ; table from frame name to dbg info references
 
 (define-macro (define-stack-optimizer keyword bindings . body)
   (let ((proc-name (symbol-append 'STACKOPT/ keyword)))
@@ -369,6 +372,7 @@ End of Big Note A |#
   ;;Following test wrong: (lambda () (subproblem) (lambda (a1 ... a100) ...))
   ;;(if state
   ;;    (internal-error "Model exists at non-continuation lambda!" state))
+  state
   (let* ((frame-vector  (cadr (assq stackopt/?frame-vector match-result)))
         (frame-name    (cadr (assq stackopt/?frame-name match-result)))
         (model  (stackopt/model/make #F (vector-copy frame-vector) frame-name
@@ -524,16 +528,28 @@ End of Big Note A |#
                   ,(call/%make-stack-closure/vector form)
                   ,@values*))))))
 
+(define (stackopt/get-dbg-refs)
+  (let ((info (make-eq-hash-table)))
+    (define (walk expr)
+      (cond ((dbg/stack-closure-ref? expr)
+            (let ((frame-var (vector-ref expr 1)))
+              (hash-table/put!
+               info
+               frame-var
+               (cons expr
+                     (hash-table/get info frame-var '())))))
+           ((dbg/heap-closure-ref? expr)
+            (walk (vector-ref expr 1)))
+           ((CALL/? expr)
+            (for-each walk (call/operands expr)))
+           (else unspecific)))
+    (dbg-info/for-all-dbg-expressions! walk)
+    info))
+
 (define (stackopt/rewrite-dbg-frames! frame-var new-vector)
-  (dbg-info/for-all-dbg-expressions!
-   (lambda (expr)
-     (if (and (call/%stack-closure-ref? expr)
-             (eq? (lookup/name (call/%stack-closure-ref/closure expr))
-                  frame-var))
-        (let* ((ix-expr (call/%stack-closure-ref/offset expr))
-               (quoted-vector (call/%vector-index/vector ix-expr)))
-          (form/rewrite! quoted-vector
-            `(QUOTE ,new-vector)))))))
+  (for-each (lambda (ref)
+             (vector-set! ref 2 new-vector))
+    (hash-table/get stackopt/dbg-refs frame-var '())))
 \f
 (define (stackopt/rearrange! model wired)
   (define (arrange-locally! model)