From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 21 Aug 1989 19:34:39 +0000 (+0000)
Subject: Change the compiler so that each top-level procedure in the input
X-Git-Tag: 20090517-FFI~11808
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cba16e4e88a59cf896679107fc8548b7e5e193d0;p=mit-scheme.git

Change the compiler so that each top-level procedure in the input
expression is compiled separately, producing a different compiled-code
block for each.  The load-time linking is removed from the sub-blocks
to be performed in the code for the top-level expression, thus
allowing it to be discarded after the expression is evaluated; only
the code needed by the procedures is retained.

The old behavior of the compiler can be obtained by setting the switch
`compiler:compile-by-procedures?' to #f.
---

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index fd2d28dd2..40ed7cf1b 100644
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.6 1988/11/07 23:50:50 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.7 1989/08/21 19:30:23 cph Exp $
 
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -36,26 +36,45 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define *block-start-label*)
 (define *current-bblock*)
 (define *pending-bblocks*)
 
-(define (generate-bits rgraphs receiver)
+(define (generate-bits rgraphs remote-links process-constants-block)
   (with-new-node-marks
    (lambda ()
-     (fluid-let ((*next-constant* 0)
-		 (*interned-constants* '())
-		 (*interned-variables* '())
-		 (*interned-assignments* '())
-		 (*interned-uuo-links* '())
-		 (*block-start-label* (generate-label)))
-       (for-each cgen-rgraph rgraphs)
-       (receiver *block-start-label*
-		 (generate/quotation-header *block-start-label*
-					    *interned-constants*
-					    *interned-variables*
-					    *interned-assignments*
-					    *interned-uuo-links*))))))
+     (for-each cgen-rgraph rgraphs)
+     (for-each (lambda (remote-link)
+		 (vector-set! remote-link
+			      0
+			      (constant->label (vector-ref remote-link 0)))
+		 unspecific)
+	       remote-links)
+     (with-values
+	 (lambda ()
+	   (generate/constants-block *interned-constants*
+				     *interned-variables*
+				     *interned-assignments*
+				     *interned-uuo-links*))
+       (or process-constants-block
+	   (lambda (constants-code environment-label free-ref-label n-sections)
+	     (LAP ,@constants-code
+		  ,@(if free-ref-label
+			(generate/quotation-header environment-label
+						   free-ref-label
+						   n-sections)
+			(LAP))
+		  ,@(let loop ((remote-links remote-links))
+		      (if (null? remote-links)
+			  (LAP)
+			  (LAP ,@(let ((remote-link (car remote-links)))
+				   (if (vector-ref remote-link 2)
+				       (generate/remote-link
+					(vector-ref remote-link 0)
+					(vector-ref remote-link 1)
+					(vector-ref remote-link 2)
+					(vector-ref remote-link 3))
+				       (LAP)))
+			       ,@(loop (cdr remote-links))))))))))))
 
 (define (cgen-rgraph rgraph)
   (fluid-let ((*current-rgraph* rgraph)
@@ -66,14 +85,16 @@ MIT in each case. |#
 	      (rgraph-entry-edges rgraph))
     (if (not (null? *pending-bblocks*))
 	(error "CGEN-RGRAPH: pending blocks left at end of pass"))))
-
+
 (define (cgen-entry edge)
   (define (loop bblock map)
     (cgen-bblock bblock map)
     (if (sblock? bblock)
 	(cgen-right (snode-next-edge bblock))
-	(begin (cgen-right (pnode-consequent-edge bblock))
-	       (cgen-right (pnode-alternative-edge bblock)))))
+	(begin
+	  (cgen-right (pnode-consequent-edge bblock))
+	  (cgen-right (pnode-alternative-edge bblock)))))
+
   (define (cgen-right edge)
     (let ((next (edge-next-node edge)))
       (if (and next (not (node-marked? next)))
diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm
index ab1d7cabc..84a1b8b3d 100644
--- a/v7/src/compiler/base/crsend.scm
+++ b/v7/src/compiler/base/crsend.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.1 1989/05/17 20:44:56 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.2 1989/08/21 19:32:18 cph Exp $
 $MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
@@ -33,7 +33,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
-;;;; Cross Compiler End.
+;;;; Cross Compiler End
 ;;; This program does not need the rest of the compiler, but should
 ;;; match the version of the same name in crstop.scm and toplev.scm
 
@@ -48,19 +48,48 @@ MIT in each case. |#
 	   ,x))))
 
 (define (cross-compile-bin-file-end input-string #!optional output-string)
-  (compiler-pathnames
-   input-string
-   (and (not (default-object? output-string)) output-string)
-   (make-pathname false false false false "bits.x" 'NEWEST)
-   (lambda (input-pathname output-pathname)
-     output-pathname
-     (cross-compile-scode-end (compiler-fasload input-pathname)))))
+  (compiler-pathnames input-string
+		      (and (not (default-object? output-string)) output-string)
+		      (make-pathname false false false false "bits.x" 'NEWEST)
+    (lambda (input-pathname output-pathname)
+      output-pathname			;ignore
+      (cross-compile-scode-end (compiler-fasload input-pathname)))))
+
+(define (compiler-pathnames input-string output-string default transform)
+  (let* ((core
+	  (lambda (input-string)
+	    (let ((input-pathname
+		   (pathname->input-truename
+		    (merge-pathnames (->pathname input-string) default))))
+	      (if (not input-pathname)
+		  (error "File does not exist" input-string))
+	      (let ((output-pathname
+		     (let ((output-pathname
+			    (pathname-new-type input-pathname "com")))
+		       (if output-string
+			   (merge-pathnames (->pathname output-string)
+					    output-pathname)
+			   output-pathname))))
+		(newline)
+		(write-string "Compile File: ")
+		(write (pathname->string input-pathname))
+		(write-string " => ")
+		(write (pathname->string output-pathname))
+		(fasdump (transform input-pathname output-pathname)
+			 output-pathname)))))
+	 (kernel
+	  (if compiler:batch-mode?
+	      (batch-kernel core)
+	      core)))
+    (if (pair? input-string)
+	(for-each kernel input-string)
+	(kernel input-string))))
 
 (define (cross-compile-scode-end cross-compilation)
   (in-compiler
    (lambda ()
      (cross-link-end cross-compilation)
-     compiler:expression)))
+     *expression*)))
 
 (define-structure (cc-vector (constructor cc-vector/make)
 			     (conc-name cc-vector/))
@@ -71,10 +100,10 @@ MIT in each case. |#
   (ic-procedure-headers false read-only true))
 
 (define (cross-link-end cc-vector)
-  (set! compiler:code-vector (cc-vector/code-vector cc-vector))
-  (set! compiler:entry-label (cc-vector/entry-label cc-vector))
-  (set! compiler:entry-points (cc-vector/entry-points cc-vector))
-  (set! compiler:label-bindings (cc-vector/label-bindings cc-vector))
+  (set! *code-vector* (cc-vector/code-vector cc-vector))
+  (set! *entry-label* (cc-vector/entry-label cc-vector))
+  (set! *entry-points* (cc-vector/entry-points cc-vector))
+  (set! *label-bindings* (cc-vector/label-bindings cc-vector))
   (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
   (phase/link))
 
@@ -92,73 +121,44 @@ MIT in each case. |#
 			((ucode-primitive &make-object)
 			 type-code:compiled-entry
 			 (make-non-pointer-object
-			  (+ (cdr (or (assq label compiler:label-bindings)
+			  (+ (cdr (or (assq label *label-bindings*)
 				      (error "Missing entry point" label)))
-			     (object-datum compiler:code-vector))))))))
-		  compiler:entry-points)))
+			     (object-datum *code-vector*))))))))
+		  *entry-points*)))
 	(let ((label->expression
 	       (lambda (label)
 		 (cdr (or (assq label bindings)
 			  (error "Label not defined as entry point" label))))))
-	  (set! compiler:expression (label->expression compiler:entry-label))
+	  (set! *expression* (label->expression *entry-label*))
 	  (for-each (lambda (entry)
 		      (set-lambda-body! (car entry)
 					(label->expression (cdr entry))))
 		    *ic-procedure-headers*)))
-      (set! compiler:code-vector)
-      (set! compiler:entry-points)
-      (set! compiler:label-bindings)
-      (set! compiler:entry-label)
+      (set! *code-vector*)
+      (set! *entry-points*)
+      (set! *label-bindings*)
+      (set! *entry-label*)
       (set! *ic-procedure-headers*))))
 
-(define (compiler-pathnames input-string output-string default transform)
-  (let* ((core
-	  (lambda (input-string)
-	    (let ((input-pathname
-		   (pathname->input-truename
-		    (merge-pathnames (->pathname input-string) default))))
-	      (if (not input-pathname)
-		  (error "File does not exist" input-string))
-	      (let ((output-pathname
-		     (let ((output-pathname
-			    (pathname-new-type input-pathname "com")))
-		       (if output-string
-			   (merge-pathnames (->pathname output-string)
-					    output-pathname)
-			   output-pathname))))
-		(newline)
-		(write-string "Compile File: ")
-		(write (pathname->string input-pathname))
-		(write-string " => ")
-		(write (pathname->string output-pathname))
-		(fasdump (transform input-pathname output-pathname)
-			 output-pathname)))))
-	 (kernel
-	  (if compiler:batch-mode?
-	      (batch-kernel core)
-	      core)))
-    (if (pair? input-string)
-	(for-each kernel input-string)
-	(kernel input-string))))
-
 ;;;; Compiler emulation
 
 (define type-code:compiled-entry (ucode-type COMPILED-ENTRY))
 (define compiler:batch-mode? false)
 
-(define compiler:expression)
-(define compiler:code-vector)
-(define compiler:entry-label)
-(define compiler:entry-points)
-(define compiler:label-bindings)
+(define *expression*)
+(define *code-vector*)
+(define *entry-label*)
+(define *entry-points*)
+(define *label-bindings*)
 (define *ic-procedure-headers*)
 
 (define (in-compiler thunk)
-  (fluid-let ((compiler:expression)
-	      (compiler:code-vector)
-	      (compiler:entry-label)
-	      (compiler:entry-points)
-	      (compiler:label-bindings)	      (*ic-procedure-headers*))
+  (fluid-let ((*expression*)
+	      (*code-vector*)
+	      (*entry-label*)
+	      (*entry-points*)
+	      (*label-bindings*)
+	      (*ic-procedure-headers*))
     (thunk)))
 
 (define (compiler-phase name thunk)
diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm
index 9e695ee05..0a687abca 100644
--- a/v7/src/compiler/base/crstop.scm
+++ b/v7/src/compiler/base/crstop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.3 1989/05/21 02:40:17 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.4 1989/08/21 19:32:21 cph Exp $
 $MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
@@ -34,7 +34,7 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; Cross Compiler Top Level.
-;;; This code shares and should be merged with toplev.scm.
+;;; This code shares and should be merged with "toplev.scm".
 ;;; Many of the procedures only differ in the default extensions.
 
 (declare (usual-integrations))
@@ -80,7 +80,7 @@ MIT in each case. |#
   (in-compiler
    (lambda ()
      (cross-link-end cross-compilation)
-     compiler:expression)))
+     *result*)))
 
 ;; This should be merged with compile-scode
 
@@ -122,7 +122,7 @@ MIT in each case. |#
 	   (phase/info-generation-2 info-output-pathname))
        ;; Here is were this procedure differs from compile-scode
        (phase/cross-link)
-       compiler:expression))))
+       *result*))))
 
 (define-structure (cc-vector (constructor cc-vector/make)
 			     (conc-name cc-vector/))
@@ -136,18 +136,19 @@ MIT in each case. |#
   (compiler-phase
    "Cross Linkification"
    (lambda ()
-     (set! compiler:expression
-	 (cc-vector/make
-	  (last-reference compiler:code-vector)
-	  (last-reference compiler:entry-label)
-	  (last-reference compiler:entry-points)
-	  (last-reference compiler:label-bindings)
-	  (last-reference *ic-procedure-headers*)))
+     (set! *result*
+	   (cc-vector/make
+	    (last-reference *code-vector*)
+	    (last-reference *entry-label*)
+	    (last-reference *entry-points*)
+	    (last-reference *label-bindings*)
+	    (last-reference *ic-procedure-headers*)))
      unspecific)))
 
 (define (cross-link-end cc-vector)
-  (set! compiler:code-vector (cc-vector/code-vector cc-vector))
-  (set! compiler:entry-label (cc-vector/entry-label cc-vector))
-  (set! compiler:entry-points (cc-vector/entry-points cc-vector))
-  (set! compiler:label-bindings (cc-vector/label-bindings cc-vector))  (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
+  (set! *code-vector* (cc-vector/code-vector cc-vector))
+  (set! *entry-label* (cc-vector/entry-label cc-vector))
+  (set! *entry-points* (cc-vector/entry-points cc-vector))
+  (set! *label-bindings* (cc-vector/label-bindings cc-vector))
+  (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
   (phase/link))
\ No newline at end of file
diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm
index ab9b3347c..9b97e1bbe 100644
--- a/v7/src/compiler/base/debug.scm
+++ b/v7/src/compiler/base/debug.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.9 1989/04/15 18:05:13 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.10 1989/08/21 19:32:23 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -79,9 +79,7 @@ MIT in each case. |#
 	 (write-string "\nOffset: ")
 	 (write-string
 	  (number->string (compiled-code-address->offset object)
-			  '(HEUR (RADIX X S)))))	((compiled-procedure? object)
-	 (debug/where (compiled-procedure-entry object)))
-	(else
+			  '(HEUR (RADIX X S)))))	(else
 	 (error "debug/where -- what?" object))))
 
 (define (compiler:write-rtl-file input-path #!optional output-path)
@@ -198,7 +196,9 @@ MIT in each case. |#
   (for-each fg/print-blocks (block-disowned-children block)))
 
 (define (fg/print-node node)
-  (if (not (node-marked? node))      (begin
+  (if (and node
+	   (not (node-marked? node)))
+      (begin
 	(node-mark! node)
 	(fg/print-object node)
 	(cfg-node-case (tagged-vector/tag node)
diff --git a/v7/src/compiler/base/infnew.scm b/v7/src/compiler/base/infnew.scm
index 67773b599..7d5bc83ac 100644
--- a/v7/src/compiler/base/infnew.scm
+++ b/v7/src/compiler/base/infnew.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.4 1989/01/06 20:50:21 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.5 1989/08/21 19:32:26 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -229,7 +229,7 @@ MIT in each case. |#
 	   (or (selector object)
 	       (error "Missing debugging info" object)))))
     (values
-     (debug-info rtl-expr/debugging-info expression)
+     (and expression (debug-info rtl-expr/debugging-info expression))
      (map (lambda (procedure)
 	    (let ((info (debug-info rtl-procedure/debugging-info procedure)))
 	      (set-dbg-procedure/external-label!
@@ -266,9 +266,11 @@ MIT in each case. |#
 	(for-each (lambda (label)
 		    (set-dbg-label/external?! (map-label label) true))
 		  external-labels)
-	(set-dbg-expression/label!
-	 expression
-	 (map-label (dbg-expression/label expression)))	(for-each
+	(if expression
+	    (set-dbg-expression/label!
+	     expression
+	     (map-label (dbg-expression/label expression))))
+	(for-each
 	 (lambda (procedure)
 	   (set-dbg-procedure/label!
 	    procedure
diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm
index 05d9613a6..05136d4e3 100644
--- a/v7/src/compiler/base/switch.scm
+++ b/v7/src/compiler/base/switch.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.10 1988/12/06 18:53:47 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.11 1989/08/21 19:32:29 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -40,6 +40,10 @@ MIT in each case. |#
 
 (define compiler:enable-integration-declarations? true)
 (define compiler:enable-expansion-declarations? true)
+(define compiler:compile-by-procedures? true)
+(define compiler:show-time-reports? false)
+(define compiler:show-procedures? true)
+(define compiler:show-phases? false)
 (define compiler:show-subphases? false)
 (define compiler:preserve-data-structures? false)
 (define compiler:code-compression? true)
@@ -60,4 +64,10 @@ MIT in each case. |#
   'HYBRID)
 
 (define compiler:default-top-level-declarations
-  '((UUO-LINK ALL)))
\ No newline at end of file
+  '((UUO-LINK ALL)))
+
+;;; Hook: bind this to a procedure of one argument and it will receive
+;;; each phase of the compiler as a thunk.  It is expected to call the
+;;; thunk after any appropriate processing.
+(define compiler:phase-wrapper
+  false)
\ No newline at end of file
diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index a0c02aee4..28c579e72 100644
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.18 1989/06/10 23:54:04 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.19 1989/08/21 19:32:32 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -36,142 +36,7 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-;;; Global variables
-
-(define *recursive-compilation-count*)
-(define *recursive-compilation-number*)
-(define *recursive-compilation-results*)
-(define *recursive-compilation-rtl-blocks*)
-
-(define *info-output-pathname* false)
-(define *rtl-output-pathname* false)
-
-(define *input-scode*)
-(define *scode*)
-(define *ic-procedure-headers*)
-(define *root-block*)
-(define *root-expression*)
-(define *rtl-expression*)
-(define *rtl-procedures*)
-(define *rtl-continuations*)
-(define *rtl-graphs*)
-(define label->object)
-(define *dbg-expression*)
-(define *dbg-procedures*)
-(define *dbg-continuations*)
-
-;;; These variable names mistakenly use the format "compiler:..."
-;;; instead of the correct format, which is "*...*".  Fix it sometime.
-(define compiler:external-labels)
-(define compiler:label-bindings)
-(define compiler:block-label)
-(define compiler:entry-label)
-(define compiler:bits)
-(define compiler:code-vector)
-(define compiler:entry-points)
-(define compiler:expression)
-
-(define compiler:phase-wrapper false)
-(define compiler:process-time 0)
-(define compiler:real-time 0)
-
-(define (compiler:reset!)
-  (set! *recursive-compilation-number* 0)
-  (set! *recursive-compilation-count* 1)
-  (set! *recursive-compilation-results* '())
-  (set! *recursive-compilation-rtl-blocks* '())
-  (set! *input-scode*)
-  (set! *scode*)
-  (set! *current-label-number*)
-  (set! *constants*)
-  (set! *blocks*)
-  (set! *expressions*)
-  (set! *procedures*)
-  (set! *lvalues*)
-  (set! *applications*)
-  (set! *parallels*)
-  (set! *ic-procedure-headers*)
-  (set! *root-expression*)
-  (set! *root-block*)
-  (set! *rtl-expression*)
-  (set! *rtl-procedures*)
-  (set! *rtl-continuations*)
-  (set! *rtl-graphs*)
-  (set! label->object)
-  (set! *dbg-expression*)
-  (set! *dbg-procedures*)
-  (set! *dbg-continuations*)
-  (set! *machine-register-map*)
-  (set! compiler:external-labels)
-  (set! compiler:label-bindings)
-  (set! compiler:block-label)
-  (set! compiler:entry-label)
-  (set! compiler:bits)
-  (set! compiler:code-vector)
-  (set! compiler:entry-points)
-  (set! compiler:expression))
-
-(define (in-compiler-recursively thunk)
-  (fluid-let ((*input-scode*)
-	      (*scode*)
-	      (*current-label-number*)
-	      (*constants*)
-	      (*blocks*)
-	      (*expressions*)
-	      (*procedures*)
-	      (*lvalues*)
-	      (*applications*)
-	      (*parallels*)
-	      (*ic-procedure-headers*)
-	      (*root-expression*)
-	      (*root-block*))
-    (fluid-let ((*rtl-expression*)
-		(*rtl-procedures*)
-		(*rtl-continuations*)
-		(*rtl-graphs*)
-		(label->object)
-		(*dbg-expression*)
-		(*dbg-procedures*)
-		(*dbg-continuations*)
-		(*machine-register-map*)
-		(compiler:external-labels)
-		(compiler:label-bindings)
-		(compiler:block-label)
-		(compiler:entry-label)
-		(compiler:bits)
-		(compiler:code-vector)
-		(compiler:entry-points)
-		(compiler:expression))
-      (thunk))))
-
-(define (in-compiler thunk)
-  (fluid-let ((compiler:process-time 0)
-	      (compiler:real-time 0))
-    (compiler:reset!)
-    (let ((value
-	   (let ((expression (thunk)))
-	     (let ((others (recursive-compilation-results)))
-	       (if (null? others)
-		   expression
-		   (scode/make-comment
-		    (make-dbg-info-vector
-		     (list->vector
-		      (cons (compiled-code-address->block expression)
-			    (map (lambda (other) (vector-ref other 2))
-				 others))))
-		    expression))))))
-      (if (not compiler:preserve-data-structures?)
-	  (compiler:reset!))
-      (compiler-time-report "Total compilation time"
-			    compiler:process-time
-			    compiler:real-time)
-      value)))
-
-(define (recursive-compilation-results)
-  (sort *recursive-compilation-results*
-	(lambda (x y) (< (vector-ref x 0) (vector-ref y 0)))))
-
-;;;; The file compiler, its usual mode.
+;;;; Usual Entry Point: File Compilation
 
 (define (cf input #!optional output)
   (let ((kernel
@@ -197,43 +62,9 @@ MIT in each case. |#
       (compile-scode (compiler-fasload input-pathname)
 		     (and compiler:generate-rtl-files?
 			  (pathname-new-type output-pathname "brtl"))
-		     (pathname-new-type output-pathname "binf")))))
-
-;;;; Utilities for compiling in batch mode
-
-(define compiler:batch-mode? false)
-(define compiler:abort-handled? false)
-(define compiler:abort-continuation)
-
-(define (compiler:batch-compile input #!optional output)
-  (fluid-let ((compiler:batch-mode? true))
-    (bind-condition-handler '() compiler:batch-error-handler
-      (lambda ()
-	(if (default-object? output)
-	    (compile-bin-file input)
-	    (compile-bin-file input output))))))
+		     (pathname-new-type output-pathname "binf"))))
+  unspecific)
 
-(define (compiler:batch-error-handler condition)
-  (and (condition/error? condition)
-       (begin (warn (condition/report-string condition))
-	      (compiler:abort false))))
-
-(define (compiler:abort value)
-  (if compiler:abort-handled?
-      (begin
-	(newline)
-	(display "*** Aborting...")
-	(compiler:abort-continuation value))
-      (error "compiler:abort: Not set up to abort" value)))
-
-(define (batch-kernel real-kernel)
-  (lambda (input-string)
-    (call-with-current-continuation
-     (lambda (abort-compilation)
-       (fluid-let ((compiler:abort-continuation abort-compilation)
-		   (compiler:abort-handled? true))
-	 (real-kernel input-string))))))
-
 (define (compiler-pathnames input-string output-string default transform)
   (let* ((core
 	  (lambda (input-string)
@@ -282,87 +113,369 @@ MIT in each case. |#
 		scode)))
 	(scan-defines scode make-open-block))))
 
+;;;; Alternate Entry Points
+
 (define (compile-procedure procedure)
   (scode-eval (compile-scode (procedure-lambda procedure) false false)
 	      (procedure-environment procedure)))
 
-;; The rtl output should be fixed
+(define (compiler:batch-compile input #!optional output)
+  (fluid-let ((compiler:batch-mode? true))
+    (bind-condition-handler '() compiler:batch-error-handler
+      (lambda ()
+	(if (default-object? output)
+	    (compile-bin-file input)
+	    (compile-bin-file input output))))))
+
+(define (compiler:batch-error-handler condition)
+  (and (not (condition/internal? condition))
+       (condition/error? condition)
+       (begin
+	 (warn (condition/report-string condition))
+	 (compiler:abort false))))
+
+(define (compiler:abort value)
+  (if (not compiler:abort-handled?)
+      (error "Not set up to abort" value))
+  (newline)
+  (write-string "*** Aborting...")
+  (compiler:abort-continuation value))
 
-(define (compile-recursively scode)
-  (let ((my-number *recursive-compilation-count*))
+(define (batch-kernel real-kernel)
+  (lambda (input-string)
+    (call-with-current-continuation
+     (lambda (abort-compilation)
+       (fluid-let ((compiler:abort-continuation abort-compilation)
+		   (compiler:abort-handled? true))
+	 (real-kernel input-string))))))
+
+(define compiler:batch-mode? false)
+(define compiler:abort-handled? false)
+(define compiler:abort-continuation)
+
+(define (compile-recursively scode procedure-result?)
+  ;; Used by the compiler when it wants to compile subexpressions as
+  ;; separate code-blocks.
+  ;; The rtl output should be fixed.
+  (let ((my-number *recursive-compilation-count*)
+	(output?
+	 (and compiler:show-phases?
+	      (not compiler:show-procedures?))))
     (set! *recursive-compilation-count* (1+ my-number))
-    (newline)
-    (newline)
-    (display "    *** Recursive compilation ")
-    (write my-number)
-    (display " ***")
-    (let ((val
-	   (fluid-let ((*recursive-compilation-number* my-number)
-		       (compiler:package-optimization-level 'NONE))
-	     (compile-scode scode
-			    (and *rtl-output-pathname* true)
-			    (and *info-output-pathname* true)
-			    in-compiler-recursively))))
-      (newline)
-      (display "    *** Done with recursive compilation ")
-      (write my-number)
-      (display " ***")
-      (newline)
-      val)))
+    (if output?
+	(begin
+	  (newline)
+	  (newline)
+	  (write-string *output-prefix*)
+	  (write-string "*** Recursive compilation ")
+	  (write my-number)
+	  (write-string " ***")))
+    (let ((value
+	   ((let ((do-it
+		   (lambda ()
+		     (fluid-let ((*recursive-compilation-number* my-number)
+				 (compiler:package-optimization-level 'NONE)
+				 (*procedure-result?* procedure-result?))
+		       (compile-scode scode
+				      (and *rtl-output-pathname* true)
+				      (and *info-output-filename* true)
+				      bind-compiler-variables)))))
+	      (if procedure-result?
+		  (let ((do-it
+			 (lambda ()
+			   (let ((result (do-it)))
+			     (set! *remote-links*
+				   (cons (cdr result) *remote-links*))
+			     (car result)))))
+		    (if compiler:show-procedures?
+			(lambda ()
+			  (compiler-phase/visible
+			   (string-append
+			    "Compiling procedure: "
+			    (write-to-string (lambda-name scode)))
+			   do-it))
+			do-it))
+		  do-it)))))      (if output?
+	  (begin
+	    (newline)
+	    (write-string *output-prefix*)
+	    (write-string "*** Done with recursive compilation ")
+	    (write my-number)
+	    (write-string " ***")
+	    (newline)))
+      value)))
+
+;;;; Global variables
+
+(define *recursive-compilation-count*)
+(define *recursive-compilation-number*)
+(define *recursive-compilation-results*)
+(define *recursive-compilation-rtl-blocks*)
+(define *procedure-result?*)
+(define *remote-links*)
+(define *process-time*)
+(define *real-time*)
+
+(define *info-output-filename* false)
+(define *rtl-output-pathname* false)
+
+;; First set: input to compilation
+;; Last used: phase/canonicalize-scode
+(define *input-scode*)
+
+;; First set: phase/canonicalize-scode
+;; Last used: phase/translate-scode
+(define *scode*)
+
+;; First set: phase/translate-scode
+;; Last used: phase/fg-optimization-cleanup
+(define *root-block*)
+
+;; First set: phase/translate-scode
+;; Last used: phase/rtl-generation
+(define *root-expression*)
+(define *root-procedure*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/bit-linearization
+(define *rtl-expression*)
+(define *rtl-procedures*)
+(define *rtl-continuations*)
+(define *rtl-graphs*)
+(define label->object)
+(define *rtl-root*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/link
+(define *ic-procedure-headers*)
+(define *entry-label*)
+(define *block-label*)
+
+;; First set: phase/bit-generation
+;; Last used: phase/info-generation-2
+(define *external-labels*)
+
+;; First set: phase/bit-generation
+;; Last used: phase/link
+(define *subprocedure-linking-info*)
+
+;; First set: phase/bit-linearization
+;; Last used: phase/assemble
+(define *bits*)
+
+;; First set: phase/bit-linearization
+;; Last used: phase/info-generation-2
+(define *dbg-expression*)
+(define *dbg-procedures*)
+(define *dbg-continuations*)
+
+;; First set: phase/assemble
+;; Last used: phase/link
+(define *label-bindings*)
+(define *code-vector*)
+(define *entry-points*)
+
+;; First set: phase/link
+;; Last used: result of compilation
+(define *result*)
+
+(define (in-compiler thunk)
+  (let ((run-compiler
+	 (lambda ()
+	   (let ((value
+		  (let ((expression (thunk)))
+		    (let ((others (recursive-compilation-results)))
+		      (if (null? others)
+			  expression
+			  (scode/make-comment
+			   (make-dbg-info-vector
+			    (let* ((others
+				    (map (lambda (other) (vector-ref other 2))
+					 others))
+				   (all-blocks
+				    (list->vector
+				     (cons
+				      (compiled-code-address->block expression)
+				      others))))
+			      (if compiler:compile-by-procedures?
+				  (list 'COMPILED-BY-PROCEDURES
+					all-blocks
+					(list->vector others))
+				  all-blocks)))
+			   expression))))))
+	     (compiler-time-report "Total compilation time"
+				   *process-time*
+				   *real-time*)
+	     value))))
+    (if compiler:preserve-data-structures?
+	(begin
+	  (compiler:reset!)
+	  (run-compiler))
+	(fluid-let ((*recursive-compilation-number* 0)
+		    (*recursive-compilation-count* 1)
+		    (*recursive-compilation-results* '())
+		    (*recursive-compilation-rtl-blocks* '())
+		    (*procedure-result?* false)
+		    (*remote-links* '())
+		    (*process-time* 0)
+		    (*real-time* 0))
+	  (bind-compiler-variables run-compiler)))))
+
+(define (bind-compiler-variables thunk)
+  ;; Split this fluid-let because compiler was choking on it.
+  (fluid-let ((*ic-procedure-headers*)
+	      (*current-label-number*)
+	      (*external-labels*)
+	      (*block-label*)
+	      (*dbg-expression*)
+	      (*dbg-procedures*)
+	      (*dbg-continuations*)
+	      (*bits*)
+	      (*next-constant*)
+	      (*interned-constants*)
+	      (*interned-variables*)
+	      (*interned-assignments*)
+	      (*interned-uuo-links*)
+	      (*constants*)
+	      (*blocks*)
+	      (*expressions*)
+	      (*procedures*)
+	      (*lvalues*)
+	      (*applications*)
+	      (*parallels*))
+    (fluid-let ((*input-scode*)
+		(*scode*)
+		(*root-expression*)
+		(*root-procedure*)
+		(*root-block*)
+		(*rtl-expression*)
+		(*rtl-procedures*)
+		(*rtl-continuations*)
+		(*rtl-graphs*)
+		(label->object)
+		(*rtl-root*)
+		(*machine-register-map*)
+		(*entry-label*)
+		(*label-bindings*)
+		(*code-vector*)
+		(*entry-points*)
+		(*subprocedure-linking-info*)
+		(*result*))
+      (thunk))))
+
+(define (recursive-compilation-results)
+  (sort *recursive-compilation-results*
+	(lambda (x y) (< (vector-ref x 0) (vector-ref y 0)))))
+
+(define (compiler:reset!)
+  (set! *recursive-compilation-number* 0)
+  (set! *recursive-compilation-count* 1)
+  (set! *recursive-compilation-results* '())
+  (set! *recursive-compilation-rtl-blocks* '())
+  (set! *procedure-result?* false)
+  (set! *remote-links* '())
+  (set! *process-time* 0)
+  (set! *real-time* 0)
+  (set! *info-output-filename* false)
+  (set! *rtl-output-pathname* false)
+
+  (set! *ic-procedure-headers*)
+  (set! *current-label-number*)
+  (set! *external-labels*)
+  (set! *bits*)
+  (set! *block-label*)
+  (set! *dbg-expression*)
+  (set! *dbg-procedures*)
+  (set! *dbg-continuations*)  (set! *next-constant*)
+  (set! *interned-constants*)
+  (set! *interned-variables*)
+  (set! *interned-assignments*)
+  (set! *interned-uuo-links*)
+  (set! *constants*)
+  (set! *blocks*)
+  (set! *expressions*)
+  (set! *procedures*)
+  (set! *lvalues*)
+  (set! *applications*)
+  (set! *parallels*)
+  (set! *input-scode*)
+  (set! *scode*)
+  (set! *root-expression*)
+  (set! *root-procedure*)
+  (set! *root-block*)
+  (set! *rtl-expression*)
+  (set! *rtl-procedures*)
+  (set! *rtl-continuations*)
+  (set! *rtl-graphs*)
+  (set! label->object)
+  (set! *rtl-root*)
+  (set! *machine-register-map*)
+  (set! *entry-label*)
+  (set! *label-bindings*)
+  (set! *code-vector*)
+  (set! *entry-points*)
+  (set! *subprocedure-linking-info*)
+  (set! *result*)
+  unspecific)
+
+;;;; Main Entry Point
 
 (define (compile-scode scode
 		       #!optional
 		       rtl-output-pathname
 		       info-output-pathname
 		       wrapper)
-
-  (if (default-object? rtl-output-pathname)
-      (set! rtl-output-pathname false))
-  (if (default-object? info-output-pathname)
-      (set! info-output-pathname false))
-
-  (fluid-let ((*info-output-pathname*
-	       (if (and info-output-pathname
-			(not (eq? info-output-pathname true)))
-		   info-output-pathname
-		   *info-output-pathname*))
-	      (*rtl-output-pathname*
-	       (if (and rtl-output-pathname
-			(not (eq? rtl-output-pathname true)))
-		   rtl-output-pathname
-		   *rtl-output-pathname*)))
-    ((if (default-object? wrapper)
-	 in-compiler
-	 wrapper)
-     (lambda ()
-       (set! *input-scode* scode)
-       (phase/fg-generation)
-       (phase/fg-optimization)
-       (phase/rtl-generation)
-       #|
-       (if info-output-pathname
-	   (phase/info-generation-1 info-output-pathname))
-       |#
-       (phase/rtl-optimization)
-       (if rtl-output-pathname
-	   (phase/rtl-file-output rtl-output-pathname))
-       (phase/bit-generation)
-       (phase/bit-linearization)
-       (phase/assemble)
-       (if info-output-pathname
-	   (phase/info-generation-2 info-output-pathname))
-       (phase/link)
-       compiler:expression))))
+  (let ((rtl-output-pathname
+	 (if (default-object? rtl-output-pathname)
+	     false
+	     rtl-output-pathname))
+	(info-output-pathname
+	 (if (default-object? info-output-pathname)
+	     false
+	     info-output-pathname))
+	(wrapper
+	 (if (default-object? wrapper) in-compiler wrapper)))
+    (fluid-let ((*info-output-filename*
+		 (if (pathname? info-output-pathname)
+		     (pathname->string info-output-pathname)
+		     *info-output-filename*))
+		(*rtl-output-pathname*
+		 (if (pathname? rtl-output-pathname)
+		     rtl-output-pathname
+		     *rtl-output-pathname*)))
+      (wrapper
+       (lambda ()
+	 (set! *input-scode* scode)
+	 (phase/fg-generation)
+	 (phase/fg-optimization)
+	 (phase/rtl-generation)
+	 #|
+	 ;; Current info-generation keeps state in-core.
+	 (if info-output-pathname
+	     (phase/info-generation-1 info-output-pathname))
+	 |#
+	 (phase/rtl-optimization)
+	 (if rtl-output-pathname
+	     (phase/rtl-file-output rtl-output-pathname))
+	 (phase/bit-generation)
+	 (phase/bit-linearization)
+	 (phase/assemble)
+	 (if info-output-pathname
+	     (phase/info-generation-2 info-output-pathname))
+	 (phase/link)
+	 *result*)))))
 
 (define (compiler-phase name thunk)
-  (compiler-phase/visible name
-    (lambda ()
-      (compiler-phase/invisible thunk))))
+  (if compiler:show-phases?
+      (compiler-phase/visible name
+	(lambda ()
+	  (compiler-phase/invisible thunk)))
+      (compiler-phase/invisible thunk)))
 
 (define (compiler-superphase name thunk)
   (if compiler:show-subphases?
       (thunk)
-      (compiler-phase/visible name thunk)))
+      (compiler-phase name thunk)))
 
 (define (compiler-subphase name thunk)
   (if compiler:show-subphases?
@@ -370,26 +483,44 @@ MIT in each case. |#
       (compiler-phase/invisible thunk)))
 
 (define (compiler-phase/visible name thunk)
-  (newline)
-  (display "    ")
-  (display name)
-  (display "...")
-  (let ((process-start (process-time-clock))
-	(real-start (real-time-clock)))
-    (thunk)
-    (let ((process-delta (- (process-time-clock) process-start))
-	  (real-delta (- (real-time-clock) real-start)))
-      (set! compiler:process-time (+ process-delta compiler:process-time))
-      (set! compiler:real-time (+ real-delta compiler:real-time))
-      (compiler-time-report "      Time taken" process-delta real-delta))))
+  (fluid-let ((*output-prefix* (string-append "    " *output-prefix*)))
+    (newline)
+    (write-string *output-prefix*)
+    (write-string name)
+    (write-string "...")
+    (if compiler:show-time-reports?
+	(let ((process-start *process-time*)
+	      (real-start *real-time*))
+	  (let ((value (thunk)))
+	    (compiler-time-report "  Time taken"
+				  (- *process-time* process-start)
+				  (- *real-time* real-start))
+	    value))
+	(thunk))))
+
+(define *output-prefix* "")
+(define *phase-level* 0)
 
 (define (compiler-phase/invisible thunk)
-  (if compiler:phase-wrapper
-      (compiler:phase-wrapper thunk)
-      (thunk)))
+  (fluid-let ((*phase-level* (1+ *phase-level*)))
+    (let ((do-it
+	   (if compiler:phase-wrapper
+	       (lambda () (compiler:phase-wrapper thunk))
+	       thunk)))
+      (if (= 1 *phase-level*)
+	  (let ((process-start (process-time-clock))
+		(real-start (real-time-clock)))
+	    (let ((value (do-it)))
+	      (let ((process-delta (- (process-time-clock) process-start))
+		    (real-delta (- (real-time-clock) real-start)))
+		(set! *process-time* (+ process-delta *process-time*))
+		(set! *real-time* (+ real-delta *real-time*)))
+	      value))
+	  (do-it)))))
 
 (define (compiler-time-report prefix process-time real-time)
   (newline)
+  (write-string *output-prefix*)
   (write-string prefix)
   (write-string ": ")
   (write (/ process-time 1000))
@@ -414,7 +545,8 @@ MIT in each case. |#
 (define (phase/canonicalize-scode)
   (compiler-subphase "Scode Canonicalization"
     (lambda ()
-      (set! *scode* (canonicalize/top-level (last-reference *input-scode*))))))
+      (set! *scode* (canonicalize/top-level (last-reference *input-scode*)))
+      unspecific)))
 
 (define (phase/translate-scode)
   (compiler-subphase "Translation of Scode into Flow Graph"
@@ -428,11 +560,21 @@ MIT in each case. |#
       (set! *applications* '())
       (set! *parallels* '())
       (set! *root-expression* (construct-graph (last-reference *scode*)))
+      (if *procedure-result?*
+	  (let ((node (expression-entry-node *root-expression*)))
+	    (if (not (and (application? node)
+			  (application/return? node)))
+		(error "Entry node of procedure compilation not return" node))
+	    (let ((operand (return/operand node)))
+	      (if (not (procedure? operand))
+		  (error "Value of procedure compilation not procedure" node))
+	      (set! *root-procedure* operand))))
       (set! *root-block* (expression-block *root-expression*))
       (if (or (null? *expressions*)
 	      (not (null? (cdr *expressions*))))
 	  (error "Multiple expressions"))
-      (set! *expressions*))))
+      (set! *expressions*)
+      unspecific)))
 
 (define (phase/fg-optimization)
   (compiler-superphase "Flow Graph Optimization"
@@ -559,46 +701,62 @@ MIT in each case. |#
   (compiler-subphase "Flow Graph Optimization Cleanup"
     (lambda ()
       (if (not compiler:preserve-data-structures?)
-	  (begin (clear-call-graph! *procedures*)
-		 (set! *constants*)
-		 (set! *blocks*)
-		 (set! *procedures*)
-		 (set! *lvalues*)
-		 (set! *applications*)
-		 (set! *parallels*)
-		 (set! *root-block*))))))
+	  (begin
+	    (clear-call-graph! *procedures*)
+	    (set! *constants*)
+	    (set! *blocks*)
+	    (set! *procedures*)
+	    (set! *lvalues*)
+	    (set! *applications*)
+	    (set! *parallels*)
+	    (set! *root-block*)
+	    unspecific)))))
 
 (define (phase/rtl-generation)
   (compiler-phase "RTL Generation"
     (lambda ()
-      (set! *rtl-procedures* '())
-      (set! *rtl-continuations* '())
-      (set! *rtl-graphs* '())
       (set! *ic-procedure-headers* '())
       (initialize-machine-register-map!)
-      (generate/top-level (last-reference *root-expression*))
+      (with-values
+	  (lambda ()
+	    (generate/top-level (last-reference *root-expression*)))
+	(lambda (expression procedures continuations rgraphs)
+	  (set! *rtl-expression* expression)
+	  (set! *rtl-procedures* procedures)
+	  (set! *rtl-continuations* continuations)
+	  (set! *rtl-graphs* rgraphs)
+	  unspecific))
+      (if *procedure-result?*
+	  (set! *rtl-expression* false))
       (set! label->object
 	    (make/label->object *rtl-expression*
 				*rtl-procedures*
 				*rtl-continuations*))
+      (set! *rtl-root*
+	    (if *procedure-result?*
+		(label->object
+		 (procedure-label (last-reference *root-procedure*)))
+		*rtl-expression*))
       (for-each (lambda (entry)
 		  (set-cdr! entry
 			    (rtl-procedure/external-label
 			     (label->object (cdr entry)))))
 		*ic-procedure-headers*)
-      (let ((n-registers
-	     (map (lambda (rgraph)
-		    (- (rgraph-n-registers rgraph)
-		       number-of-machine-registers))
-		  *rtl-graphs*)))
-	(newline)
-	(write-string "      Registers used: ")
-	(write (apply max n-registers))
-	(write-string " max, ")
-	(write (apply min n-registers))
-	(write-string " min, ")
-	(write (/ (apply + n-registers) (length n-registers)))
-	(write-string " mean")))))
+      (if compiler:show-phases?
+	  (let ((n-registers
+		 (map (lambda (rgraph)
+			(- (rgraph-n-registers rgraph)
+			   number-of-machine-registers))
+		      *rtl-graphs*)))
+	    (newline)
+	    (write-string *output-prefix*)
+	    (write-string "  Registers used: ")
+	    (write (apply max n-registers))
+	    (write-string " max, ")
+	    (write (apply min n-registers))
+	    (write-string " min, ")
+	    (write (/ (apply + n-registers) (length n-registers)))
+	    (write-string " mean"))))))
 
 (define (phase/rtl-optimization)
   (compiler-superphase "RTL Optimization"
@@ -658,40 +816,59 @@ MIT in each case. |#
   (compiler-phase "RTL File Output"
     (lambda ()
       (let ((rtl
-	     (linearize-rtl *rtl-expression*
+	     (linearize-rtl *rtl-root*
 			    *rtl-procedures*
 			    *rtl-continuations*)))
 	(if (eq? pathname true)
 	    ;; recursive compilation
-	    (set! *recursive-compilation-rtl-blocks*
-		  (cons (cons *recursive-compilation-number* rtl)
-			*recursive-compilation-rtl-blocks*))
+	    (begin
+	      (set! *recursive-compilation-rtl-blocks*
+		    (cons (cons *recursive-compilation-number* rtl)
+			  *recursive-compilation-rtl-blocks*))
+	      unspecific)
 	    (fasdump (if (null? *recursive-compilation-rtl-blocks*)
 			 rtl
 			 (list->vector
 			  (cons (cons 0 rtl)
 				*recursive-compilation-rtl-blocks*)))
 		     pathname))))))
-
+
 (define (phase/bit-generation)
   (compiler-phase "LAP Generation"
     (lambda ()
-      (set! compiler:external-labels '())
-      (generate-bits
-       *rtl-graphs*
-       (lambda (block-label prefix)
-	 (set! compiler:block-label block-label)
-	 (node-insert-snode! (rtl-expr/entry-node *rtl-expression*)
-			     (make-sblock prefix))))
-      (set! compiler:entry-label (rtl-expr/label *rtl-expression*)))))
-
+      (set! *next-constant* 0)
+      (set! *interned-constants* '())
+      (set! *interned-variables* '())
+      (set! *interned-assignments* '())
+      (set! *interned-uuo-links* '())
+      (set! *block-label* (generate-label))
+      (set! *external-labels* '())
+      (if *procedure-result?*
+	  (generate-bits *rtl-graphs* '()
+	    (lambda (prefix environment-label free-ref-label n-sections)
+	      (node-insert-snode! (rtl-procedure/entry-node *rtl-root*)
+				  (make-sblock prefix))
+	      (set! *entry-label*
+		    (rtl-procedure/external-label *rtl-root*))
+	      (set! *subprocedure-linking-info*
+		    (vector environment-label free-ref-label n-sections))
+	      unspecific))
+	  (begin
+	    (let ((prefix (generate-bits *rtl-graphs* *remote-links* false)))
+	      (node-insert-snode! (rtl-expr/entry-node *rtl-root*)
+				  (make-sblock prefix)))
+	    (set! *entry-label* (rtl-expr/label *rtl-root*))
+	    unspecific)))))
+
 (define (phase/bit-linearization)
   (compiler-phase "LAP Linearization"
     (lambda ()
-      (set! compiler:bits
+      (set! *bits*
 	    (append-instruction-sequences!
-	     (lap:make-entry-point compiler:entry-label compiler:block-label)
-	     (linearize-bits *rtl-expression*
+	     (if *procedure-result?*
+		 (LAP (ENTRY-POINT ,*entry-label*))
+		 (lap:make-entry-point *entry-label* *block-label*))
+	     (linearize-bits *rtl-root*
 			     *rtl-procedures*
 			     *rtl-continuations*)))
       (with-values
@@ -702,52 +879,56 @@ MIT in each case. |#
 	(lambda (expression procedures continuations)
 	  (set! *dbg-expression* expression)
 	  (set! *dbg-procedures* procedures)
-	  (set! *dbg-continuations* continuations)))
+	  (set! *dbg-continuations* continuations)
+	  unspecific))
       (if (not compiler:preserve-data-structures?)
-	  (begin (set! label->object)
-		 (set! *rtl-expression*)
-		 (set! *rtl-procedures*)
-		 (set! *rtl-continuations*)
-		 (set! *rtl-graphs*))))))
-
+	  (begin
+	    (set! *rtl-expression*)
+	    (set! *rtl-procedures*)
+	    (set! *rtl-continuations*)
+	    (set! *rtl-graphs*)
+	    (set! label->object)
+	    (set! *rtl-root*)
+	    unspecific)))))
+
 (define (phase/assemble)
   (compiler-phase "Assembly"
     (lambda ()
-      (assemble (last-reference compiler:block-label)
-		(last-reference compiler:bits)
+      (assemble *block-label* (last-reference *bits*)
 	(lambda (count code-vector labels bindings linkage-info)
-	  linkage-info		; ignored
-	  (set! compiler:code-vector code-vector)
-	  (set! compiler:entry-points labels)
-	  (set! compiler:label-bindings bindings)
-	  (newline)
-	  (display "      Branch tensioning done in ")
-	  (write (1+ count))
-	  (if (zero? count)
-	      (display " iteration.")
-	      (display " iterations.")))))))
+	  linkage-info			;ignored
+	  (set! *code-vector* code-vector)
+	  (set! *entry-points* labels)
+	  (set! *label-bindings* bindings)
+	  (if compiler:show-phases?
+	      (begin
+		(newline)
+		(write-string *output-prefix*)
+		(write-string "  Branch tensioning done in ")
+		(write (1+ count))
+		(write-string
+		 (if (zero? count) " iteration." " iterations.")))))))))
 
 (define (phase/info-generation-2 pathname)
   (compiler-phase "Debugging Information Generation"
     (lambda ()
       (set-compiled-code-block/debugging-info!
-       compiler:code-vector
+       *code-vector*
        (let ((info
 	      (info-generation-phase-3
 	       (last-reference *dbg-expression*)
 	       (last-reference *dbg-procedures*)
 	       (last-reference *dbg-continuations*)
-	       compiler:label-bindings
-	       (last-reference compiler:external-labels))))
+	       *label-bindings*
+	       (last-reference *external-labels*))))
 	 (if (eq? pathname true)	; recursive compilation
 	     (begin
 	       (set! *recursive-compilation-results*
 		     (cons (vector *recursive-compilation-number*
 				   info
-				   compiler:code-vector)
+				   *code-vector*)
 			   *recursive-compilation-results*))
-	       (cons (pathname->string *info-output-pathname*)
-		     *recursive-compilation-number*))
+	       (cons *info-output-filename* *recursive-compilation-number*))
 	     (begin
 	       (fasdump (let ((others (recursive-compilation-results)))
 			  (if (null? others)
@@ -757,37 +938,63 @@ MIT in each case. |#
 				     (map (lambda (other) (vector-ref other 1))
 					  others)))))
 			pathname)
-	       (pathname->string pathname))))))))
+	       *info-output-filename*)))))))
 
 (define (phase/link)
   (compiler-phase "Linkification"
     (lambda ()
       ;; This has sections locked against GC to prevent relocation
       ;; while computing addresses.
-      (let ((bindings
-	     (map (lambda (label)
-		    (cons
-		     label
-		     (with-absolutely-no-interrupts
-		      (lambda ()
-			((ucode-primitive &make-object)
-			 type-code:compiled-entry
-			 (make-non-pointer-object
-			  (+ (cdr (or (assq label compiler:label-bindings)
-				      (error "Missing entry point" label)))
-			     (object-datum compiler:code-vector))))))))
-		  compiler:entry-points)))
-	(let ((label->expression
-	       (lambda (label)
-		 (cdr (or (assq label bindings)
-			  (error "Label not defined as entry point" label))))))
-	  (set! compiler:expression (label->expression compiler:entry-label))
-	  (for-each (lambda (entry)
-		      (set-lambda-body! (car entry)
-					(label->expression (cdr entry))))
-		    *ic-procedure-headers*)))
-      (set! compiler:code-vector)
-      (set! compiler:entry-points)
-      (set! compiler:label-bindings)
-      (set! compiler:entry-label)
-      (set! *ic-procedure-headers*))))
\ No newline at end of file
+      (let* ((label->offset
+	      (lambda (label)
+		(cdr (or (assq label *label-bindings*)
+			 (error "Missing entry point" label)))))
+	     (bindings
+	      (map (lambda (label)
+		     (cons
+		      label
+		      (with-absolutely-no-interrupts
+		       (lambda ()
+			 ((ucode-primitive &make-object)
+			  type-code:compiled-entry
+			  (make-non-pointer-object
+			   (+ (label->offset label)
+			      (object-datum *code-vector*))))))))
+		   *entry-points*))
+	     (label->address
+	      (lambda (label)
+		(cdr (or (assq label bindings)
+			 (error "Label not defined as entry point"
+				label))))))
+	(set! *result*
+	      (if *procedure-result?*
+		  (let ((linking-info *subprocedure-linking-info*))
+		    (let ((compiled-procedure (label->address *entry-label*))
+			  (translate-label
+			   (let ((block-offset (label->offset *block-label*)))
+			     (lambda (index)
+			       (let ((label (vector-ref linking-info index)))
+				 (and label
+				      (- (label->offset label)
+					 block-offset)))))))
+		      (cons compiled-procedure
+			    (vector
+			     (compiled-code-address->block compiled-procedure)
+			     (translate-label 0)
+			     (translate-label 1)
+			     (vector-ref linking-info 2)))))
+		  (label->address *entry-label*)))
+	(for-each (lambda (entry)
+		    (set-lambda-body! (car entry)
+				      (label->address (cdr entry))))
+		  *ic-procedure-headers*))
+      (if (not compiler:preserve-data-structures?)
+	  (begin
+	    (set! *code-vector*)
+	    (set! *entry-points*)
+	    (set! *subprocedure-linking-info*)
+	    (set! *label-bindings*)
+	    (set! *block-label*)
+	    (set! *entry-label*)
+	    (set! *ic-procedure-headers*)
+	    unspecific)))))
\ No newline at end of file
diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm
index afeee25ec..f15ead5a2 100644
--- a/v7/src/compiler/fggen/canon.scm
+++ b/v7/src/compiler/fggen/canon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.5 1989/08/15 12:58:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.6 1989/08/21 19:33:57 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -321,10 +321,24 @@ ARBITRARY:	The expression may be executed more than once.  It
 	       false true false))
 
 (define (canonicalize/lambda expr bound context)
-  (canonicalize/lambda* expr bound
-			(if (eq? context 'FIRST-CLASS)
-			    'FIRST-CLASS
-			    'ARBITRARY)))
+  (let ((canout
+	 (canonicalize/lambda* expr bound
+			       (if (eq? context 'FIRST-CLASS)
+				   'FIRST-CLASS
+				   'ARBITRARY))))
+    (if (and (eq? context 'TOP-LEVEL)
+	     (canout-safe? canout)
+	     compiler:compile-by-procedures?)
+	(make-canout
+	 (scode/make-directive
+	  (canout-expr canout)
+	  '(COMPILE-PROCEDURE)
+	  expr)
+	 true
+	 (canout-needs? canout)
+	 (canout-splice? canout))
+	canout)))
+
 (define (canonicalize/sequence expr bound context)
   (cond ((not (scode/open-block? expr))
 	 (scode/sequence-components expr
diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
index 642933ad7..a835b8fec 100644
--- a/v7/src/compiler/fggen/fggen.scm
+++ b/v7/src/compiler/fggen/fggen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.18 1989/08/15 12:58:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.19 1989/08/21 19:34:01 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -76,9 +76,9 @@ MIT in each case. |#
   ;; The call to `process-declarations!' must come after the
   ;; expression is generated because it can refer to the set of free
   ;; variables in the expression.
