From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 7 Sep 1988 06:23:24 +0000 (+0000)
Subject: Add new analysis to determine how RTL basic blocks are related by
X-Git-Tag: 20090517-FFI~12540
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7162113ea3970da46b9e32811a09c8f9e6e2b95e;p=mit-scheme.git

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 718cf9e0d..e08152369 100644
--- 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))
 
-(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 c7c021f79..ab65e3a7c 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.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))
-
+
+(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)))
+
 ;;; 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.
-
-(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