From a290733a8a22c59f93eb1653857212364425dd4b Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 15 Dec 1988 17:26:09 +0000
Subject: [PATCH] Introduce new algorithm to delete unreachable nodes from the
 RTL graph.

---
 v7/src/compiler/rtlgen/rtlgen.scm | 60 ++++++++++++++++++++-----------
 1 file changed, 39 insertions(+), 21 deletions(-)

diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm
index 62c18240f..f347240b6 100644
--- a/v7/src/compiler/rtlgen/rtlgen.scm
+++ b/v7/src/compiler/rtlgen/rtlgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.12 1988/12/12 21:53:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.13 1988/12/15 17:26:09 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -240,26 +240,44 @@ MIT in each case. |#
      (for-each (lambda (edge)
 		 (bblock-compress! (edge-right-node edge)))
 	       (rgraph-initial-edges rgraph))))
-  (set-rgraph-bblocks! rgraph (collect-rgraph-bblocks rgraph)))
+  ;; This code attempts to remove backwards edges to pieces of the
+  ;; graph which were generated and then not used.  It does this by
+  ;; walking forward through the graph, and looking backward at each
+  ;; node to find edges that have not been walked over.
+  (with-new-node-marks
+   (lambda ()
+     (let ((initial-bblocks
+	    (map->eq-set edge-right-node (rgraph-initial-edges rgraph))))
+       (let ((result '()))
+	 (define (loop bblock)
+	   (if (sblock? bblock)
+	       (next (snode-next bblock))
+	       (begin
+		 (next (pnode-consequent bblock))
+		 (next (pnode-alternative bblock)))))
 
-(define collect-rgraph-bblocks
-  (let ()
-    (define (loop bblock)
-      (node-mark! bblock)
-      (cons bblock
-	    (if (sblock? bblock)
-		(next (snode-next bblock))
-		(append! (next (pnode-consequent bblock))
-			 (next (pnode-alternative bblock))))))
+	 (define (next bblock)
+	   (if (and bblock (not (node-marked? bblock)))
+	       (begin
+		 (node-mark! bblock)
+		 (set! result (cons bblock result))
+		 (loop bblock))))
 
-    (define (next bblock)
-      (if (and bblock (not (node-marked? bblock)))
-	  (loop bblock)
-	  '()))
+	 (define (delete-block-edges! disallow-entries?)
+	   (let ((delete-edges!
+		  (list-deletor!
+		   (lambda (edge)
+		     (let ((bblock (edge-left-node edge)))
+		       (if bblock
+			   (not (node-marked? bblock))
+			   disallow-entries?))))))
+	     (lambda (bblock)
+	       (set-node-previous-edges!
+		bblock
+		(delete-edges! (node-previous-edges bblock))))))
 
-    (lambda (rgraph)
-      (with-new-node-marks
-       (lambda ()
-	 (mapcan (lambda (edge)
-		   (loop (edge-right-node edge)))
-		 (rgraph-initial-edges rgraph)))))))
\ No newline at end of file
+	 (for-each node-mark! initial-bblocks)
+	 (for-each loop initial-bblocks)
+	 (for-each (delete-block-edges! false) initial-bblocks)
+	 (for-each (delete-block-edges! true) result)
+	 (set-rgraph-bblocks! rgraph (append! initial-bblocks result)))))))
\ No newline at end of file
-- 
2.25.1