-  (let ((node (generate/expression block continuation expression)))
+  (let ((scfg (generate/expression block continuation expression)))
     (process-top-level-declarations! block declarations)
-    node))
+    scfg))
 
 ;;;; Continuations
 
@@ -118,8 +118,7 @@ MIT in each case. |#
 	 (virtual-continuation/type continuation))
 	((procedure? continuation)
 	 (continuation/type continuation))
-	(else
-	 (error "Illegal continuation" continuation))))
+	(else (error "Illegal continuation" continuation))))
 
 (define (continuation/type? continuation type)
   (cond ((variable? continuation)
@@ -128,8 +127,7 @@ MIT in each case. |#
 	 (eq? (virtual-continuation/type continuation) type))
 	((procedure? continuation)
 	 (eq? (continuation/type continuation) type))
-	(else
-	 (error "Illegal continuation" continuation))))
+	(else (error "Illegal continuation" continuation))))
 
 (define-integrable (continuation/effect? continuation)
   (continuation/type? continuation continuation-type/effect))
@@ -150,6 +148,13 @@ MIT in each case. |#
   (cond ((variable? continuation) (make-reference block continuation true))
 	((procedure? continuation) continuation)
 	(else (error "Illegal continuation" continuation))))
+
+(define (scfg*ctype->ctype! continuation)
+  (continuation/case continuation
+		     scfg*scfg->scfg!
+		     scfg*scfg->scfg!
+		     scfg*pcfg->pcfg!
+		     scfg*subproblem->subproblem!))
 
 ;;;; Subproblems
 
