Add new analysis to determine how RTL basic blocks are related by

continuations.  Attempt to order the linearized RTL and LAP so that
continuations come out nearer to where they are referenced.  A unique
continuation (very common) tries to come out immediately following the
invocation of the procedure that returns to it.

diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm
index 718cf9e0d79ee81385aca873757c9537107e2b68..e081523691565ea8425eb2c95134edb2ab8784f0 100644 (file)
--- a/v7/src/compiler/back/linear.scm
+++ b/v7/src/compiler/back/linear.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.2 1988/06/14 08:10:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.3 1988/09/07 06:23:24 cph Exp $
 
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -36,53 +36,58 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 \f
-(define (bblock-linearize-bits bblock)
-  (node-mark! bblock)
-  (if (and (not (bblock-label bblock))
-          (node-previous>1? bblock))
-      (bblock-label! bblock))
-  (let ((kernel
-        (lambda ()
-          (LAP ,@(bblock-instructions bblock)
-               ,@(if (sblock? bblock)
-                     (linearize-sblock-next (snode-next bblock))
-                     (linearize-pblock bblock
-                                       (pnode-consequent bblock)
-                                       (pnode-alternative bblock)))))))
-    (if (bblock-label bblock)
-       (LAP ,(lap:make-label-statement (bblock-label bblock)) ,@(kernel))
-       (kernel))))
+(define (bblock-linearize-bits bblock queue-continuations!)
+  (define (linearize-bblock bblock)
+    (node-mark! bblock)
+    (queue-continuations! bblock)
+    (if (and (not (bblock-label bblock))
+            (node-previous>1? bblock))
+       (bblock-label! bblock))
+    (let ((kernel
+          (lambda ()
+            (LAP ,@(bblock-instructions bblock)
+                 ,@(if (sblock? bblock)
+                       (linearize-sblock-next
+                        (or (snode-next bblock)
+                            (sblock-continuation bblock)))
+                       (linearize-pblock bblock
+                                         (pnode-consequent bblock)
+                                         (pnode-alternative bblock)))))))
+      (if (bblock-label bblock)
+         (LAP ,(lap:make-label-statement (bblock-label bblock)) ,@(kernel))
+         (kernel))))
 
-(define (linearize-sblock-next bblock)
-  (cond ((not bblock) (LAP))
-       ((node-marked? bblock)
-        (LAP ,(lap:make-unconditional-branch (bblock-label! bblock))))
-       (else (bblock-linearize-bits bblock))))
+  (define (linearize-sblock-next bblock)
+    (cond ((not bblock) (LAP))
+         ((node-marked? bblock)
+          (LAP ,(lap:make-unconditional-branch (bblock-label! bblock))))
+         (else (linearize-bblock bblock))))
 
-(define (linearize-pblock pblock cn an)
-  (if (node-marked? cn)
-      (if (node-marked? an)
-         (LAP ,@((pblock-consequent-lap-generator pblock) (bblock-label! cn))
-              ,(lap:make-unconditional-branch (bblock-label! an)))
-         (LAP ,@((pblock-consequent-lap-generator pblock) (bblock-label! cn))
-              ,@(bblock-linearize-bits an)))
-      (if (node-marked? an)
-         (LAP ,@((pblock-alternative-lap-generator pblock) (bblock-label! an))
-              ,@(bblock-linearize-bits cn))
-         (let ((label (bblock-label! cn))
-               (alternative (bblock-linearize-bits an)))
-           (LAP ,@((pblock-consequent-lap-generator pblock) label)
-                ,@alternative
-                ,@(if (node-marked? cn)
-                      (LAP)
-                      (bblock-linearize-bits cn)))))))
+  (define (linearize-pblock pblock cn an)
+    (if (node-marked? cn)
+       (if (node-marked? an)
+           (LAP ,@((pblock-consequent-lap-generator pblock)
+                   (bblock-label! cn))
+                ,(lap:make-unconditional-branch (bblock-label! an)))
+           (LAP ,@((pblock-consequent-lap-generator pblock)
+                   (bblock-label! cn))
+                ,@(linearize-bblock an)))
+       (if (node-marked? an)
+           (LAP ,@((pblock-alternative-lap-generator pblock)
+                   (bblock-label! an))
+                ,@(linearize-bblock cn))
+           (let ((label (bblock-label! cn))
+                 (alternative (linearize-bblock an)))
+             (LAP ,@((pblock-consequent-lap-generator pblock) label)
+                  ,@alternative
+                  ,@(if (node-marked? cn)
+                        (LAP)
+                        (linearize-bblock cn)))))))
 
-(define (map-lap procedure objects)
-  (let loop ((objects objects))
-    (if (null? objects)
-       (LAP)
-       (LAP ,@(procedure (car objects))
-            ,@(loop (cdr objects))))))
+  (linearize-bblock bblock))
 
 (define linearize-bits
-  (make-linearizer map-lap bblock-linearize-bits))
\ No newline at end of file
+  (make-linearizer bblock-linearize-bits
+    (lambda () (LAP))
+    (lambda (x y) (LAP ,@x ,@y))
+    identity-procedure))
\ No newline at end of file

diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm
index c7c021f79420167b1c3ce016f747ca217ba2b12c..ab65e3a7c2b9369c72e22904246999d4c2da518d 100644 (file)
--- a/v7/src/compiler/rtlbase/rtline.scm
+++ b/v7/src/compiler/rtlbase/rtline.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.3 1988/06/14 08:37:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.4 1988/09/07 06:22:54 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -35,66 +35,151 @@ MIT in each case. |#
 ;;;; RTL linearizer
 
 (declare (usual-integrations))
-
+\f
+(define ((make-linearizer bblock-linearize
+                         initial-value
+                         instruction-append!
+                         final-value)
+        expression procedures continuations)
+  continuations                                ;ignore
+  (with-new-node-marks
+   (lambda ()
+     (let ((input-queue (make-queue))
+          (output (initial-value)))
+       (let ((queue-continuations!
+             (lambda (bblock)
+               (for-each (lambda (bblock)
+                           (enqueue!/unsafe input-queue bblock))
+                         (bblock-continuations bblock)))))
+        (let ((process-bblock!
+               (lambda (bblock)
+                 (if (not (node-marked? bblock))
+                     (begin
+                       (set! output
+                             (instruction-append!
+                              output
+                              (bblock-linearize bblock
+                                                queue-continuations!))))))))
+          (process-bblock! (rtl-expr/entry-node expression))      (queue-map!/unsafe input-queue process-bblock!)
+          (for-each (lambda (procedure)
+                      (process-bblock! (rtl-procedure/entry-node procedure))
+                      (queue-map!/unsafe input-queue process-bblock!))
+                    procedures)
+          (final-value output)))))))
+
+(define (setup-bblock-continuations! rgraphs)
+  (for-each
+   (lambda (rgraph)
+     (for-each
+      (lambda (bblock)
+       (let ((continuations '()))
+         (bblock-walk-forward bblock
+           (lambda (rinst)
+             (for-each (lambda (continuation)
+                         (if (not (memq continuation continuations))
+                             (set! continuations
+                                   (cons continuation continuations))))
+                       (rtl:continuations-mentioned (rinst-rtl rinst)))))
+         (set-bblock-continuations! bblock
+                                    (map label->continuation-entry
+                                         continuations)))
+       (if (sblock? bblock)
+           (let ((rtl (rinst-rtl (rinst-last (bblock-instructions bblock)))))
+             (if (rtl:invocation? rtl)
+                 (let ((continuation (rtl:invocation-continuation rtl)))
+                   (if continuation
+                       (set-sblock-continuation!
+                        bblock
+                        (label->continuation-entry continuation))))))))
+      (rgraph-bblocks rgraph)))
+   rgraphs))
+
+(define-integrable (label->continuation-entry label)
+  (rtl-continuation/entry-node (label->object label)))
+
+(define (rtl:continuations-mentioned rtl)
+  (define (loop expression)
+    (if (pair? expression)
+       (case (car expression)
+         ((CONSTANT)
+          '())
+         ((ENTRY:CONTINUATION)
+          (list (cadr expression)))
+         (else
+          (mapcan loop (cdr expression))))
+       '()))
+  (mapcan loop (cdr rtl)))
+\f
 ;;; The linearizer attaches labels to nodes under two conditions.  The
 ;;; first is that the node in question has more than one previous
 ;;; neighboring node.  The other is when a conditional branch requires
 ;;; such a label.  It is assumed that if one encounters a node that
 ;;; has already been linearized, that it has a label, since this
 ;;; implies that it has more than one previous neighbor.
-\f
-(package (bblock-linearize-rtl)
-
-(define-export (bblock-linearize-rtl bblock)
-  (node-mark! bblock)
-  (if (and (not (bblock-label bblock))
-          (node-previous>1? bblock))
-      (bblock-label! bblock))
-  (let ((kernel
-        (lambda ()
-          (let loop ((rinst (bblock-instructions bblock)))
-            (cond ((rinst-next rinst)
-                   (cons (rinst-rtl rinst)
-                         (loop (rinst-next rinst))))
-                  ((sblock? bblock)
-                   (cons (rinst-rtl rinst)
-                         (linearize-sblock-next (snode-next bblock))))
-                  (else
-                   (linearize-pblock bblock
-                                     (rinst-rtl rinst)
-                                     (pnode-consequent bblock)
-                                     (pnode-alternative bblock))))))))
-    (if (bblock-label bblock)
-       `(,(rtl:make-label-statement (bblock-label bblock)) ,@(kernel))
-       (kernel))))
-
-(define (linearize-sblock-next bblock)
-  (cond ((not bblock) '())
-       ((node-marked? bblock)
-        `(,(rtl:make-jump-statement (bblock-label! bblock))))
-       (else (bblock-linearize-rtl bblock))))
-
-(define (linearize-pblock pblock predicate cn an)
-  pblock
-  (if (node-marked? cn)
-      (if (node-marked? an)
-         `(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
-           ,(rtl:make-jump-statement (bblock-label! an)))
-         `(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
-           ,@(bblock-linearize-rtl an)))
-      (if (node-marked? an)
-         `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
-                                      (bblock-label! an))
-           ,@(bblock-linearize-rtl cn))
-         (let ((label (bblock-label! cn))
-               (alternative (bblock-linearize-rtl an)))
-           `(,(rtl:make-jumpc-statement predicate label)
-             ,@alternative
-             ,@(if (node-marked? cn)
-                   '()
-                   (bblock-linearize-rtl cn)))))))
-
-)
+
+(define (bblock-linearize-rtl bblock queue-continuations!)
+  (define (linearize-bblock bblock)
+    (node-mark! bblock)
+    (queue-continuations! bblock)
+    (if (and (not (bblock-label bblock))
+            (node-previous>1? bblock))
+       (bblock-label! bblock))
+    (let ((kernel
+          (lambda ()
+            (let loop ((rinst (bblock-instructions bblock)))
+              (cond ((rinst-next rinst)
+                     (cons (rinst-rtl rinst)
+                           (loop (rinst-next rinst))))
+                    ((sblock? bblock)
+                     (cons (rinst-rtl rinst)
+                           (linearize-sblock-next
+                            (or (snode-next bblock)
+                                (sblock-continuation bblock)))))
+                    (else
+                     (linearize-pblock bblock
+                                       (rinst-rtl rinst)
+                                       (pnode-consequent bblock)
+                                       (pnode-alternative bblock))))))))
+      (if (bblock-label bblock)
+         `(,(rtl:make-label-statement (bblock-label bblock)) ,@(kernel))
+         (kernel))))
+
+  (define (linearize-sblock-next sblock)
+    (cond ((not sblock)
+          '())
+         ((node-marked? sblock)
+          `(,(rtl:make-jump-statement (bblock-label! sblock))))
+         (else
+          (linearize-bblock sblock))))
+
+  (define (linearize-pblock pblock predicate cn an)
+    pblock
+    (if (node-marked? cn)
+       (if (node-marked? an)
+           `(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
+             ,(rtl:make-jump-statement (bblock-label! an)))
+           `(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
+             ,@(linearize-bblock an)))
+       (if (node-marked? an)
+           `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
+                                        (bblock-label! an))
+             ,@(linearize-bblock cn))
+           (let ((label (bblock-label! cn))
+                 (alternative (linearize-bblock an)))
+             `(,(rtl:make-jumpc-statement predicate label)
+               ,@alternative
+               ,@(if (node-marked? cn)
+                     '()
+                     (linearize-bblock cn)))))))
+
+  (linearize-bblock bblock))
 
 (define linearize-rtl
-  (make-linearizer mapcan bblock-linearize-rtl))
\ No newline at end of file
+  (make-linearizer bblock-linearize-rtl
+    (lambda ()
+      (let ((value (list false)))
+       (cons value value)))    (lambda (accumulator instructions)
+      (set-cdr! (cdr accumulator) instructions)
+      (set-cdr! accumulator (last-pair instructions))
+      accumulator)
+    cdar))
\ No newline at end of file