Label basic blocks that have multiple previous edges, even if those

edges do not have nodes attached to them.  Also reorganized to
guarantee that the labelling side effects are ordered correctly.

diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm
index e081523691565ea8425eb2c95134edb2ab8784f0..e1d45c487189e94b06699cf7fb304d48a8ab1db9 100644 (file)
--- a/v7/src/compiler/back/linear.scm
+++ b/v7/src/compiler/back/linear.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.4 1988/09/15 05:05:02 cph Exp $
 
 Copyright (c) 1987, 1988 Massachusetts Institute of Technology
 
@@ -41,8 +41,9 @@ MIT in each case. |#
     (node-mark! bblock)
     (queue-continuations! bblock)
     (if (and (not (bblock-label bblock))
-            (node-previous>1? bblock))
-       (bblock-label! bblock))
+            (let ((edges (node-previous-edges bblock)))
+              (and (not (null? edges))
+                   (not (null? (cdr edges))))))        (bblock-label! bblock))
     (let ((kernel
           (lambda ()
             (LAP ,@(bblock-instructions bblock)
@@ -58,27 +59,29 @@ MIT in each case. |#
          (kernel))))
 
   (define (linearize-sblock-next bblock)
-    (cond ((not bblock) (LAP))
+    (cond ((not bblock)
+          (LAP))
          ((node-marked? bblock)
-          (LAP ,(lap:make-unconditional-branch (bblock-label! bblock))))
-         (else (linearize-bblock bblock))))
+          (LAP ,(lap:make-unconditional-branch (get-bblock-label bblock))))
+         (else
+          (linearize-bblock bblock))))
 
   (define (linearize-pblock pblock cn an)
     (if (node-marked? cn)
+       (let ((clabel (get-bblock-label cn)))
+         (if (node-marked? an)
+             (let ((alabel (get-bblock-label an)))
+               (LAP ,@((pblock-consequent-lap-generator pblock) clabel)
+                    ,(lap:make-unconditional-branch alabel)))
+             (LAP ,@((pblock-consequent-lap-generator pblock) clabel)
+                  ,@(linearize-bblock an))))
        (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)
+           (let ((alabel (get-bblock-label an)))
+             (LAP ,@((pblock-alternative-lap-generator pblock) alabel)
+                  ,@(linearize-bblock cn)))
+           (let* ((clabel (bblock-label! cn))
+                  (alternative (linearize-bblock an)))
+             (LAP ,@((pblock-consequent-lap-generator pblock) clabel)
                   ,@alternative
                   ,@(if (node-marked? cn)
                         (LAP)
@@ -86,6 +89,10 @@ MIT in each case. |#
 
   (linearize-bblock bblock))
 
+(define (get-bblock-label bblock)
+  (or (bblock-label bblock)
+      (error "GET-BBLOCK-LABEL: block not labeled" bblock)))
+
 (define linearize-bits
   (make-linearizer bblock-linearize-bits
     (lambda () (LAP))

diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm
index ab65e3a7c2b9369c72e22904246999d4c2da518d..82ee60edc18781fd8f81be7695e1a04c36967b21 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.4 1988/09/07 06:22:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.5 1988/09/15 05:05:44 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -122,7 +122,9 @@ MIT in each case. |#
     (node-mark! bblock)
     (queue-continuations! bblock)
     (if (and (not (bblock-label bblock))
-            (node-previous>1? bblock))
+            (let ((edges (node-previous-edges bblock)))
+              (and (not (null? edges))
+                   (not (null? (cdr edges))))))
        (bblock-label! bblock))
     (let ((kernel
           (lambda ()
@@ -148,24 +150,27 @@ MIT in each case. |#
     (cond ((not sblock)
           '())
          ((node-marked? sblock)
-          `(,(rtl:make-jump-statement (bblock-label! sblock))))
+          `(,(rtl:make-jump-statement (get-bblock-label sblock))))
          (else
           (linearize-bblock sblock))))
 
   (define (linearize-pblock pblock predicate cn an)
     pblock
     (if (node-marked? cn)
+       (let ((clabel (get-bblock-label cn)))
+         (if (node-marked? an)
+             (let ((alabel (get-bblock-label an)))
+               `(,(rtl:make-jumpc-statement predicate clabel)
+                 ,(rtl:make-jump-statement alabel)))
+             `(,(rtl:make-jumpc-statement predicate clabel)
+               ,@(linearize-bblock an))))
        (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)))
+           (let ((alabel (get-bblock-label an)))
+             `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
+                                          alabel)
+               ,@(linearize-bblock cn)))
+           (let* ((label (bblock-label! cn))
+                  (alternative (linearize-bblock an)))
              `(,(rtl:make-jumpc-statement predicate label)
                ,@alternative
                ,@(if (node-marked? cn)
@@ -174,6 +179,10 @@ MIT in each case. |#
 
   (linearize-bblock bblock))
 
+(define (get-bblock-label bblock)
+  (or (bblock-label bblock)
+      (error "GET-BBLOCK-LABEL: block not labeled" bblock)))
+
 (define linearize-rtl
   (make-linearizer bblock-linearize-rtl
     (lambda ()