@@ -175,6 +180,13 @@ MIT in each case. |#
 		   (subproblem-continuation subproblem)
 		   (subproblem-rvalue subproblem)))
 
+(define (pcfg*subproblem->subproblem! pcfg consequent alternative)
+  (make-subproblem (pcfg*scfg->scfg! pcfg
+				     (subproblem-prefix consequent)
+				     (subproblem-prefix alternative))
+		   (subproblem-continuation consequent)
+		   (subproblem-rvalue alternative)))
+
 (define *virtual-continuations*)
 
 (define (virtual-continuation/make block parent type debugging)
@@ -443,12 +455,7 @@ MIT in each case. |#
 ;;;; Combinators
 
 (define (generate/sequence block continuation expression)
-  (let ((join
-	 (continuation/case continuation
-			    scfg*scfg->scfg!
-			    scfg*scfg->scfg!
-			    scfg*pcfg->pcfg!
-			    scfg*subproblem->subproblem!)))
+  (let ((join (scfg*ctype->ctype! continuation)))
     (let ((do-action
 	   (lambda (action continuation-type)
 	     (generate/subproblem/effect block
@@ -470,7 +477,7 @@ MIT in each case. |#
 	       (do-result (&triple-third expression)))))
 	    (else
 	     (error "Not a sequence" expression))))))
-
+
 (define (generate/conditional block continuation expression)
   (scode/conditional-components expression
     (lambda (predicate consequent alternative)
@@ -482,11 +489,7 @@ MIT in each case. |#
 					    expression)))
 	(let ((simple
 	       (lambda (hooks branch)
-		 ((continuation/case continuation
-				     scfg*scfg->scfg!
-				     scfg*scfg->scfg!
-				     scfg*pcfg->pcfg!
-				     scfg*subproblem->subproblem!)
+		 ((scfg*ctype->ctype! continuation)
 		  (make-scfg (cfg-entry-node predicate) hooks)
 		  (generate/expression block continuation branch)))))
 	  (cond ((hooks-null? (pcfg-consequent-hooks predicate))
@@ -526,61 +529,56 @@ MIT in each case. |#
 (define (generate/combination block continuation expression)
   (scode/combination-components expression
     (lambda (operator operands)
-      (let ((make-combination
-	     (lambda (push continuation)
-	       (make-combination
-		block
-		(continuation-reference block continuation)
-		(wrapper/subproblem/value
-		 block
-		 continuation
-		 (make-continuation-debugging-info 'COMBINATION-OPERAND
-						   expression
-						   0)
-		 (lambda (continuation*)
-		   (if (scode/lambda? operator)
-		       (generate/lambda* block
-					 continuation*
-					 operator
-					 (continuation/known-type continuation)
-					 false)
-		       (generate/expression block
-					    continuation*
-					    operator))))
-		(let loop ((operands operands) (index 1))
-		  (if (null? operands)
-		      '()
-		      (cons (generate/subproblem/value block
-						       continuation
-						       (car operands)
-						       'COMBINATION-OPERAND
+      (if (eq? not operator)
+	  (generate/conditional block
+				continuation
+				(scode/make-conditional (car operands) #F #T))
+	  (let ((make-combination
+		 (lambda (push continuation)
+		   (make-combination
+		    block
+		    (continuation-reference block continuation)
+		    (wrapper/subproblem/value
+		     block
+		     continuation
+		     (make-continuation-debugging-info 'COMBINATION-OPERAND
 						       expression
-						       index)
-			    (loop (cdr operands) (1+ index)))))
-		push))))
-	((continuation/case continuation
-	   (lambda () (make-combination false continuation))
-	   (lambda ()
-	     (if (variable? continuation)
-		 (make-combination false continuation)
-		 (with-reified-continuation block
-					    continuation
-					    scfg*scfg->scfg!
-		   (lambda (push continuation)
-		     (make-scfg
-		      (cfg-entry-node (make-combination push continuation))
-		      (continuation/next-hooks continuation))))))
-	   (lambda ()
-	     (if (eq? not operator)
-		 (pcfg*pcfg->pcfg!
-		  (generate/subproblem/predicate block
-						 continuation
-						 (car operands)
-						 'COMBINATION-OPERAND
-						 expression
-						 1)
-		  (generate/expression block continuation false)
-		  (generate/expression block continuation true))
+						       0)
+		     (lambda (continuation*)
+		       (if (scode/lambda? operator)
+			   (generate/lambda*
+			    block
+			    continuation*
+			    operator
+			    (continuation/known-type continuation)
+			    false)
+			   (generate/expression block
+						continuation*
+						operator))))
+		    (let loop ((operands operands) (index 1))
+		      (if (null? operands)
+			  '()
+			  (cons (generate/subproblem/value block
+							   continuation
+							   (car operands)
+							   'COMBINATION-OPERAND
+							   expression
+							   index)
+				(loop (cdr operands) (1+ index)))))
+		    push))))
+	    ((continuation/case continuation
+	       (lambda () (make-combination false continuation))
+	       (lambda ()
+		 (if (variable? continuation)
+		     (make-combination false continuation)
+		     (with-reified-continuation block
+						continuation
+						scfg*scfg->scfg!
+		       (lambda (push continuation)
+			 (make-scfg
+			  (cfg-entry-node (make-combination push continuation))
+			  (continuation/next-hooks continuation))))))
+	       (lambda ()
 		 (with-reified-continuation block
 					    continuation
 					    scfg*pcfg->pcfg!
@@ -590,15 +588,15 @@ MIT in each case. |#
 		       (cfg-entry-node (make-combination push continuation))
 		       (continuation/next-hooks continuation))
 		      (make-true-test block
-				      (continuation/rvalue continuation)))))))
-	   (lambda ()
-	     (with-reified-continuation block
-					continuation
-					scfg*subproblem->subproblem!
-	       (lambda (push continuation)
-		 (make-subproblem/canonical
-		  (make-combination push continuation)
-		  continuation))))))))))
+				      (continuation/rvalue continuation))))))
+	       (lambda ()
+		 (with-reified-continuation block
+					    continuation
+					    scfg*subproblem->subproblem!
+		   (lambda (push continuation)
+		     (make-subproblem/canonical
+		      (make-combination push continuation)
+		      continuation)))))))))))
 
 ;;;; Assignments
 
