From 4afc8ddc58ead647728b03d8d54a2650dae8286f Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 15 Sep 1988 05:05:44 +0000
Subject: [PATCH] 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.
---
v7/src/compiler/back/linear.scm | 45 +++++++++++++++++-------------
v7/src/compiler/rtlbase/rtline.scm | 35 ++++++++++++++---------
2 files changed, 48 insertions(+), 32 deletions(-)
diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm
index e08152369..e1d45c487 100644
--- 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 ab65e3a7c..82ee60edc 100644
--- 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 ()
--
2.25.1