From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 20 Dec 1986 22:54:13 +0000 (+0000)
Subject: Redesign of CFG data structures.
X-Git-Tag: 20090517-FFI~13784
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7ac78084286e141d4db35183a8fb511c99736b69;p=mit-scheme.git

Redesign of CFG data structures.
---

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index 1ec29f8e9..5b1f45e63 100644
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -37,56 +37,53 @@
 
 ;;;; LAP Code Generation
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.19 1986/12/18 06:10:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.20 1986/12/20 22:52:16 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
 
 (define *code-object-label*)
 (define *code-object-entry*)
+(define *current-rnode*)
+(define *dead-registers*)
 
 (define (generate-lap quotations procedures continuations receiver)
-  (fluid-let ((*generation* (make-generation))
-	      (*next-constant* 0)
-	      (*interned-constants* '())
-	      (*block-start-label* (generate-label))
-	      (*code-object-label*)
-	      (*code-object-entry*))
-    (for-each (lambda (quotation)
-		(cgen-cfg quotation quotation-rtl))
-	      quotations)
-    (for-each (lambda (procedure)
-		(cgen-cfg procedure procedure-rtl))
-	      procedures)
-    (for-each (lambda (continuation)
-		(cgen-cfg continuation continuation-rtl))
-	      continuations)
-    (receiver *interned-constants* *block-start-label*)))
+  (with-new-node-marks
+   (lambda ()
+     (fluid-let ((*next-constant* 0)
+		 (*interned-constants* '())
+		 (*block-start-label* (generate-label))
+		 (*code-object-label*)
+		 (*code-object-entry*))
+       (for-each (lambda (quotation)
+		   (cgen-cfg quotation quotation-rtl))
+		 quotations)
+       (for-each (lambda (procedure)
+		   (cgen-cfg procedure procedure-rtl))
+		 procedures)
+       (for-each (lambda (continuation)
+		   (cgen-cfg continuation continuation-rtl))
+		 continuations)
+       (receiver *interned-constants* *block-start-label*)))))
 
 (define (cgen-cfg object extract-cfg)
   (set! *code-object-label* (code-object-label-initialize object))
   (let ((rnode (cfg-entry-node (extract-cfg object))))
     (set! *code-object-entry* rnode)
     (cgen-rnode rnode)))
-
-(define *current-rnode*)
-(define *dead-registers*)
 
 (define (cgen-rnode rnode)
   (define (cgen-right-node next)
-    (if (and next (not (eq? (node-generation next) *generation*)))
+    (if (and next (not (node-marked? next)))
 	(begin (if (node-previous>1? next)
-		   (let ((hook (find-hook rnode next))
-			 (snode (statement->snode '(NOOP))))
-		     (set-node-generation! snode *generation*)
+		   (let ((snode (statement->snode '(NOOP))))
 		     (set-rnode-lap! snode
 				     (clear-map-instructions
 				      (rnode-register-map rnode)))
-		     (hook-disconnect! hook next)
-		     (hook-connect! hook snode)
-		     (snode-next-connect! snode next)))
+		     (node-mark! snode)
+		     (insert-snode-in-edge! rnode next snode)))
 	       (cgen-rnode next))))
-  (set-node-generation! rnode *generation*)
+  (node-mark! rnode)
   ;; LOOP is for easy restart while debugging.
   (let loop ()
     (let ((match-result (pattern-lookup *cgen-rules* (rnode-rtl rnode))))
@@ -115,7 +112,7 @@
 	(cons (cons pattern result-procedure)
 	      *cgen-rules*))
   pattern)
-
+
 (define (rnode-input-register-map rnode)
   (if (or (eq? rnode *code-object-entry*)
 	  (not (node-previous=1? rnode)))
@@ -127,8 +124,8 @@
 	       map
 	       (regset->list
 		(regset-difference
-		 (bblock-live-at-exit (rnode-bblock previous))
-		 (bblock-live-at-entry (rnode-bblock rnode))))
+		 (bblock-live-at-exit (node-bblock previous))
+		 (bblock-live-at-entry (node-bblock rnode))))
 	       (lambda (map aliases) map))
 	      map)))))
 
diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm
index 37c6856fd..689f0ea2e 100644
--- a/v7/src/compiler/base/cfg1.scm
+++ b/v7/src/compiler/base/cfg1.scm
@@ -37,215 +37,187 @@
 
 ;;;; Control Flow Graph Abstraction
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.142 1986/12/18 12:07:02 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.143 1986/12/20 22:51:15 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
 
-;;;; Basic Node Types
+;;;; Node Datatypes
 
 (define cfg-node-tag (make-vector-tag false 'CFG-NODE))
 (define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag))
-(define-vector-slots node 1 previous alist generation)
-
-(define (cfg-node-describe node)
-  `((NODE-PREVIOUS ,(node-previous node))
-    (NODE-ALIST ,(node-alist node))
-    (NODE-GENERATION ,(node-generation node))))
+(define-vector-slots node 1 generation bblock alist previous-edges)
 
 (define-vector-method cfg-node-tag ':DESCRIBE
-  cfg-node-describe)
+  (lambda (node)
+    (descriptor-list node generation bblock alist previous-edges)))
 
 (define snode-tag (make-vector-tag cfg-node-tag 'SNODE))
 (define snode? (tagged-vector-subclass-predicate snode-tag))
-(define-vector-slots snode 4 &next)
+(define-vector-slots snode 5 next-edge)
 
 (define (make-snode tag . extra)
-  (list->vector (cons* tag '() '() false false extra)))
+  (list->vector (cons* tag false false '() '() false extra)))
 
-(define (snode-describe snode)
-  (append! (cfg-node-describe snode)
-	   `((SNODE-&NEXT ,(snode-&next snode)))))
+(define-integrable (snode-next snode)
+  (edge-right-node (snode-next-edge snode)))
 
 (define-vector-method snode-tag ':DESCRIBE
-  snode-describe)
+  (lambda (snode)
+    (append! ((vector-tag-parent-method snode-tag ':DESCRIBE) snode)
+	     (descriptor-list snode next-edge))))
 
 (define pnode-tag (make-vector-tag cfg-node-tag 'PNODE))
 (define pnode? (tagged-vector-subclass-predicate pnode-tag))
-(define-vector-slots pnode 4 &consequent &alternative)
+(define-vector-slots pnode 5 consequent-edge alternative-edge)
 
 (define (make-pnode tag . extra)
-  (list->vector (cons* tag '() '() false false false extra)))
+  (list->vector (cons* tag false false '() '() false false extra)))
+
+(define-integrable (pnode-consequent pnode)
+  (edge-right-node (pnode-consequent-edge pnode)))
 
-(define (pnode-describe pnode)
-  (append! (cfg-node-describe pnode)
-	   `((PNODE-&CONSEQUENT ,(pnode-&consequent pnode))
-	     (PNODE-&ALTERNATIVE ,(pnode-&alternative pnode)))))
+(define-integrable (pnode-alternative pnode)
+  (edge-right-node (pnode-alternative-edge pnode)))
 
 (define-vector-method pnode-tag ':DESCRIBE
-  pnode-describe)
+  (lambda (pnode)
+    (append! ((vector-tag-parent-method pnode-tag ':DESCRIBE) pnode)
+	     (descriptor-list pnode consequent-edge alternative-edge))))
 
-;;;; Hooks
-
-;;; There are several different types of node, each of which has
-;;; different types of "next" connections, for example, the predicate
-;;; node has a consequent and an alternative connection.  Any kind of
-;;; node can be connected to either of these connections.  Since it is
-;;; desirable to be able to splice nodes in and out of the graph, we
-;;; would like to be able to dis/connect a node from its previous node
-;;; without knowing anything about that node.  Hooks provide this
-;;; capability by providing an operation for setting the previous
-;;; node's appropriate "next" connection to any value.
-
-(define-integrable make-hook cons)
-(define-integrable hook-node car)
-(define-integrable hook-basher cdr)
-
-(define-integrable (find-hook node next)
-  (assq node (node-previous next)))
-
-(define (hook=? x y)
-  (and (eq? (hook-node x) (hook-node y))
-       (eq? (hook-basher x) (hook-basher y))))
-
-(define hook-member?
-  (member-procedure hook=?))
-
-(define (hooks-union x y)
-  (let loop ((x x))
-    (cond ((null? x) y)
-	  ((hook-member? (car x) y) (loop (cdr x)))
-	  (else (cons (car x) (loop (cdr x)))))))
-
-(define (hook-connect! hook node)
-  (set-node-previous! node (cons hook (node-previous node)))
-  (let ((old ((hook-basher hook) (hook-node hook) node)))
-    (if old
-	(error "Connect node twice!" hook old node))))
-
-(define (hook-disconnect! hook node)
-  (set-node-previous! node (delq! hook (node-previous node)))
-  (if (not ((hook-basher hook) (hook-node hook) false))
-      (error "Disconnect node twice!" hook node)))
-
-(define (hooks-connect! hooks node)
-  (define (loop hooks)
-    (if (not (null? hooks))
-	(begin (hook-connect! (car hooks) node)
-	       (loop (cdr hooks)))))
-  (loop hooks))
-
-(define (hooks-disconnect! hooks node)
-  (define (loop hooks)
-    (if (not (null? hooks))
-	(begin (hook-disconnect! (car hooks) node)
-	       (loop (cdr hooks)))))
-  (loop hooks))
+;;;; Edge Datatype
+
+(define-vector-slots edge 0 left-node left-connect right-node)
+
+(define-integrable (make-edge left-node left-connect right-node)
+  (vector left-node left-connect right-node))
+
+(define (create-edge! left-node left-connect right-node)
+  (let ((edge (make-edge left-node left-connect right-node)))
+    (if left-node
+	(left-connect left-node edge))
+    (if right-node
+	(let ((previous (node-previous-edges right-node)))
+	  (if (not (memq right-node previous))
+	      (set-node-previous-edges! right-node (cons edge previous)))))))
+
+(define (edge-connect-left! edge left-node left-connect)
+  (set-edge-left-node! edge left-node)
+  (set-edge-left-connect! edge left-connect)
+  (if left-node
+      (left-connect left-node edge)))
+
+(define (edge-connect-right! edge right-node)
+  (set-edge-right-node! edge right-node)
+  (if right-node
+      (let ((previous (node-previous-edges right-node)))
+	(if (not (memq right-node previous))
+	    (set-node-previous-edges! right-node (cons edge previous))))))
+
+(define (edges-connect-right! edges right-node)
+  (for-each (lambda (edge)
+	      (edge-connect-right! edge right-node))
+	    edges))
+
+(define (edge-disconnect-left! edge)
+  (let ((left-node (set-edge-left-node! edge false))
+	(left-connect (set-edge-left-connect! edge false)))
+    (if left-node
+	(left-connect left-node false))))
+
+(define (edge-disconnect-right! edge)
+  (let ((right-node (set-edge-right-node! edge false)))
+    (if right-node
+	(set-node-previous-edges! right-node
+				  (delq! edge
+					 (node-previous-edges right-node))))))
+
+(define (edge-disconnect! edge)
+  (edge-disconnect-left! edge)
+  (edge-disconnect-right! edge))
+
+(define (edges-disconnect-right! edges)
+  (for-each edge-disconnect-right! edges))
 
-;;;; Holders
-
-;;; Entry/Exit holder nodes are used to hold onto the edges of a
-;;; graph.  Entry holders need only a next connection, and exit
-;;; holders need only a previous connection.
-
-(define entry-holder-tag (make-vector-tag cfg-node-tag 'ENTRY-HOLDER))
-(define-vector-slots entry-holder 1 &next)
-
-(define (entry-holder? node)
-  (eq? (vector-ref node 0) entry-holder-tag))
-
-(define-integrable (make-entry-holder)
-  (vector entry-holder-tag false))
+;;;; Editing
 
-(define (node->holder node)
-  (let ((holder (make-entry-holder)))
-    (entry-holder-connect! holder node)
-    holder))
+;;; BBlock information is preserved only for deletions.  Doing the
+;;; same for insertions is more difficult and not currently needed.
 
-(define (set-entry-holder-next! entry-holder node)
-  (entry-holder-disconnect! entry-holder)
-  (entry-holder-connect! entry-holder node))
-
-(define-vector-method entry-holder-tag ':DESCRIBE
-  (lambda (entry-holder)
-    `((ENTRY-HOLDER-&NEXT ,(entry-holder-&next entry-holder)))))
-
-(define exit-holder-tag (make-vector-tag cfg-node-tag 'EXIT-HOLDER))
-
-(define (exit-holder? node)
-  (eq? (vector-ref node 0) exit-holder-tag))
-
-(define-integrable (make-exit-holder)
-  (vector exit-holder-tag '()))
-
-(define-vector-method exit-holder-tag ':DESCRIBE
-  (lambda (exit-holder)
-    `((NODE-PREVIOUS ,(node-previous exit-holder)))))
-
-(define (next-reference node)
-  (and node (not (exit-holder? node)) node))
-
-(define-integrable (snode-next snode)
-  (next-reference (snode-&next snode)))
-
-(define-integrable (pnode-consequent pnode)
-  (next-reference (pnode-&consequent pnode)))
-
-(define-integrable (pnode-alternative pnode)
-  (next-reference (pnode-&alternative pnode)))
-
-(define-integrable (entry-holder-next entry)
-  (next-reference (entry-holder-&next entry)))
+(define (snode-delete! snode)
+  (let ((bblock (node-bblock snode)))
+    (if (and bblock
+	     (eq? snode (bblock-exit bblock))
+	     (not (eq? snode (bblock-entry bblock))))
+	(set-bblock-exit! bblock (node-previous-first snode))))
+  (let ((previous-edges (node-previous-edges snode))
+	(next-edge (snode-next-edge snode)))
+    (let ((node (edge-right-node next-edge)))
+      (edges-disconnect-right! previous-edges)
+      (edge-disconnect! next-edge)
+      (edges-connect-right! previous-edges node))))
+
+(define (edge-insert-snode! edge snode)
+  (let ((next (edge-right-node edge)))
+    (edge-disconnect-right! edge)
+    (edge-connect-right! edge snode)
+    (create-edge! snode set-snode-next! next)))
+
+(define (node-insert-snode! node snode)
+  (let ((previous-edges (node-previous-edges node)))
+    (edges-disconnect-right! previous-edges)
+    (edges-connect-right! previous-edges snode)
+    (create-edge! snode set-snode-next! node)))
 
-(define-integrable (entry-holder-hook? hook)
-  (entry-holder? (hook-node hook)))
+;;;; Previous Connections
 
 (define-integrable (node-previous=0? node)
-  (hooks=0? (node-previous node)))
+  (edges=0? (node-previous node)))
 
-(define (hooks=0? hooks)
-  (or (null? hooks)
-      (and (entry-holder-hook? (car hooks))
-	   (hooks=0? (cdr hooks)))))
+(define (edges=0? edges)
+  (cond ((null? edges) true)
+	((edge-left-node (car edges)) false)
+	(else (edges=0? (cdr edges)))))
 
 (define-integrable (node-previous>0? node)
-  (hooks>0? (node-previous node)))
+  (edges>0? (node-previous node)))
 
-(define (hooks>0? hooks)
-  (and (not (null? hooks))
-       (or (not (entry-holder-hook? (car hooks)))
-	   (hooks>0? (cdr hooks)))))
+(define (edges>0? edges)
+  (cond ((null? edges) false)
+	((edge-left-node (car edges)) true)
+	(else (edges>0? (cdr edges)))))
 
 (define-integrable (node-previous=1? node)
-  (hooks=1? (node-previous node)))
+  (edges=1? (node-previous node)))
 
-(define (hooks=1? hooks)
-  (and (not (null? hooks))
-       ((if (entry-holder-hook? (car hooks)) hooks=1? hooks=0?)
-	(cdr hooks))))
+(define (edges=1? edges)
+  (if (null? edges)
+      false
+      ((if (entry-holder-hook? (car edges)) edges=1? edges=0?) (cdr edges))))
 
 (define-integrable (node-previous>1? node)
-  (hooks>1? (node-previous node)))
+  (edges>1? (node-previous node)))
 
-(define (hooks>1? hooks)
-  (and (not (null? hooks))
-       ((if (entry-holder-hook? (car hooks)) hooks>1? hooks>0?)
-	(cdr hooks))))
+(define (edges>1? edges)
+  (if (null? edges)
+      false
+      ((if (entry-holder-hook? (car edges)) edges>1? edges>0?) (cdr edges))))
 
 (define-integrable (node-previous-first node)
-  (hook-node (hooks-first (node-previous node))))
+  (edges-first-node (node-previous-edges node)))
 
-(define (hooks-first hooks)
-  (cond ((null? hooks) (error "No first hook"))
-	((entry-holder-hook? (car hooks)) (hooks-first (cdr hooks)))
-	(else (car hooks))))
+(define (edges-first-node edges)
+  (if (null? edges)
+      (error "No first hook")
+      (or (edge-left-node (car edges))
+	  (edges-first-node (cdr edges)))))
 
 (define (for-each-previous-node node procedure)
-  (for-each (lambda (hook)
-	      (let ((node (hook-node hook)))
-		(if (not (entry-holder? node))
+  (for-each (lambda (edge)
+	      (let ((node (edge-left-node edge)))
+		(if node
 		    (procedure node))))
-	    (node-previous node)))
+	    (node-previous-edges node)))
 
 ;;;; Noops
 
@@ -284,57 +256,59 @@
 (define (constant->pcfg value)
   ((if value make-true-pcfg make-false-pcfg)))
 
-;;;; Simple Construction
+;;;; Miscellaneous
 
-(define ((node-connector set-node-next!) node next)
-  (hook-connect! (make-hook node set-node-next!) next))
+(package (with-new-node-marks
+	  node-marked?
+	  node-mark!)
 
-(define snode-next-connect! (node-connector set-snode-&next!))
-(define pnode-consequent-connect! (node-connector set-pnode-&consequent!))
-(define pnode-alternative-connect! (node-connector set-pnode-&alternative!))
-(define entry-holder-connect! (node-connector set-entry-holder-&next!))
+(define *generation*)
+
+(define-export (with-new-node-marks thunk)
+  (fluid-let ((*generation* (make-generation)))
+    (thunk)))
 
-(define ((node-disconnector node-next) node)
-  (let ((next (node-next node)))
-    (if next (node-disconnect! node next))
-    next))
+(define make-generation
+  (let ((generation 0))
+    (named-lambda (make-generation)
+      (let ((value generation))
+	(set! generation (1+ generation))
+	value))))
 
-(define (node-disconnect! node next)
-  (hook-disconnect! (find-hook node next) next))
+(define-export (node-marked? node)
+  (eq? (node-generation node) *generation*))
 
-(define snode-next-disconnect! (node-disconnector snode-&next))
-(define pnode-consequent-disconnect! (node-disconnector pnode-&consequent))
-(define pnode-alternative-disconnect! (node-disconnector pnode-&alternative))
-(define entry-holder-disconnect! (node-disconnector entry-holder-next))
+(define-export (node-mark! node)
+  (set-node-generation! node *generation*))
 
-(define (node-previous-disconnect! node)
-  (let ((hooks (node-previous node)))
-    (hooks-disconnect! hooks node)
-    hooks))
+)
 
-(define (node-get node key)
+(define (node-property-get node key)
   (let ((entry (assq key (node-alist node))))
     (and entry (cdr entry))))
 
-(define (node-put! node key item)
+(define (node-property-put! node key item)
   (let ((entry (assq key (node-alist node))))
     (if entry
 	(set-cdr! entry item)
 	(set-node-alist! node (cons (cons key item) (node-alist node))))))
 
-(define (node-remove! node key)
+(define (node-property-remove! node key)
   (set-node-alist! node (del-assq! key (node-alist node))))
 
-(define *generation*)
+(define (node-label node)
+  (or (node-labelled? node)
+      (let ((label (generate-label)))
+	(set-node-label! node label)
+	label)))
 
-(define make-generation
-  (let ((generation 0))
-    (named-lambda (make-generation)
-      (let ((value generation))
-	(set! generation (1+ generation))
-	value))))
+(define-integrable (node-labelled? node)
+  (node-property-get node node-label))
+
+(define-integrable (set-node-label! node label)
+  (node-property-put! node node-label label))
 
-;;;; CFG Objects
+;;;; CFG Datatypes
 
 ;;; A CFG is a compound CFG-node, so there are different types of CFG
 ;;; corresponding to the (connective-wise) different types of
@@ -365,28 +339,52 @@
 (define-integrable (pcfg-alternative-hooks pcfg)
   (vector-ref pcfg 3))
 
+(define-integrable (make-null-cfg) false)
+(define-integrable cfg-null? false?)
+
+(define-integrable (snode->scfg snode)
+  (node->scfg snode set-snode-next!))
+
 (define (node->scfg node set-node-next!)
   (make-scfg node
 	     (list (make-hook node set-node-next!))))
 
-(define-integrable (snode->scfg snode)
-  (node->scfg snode set-snode-&next!))
+(define-integrable (pnode->pcfg pnode)
+  (node->pcfg pnode
+	      set-pnode-consequent!
+	      set-pnode-alternative!))
 
 (define (node->pcfg node set-node-consequent! set-node-alternative!)
   (make-pcfg node
 	     (list (make-hook node set-node-consequent!))
 	     (list (make-hook node set-node-alternative!))))
+
+;;;; Hook Datatype
 
-(define-integrable (pnode->pcfg pnode)
-  (node->pcfg pnode
-	      set-pnode-&consequent!
-	      set-pnode-&alternative!))
+(define-integrable make-hook cons)
+(define-integrable hook-node car)
+(define-integrable hook-connect cdr)
 
-(define-integrable (make-null-cfg)
-  false)
+(define (hook=? x y)
+  (and (eq? (hook-node x) (hook-node y))
+       (eq? (hook-connect x) (hook-connect y))))
+
+(define hook-member?
+  (member-procedure hook=?))
+
+(define (hooks-union x y)
+  (let loop ((x x))
+    (cond ((null? x) y)
+	  ((hook-member? (car x) y) (loop (cdr x)))
+	  (else (cons (car x) (loop (cdr x)))))))
 
-(define-integrable (cfg-null? cfg)
-  (false? cfg))
+(define (hooks-connect! hooks node)
+  (for-each (lambda (hook)
+	      (hook-connect! hook node))
+	    hooks))
+
+(define (hook-connect! hook node)
+  (create-edge! (hook-node hook) (hook-connect hook) node))
 
 ;;;; CFG Construction
 
@@ -399,12 +397,18 @@
 (define-integrable (pcfg-alternative-connect! pcfg cfg)
   (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg)))
 
+(define (scfg*scfg->scfg! scfg scfg*)
+  (cond ((not scfg) scfg*)
+	((not scfg*) scfg)
+	(else (scfg-next-connect! scfg scfg*)
+	      (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
+
 (package (scfg-append! scfg*->scfg!)
 
-(define (scfg-append! . scfgs)
+(define-export (scfg-append! . scfgs)
   (scfg*->scfg! scfgs))
 
-(define (scfg*->scfg! scfgs)
+(define-export (scfg*->scfg! scfgs)
   (let ((first (find-non-null scfgs)))
     (and (not (null? first))
 	 (let ((second (find-non-null (cdr first))))
@@ -429,12 +433,6 @@
       (find-non-null (cdr scfgs))))
 
 )
-
-(define (scfg*scfg->scfg! scfg scfg*)
-  (cond ((not scfg) scfg*)
-	((not scfg*) scfg)
-	(else (scfg-next-connect! scfg scfg*)
-	      (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
 
 (define (pcfg->scfg! pcfg)
   (make-scfg* (cfg-entry-node pcfg)
@@ -527,125 +525,6 @@
   (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*))
 
 )
-
-;;;; CFG Editing Support
-
-(define (snode-replace! snode scfg)
-  (if (cfg-null? scfg)
-      (snode-delete! snode)
-      (begin (node-previous-replace! snode scfg)
-	     (node-next-replace! snode snode-&next (scfg-next-hooks scfg)))))
-
-(define (snode-delete! snode)
-  (node-next-replace! snode snode-&next (node-previous-disconnect! snode)))
-
-(define (pnode-replace! pnode pcfg)
-  (if (cfg-null? pcfg)
-      (error "PNODE-REPLACE!: Cannot delete pnode"))
-  (node-previous-replace! pnode pcfg)
-  (node-next-replace! pnode pnode-&consequent (pcfg-consequent-hooks pcfg))
-  (node-next-replace! pnode pnode-&alternative (pcfg-alternative-hooks pcfg)))
-
-(define (node-replace! node cfg)
-  ((vector-method node node-replace!) node cfg))
-
-(define-vector-method snode-tag node-replace! snode-replace!)
-(define-vector-method pnode-tag node-replace! pnode-replace!)
-
-(define (node-previous-replace! node cfg)
-  (let ((previous (node-previous node)))
-    (hooks-disconnect! previous node)
-    (hooks-connect! previous (cfg-entry-node cfg))))
-
-(define (node-next-replace! node next hooks)
-  (let ((next (next node)))
-    (if next
-	(begin (node-disconnect! node next)
-	       (hooks-connect! hooks next)))))
-
-(define (hook-insert-scfg! hook next scfg)
-  (if scfg
-      (begin (hook-disconnect! hook next)
-	     (hook-connect! hook (cfg-entry-node scfg))
-	     (hooks-connect! (scfg-next-hooks scfg) next))))
-
-(define (node-insert-scfg! node scfg)
-  (if scfg
-      (begin (node-previous-replace! node scfg)
-	     (hooks-connect! (scfg-next-hooks scfg) node))))
-
-;;;; Frames
-
-(define frame-tag (make-vector-tag false 'FRAME))
-(define-vector-slots frame 1 &entry)
-
-(define-integrable (frame-entry-node frame)
-  (entry-holder-next (frame-&entry frame)))
-
-(define (frame-describe frame)
-  `((FRAME-&ENTRY ,(frame-&entry frame))))
-
-(define sframe-tag (make-vector-tag frame-tag 'SFRAME))
-(define-vector-slots sframe 2 &next)
-
-(define-integrable (make-sframe entry next)
-  (vector sframe-tag entry next))
-
-(define-integrable (sframe-next-hooks sframe)
-  (node-previous (sframe-&next sframe)))
-
-(define-vector-method sframe-tag ':DESCRIBE
-  (lambda (sframe)
-    (append! (frame-describe sframe)
-	     `((SFRAME-&NEXT ,(sframe-&next sframe))))))
-
-(define (scfg->sframe scfg)
-  (let ((entry (make-entry-holder))
-	(next (make-exit-holder)))
-    (entry-holder-connect! entry (cfg-entry-node scfg))
-    (hooks-connect! (scfg-next-hooks scfg) next)
-    (make-sframe entry next)))
-
-(define (sframe->scfg sframe)
-  (let ((entry (frame-entry-node sframe)))
-    (if entry
-	(make-scfg entry (sframe-next-hooks sframe))
-	(make-null-cfg))))
-
-(define pframe-tag (make-vector-tag frame-tag 'PFRAME))
-(define-vector-slots pframe 2 &consequent &alternative)
-
-(define-integrable (make-pframe entry consequent alternative)
-  (vector pframe-tag entry consequent alternative))
-
-(define-integrable (pframe-consequent-hooks pframe)
-  (node-previous (pframe-&consequent pframe)))
-
-(define-integrable (pframe-alternative-hooks pframe)
-  (node-previous (pframe-&alternative pframe)))
-
-(define-vector-method pframe-tag ':DESCRIBE
-  (lambda (pframe)
-    (append! (frame-describe pframe)
-	     `((PFRAME-&CONSEQUENT ,(pframe-&consequent pframe))
-	       (PFRAME-&ALTERNATIVE ,(pframe-&alternative pframe))))))
-
-(define (pcfg->pframe pcfg)
-  (let ((entry (make-entry-holder))
-	(consequent (make-exit-holder))
-	(alternative (make-exit-holder)))
-    (entry-holder-connect! entry (cfg-entry-node pcfg))
-    (hooks-connect! (pcfg-consequent-hooks pcfg) consequent)
-    (hooks-connect! (pcfg-alternative-hooks pcfg) alternative)
-    (make-pframe entry consequent alternative)))
-
-(define (pframe->pcfg pframe)
-  (let ((entry (frame-entry-node pframe)))
-    (if entry
-	(make-pcfg entry
-		   (pframe-consequent-hooks pframe)
-		   (pframe-alternative-hooks pframe))
-	(make-null-cfg))))
 
 ;;; end USING-SYNTAX
 )
diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm
index 486220e86..91e124545 100644
--- a/v7/src/compiler/base/ctypes.scm
+++ b/v7/src/compiler/base/ctypes.scm
@@ -37,7 +37,7 @@
 
 ;;;; Compiler CFG Datatypes
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.36 1986/12/18 03:37:04 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.37 1986/12/20 22:51:33 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -59,11 +59,6 @@
 (define-integrable (make-true-test rvalue)
   (pnode->pcfg (make-pnode true-test-tag rvalue)))
 
-(define-pnode type-test rvalue type)
-
-(define (make-type-test rvalue type)
-  (pnode->pcfg (make-pnode type-test-tag rvalue type)))
-
 (define-pnode unassigned-test block variable)
 
 (define-integrable (make-unassigned-test block variable)
@@ -74,11 +69,6 @@
 (define-integrable (make-unbound-test block variable)
   (pnode->pcfg (make-pnode unbound-test-tag block variable)))
 
-(define-snode rtl-quote generator)
-
-(define-integrable (make-rtl-quote generator)
-  (snode->scfg (make-snode rtl-quote-tag generator)))
-
 (define-snode combination block compilation-type value operator operands
   procedures known-operator)
 (define *combinations*)
@@ -94,36 +84,20 @@
 			     (cons combination (vnode-combinations value)))
     (snode->scfg combination)))
 
-(define-snode continuation block &entry delta generator rtl-frame label)
+(define-snode continuation rtl delta label)
 (define *continuations*)
 
-(define-integrable (make-continuation block entry delta generator)
+(define-integrable (make-continuation rtl delta)
   (let ((continuation
-	 (make-snode continuation-tag block (node->holder entry) delta
-		     generator false (generate-label 'CONTINUATION))))
+	 (make-snode continuation-tag rtl delta
+		     (generate-label 'CONTINUATION))))
     (set! *continuations* (cons continuation *continuations*))
     continuation))
 
-(define-integrable (continuation-entry continuation)
-  (entry-holder-next (continuation-&entry continuation)))
-
-(define-integrable (continuation-rtl continuation)
-  (sframe->scfg (continuation-rtl-frame continuation)))
-
-(define-integrable (set-continuation-rtl! continuation rtl)
-  (set-continuation-rtl-frame! continuation (scfg->sframe rtl)))
-
 (define-unparser continuation-tag
   (lambda (continuation)
     (write (continuation-label continuation))))
 
-(define-snode invocation number-pushed continuation procedure generator)
-
-(define-integrable (make-invocation number-pushed continuation procedure
-				    generator)
-  (snode->scfg (make-snode invocation-tag number-pushed continuation procedure
-			   generator)))
-
 ;;; end USING-SYNTAX
 )
 
diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm
index 2a9250070..7c38ac8ea 100644
--- a/v7/src/compiler/base/macros.scm
+++ b/v7/src/compiler/base/macros.scm
@@ -37,6 +37,8 @@
 
 ;;;; Compiler Macros
 
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.53 1986/12/20 22:52:39 cph Exp $
+
 (declare (usual-integrations))
 
 (in-package compiler-package
@@ -160,29 +162,33 @@
 (let-syntax
  ((define-type-definition
     (macro (name reserved)
-      `(SYNTAX-TABLE-DEFINE (ACCESS COMPILER-SYNTAX-TABLE COMPILER-PACKAGE)
-			    ',(symbol-append 'DEFINE- name)
-	 (macro (type . slots)
-	   (let ((tag-name (symbol-append type '-TAG)))
-	     `(BEGIN (DEFINE ,tag-name
-		       (MAKE-VECTOR-TAG ,',(symbol-append name '-TAG) ',type))
-		     (DEFINE ,(symbol-append type '?)
-		       (TAGGED-VECTOR-PREDICATE ,tag-name))
-		     (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
-		     (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE
-		       (LAMBDA (,type)
-			 (APPEND!
-			  (,',(symbol-append name '-DESCRIBE) ,type)
-			  (LIST ,@(map (lambda (slot)
-					 (let ((ref-name
-						(symbol-append type '- slot)))
-					   ``(,',ref-name
-					      ,(,ref-name ,type))))
-				       slots))))))))))))
- (define-type-definition snode 5)
- (define-type-definition pnode 6)
+      (let ((parent (symbol-append name '-TAG)))
+	`(SYNTAX-TABLE-DEFINE (ACCESS COMPILER-SYNTAX-TABLE COMPILER-PACKAGE)
+			      ',(symbol-append 'DEFINE- name)
+	   (macro (type . slots)
+	     (let ((tag-name (symbol-append type '-TAG)))
+	       `(BEGIN (DEFINE ,tag-name
+			 (MAKE-VECTOR-TAG ,',parent ',type))
+		       (DEFINE ,(symbol-append type '?)
+			 (TAGGED-VECTOR-PREDICATE ,tag-name))
+		       (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
+		       (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE
+			 (LAMBDA (,type)
+			   (APPEND!
+			    ((VECTOR-TAG-METHOD ,',parent ':DESCRIBE) ,type)
+			    (DESCRIPTOR-LIST ,type ,@slots))))))))))))
+ (define-type-definition snode 6)
+ (define-type-definition pnode 7)
  (define-type-definition rvalue 1)
  (define-type-definition vnode 10))
+
+(syntax-table-define (access compiler-syntax-table compiler-package)
+		     'DESCRIPTOR-LIST
+  (macro (type . slots)
+    `(LIST ,@(map (lambda (slot)
+		    (let ((ref-name (symbol-append type '- slot)))
+		      ``(,',ref-name ,(,ref-name ,type))))
+		  slots))))
 
 (let ((rtl-common
        (lambda (type prefix components wrap-constructor)
diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm
index eb4499b9a..6c89193a7 100644
--- a/v7/src/compiler/base/utils.scm
+++ b/v7/src/compiler/base/utils.scm
@@ -37,7 +37,7 @@
 
 ;;;; Compiler Utilities
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.76 1986/12/18 06:12:29 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.77 1986/12/20 22:54:13 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -85,9 +85,15 @@
   (vector-tag-put! tag name method)
   name)
 
+(define (vector-tag-method tag name)
+  (or (vector-tag-get tag name)
+      (error "Unbound method" tag name)))
+
+(define-integrable (vector-tag-parent-method tag name)
+  (vector-tag-method (cdr tag) name))
+
 (define-integrable (vector-method vector name)
-  (or (vector-tag-get (vector-tag vector) name)
-      (error "Unbound method" vector name)))
+  (vector-tag-method (vector-tag vector) name))
 
 (define (define-unparser tag unparser)
   (define-vector-method tag ':UNPARSE unparser))
diff --git a/v7/src/compiler/rtlopt/ralloc.scm b/v7/src/compiler/rtlopt/ralloc.scm
index 2a78b3786..03a2d270c 100644
--- a/v7/src/compiler/rtlopt/ralloc.scm
+++ b/v7/src/compiler/rtlopt/ralloc.scm
@@ -38,7 +38,7 @@
 ;;;; Register Allocation
 ;;;  Based on the GNU C Compiler
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.8 1986/12/15 05:27:11 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.9 1986/12/20 22:52:48 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -71,7 +71,7 @@
 			       (vector-ref register->renumber register)))
 			  (if renumber
 			      (regset-adjoin! live renumber)))))
-		    (walk-bblock-forward bblock
+		    (bblock-walk-forward bblock
 		      (lambda (rnode next)
 			(for-each-regset-member live
 			  (lambda (renumber)
diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm
index b64e968c5..9500f7163 100644
--- a/v7/src/compiler/rtlopt/rcse1.scm
+++ b/v7/src/compiler/rtlopt/rcse1.scm
@@ -38,7 +38,7 @@
 ;;;; RTL Common Subexpression Elimination
 ;;;  Based on the GNU C Compiler
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.95 1986/12/18 12:10:53 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.96 1986/12/20 22:52:56 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -169,6 +169,17 @@
 (define-cse-method 'RETURN noop)
 (define-cse-method 'PROCEDURE-HEAP-CHECK noop)
 (define-cse-method 'CONTINUATION-HEAP-CHECK noop)
+
+(define (define-stack-trasher type)
+  (define-cse-method type trash-stack))
+
+(define (trash-stack statement)
+  (stack-invalidate!)
+  (stack-pointer-invalidate!))
+
+(define-stack-trasher 'SETUP-CLOSURE-LEXPR)
+(define-stack-trasher 'SETUP-STACK-LEXPR)
+(define-stack-trasher 'MESSAGE-SENDER:VALUE)
 
 (define (define-lookup-method type get-environment set-environment! register)
   (define-cse-method type
@@ -225,6 +236,9 @@
 
 (define (define-invocation-method type)
   (define-cse-method type
+    noop
+#|  This will be needed when the snode-next of an invocation
+    gets connected to the callee's entry node.
     (lambda (statement)
       (let ((prefix (rtl:invocation-prefix statement)))
 	(case (car prefix)
@@ -235,7 +249,9 @@
 	     (stack-region-invalidate! 0 (+ size distance)) ;laziness
 	     (stack-pointer-adjust! distance)))
 	  ((APPLY-STACK APPLY-CLOSURE) (trash-stack statement))
-	  (else (error "Bad prefix type" prefix)))))))
+	  (else (error "Bad prefix type" prefix)))))
+|#
+    ))
 
 (define (continuation-adjustment statement)
   (let ((continuation (rtl:invocation-continuation statement)))
@@ -270,17 +286,6 @@
 
 (define-message-receiver 'MESSAGE-RECEIVER:SUBPROBLEM
   rtl:message-receiver-size:subproblem)
-
-(define (define-stack-trasher type)
-  (define-cse-method type trash-stack))
-
-(define (trash-stack statement)
-  (stack-invalidate!)
-  (stack-pointer-invalidate!))
-
-(define-stack-trasher 'SETUP-CLOSURE-LEXPR)
-(define-stack-trasher 'SETUP-STACK-LEXPR)
-(define-stack-trasher 'MESSAGE-SENDER:VALUE)
 
 ;;;; Canonicalization
 
diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm
index 17340727d..c91e50e02 100644
--- a/v7/src/compiler/rtlopt/rlife.scm
+++ b/v7/src/compiler/rtlopt/rlife.scm
@@ -38,57 +38,11 @@
 ;;;; RTL Register Lifetime Analysis
 ;;;  Based on the GNU C Compiler
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.52 1986/12/18 12:11:09 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.53 1986/12/20 22:53:21 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
 
-;;;; Basic Blocks
-
-(define *block-number*)
-
-(define (find-blocks rnodes)
-  (fluid-let ((*generation* (make-generation))
-	      (*block-number* 0))
-    (set! *bblocks* '())
-    (for-each (lambda (rnode)
-		(set-node-generation! rnode *generation*))
-	      rnodes)
-    (for-each walk-entry rnodes)))
-
-(define (walk-next next)
-  (if (not (eq? (node-generation next) *generation*))
-      (walk-entry next)))
-
-(define (walk-entry rnode)
-  (let ((bblock (make-bblock *block-number* rnode *n-registers*)))
-    (set! *block-number* (1+ *block-number*))
-    (set! *bblocks* (cons bblock *bblocks*))
-    (walk-rnode bblock rnode)))
-
-(define (walk-rnode bblock rnode)
-  (set-node-generation! rnode *generation*)
-  (set-rnode-bblock! rnode bblock)
-  ((vector-method rnode walk-rnode) bblock rnode))
-
-(define-vector-method rtl-snode-tag walk-rnode
-  (lambda (bblock snode)
-    (let ((next (snode-next snode)))
-      (cond ((not next)
-	     (set-bblock-exit! bblock snode))
-	    ((or (node-previous>1? next)
-		 (rtl:invocation? (rnode-rtl snode)))
-	     (set-bblock-exit! bblock snode)
-	     (walk-next next))
-	    (else
-	     (walk-rnode bblock next))))))
-
-(define-vector-method rtl-pnode-tag walk-rnode
-  (lambda (bblock pnode)
-    (set-bblock-exit! bblock pnode)
-    (walk-next (pnode-consequent pnode))
-    (walk-next (pnode-alternative pnode))))
-
 ;;;; Lifetime Analysis
 
 (define (lifetime-analysis bblocks)
@@ -107,7 +61,7 @@
 			       (for-each-previous-node (bblock-entry bblock)
 				 (lambda (rnode)
 				   (regset-union! (bblock-new-live-at-exit
-						   (rnode-bblock rnode))
+						   (node-bblock rnode))
 						  live-at-entry)))))))
 		bblocks)
       (if changed?
@@ -143,7 +97,7 @@
   (let ((old (bblock-live-at-entry bblock))
 	(dead (regset-allocate *n-registers*))
 	(live (regset-allocate *n-registers*)))
-    (walk-bblock-backward bblock
+    (bblock-walk-backward bblock
       (lambda (rnode previous)
 	(regset-clear! dead)
 	(regset-clear! live)
@@ -166,7 +120,7 @@
 (define (rtl-snode-delete! rnode)
   (let ((previous (node-previous rnode))
 	(next (snode-next rnode))
-	(bblock (rnode-bblock rnode)))
+	(bblock (node-bblock rnode)))
     (snode-delete! rnode)
     (if (eq? rnode (bblock-entry bblock))
 	(if (eq? rnode (bblock-exit bblock))
@@ -188,7 +142,7 @@
 		    (record-register-reference register rnode)
 		    (if (and (regset-member? needed register)
 			     rnode*
-			     (eq? (rnode-bblock rnode) (rnode-bblock rnode*)))
+			     (eq? (node-bblock rnode) (node-bblock rnode*)))
 			(set-rnode-logical-link! rnode* rnode)))))))))
 
 (define (mark-used-registers! needed live rtl rnode)
@@ -216,7 +170,7 @@
       (rtl:for-each-subexpression rtl loop)))
 
 (define (record-register-reference register rnode)
-  (let ((bblock (rnode-bblock rnode))
+  (let ((bblock (node-bblock rnode))
 	(bblock* (register-bblock register)))
     (cond ((not bblock*)
 	   (set-register-bblock! register bblock))
@@ -228,23 +182,27 @@
   (and (rtl:register? expression)
        (pseudo-register? (rtl:register-number expression))))
 
-;;;; Optimization
+;;;; Dead Code Elimination
 
-(define (optimize-block bblock)
-  (if (not (eq? (bblock-entry bblock) (bblock-exit bblock)))
-      (let ((live (regset-copy (bblock-live-at-entry bblock)))
-	    (births (make-regset *n-registers*)))
-	(walk-bblock-forward bblock
-	  (lambda (rnode next)
-	    (if next
-		(begin (optimize-rtl live rnode next)
-		       (regset-clear! births)
-		       (mark-set-registers! live births (rnode-rtl rnode)
-					    false)
-		       (for-each (lambda (register)
-				   (regset-delete! live register))
-				 (rnode-dead-registers rnode))
-		       (regset-union! live births))))))))
+(define (dead-code-elimination bblocks)
+  (for-each (lambda (bblock)
+	      (if (not (eq? (bblock-entry bblock) (bblock-exit bblock)))
+		  (let ((live (regset-copy (bblock-live-at-entry bblock)))
+			(births (make-regset *n-registers*)))
+		    (bblock-walk-forward bblock
+		      (lambda (rnode next)
+			(if next
+			    (begin (optimize-rtl live rnode next)
+				   (regset-clear! births)
+				   (mark-set-registers! live
+							births
+							(rnode-rtl rnode)
+							false)
+				   (for-each (lambda (register)
+					       (regset-delete! live register))
+					     (rnode-dead-registers rnode))
+				   (regset-union! live births))))))))
+	    bblocks))
 
 (define (optimize-rtl live rnode next)
   (let ((rtl (rnode-rtl rnode)))
@@ -306,7 +264,7 @@
 			     (write-string "; multiple blocks")))
 			(bblock
 			 (write-string "; block ")
-			 (write (bblock-number bblock)))
+			 (write (unhash bblock)))
 			(else
 			 (write-string "; no block!")))))))))