@@ -717,10 +715,15 @@ MIT in each case. |#
 	    (generate/expression block continuation expression))
 	   ((COMPILE)
 	    (if (not (scode/quotation? expression))
-		(error "generate/comment: Bad compile directive" comment))
+		(error "Bad compile directive" comment))
 	    (continue/rvalue-constant block continuation
 	     (make-constant
-	      (compile-recursively (scode/quotation-expression expression)))))	   ((ENCLOSE)
+	      (compile-recursively
+	       (scode/quotation-expression expression false)))))	   ((COMPILE-PROCEDURE)
+	    (if (not (scode/lambda? expression))
+		(error "Bad compile-procedure directive" comment))
+	    (continue/rvalue-constant block continuation
+	     (make-constant (compile-recursively expression true))))	   ((ENCLOSE)
 	    (generate/enclose block continuation expression))
 	   (else
 	    (warn "generate/comment: Unknown directive" (cadr text) comment)
diff --git a/v7/src/compiler/fgopt/simapp.scm b/v7/src/compiler/fgopt/simapp.scm
index 2f7bc3cc1..315aa6e5e 100644
--- a/v7/src/compiler/fgopt/simapp.scm
+++ b/v7/src/compiler/fgopt/simapp.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.4 1988/12/12 21:30:21 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.5 1989/08/21 19:34:13 cph Rel $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -109,17 +109,22 @@ MIT in each case. |#
 			   (lvalue-connect! (car parameters) (car operands))
 			   (loop (cdr parameters) (cdr operands)))))))
 	      ((rvalue/constant? operator)
-	       (let ((value (constant-value operator)))
-		 (cond ((primitive-procedure? value)
-			(if (not
-			     (primitive-arity-correct? value
-						       (-1+ number-supplied)))
-			    (warn
-			     "Primitive called with wrong number of arguments"
-			     value
-			     number-supplied)))
-		       ((not (unassigned-reference-trap? value))
-			(warn "Inapplicable operator" value)))))
+	       (let ((value (constant-value operator))
+		     (argument-count (-1+ number-supplied)))
+		 (if (not
+		      (cond ((eq? value compiled-error-procedure)
+			     (positive? argument-count))
+			    ((or (primitive-procedure? value)
+				 (compiled-procedure? value))
+			     (procedure-arity-valid? value argument-count))
+			    (else
+			     (if (not (unassigned-reference-trap? value))
+				 (warn "Inapplicable operator" value))
+			     true)))
+		     (warn
+		      "Procedure called with wrong number of arguments"
+		      value
+		      number-supplied))))
 	      (else
 	       (warn "Inapplicable operator" operator)))))))
 
diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg
index 6f38a4bb2..c39077d13 100644
--- a/v7/src/compiler/machines/bobcat/compiler.pkg
+++ b/v7/src/compiler/machines/bobcat/compiler.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.23 1989/07/25 13:06:04 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.24 1989/08/21 19:33:33 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -79,6 +79,7 @@ MIT in each case. |#
 	  compiler:analyze-side-effects?
 	  compiler:cache-free-variables?
 	  compiler:code-compression?
+	  compiler:compile-by-procedures?
 	  compiler:cse?
 	  compiler:default-top-level-declarations
 	  compiler:enable-expansion-declarations?
@@ -92,7 +93,10 @@ MIT in each case. |#
 	  compiler:optimize-environments?
 	  compiler:package-optimization-level
 	  compiler:preserve-data-structures?
-	  compiler:show-subphases?))
+	  compiler:show-phases?
+	  compiler:show-procedures?
+	  compiler:show-subphases?
+	  compiler:show-time-reports?))
 
 (define-package (compiler reference-contexts)
   (files "base/refctx")
@@ -161,7 +165,8 @@ MIT in each case. |#
 	  *rtl-graphs*
 	  *rtl-procedures*)
   (export (compiler lap-syntaxer)
-	  compiler:external-labels
+	  *block-label*
+	  *external-labels*
 	  label->object)
   (export (compiler debug)
 	  *root-expression*
@@ -552,6 +557,11 @@ MIT in each case. |#
 	  lap:make-unconditional-branch
 	  lap:syntax-instruction)
   (export (compiler top-level)
+	  *interned-assignments*
+	  *interned-constants*
+	  *interned-uuo-links*
+	  *interned-variables*
+	  *next-constant*
 	  generate-bits)
   (import (scode-optimizer expansion)
 	  scode->scode-expander))
@@ -593,7 +603,8 @@ MIT in each case. |#
 	  compiler:disassemble)
   (import (runtime compiler-info)
 	  compiled-code-block/dbg-info
-	  dbg-info-vector/items	  dbg-info-vector?
+	  dbg-info-vector/blocks-vector
+	  dbg-info-vector?
 	  dbg-info/labels
 	  dbg-label/external?
 	  dbg-label/name
diff --git a/v7/src/compiler/machines/bobcat/compiler.sf b/v7/src/compiler/machines/bobcat/compiler.sf
index 91e1f2fb7..74d7ac683 100644
--- a/v7/src/compiler/machines/bobcat/compiler.sf
+++ b/v7/src/compiler/machines/bobcat/compiler.sf
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.9 1989/08/03 23:43:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.10 1989/08/21 19:33:37 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -82,14 +82,14 @@ MIT in each case. |#
 (in-package (->environment '(COMPILER LAP-SYNTAXER))
   (if (and compiler:enable-expansion-declarations?
 	   (null? early-instructions))
-      (fluid-let ((load-noisily? false))
+      (fluid-let ((load-noisily? false)
+		  (load/suppress-loading-message? false))
+	(write-string "\n\n---- Pre-loading instruction sets ----")
 	(for-each (lambda (name)
-		    (write-string "\nPre-loading instruction set from ")
-		    (write name)
 		    (load (string-append "machines/bobcat/" name ".scm")
 			  '(COMPILER LAP-SYNTAXER)
-			  early-syntax-table)
-		    (write-string " -- done"))		  '("instr1" "instr2" "instr3" "instr4"
+			  early-syntax-table))
+		  '("instr1" "instr2" "instr3" "instr4"
 			     "flinstr1" "flinstr2")))))
 
 ;; Resyntax any files that need it.
diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm
index 805911b9f..2aa6369ca 100644
--- a/v7/src/compiler/machines/bobcat/dassm1.scm
+++ b/v7/src/compiler/machines/bobcat/dassm1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.12 1989/08/11 02:29:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.13 1989/08/21 19:33:40 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -49,34 +49,46 @@ MIT in each case. |#
   (let ((pathname (->pathname filename)))
     (with-output-to-file (pathname-new-type pathname "lap")
       (lambda ()
-	(let ((object (fasload (pathname-new-type pathname "com")))
-	      (info (let ((pathname (pathname-new-type pathname "binf")))
-		      (and (if (default-object? symbol-table?)
-			       (file-exists? pathname)
-			       symbol-table?)
-			   (fasload pathname)))))
-	  (cond ((compiled-code-address? object)
-		 (disassembler/write-compiled-code-block
-		  (compiled-code-address->block object)
-		  info
-		  false))
-		((not (scode/comment? object))
-		 (error "compiler:write-lap-file : Not a compiled file"
-			(pathname-new-type pathname "com")))
-		(else
-		 (scode/comment-components
-		  object
-		  (lambda (text expression)
-		    expression ;; ignored
-		    (if (dbg-info-vector? text)
-			(let ((items (dbg-info-vector/items text)))
-			  (for-each disassembler/write-compiled-code-block
-				    (vector->list items)
-				    (if (false? info)
-					(make-list (vector-length items) false)
-					(vector->list info))))
-			(error "compiler:write-lap-file : Not a compiled file"
-			       (pathname-new-type pathname "com"))))))))))))
+	(let ((com-file (pathname-new-type pathname "com")))
+	  (let ((object (fasload com-file))
+		(info
+		 (let ((pathname (pathname-new-type pathname "binf")))
+		   (and (if (default-object? symbol-table?)
+			    (file-exists? pathname)
+			    symbol-table?)
+			(fasload pathname)))))
+	    (if (compiled-code-address? object)
+		(disassembler/write-compiled-code-block
+		 (compiled-code-address->block object)
+		 info)
+		(begin
+		  (if (not
+		       (and (scode/comment? object)
+			    (dbg-info-vector? (scode/comment-text object))))
+		      (error "Not a compiled file" com-file))
+		  (let ((items
+			 (vector->list
+			  (dbg-info-vector/blocks-vector
+			   (scode/comment-text object)))))
+		    (if (not (null? items))
+			(if (false? info)
+			    (let loop ((items items))
+			      (disassembler/write-compiled-code-block
+			       (car items)
+			       false)
+			      (if (not (null? (cdr items)))
+				  (begin
+				    (write-char #\page)
+				    (loop (cdr items)))))
+			    (let loop
+				((items items) (info (vector->list info)))
+			      (disassembler/write-compiled-code-block
+			       (car items)
+			       (car info))
+			      (if (not (null? (cdr items)))
+				  (begin
+				    (write-char #\page)
+				    (loop (cdr items) (cdr info))))))))))))))))
 
 (define disassembler/base-address)
 
@@ -101,23 +113,10 @@ MIT in each case. |#
 (define compiled-code-block/objects-per-procedure-cache)
 (define compiled-code-block/objects-per-variable-cache)
 
-(define (write-block block)
-  (write-string "#[COMPILED-CODE-BLOCK ")
-  (write-string
-   (number->string (object-hash block) '(HEUR (RADIX D S))))
-  (write-string " ")
-  (write-string
-   (number->string (object-datum block) '(HEUR (RADIX X E))))
-  (write-string "]"))
-
-(define (disassembler/write-compiled-code-block block info #!optional page?)
+(define (disassembler/write-compiled-code-block block info)
   (let ((symbol-table (and info (dbg-info/labels info))))
-    (if (or (default-object? page?) page?)
-	(begin
-	  (write-char #\page)
-	  (newline)))
     (write-string "Disassembly of ")
-    (write-block block)
+    (write block)
     (write-string ":\n")
     (write-string "Code:\n\n")
     (disassembler/write-instruction-stream
@@ -140,16 +139,9 @@ MIT in each case. |#
   (fluid-let ((*unparser-radix* 16))
     (disassembler/for-each-instruction instruction-stream
       (lambda (offset instruction)
-	(disassembler/write-instruction
-	 symbol-table
-	 offset
-	 (lambda ()
-	   (let ((string
-		  (with-output-to-string
-		    (lambda ()
-		      (display instruction)))))
-	     (string-downcase! string)
-	     (write-string string))))))))
+	(disassembler/write-instruction symbol-table
+					offset
+					(lambda () (display instruction)))))))
 
 (define (disassembler/for-each-instruction instruction-stream procedure)
   (let loop ((instruction-stream instruction-stream))
@@ -194,14 +186,14 @@ MIT in each case. |#
 		   (let ((label
 			  (disassembler/lookup-symbol symbol-table offset)))
 		     (if label
-			 (write-string (string-downcase label))
+			 (write-string label)
 			 (write offset))))
 		 (write-string ")")))))
 	((compiled-code-address? constant)
 	 (write-string "  (offset ")
 	 (write (compiled-code-address->offset constant))
 	 (write-string " in ")
-	 (write-block (compiled-code-address->block constant))
+	 (write (compiled-code-address->block constant))
 	 (write-string ")"))
 	(else false)))
 
@@ -275,7 +267,8 @@ MIT in each case. |#
 	(if label
 	    (begin
 	      (write-char #\Tab)
-	      (write-string (string-downcase (dbg-label/name label)))	      (write-char #\:)
+	      (write-string (dbg-label/name label))
+	      (write-char #\:)
 	      (newline)))))
 
   (if disassembler/write-addresses?
diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index 37c93b7d5..1867daa99 100644
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.48 1989/08/15 12:59:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.49 1989/08/21 19:33:43 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -41,4 +41,4 @@ MIT in each case. |#
 	    ((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
 	  '((COMPILER MACROS)
 	    (COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 48 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 49 '()))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 762f2e076..7fd4c7cce 100644
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.15 1988/12/30 07:05:20 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.16 1989/08/21 19:33:47 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -102,7 +102,7 @@ MIT in each case. |#
     (LAP ,@set-extension
 	 ,@(clear-map!)
 	 ,(load-dnw frame-size 0)
-	 (LEA (@PCR ,*block-start-label*) (A 1))
+	 (LEA (@PCR ,*block-label*) (A 1))
 	 (JMP ,entry:compiler-cache-reference-apply))))
 
 (define-rule statement
@@ -277,8 +277,7 @@ MIT in each case. |#
 ;;;; External Labels
 
 (define (make-external-label code label)
-  (set! compiler:external-labels 
-	(cons label compiler:external-labels))
+  (set! *external-labels* (cons label *external-labels*))
   (LAP (DC UW ,code)
        (BLOCK-OFFSET ,label)
        (LABEL ,label)))
@@ -439,74 +438,87 @@ MIT in each case. |#
 ;;;; Entry Header
 ;;; This is invoked by the top level of the LAP generator.
 
-(define generate/quotation-header
-  (let ((uuo-link-tag 0)
-	(reference-tag 1)
-	(assignment-tag 2))
-
-    (define (make-constant-block-tag tag datum)
-      (if (> datum #xffff)
-	  (error "make-constant-block-tag: datum too large" datum)
-	  (+ (* tag #x10000) datum)))
-
-    (define (declare-constants tag constants info)
-      (define (inner constants)
-	(if (null? constants)
-	    (cdr info)
-	    (let ((entry (car constants)))
-	      (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
-		   ,@(inner (cdr constants))))))
-
-      (if (and tag (not (null? constants)))
-	  (let ((label (allocate-constant-label)))
-	    (cons label
-		  (inner `((,(make-constant-block-tag tag (length constants))
-			    . ,label)
-			   ,@constants))))
-	  (cons (car info) (inner constants))))
-
-    (define (transmogrifly uuos)
-      (define (inner name assoc)
-	(if (null? assoc)
-	    (transmogrifly (cdr uuos))
-	    (cons (cons name (cdar assoc)) 		; uuo-label
-		  (cons (cons (caar assoc)		; frame-size
-			      (allocate-constant-label))
-			(inner name (cdr assoc))))))
-      (if (null? uuos)
-	  '()
-	  (inner (caar uuos) (cdar uuos))))
-
-    (lambda (block-label constants references assignments uuo-links)
-      (let ((constant-info
-	     (declare-constants uuo-link-tag (transmogrifly uuo-links)
-	       (declare-constants reference-tag references
-		 (declare-constants assignment-tag assignments
-		   (declare-constants #f constants
-		     (cons '() (LAP))))))))
-	(let ((free-ref-label (car constant-info))
-	      (constants-code (cdr constant-info))
-	      (debugging-information-label (allocate-constant-label))
-	      (environment-label (allocate-constant-label)))
-	  (LAP ,@constants-code
-	       ;; Place holder for the debugging info filename
-	       (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
-	       ;; Place holder for the load time environment if needed
-	       (SCHEME-OBJECT ,environment-label
-			      ,(if (null? free-ref-label) 0 'ENVIRONMENT))
-	       ,@(if (null? free-ref-label)
-		     (LAP)
-		     (LAP (LEA (@PCR ,environment-label) (A 0))
-			  (MOV L ,reg:environment (@A 0))
-			  (LEA (@PCR ,block-label) (A 0))
-			  (LEA (@PCR ,free-ref-label) (A 1))
-			  ,(load-dnw (+ (if (null? uuo-links) 0 1)
-					(if (null? references) 0 1)
-					(if (null? assignments) 0 1))
-				     0)
-			  (JSR ,entry:compiler-link)
-			  ,@(make-external-label (continuation-code-word false)
-						 (generate-label))))))))))
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+  (LAP (LEA (@PCR ,environment-label) (A 0))
+       (MOV L ,reg:environment (@A 0))
+       (LEA (@PCR ,*block-label*) (A 0))
+       (LEA (@PCR ,free-ref-label) (A 1))
+       ,(load-dnw n-sections 0)
+       (JSR ,entry:compiler-link)
+       ,@(make-external-label (continuation-code-word false)
+			      (generate-label))))
+
+(define (generate/remote-link code-block-label
+			      environment-offset
+			      free-ref-offset
+			      n-sections)
+  (LAP (MOV L (@PCR ,code-block-label) (D 0))
+       (AND L ,mask-reference (D 0))
+       (MOV L (D 0) (A 0))
+       (LEA (@AO 0 ,environment-offset) (A 1))
+       (MOV L ,reg:environment (@A 1))
+       (LEA (@AO 0 ,free-ref-offset) (A 1))
+       ,(load-dnw n-sections 0)
+       (JSR ,entry:compiler-link)
+       ,@(make-external-label (continuation-code-word false)
+			      (generate-label))))
+
+(define (generate/constants-block constants references assignments uuo-links)
+  (let ((constant-info
+	 (declare-constants 0 (transmogrifly uuo-links)
+	   (declare-constants 1 references
+	     (declare-constants 2 assignments
+	       (declare-constants false constants
+		 (cons false (LAP))))))))
+    (let ((free-ref-label (car constant-info))
+	  (constants-code (cdr constant-info))
+	  (debugging-information-label (allocate-constant-label))
+	  (environment-label (allocate-constant-label))
+	  (n-sections
+	   (+ (if (null? uuo-links) 0 1)
+	      (if (null? references) 0 1)
+	      (if (null? assignments) 0 1))))
+      (values
+       (LAP ,@constants-code
+	    ;; Place holder for the debugging info filename
+	    (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+	    ;; Place holder for the load time environment if needed
+	    (SCHEME-OBJECT ,environment-label
+			   ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+       environment-label
+       free-ref-label
+       n-sections))))
+
+(define (declare-constants tag constants info)
+  (define (inner constants)
+    (if (null? constants)
+	(cdr info)
+	(let ((entry (car constants)))
+	  (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+	       ,@(inner (cdr constants))))))
+  (if (and tag (not (null? constants)))
+      (let ((label (allocate-constant-label)))
+	(cons label
+	      (inner
+	       `((,(let ((datum (length constants)))
+		     (if (> datum #xffff)
+			 (error "datum too large" datum))
+		     (+ (* tag #x10000) datum))
+		  . ,label)
+		 ,@constants))))
+      (cons (car info) (inner constants))))
+
+(define (transmogrifly uuos)
+  (define (inner name assoc)
+    (if (null? assoc)
+	(transmogrifly (cdr uuos))
+	(cons (cons name (cdar assoc)) 		; uuo-label
+	      (cons (cons (caar assoc)		; frame-size
+			  (allocate-constant-label))
+		    (inner name (cdr assoc))))))
+  (if (null? uuos)
+      '()
+      (inner (caar uuos) (cdar uuos))))
 
 ;;; Local Variables: ***
 ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm
index 0c71cfdf9..417fe3981 100644
--- a/v7/src/compiler/rtlbase/rtline.scm
+++ b/v7/src/compiler/rtlbase/rtline.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.8 1988/11/06 14:49:45 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.9 1989/08/21 19:34:24 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -40,7 +40,7 @@ MIT in each case. |#
 			  initial-value
 			  instruction-append!
 			  final-value)
-	 expression procedures continuations)
+	 root procedures continuations)
   continuations				;ignore
   (with-new-node-marks
    (lambda ()
@@ -60,7 +60,11 @@ MIT in each case. |#
 			     output
 			     (bblock-linearize bblock
 					       queue-continuations!)))))))
-	   (process-bblock! (rtl-expr/entry-node expression))	   (queue-map!/unsafe input-queue process-bblock!)
+	   (process-bblock!
+	    (cond ((rtl-expr? root) (rtl-expr/entry-node root))
+		  ((rtl-procedure? root) (rtl-procedure/entry-node root))
+		  (else (error "Illegal linearization root" root))))
+	   (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!))
diff --git a/v7/src/compiler/rtlbase/rtlobj.scm b/v7/src/compiler/rtlbase/rtlobj.scm
index 534be4b44..754842bc5 100644
--- a/v7/src/compiler/rtlbase/rtlobj.scm
+++ b/v7/src/compiler/rtlbase/rtlobj.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.6 1989/08/10 11:39:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.7 1989/08/21 19:34:27 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -108,9 +108,11 @@ MIT in each case. |#
   (let ((hash-table
 	 (symbol-hash-table/make
 	  (1+ (+ (length procedures) (length continuations))))))
-    (symbol-hash-table/insert! hash-table
-			       (rtl-expr/label expression)
-			       expression)    (for-each (lambda (procedure)
+    (if expression
+	(symbol-hash-table/insert! hash-table
+				   (rtl-expr/label expression)
+				   expression))
+    (for-each (lambda (procedure)
 		(symbol-hash-table/insert! hash-table
 					   (rtl-procedure/label procedure)
 					   procedure))
diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm
index a84fcaf33..9afb9c613 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.19 1989/08/08 01:21:29 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.20 1989/08/21 19:34:39 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -39,7 +39,9 @@ MIT in each case. |#
 (define *generation-queue*)
 (define *queued-procedures*)
 (define *queued-continuations*)
-
+(define *rgraphs*)
+(define *procedures*)
+(define *continuations*)
 (define *extra-continuations*)
 
 (define (generate/top-level expression)
@@ -47,42 +49,48 @@ MIT in each case. |#
    (lambda ()
      (fluid-let ((*generation-queue* (make-queue))
 		 (*queued-procedures* '())
-		 (*queued-continuations* '()))
-       (set! *extra-continuations* '())
-       (set! *rtl-expression* (generate/expression expression))
-       (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk)))
-       (set! *rtl-graphs*
-	     (list-transform-positive (reverse! *rtl-graphs*)
-	       (lambda (rgraph)
-		 (not (null? (rgraph-entry-edges rgraph))))))
-       (for-each (lambda (rgraph)
-		   (rgraph/compress! rgraph)
-		   (rgraph/postcompress! rgraph))
-		 *rtl-graphs*)
-       (set! *rtl-procedures* (reverse! *rtl-procedures*))
-       (set! *rtl-continuations*
-	     (append *extra-continuations* (reverse! *rtl-continuations*)))))))
+		 (*queued-continuations* '())
+		 (*rgraphs* '())
+		 (*procedures* '())
+		 (*continuations* '())
+		 (*extra-continuations* '()))
+       (let ((expression (generate/expression expression)))
+	 (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk)))
+	 (let ((rgraphs
+		(list-transform-positive (reverse! *rgraphs*)
+		  (lambda (rgraph)
+		    (not (null? (rgraph-entry-edges rgraph)))))))
+	   (for-each (lambda (rgraph)
+		       (rgraph/compress! rgraph)
+		       (rgraph/postcompress! rgraph))
+		     rgraphs)
+	   (values expression
+		   (reverse! *procedures*)
+		   (append *extra-continuations* (reverse! *continuations*))
+		   rgraphs)))))))
 
 (define (enqueue-procedure! procedure)
   (if (not (memq procedure *queued-procedures*))
       (begin
 	(enqueue!/unsafe *generation-queue*
-			 (lambda ()
-			   (set! *rtl-procedures*
-				 (cons (generate/procedure procedure)
-				       *rtl-procedures*))))
-	(set! *queued-procedures* (cons procedure *queued-procedures*)))))
+	  (lambda ()
+	    (set! *procedures*
+		  (cons (generate/procedure procedure) *procedures*))
+	    unspecific))
+	(set! *queued-procedures* (cons procedure *queued-procedures*))
+	unspecific)))
 
 (define (enqueue-continuation! continuation)
   (if (not (memq continuation *queued-continuations*))
       (begin
 	(enqueue!/unsafe *generation-queue*
-			 (lambda ()
-			   (set! *rtl-continuations*
-				 (cons (generate/continuation continuation)
-				       *rtl-continuations*))))
+	  (lambda ()
+	    (set! *continuations*
+		  (cons (generate/continuation continuation) *continuations*))
+	    unspecific))
 	(set! *queued-continuations*
-	      (cons continuation *queued-continuations*)))))
+	      (cons continuation *queued-continuations*))
+	unspecific)))
 
 (define (generate/expression expression)
   (with-values
@@ -257,7 +265,8 @@ MIT in each case. |#
     (or (subgraph-color/rgraph color)
 	(let ((rgraph (make-rgraph number-of-machine-registers)))
 	  (set-subgraph-color/rgraph! color rgraph)
-	  (set! *rtl-graphs* (cons rgraph *rtl-graphs*))	  rgraph))))
+	  (set! *rgraphs* (cons rgraph *rgraphs*))
+	  rgraph))))
 
 (define (generate/node node)
   (let ((memoization (cfg-node-get node memoization-tag)))