From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 4 Dec 1987 19:28:21 +0000 (+0000)
Subject: Major redesign of front end of compiler.  Continuations are now
X-Git-Tag: 20090517-FFI~13019
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9341f6b619cb327963e9ae47b99a11b3fd83ffc5;p=mit-scheme.git

Major redesign of front end of compiler.  Continuations are now
modeled more exactly by means of a CPS-style analysis.  Poppers have
been flushed in favor of dynamic links, and optimizations have been
added that eliminate the use of static and dynamic links in many
cases.
---

diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
new file mode 100644
index 000000000..261faafef
--- /dev/null
+++ b/v7/src/compiler/fggen/fggen.scm
@@ -0,0 +1,596 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.1 1987/12/04 19:27:53 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Flow Graph Generation
+
+(declare (usual-integrations))
+
+(define (construct-graph scode)
+  (fluid-let ((*virtual-continuations* '()))
+    (let ((block (make-block false 'EXPRESSION)))
+      (let ((continuation (make-continuation-variable block)))
+	(let ((expression
+	       (make-expression
+		block
+		continuation
+		(transmit-values
+		    (if (scode/open-block? scode)
+			(scode/open-block-components scode
+			  (lambda (names declarations body)
+			    (return-3 (make-variables block names)
+				      declarations
+				      (unscan-defines names '() body))))
+			(return-3 '() '() scode))
+		  (lambda (variables declarations scode)
+		    (set-block-bound-variables! block variables)
+		    (generate/body block continuation declarations scode))))))
+	  (for-each (lambda (procedure)
+		      (if (procedure-continuation? procedure)
+			  (set-procedure-entry-node!
+			   procedure
+			   (snode-next (procedure-entry-node procedure)))))
+		    *procedures*)
+	  (for-each (lambda (continuation)
+		      (set-virtual-continuation/parent! continuation false))
+		    *virtual-continuations*)
+	  expression)))))
+
+(define (make-variables block names)
+  (map (lambda (name) (make-variable block name)) names))
+
+(define (generate/body block continuation declarations expression)
+  ;; 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)))
+    (process-declarations! block declarations)
+    node))
+
+(define (continue/rvalue block continuation rvalue)
+  ((continuation/case continuation
+     (lambda ()
+       (make-return block (make-reference block continuation true) rvalue))
+     (lambda ()
+       (make-null-cfg))
+     (lambda ()
+       (make-true-test rvalue))
+     (lambda ()
+       (if (not (virtual-continuation? continuation))
+	   (error "Continuation should be virtual" continuation))
+       (make-subproblem (make-null-cfg) continuation rvalue)))))
+
+;;;; Continuations
+
+(define (continuation/case continuation unknown effect predicate value)
+  (cond ((variable? continuation) unknown)
+	((procedure? continuation)
+	 (let ((type (continuation/type continuation)))
+	   (cond ((eq? type continuation-type/effect) effect)
+		 ((eq? type continuation-type/predicate) predicate)
+		 ((eq? type continuation-type/value) value)
+		 (else (error "Illegal continuation type" type)))))
+	((virtual-continuation? continuation)
+	 (let ((type (virtual-continuation/type continuation)))
+	   (cond ((eq? type continuation-type/effect) effect)
+		 ((eq? type continuation-type/predicate) predicate)
+		 ((eq? type continuation-type/value) value)
+		 (else (error "Illegal virtual continuation type" type)))))
+	(else (error "Illegal continuation" continuation))))
+
+(define (continuation/type? continuation type)
+  (cond ((variable? continuation) false)
+	((procedure? continuation)
+	 (eq? (continuation/type continuation) type))
+	((virtual-continuation? continuation)
+	 (eq? (virtual-continuation/type continuation) type))
+	(else
+	 (error "Illegal continuation" continuation))))
+
+(define-integrable (continuation/effect? continuation)
+  (continuation/type? continuation continuation-type/effect))
+
+(define-integrable (continuation/predicate? continuation)
+  (continuation/type? continuation continuation-type/predicate))
+
+(define (continuation/rvalue continuation)
+  (make-reference (continuation/block continuation)
+		  (continuation/parameter continuation)
+		  true))
+
+(define-integrable (continuation/next-hooks continuation)
+  (list (make-hook (continuation/entry-node continuation)
+		   set-snode-next-edge!)))
+
+(define-integrable (continuation-reference block continuation)
+  (cond ((variable? continuation) (make-reference block continuation true))
+	((procedure? continuation) continuation)
+	(else (error "Illegal continuation" continuation))))
+
+;;;; Subproblems
+
+(define (subproblem-canonicalize subproblem)
+  (if (subproblem-canonical? subproblem)
+      subproblem
+      (let ((continuation
+	     (continuation/reify! (subproblem-continuation subproblem))))
+	(make-subproblem/canonical
+	 (scfg*scfg->scfg! (subproblem-prefix subproblem)
+			   (make-return (subproblem-block subproblem)
+					continuation
+					(subproblem-rvalue subproblem)))
+	 continuation))))
+
+(define (continuation/reify! continuation)
+  (if (virtual-continuation? continuation)
+      (virtual-continuation/reify! continuation)
+      continuation))
+
+(define (make-subproblem/canonical prefix continuation)
+  (make-subproblem prefix
+		   continuation
+		   (continuation/rvalue continuation)))
+
+(define (scfg*subproblem->subproblem! scfg subproblem)
+  (make-subproblem (scfg*scfg->scfg! scfg (subproblem-prefix subproblem))
+		   (subproblem-continuation subproblem)
+		   (subproblem-rvalue subproblem)))
+
+(define (pcfg*subproblem->subproblem! predicate consequent alternative)
+  ;; This depends on the fact that, after canonicalizing two
+  ;; subproblems which were generated with the same continuation, the
+  ;; block, continuation, and rvalue of each subproblem are identical.
+  (let ((consequent (subproblem-canonicalize consequent))
+	(alternative (subproblem-canonicalize alternative)))
+    (make-subproblem (pcfg*scfg->scfg! predicate
+				       (subproblem-prefix consequent)
+				       (subproblem-prefix alternative))
+		     (subproblem-continuation consequent)
+		     (subproblem-rvalue consequent))))
+
+(define (generator/subproblem type scfg*value->value!)
+  (lambda (block continuation expression)
+    (let ((continuation (virtual-continuation/make block continuation type)))
+      (let ((value (generate/expression block continuation expression)))
+	(if (virtual-continuation/reified? continuation)
+	    (scfg*value->value!
+	     (make-push block (virtual-continuation/reification continuation))
+	     value)
+	    value)))))
+
+(define *virtual-continuations*)
+
+(define (virtual-continuation/make block parent type)
+  (let ((continuation (virtual-continuation/%make block parent type)))
+    (set! *virtual-continuations* (cons continuation *virtual-continuations*))
+    continuation))
+
+(define generate/subproblem/effect
+  (generator/subproblem continuation-type/effect scfg*scfg->scfg!))
+
+(define generate/subproblem/predicate
+  (generator/subproblem continuation-type/predicate scfg*pcfg->pcfg!))
+
+(define generate/subproblem/value
+  (generator/subproblem continuation-type/value scfg*subproblem->subproblem!))
+
+;;;; Values
+
+(define (generate/constant block continuation expression)
+  (continue/rvalue block continuation (make-constant expression)))
+
+(define (generate/the-environment block continuation expression)
+  (continue/rvalue block continuation block))
+
+(define (generate/variable block continuation expression)
+  (continue/rvalue block
+		   continuation
+		   (make-reference block
+				   (find-name block
+					      (scode/variable-name expression))
+				   false)))
+
+(define (generate/safe-variable block continuation expression)
+  (continue/rvalue
+   block
+   continuation
+   (make-reference block
+		   (find-name block (scode/safe-variable-name expression))
+		   true)))
+
+(define-integrable (scode/make-safe-variable name)
+  (cons safe-variable-tag name))
+
+(define-integrable (scode/safe-variable-name reference)
+  (cdr reference))
+
+(define safe-variable-tag
+  "safe-variable")
+
+(define (generate/unassigned? block continuation expression)
+  (if (continuation/predicate? continuation)
+      (continue/rvalue block
+		       continuation
+		       (make-unassigned-test
+			block
+			(find-name block (scode/unassigned?-name expression))))
+      (generate/conditional block
+			    continuation
+			    (scode/make-conditional expression #T #F))))
+
+(define (find-name block name)
+  (define (search block)
+    (or (variable-assoc name (block-bound-variables block))
+	(variable-assoc name (block-free-variables block))
+	(let ((variable
+	       (if (block-parent block)
+		   (search (block-parent block))
+		   (make-variable block name))))
+	  (set-block-free-variables! block
+				     (cons variable
+					   (block-free-variables block)))
+	  variable)))
+  (search block))
+
+(define (generate/lambda block continuation expression)
+  (continue/rvalue
+   block
+   continuation
+   (scode/lambda-components expression
+     (lambda (name required optional rest auxiliary declarations body)
+       (transmit-values (parse-procedure-body auxiliary body)
+	 (lambda (names values body)
+	   (let ((block (make-block block 'PROCEDURE)))
+	     (let ((continuation (make-continuation-variable block))
+		   (required (make-variables block required))
+		   (optional (make-variables block optional))
+		   (rest (and rest (make-variable block rest)))
+		   (names (make-variables block names)))
+	       (set-block-bound-variables! block
+					   `(,continuation
+					     ,@required
+					     ,@optional
+					     ,@(if rest (list rest) '())
+					     ,@names))
+	       (make-procedure
+		continuation-type/procedure
+		block name (cons continuation required) optional rest names
+		(map (lambda (value)
+		       ;; The other parts of this subproblem are not
+		       ;; interesting since `value' is guaranteed to
+		       ;; be either a constant or a procedure.
+		       (subproblem-rvalue
+			(generate/subproblem/value block continuation value)))
+		     values)
+		(generate/body block continuation declarations body))))))))))
+
+(define (parse-procedure-body auxiliary body)
+  (transmit-values
+      (parse-procedure-body* auxiliary (scode/sequence-actions body))
+    (lambda (names values auxiliary actions)
+      (if (null? auxiliary)
+	  (return-3 names values (scode/make-sequence actions))
+	  (return-3 '() '()
+		    (scode/make-combination
+		     (scode/make-lambda
+		      lambda-tag:let auxiliary '() false names '()
+		      (scode/make-sequence
+		       (map* actions scode/make-assignment names values)))
+		     (map (lambda (name) (scode/make-unassigned-object))
+			  auxiliary)))))))
+
+(define (parse-procedure-body* names actions)
+  ;; Extract any definitions that do not depend on the order of
+  ;; events.
+  (cond ((null? names)
+	 (return-4 '() '() '() actions))
+	((null? actions)
+	 (error "Extraneous auxiliaries" names))
+
+	;; Because `scan-defines' returns the auxiliary names in a
+	;; particular order, we can expect to encounter them in that
+	;; same order when looking through the body's actions.
+
+	((and (scode/assignment? (car actions))
+	      (eq? (scode/assignment-name (car actions)) (car names)))
+	 (transmit-values (parse-procedure-body* (cdr names) (cdr actions))
+	   (let ((value (scode/assignment-value (car actions))))
+	     (if (or (scode/lambda? value)
+		     (scode/delay? value)
+		     (scode/constant? value))
+		 (lambda (names* values auxiliary actions*)
+		   (return-4 (cons (car names) names*)
+			     (cons value values)
+			     auxiliary
+			     (if (null? actions*)
+				 (list undefined-conditional-branch)
+				 actions*)))
+		 (lambda (names* values auxiliary actions*)
+		   (return-4 names*
+			     values
+			     (cons (car names) auxiliary)
+			     (cons (car actions) actions*)))))))
+	(else
+	 (transmit-values (parse-procedure-body* names (cdr actions))
+	   (lambda (names* values auxiliary actions*)
+	     (return-4 names*
+		       values
+		       auxiliary
+		       (cons (car actions) actions*)))))))
+
+;;;; Combinators
+
+(define (generate/combination block continuation expression)
+  (let ((continuation (continuation/reify! continuation)))
+    (let ((generator
+	   (lambda (expression)
+	     (generate/subproblem/value block #|(make-block block 'JOIN)|#
+					continuation
+					expression))))
+      (scode/combination-components expression
+	(lambda (operator operands)
+	  (let ((combination
+		 (make-combination block
+				   (continuation-reference block continuation)
+				   (generator operator)
+				   (map generator operands))))
+	    ((continuation/case continuation
+	       (lambda ()
+		 combination)
+	       (lambda ()
+		 (make-scfg (cfg-entry-node combination)
+			    (continuation/next-hooks continuation)))
+	       (lambda ()
+		 (scfg*pcfg->pcfg!
+		  (make-scfg (cfg-entry-node combination)
+			     (continuation/next-hooks continuation))
+		  (make-true-test (continuation/rvalue continuation))))
+	       (lambda ()
+		 (make-subproblem/canonical combination continuation))))))))))
+
+(define (generate/sequence block continuation expression)
+  (let ((join
+	 (continuation/case continuation
+			    scfg*scfg->scfg!
+			    scfg*scfg->scfg!
+			    scfg*pcfg->pcfg!
+			    scfg*subproblem->subproblem!)))
+    (let loop ((actions (scode/sequence-actions expression)))
+      (if (null? (cdr actions))
+	  (generate/expression block continuation (car actions))
+	  (join (generate/subproblem/effect block continuation (car actions))
+		(loop (cdr actions)))))))
+
+(define (generate/conditional block continuation expression)
+  (scode/conditional-components expression
+    (lambda (predicate consequent alternative)
+      ((continuation/case continuation
+			  pcfg*scfg->scfg!
+			  pcfg*scfg->scfg!
+			  pcfg*pcfg->pcfg!
+			  pcfg*subproblem->subproblem!)
+       (generate/subproblem/predicate block continuation predicate)
+       (generate/expression block continuation consequent)
+       (generate/expression block continuation alternative)))))
+
+;;;; Assignments
+
+(define (generate/assignment* maker find-name block continuation name value)
+  (let ((subproblem (generate/subproblem/value block continuation value)))
+    (scfg*scfg->scfg!
+     (if (subproblem-canonical? subproblem)
+	 (make-scfg
+	  (cfg-entry-node (subproblem-prefix subproblem))
+	  (continuation/next-hooks (subproblem-continuation subproblem)))
+	 (subproblem-prefix subproblem))
+     (maker block (find-name block name) (subproblem-rvalue subproblem)))))
+
+(define (generate/assignment block continuation expression)
+  (scode/assignment-components expression
+    (lambda (name value)
+      (if (continuation/effect? continuation)
+	  (generate/assignment* make-assignment find-name
+				block continuation name value)
+	  (generate/combination
+	   block
+	   continuation
+	   (let ((old-value-temp (generate-uninterned-symbol))
+		 (new-value-temp (generate-uninterned-symbol)))
+	     (scode/make-let (list old-value-temp new-value-temp)
+			     (list (scode/make-safe-variable name) value)
+			     (scode/make-assignment
+			      name
+			      (scode/make-variable new-value-temp))
+			     (scode/make-variable old-value-temp))))))))
+
+(define (generate/definition block continuation expression)
+  (scode/definition-components expression
+    (lambda (name value)
+      (if (continuation/effect? continuation)
+	  (generate/assignment* make-definition make-definition-variable
+				block continuation name
+				(insert-letrec name value))
+	  (generate/sequence block
+			     continuation
+			     (scode/make-sequence
+			      (list (scode/make-definition name value)
+				    name)))))))
+
+(define (make-definition-variable block name)
+  (let ((bound (block-bound-variables block)))
+    (or (variable-assoc name bound)
+	(let ((variable (make-variable block name)))
+	  (set-block-bound-variables! block (cons variable bound))
+	  variable))))
+
+(define (insert-letrec name value)
+  (if (and compiler:implicit-self-static?
+	   (scode/lambda? value))
+      (scode/make-let '() '()
+		      (scode/make-definition name value)
+		      (scode/make-variable name))
+      value))
+
+;;;; Rewrites
+
+(define (generate/access block continuation expression)
+  (scode/access-components expression
+    (lambda (environment name)
+      (generate/combination
+       block
+       continuation
+       (scode/make-combination (ucode-primitive lexical-reference)
+			       (list environment name))))))
+
+(define (generate/comment block continuation expression)
+  (generate/expression block
+		       continuation
+		       (scode/comment-expression expression)))
+
+(define (generate/delay block continuation expression)
+  (generate/lambda block
+		   continuation
+		   (scode/make-lambda lambda-tag:delay '() '() false '() '()
+				      (scode/delay-expression expression))))
+
+(define (generate/disjunction block continuation expression)
+  (scode/disjunction-components expression
+    (lambda (predicate alternative)
+      (generate/combination
+       block
+       continuation
+       (let ((temp (generate-uninterned-symbol)))
+	 (scode/make-let (list temp)
+			 (list predicate)
+			 (let ((predicate (scode/make-variable temp)))
+			   (scode/make-conditional predicate
+						   predicate
+						   alternative))))))))
+
+(define (generate/error-combination block continuation expression)
+  (scode/error-combination-components expression
+    (lambda (message irritants)
+      (generate/combination
+       block
+       continuation
+       (scode/make-combination compiled-error-procedure
+			       (cons message irritants))))))
+
+(define (generate/in-package block continuation expression)
+  (warn "IN-PACKAGE not supported; body will be interpreted" expression)
+  (scode/in-package-components expression
+    (lambda (environment expression)
+      (generate/combination
+       block
+       continuation
+       (scode/make-combination (ucode-primitive scode-eval)
+			       (list (scode/make-quotation expression)
+				     environment))))))
+
+(define (generate/quotation block continuation expression)
+  (generate/combination
+   block
+   continuation
+   (scode/make-combination
+    (ucode-primitive car)
+    (list (list (scode/quotation-expression expression))))))
+
+(define (scode/make-let names values . body)
+  (scan-defines (scode/make-sequence body)
+    (lambda (auxiliary declarations body)
+      (scode/make-combination
+       (scode/make-lambda lambda-tag:let names '() false
+			  auxiliary declarations body)
+       values))))
+
+;;;; Dispatcher
+
+(define generate/expression
+  (let ((dispatch-vector
+	 (make-vector number-of-microcode-types generate/constant))
+	(generate/combination
+	 (lambda (block continuation expression)
+	   (let ((operator (scode/combination-operator expression))
+		 (operands (scode/combination-operands expression)))
+	     (cond ((and (eq? operator (ucode-primitive lexical-unassigned?))
+			 (the-environment? (car operands))
+			 (scode/symbol? (cadr operands)))
+		    (generate/unassigned? block continuation expression))
+		   ((or (eq? operator (ucode-primitive error-procedure))
+			(and (scode/absolute-reference? operator)
+			     (eq? (scode/absolute-reference-name operator)
+				  'ERROR-PROCEDURE)))
+		    (generate/error-combination block continuation expression))
+		   (else
+		    (generate/combination block continuation expression))))))
+	(generate/pair
+	 (lambda (block continuation expression)
+	   (if (eq? (car expression) safe-variable-tag)
+	       (generate/safe-variable block continuation expression)
+	       (generate/constant block continuation expression)))))
+
+    (let-syntax
+	((dispatch-entry
+	  (macro (type handler)
+	    `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler)))
+	 (dispatch-entries
+	  (macro (types handler)
+	    `(BEGIN ,@(map (lambda (type)
+			     `(DISPATCH-ENTRY ,type ,handler))
+			   types))))
+	 (standard-entry
+	  (macro (name)
+	    `(DISPATCH-ENTRY ,name ,(symbol-append 'GENERATE/ name)))))
+      (standard-entry access)
+      (standard-entry assignment)
+      (standard-entry conditional)
+      (standard-entry definition)
+      (standard-entry delay)
+      (standard-entry disjunction)
+      (standard-entry in-package)
+      (standard-entry pair)
+      (standard-entry quotation)
+      (standard-entry the-environment)
+      (standard-entry variable)
+      (dispatch-entries (lambda lexpr extended-lambda) generate/lambda)
+      (dispatch-entries (sequence-2 sequence-3) generate/sequence)
+      (dispatch-entries (combination-1 combination-2 combination
+				       primitive-combination-0
+				       primitive-combination-1
+				       primitive-combination-2
+				       primitive-combination-3)
+			generate/combination)
+      (dispatch-entry comment generate/comment))
+    (named-lambda (generate/expression block continuation expression)
+      ((vector-ref dispatch-vector (primitive-type expression))
+       block continuation expression))))
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm
new file mode 100644
index 000000000..06652be22
--- /dev/null
+++ b/v7/src/compiler/fgopt/closan.scm
@@ -0,0 +1,118 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.1 1987/12/04 19:27:30 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Closure Analysis
+
+(declare (usual-integrations))
+
+#|
+
+The closure analysis operates by identifying the "closing limit" of
+each procedure, which is defined as the nearest ancestor of the
+procedure's closing block which is active during the procedure's
+lifetime.  The closing limit is false whenever the extent of the
+procedure is not fully known, or if the procedure must be fully closed
+for any reason (including canonicalization).
+
+Procedures that are called from a closed procedure must inherit that
+procedure's closing limit since only the blocks farther away than the
+closing limit can be assumed to exist when those procedures are
+called.
+
+The procedure's free variables which are bound in blocks up to the
+closing limit (exclusive) must be consed in the heap.  Other free
+variables don't necessarily need to be allocated on the heap, provided
+that there is a known way to get to them.
+
+This analysis is maximal in that it is required for ANY closure
+construction mechanism that optimizes by means of a stack, because use
+of a stack associates procedure extent with block scope.  For many
+simple techniques it generates more information than is needed.
+
+|#
+
+(package (identify-closure-limits!)
+
+(define-export (identify-closure-limits! procedures applications assignments)
+  (for-each initialize-closure-limit! procedures)
+  (for-each close-application-arguments! applications)
+  (for-each close-assignment-values! assignments))
+
+(define (initialize-closure-limit! procedure)
+  (if (not (procedure-continuation? procedure))
+      (set-procedure-closing-limit!
+       procedure
+       (and (not (procedure-passed-out? procedure))
+	    (procedure-closing-block procedure)))))
+
+(define (close-application-arguments! application)
+  (close-values!
+   (application-operand-values application)
+   (let ((procedure (rvalue-known-value (application-operator application))))
+     (and procedure
+	  (rvalue/procedure? procedure)
+	  (procedure-always-known-operator? procedure)
+	  (procedure-block procedure)))))
+
+(define (close-assignment-values! assignment)
+  (close-rvalue! (assignment-rvalue assignment)
+		 (variable-block (assignment-lvalue assignment))))
+
+(define-integrable (close-rvalue! rvalue binding-block)
+  (close-values! (rvalue-values rvalue) binding-block))
+
+(define (close-values! values binding-block)
+  (for-each (lambda (value)
+	      (if (and (rvalue/procedure? value)
+		       (not (procedure-continuation? value)))
+		  (close-procedure! value binding-block)))
+	    values))
+
+(define (close-procedure! procedure binding-block)
+  (let ((closing-limit (procedure-closing-limit procedure)))
+    (let ((new-closing-limit
+	   (and binding-block
+		closing-limit
+		(block-nearest-common-ancestor binding-block closing-limit))))
+      (if (not (eq? new-closing-limit closing-limit))
+	  (begin
+	    (set-procedure-closing-limit! procedure new-closing-limit)
+	    (for-each-block-descendent! (procedure-block procedure)
+	      (lambda (block)
+		(for-each (lambda (application)
+			    (close-rvalue! (application-operator application)
+					   new-closing-limit))
+			  (block-applications block)))))))))
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/contan.scm b/v7/src/compiler/fgopt/contan.scm
new file mode 100644
index 000000000..5f26f8373
--- /dev/null
+++ b/v7/src/compiler/fgopt/contan.scm
@@ -0,0 +1,168 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.1 1987/12/04 19:27:35 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Continuation Analysis
+
+(declare (usual-integrations))
+
+(package (continuation-analysis)
+
+;;; Determine when static or dynamic links are to be used.  For static
+;;; links, we compute the `block-stack-link' which is the set of
+;;; blocks which might be immediately adjacent (away from the top of
+;;; the stack) to the given block on the stack.  If it is possible to
+;;; find the parent in a consistent way with any one of these adjacent
+;;; blocks, we do not need a static link.  Otherwise, we set
+;;; `block-stack-link' to the empty list and use a static link.
+
+;;; For dynamic links, we compute the popping limit of a procedure's
+;;; continuation variable, which is the farthest ancestor of the
+;;; procedure's block that is be popped when invoking the
+;;; continuation.  If we cannot compute the limit statically (value is
+;;; #F), we must use a dynamic link.
+
+;;; This code takes advantage of the fact that the continuation
+;;; variable is not referenced in blocks other than the procedure's
+;;; block.  This may change if call/cc is handled specially.
+
+(define-export (continuation-analysis blocks procedures)
+  (for-each (lambda (procedure)
+	      (if (procedure-continuation? procedure)
+		  (begin
+		    (set-continuation/lvalues! procedure '())
+		    (set-continuation/dynamic-link?! procedure false))))
+	    procedures)
+  (for-each (lambda (block)
+	      (if (stack-block? block)
+		  (analyze-continuation block)))
+	    blocks)
+  (for-each (lambda (block)
+	      (if (stack-block? block)
+		  (let ((lvalue (stack-block/continuation-lvalue block)))
+		    (if (not (variable-popping-limit lvalue))
+			(force-dynamic-link! lvalue)))))
+	    blocks)
+  (for-each (lambda (block)
+	      (if (stack-block? block)
+		  (lvalue-mark-clear! (stack-block/continuation-lvalue block)
+				      dynamic-link-marker)))
+	    blocks))
+
+(define (force-dynamic-link! lvalue)
+  (if (not (lvalue-mark-set? lvalue dynamic-link-marker))
+      (begin
+	(lvalue-mark-set! lvalue dynamic-link-marker)
+	(for-each (lambda (continuation)
+		    (if (not (continuation/dynamic-link? continuation))
+			(begin
+			  (set-continuation/dynamic-link?! continuation true)
+			  (for-each (lambda (lvalue)
+				      (if (variable-popping-limit lvalue)
+					  (force-dynamic-link! lvalue)))
+				    (continuation/lvalues continuation)))))
+		  (lvalue-values lvalue)))))
+
+(define dynamic-link-marker
+  "dynamic-link")
+
+(define (analyze-continuation block)
+  (let ((lvalue (stack-block/continuation-lvalue block)))
+    (for-each (lambda (continuation)
+		(set-continuation/lvalues!
+		 continuation
+		 (cons lvalue (continuation/lvalues continuation))))
+	      (lvalue-values lvalue))
+    (set-variable-popping-limit!
+     lvalue
+     (if (stack-parent? block)
+	 (let ((external (stack-block/external-ancestor block)))
+	   (let ((joins (continuation-join-blocks block lvalue external)))
+	     (set-block-stack-link! block (adjacent-blocks block lvalue joins))
+	     (and (not (null? joins))
+		  (null? (cdr joins))
+		  (or (car joins) external))))
+	 block))))
+
+(define (adjacent-blocks block lvalue joins)
+  (let ((parent (block-parent block)))
+    (transmit-values
+	(discriminate-items joins
+			    (lambda (join)
+			      (or (eq? join block)
+				  (eq? join parent))))
+      (lambda (internal external)
+	(cond ((null? internal)
+	       ;; The procedure is never invoked as a subproblem.
+	       ;; Therefore its ancestor frame and all intermediate
+	       ;; frames are always immediately adjacent on the stack.
+	       (list parent))
+	      ((and (null? external)
+		    (null? (cdr internal))
+		    ;; Eliminate pathological case of procedure which
+		    ;; is always invoked as a subproblem of itself.
+		    ;; This can be written but the code can never be
+		    ;; invoked.
+		    (not (block-ancestor-or-self? (car internal) block)))
+	       ;; The procedure is always invoked as a subproblem, and
+	       ;; all of the continuations are closed in the same
+	       ;; block.  Therefore we can reach the ancestor frame by
+	       ;; reference to that block.
+	       (map continuation/block (lvalue-values lvalue)))
+	      (else
+	       ;; The relative position of the ancestor frame is not
+	       ;; statically determinable.
+	       '()))))))
+
+(define (continuation-join-blocks block lvalue external)
+  (let ((ancestry (memq external (block-ancestry block '()))))
+    (let ((blocks
+	   (map->eq-set
+	    (lambda (block*)
+	      (let ((ancestry* (memq external (block-ancestry block* '()))))
+		(and ancestry*
+		     (let loop
+			 ((ancestry (cdr ancestry))
+			  (ancestry* (cdr ancestry*)))
+		       (cond ((null? ancestry) block)
+			     ((and (not (null? ancestry*))
+				   (eq? (car ancestry) (car ancestry*)))
+			      (loop (cdr ancestry) (cdr ancestry*)))
+			     (else (car ancestry)))))))
+	    (map->eq-set continuation/closing-block
+			 (lvalue-values lvalue)))))
+      (if (lvalue-passed-in? lvalue)
+	  (eq-set-adjoin false blocks)
+	  blocks))))
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/desenv.scm b/v7/src/compiler/fgopt/desenv.scm
new file mode 100644
index 000000000..4a72868a6
--- /dev/null
+++ b/v7/src/compiler/fgopt/desenv.scm
@@ -0,0 +1,227 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/desenv.scm,v 4.1 1987/12/04 19:27:45 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Environment Design
+
+(declare (usual-integrations))
+
+;;;; Frame Layout
+
+#|
+
+Layout of stack frames.  The top of each frame is where the frame
+pointer points to, which is the most recently pushed item in the
+frame (i.e. the item closest to the top of stack).  There are two
+kinds of frames, depending on what kind of procedure this is.
+
+Open procedure frame:
+
++-------+-------+-------+-------+
+|	   Auxiliary 1		|
++-------+-------+-------+-------+
+:		:		:
++-------+-------+-------+-------+
+|	   Auxiliary M		|
++-------+-------+-------+-------+
+|	    Argument 1		|
++-------+-------+-------+-------+
+:		:		:
++-------+-------+-------+-------+
+|	    Argument N		|
++-------+-------+-------+-------+
+|	  Rest Argument		|	(omitted if none)
++-------+-------+-------+-------+
+|    Pointer to parent frame	|	(omitted if known)
++-------+-------+-------+-------+
+
+Closed procedure frame:
+
++-------+-------+-------+-------+
+|	   Auxiliary 1		|
++-------+-------+-------+-------+
+:		:		:
++-------+-------+-------+-------+
+|	   Auxiliary M		|
++-------+-------+-------+-------+
+|	     Operator		|	(omitted if not needed)
++-------+-------+-------+-------+
+|	    Argument 1		|
++-------+-------+-------+-------+
+:		:		:
++-------+-------+-------+-------+
+|	    Argument N		|
++-------+-------+-------+-------+
+|	  Rest Argument		|	(omitted if none)
++-------+-------+-------+-------+
+
+|#
+
+(package (design-environment-frames!)
+
+(define-export (design-environment-frames! blocks)
+  (for-each (lambda (block)
+	      (enumeration-case block-type (block-type block)
+		((IC)
+		 (if (rvalue/procedure? (block-procedure block))
+		     (setup-ic-block-offsets! block)))
+		((STACK)
+		 (delete-integrated-parameters! block)
+		 (for-each (lambda (variable)
+			     (if (variable-assigned? variable)
+				 (set-variable-in-cell?! variable true)))
+			   (block-bound-variables block))
+		 (setup-stack-block-offsets! block))
+		((CONTINUATION)
+		 (set-block-frame-size!
+		  block
+		  (continuation/frame-size (block-procedure block))))
+		((CLOSURE) 'DONE)
+		(else
+		 (error "Illegal block type" block))))
+	    blocks))
+
+(package (delete-integrated-parameters!)
+
+(define-export (delete-integrated-parameters! block)
+  (let ((deletions '())
+	(procedure (block-procedure block)))
+    (if (procedure-interface-optimizible? procedure)
+	(begin
+	  (let ((delete-integrations
+		 (lambda (get-names set-names!)
+		   (transmit-values
+		       (find-integrated-variables (get-names procedure))
+		     (lambda (not-integrated integrated)
+		       (if (not (null? integrated))
+			   (begin
+			     (set-names! procedure not-integrated)
+			     (set! deletions
+				   (eq-set-union deletions integrated)))))))))
+	    (delete-integrations (lambda (procedure)
+				   (cdr (procedure-required procedure)))
+				 (lambda (procedure required)
+				   (set-cdr! (procedure-required procedure)
+					     required)))
+	    (delete-integrations procedure-optional set-procedure-optional!))
+	  (let ((rest (procedure-rest procedure)))
+	    (if (and rest (lvalue-integrated? rest))
+		(begin (set! deletions (eq-set-adjoin deletions rest))
+		       (set-procedure-rest! procedure false))))))
+    (transmit-values
+	(find-integrated-bindings (procedure-names procedure)
+				  (procedure-values procedure))
+      (lambda (names values integrated)
+	(set-procedure-names! procedure names)
+	(set-procedure-values! procedure values)
+	(set! deletions (eq-set-union deletions integrated))))
+    (if (not (null? deletions))
+	(set-block-bound-variables!
+	 block
+	 (eq-set-difference (block-bound-variables block) deletions)))))
+
+(define (find-integrated-bindings names values)
+  (if (null? names)
+      (return-3 '() '() '())
+      (transmit-values (find-integrated-bindings (cdr names) (cdr values))
+	(lambda (names* values* integrated)
+	  (if (lvalue-integrated? (car names))
+	      (return-3 names* values* (cons (car names) integrated))
+	      (return-3 (cons (car names) names*)
+			(cons (car values) values*)
+			integrated))))))
+
+(define (find-integrated-variables variables)
+  (if (null? variables)
+      (return-2 '() '())
+      (transmit-values (find-integrated-variables (cdr variables))
+	(lambda (not-integrated integrated)
+	  (if (lvalue-integrated? (car variables))
+	      (return-2 not-integrated
+			(cons (car variables) integrated))
+	      (return-2 (cons (car variables) not-integrated)
+			integrated))))))
+
+)
+
+(package (setup-ic-block-offsets! setup-stack-block-offsets!)
+
+(define-export (setup-ic-block-offsets! block)
+  (let ((procedure (block-procedure block)))
+    (setup-variable-offsets!
+     (procedure-names procedure)
+     (setup-variable-offset!
+      (procedure-rest procedure)
+      (setup-variable-offsets!
+       (procedure-optional procedure)
+       (setup-variable-offsets! (cdr (procedure-required procedure))
+				ic-block-first-parameter-offset))))))
+
+(define-export (setup-stack-block-offsets! block)
+  (let ((procedure (block-procedure block)))
+    (set-block-frame-size!
+     block
+     (let ((offset
+	    (setup-variable-offset!
+	     (procedure-rest procedure)
+	     (setup-variable-offsets!
+	      (procedure-optional procedure)
+	      (setup-variable-offsets!
+	       (cdr (procedure-required procedure))
+	       (let ((offset
+		      (setup-variable-offsets! (procedure-names procedure) 0)))
+		 (if (and (procedure/closure? procedure)
+			  (closure-procedure-needs-operator? procedure))
+		     (begin (set-procedure-closure-offset! procedure offset)
+			    (1+ offset))
+		     offset)))))))
+       (if (or (procedure/closure? procedure)
+	       (not (stack-block/static-link? block)))
+	   offset
+	   (1+ offset))))))
+
+(define (setup-variable-offsets! variables offset)
+  (if (null? variables)
+      offset
+      (begin (set-variable-normal-offset! (car variables) offset)
+	     (setup-variable-offsets! (cdr variables) (1+ offset)))))
+
+(define (setup-variable-offset! variable offset)
+  (if variable
+      (begin (set-variable-normal-offset! variable offset)
+	     (1+ offset))
+      offset))
+
+)
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/operan.scm b/v7/src/compiler/fgopt/operan.scm
new file mode 100644
index 000000000..f43e60b7c
--- /dev/null
+++ b/v7/src/compiler/fgopt/operan.scm
@@ -0,0 +1,105 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.1 1987/12/04 19:28:06 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Operator Analysis
+
+(declare (usual-integrations))
+
+(package (operator-analysis)
+
+(define-export (operator-analysis procedures applications)
+  (for-each (lambda (procedure)
+	      (if (procedure-continuation? procedure)
+		  (set-continuation/combinations! procedure '())))
+	    procedures)
+  (for-each (lambda (application)
+	      (if (eq? (application-type application) 'COMBINATION)
+		  (analyze/combination application)))
+	    applications)
+  (for-each (lambda (procedure)
+	      (if (procedure-continuation? procedure)
+		  (set-continuation/passed-out?!
+		   procedure
+		   (continuation-passed-out? procedure))))
+	    procedures)
+  (for-each (lambda (procedure)
+	      (set-procedure-always-known-operator?!
+	       procedure
+	       (if (procedure-continuation? procedure)
+		   (analyze/continuation procedure)
+		   (analyze/procedure procedure))))
+	    procedures))
+
+(define (analyze/combination combination)
+  (for-each (lambda (continuation)
+	      (set-continuation/combinations!
+	       continuation
+	       (cons combination
+		     (continuation/combinations continuation))))
+	    (rvalue-values (combination/continuation combination))))
+
+(define (continuation-passed-out? continuation)
+  (there-exists? (continuation/combinations continuation)
+    (lambda (combination)
+      (and (not (combination/inline? combination))
+	   (there-exists? (rvalue-values (combination/operator combination))
+	     (lambda (rvalue) (not (rvalue/procedure? rvalue))))))))
+
+(define (analyze/continuation continuation)
+  (and (not (continuation/passed-out? continuation))
+       (let ((returns (continuation/returns continuation))
+	     (combinations (continuation/combinations continuation)))
+	 (and (or (not (null? returns))
+		  (not (null? combinations)))
+	      (for-all? returns
+		(lambda (return)
+		  (eq? (rvalue-known-value (return/operator return))
+		       continuation)))
+	      (for-all? combinations
+		(lambda (combination)
+		  (eq? (rvalue-known-value
+			(combination/continuation combination))
+		       continuation)))))))
+
+(define (analyze/procedure procedure)
+  (and (not (procedure-passed-out? procedure))
+       (let ((combinations (procedure-applications procedure)))
+	 (and (not (null? combinations))
+	      (for-all? combinations
+		(lambda (combination)
+		  (eq? (rvalue-known-value (combination/operator combination))
+		       procedure)))))))
+
+;;; end OPERATOR-ANALYSIS
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm
new file mode 100644
index 000000000..bed72ef36
--- /dev/null
+++ b/v7/src/compiler/fgopt/order.scm
@@ -0,0 +1,269 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.1 1987/12/04 19:28:12 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Argument Ordering Analysis
+
+(declare (usual-integrations))
+
+(package (subproblem-ordering)
+
+(define-export (subproblem-ordering parallels)
+  (for-each (lambda (parallel)
+	      (let ((previous-edges (node-previous-edges parallel))
+		    (next-edge (snode-next-edge parallel)))
+		(let ((rest
+		       (or (edge-next-node next-edge)
+			   (error "PARALLEL node missing next" parallel))))
+		  (edges-disconnect-right! previous-edges)
+		  (edge-disconnect! next-edge)
+		  (edges-connect-right!
+		   previous-edges
+		   (parallel-replacement-node parallel rest)))))
+	    parallels))
+
+(define (parallel-replacement-node parallel rest)
+  (transmit-values
+      (order-subproblems/application (parallel-application-node parallel)
+				     (parallel-subproblems parallel))
+    (lambda (subproblems suffix)
+      (linearize-subproblems subproblems (scfg*node->node! suffix rest)))))
+
+(define (linearize-subproblems subproblems rest)
+  (let loop ((subproblems subproblems))
+    (if (null? subproblems)
+	rest
+	(linearize-subproblem (car subproblems)
+			      (loop (cdr subproblems))))))
+
+(define (linearize-subproblem subproblem rest)
+  (let ((continuation (subproblem-continuation subproblem))
+	(prefix (subproblem-prefix subproblem)))
+    (if (subproblem-canonical? subproblem)
+	(begin
+	  (if (continuation/entry-node continuation)
+	      (error "Attempt to reattach continuation body"
+		     continuation))
+	  (set-continuation/entry-node! continuation rest)
+	  (cfg-entry-node prefix))
+	(scfg*node->node!
+	 prefix
+	 (scfg*node->node!
+	  (if (eq? continuation-type/effect
+		   (virtual-continuation/type continuation))
+	      (make-null-cfg)
+	      (make-virtual-return continuation
+				   (subproblem-rvalue subproblem)))
+	  rest)))))
+
+(define (order-subproblems/application application subproblems)
+  (case (application-type application)
+    ((COMBINATION)
+     (if (combination/inline? application)
+	 (order-subproblems/combination/inline application subproblems)
+	 (return-2 (order-subproblems/combination/out-of-line application
+							      subproblems)
+		   (make-null-cfg))))
+    ((RETURN)
+     (set-subproblem-types! subproblems continuation-type/effect)
+     (return-2 subproblems (make-null-cfg)))
+    (else
+     (error "Unknown application type" application))))
+
+(define (order-subproblems/combination/inline combination subproblems)
+  (let ((inliner (combination/inliner combination)))
+    (let ((operands
+	   (list-filter-indices (cdr subproblems) (inliner/operands inliner))))
+      (set-inliner/operands! inliner (map subproblem-continuation operands))
+      (order-subproblems/inline (car subproblems) operands))))
+
+(define (order-subproblems/inline operator operands)
+  (set-subproblem-type! operator continuation-type/effect)
+  (transmit-values (discriminate-items operands subproblem-simple?)
+    (lambda (simple complex)
+      (if (null? complex)
+	  (begin
+	    (set-subproblem-types! simple continuation-type/value)
+	    (return-2 (cons operator operands) (make-null-cfg)))
+	  (let ((push-set (cdr complex))
+		(value-set (cons (car complex) simple)))
+	    (set-subproblem-types! push-set continuation-type/push)
+	    (set-subproblem-types! value-set continuation-type/register)
+	    (return-2 (cons operator (append! push-set value-set))
+		      (scfg*->scfg!
+		       (reverse!
+			(map (lambda (subproblem)
+			       (make-pop (subproblem-continuation subproblem)))
+			     push-set)))))))))
+
+(define (order-subproblems/combination/out-of-line combination subproblems)
+  (let ((subproblems
+	 (order-subproblems/out-of-line
+	  (combination/block combination)
+	  (car subproblems)
+	  (cdr subproblems)
+	  (rvalue-known-value (combination/operator combination)))))
+    (set-combination/frame-size!
+     combination
+     (let loop ((subproblems subproblems) (accumulator 0))
+       (if (null? subproblems)
+	   accumulator
+	   (loop (cdr subproblems)
+		 (if (eq? (subproblem-type (car subproblems))
+			  continuation-type/push)
+		     (1+ accumulator)
+		     accumulator)))))
+    subproblems))
+
+(define (order-subproblems/out-of-line block operator operands callee)
+  (set-subproblem-type! operator (operator-type (subproblem-rvalue operator)))
+  (if (and callee
+	   (rvalue/procedure? callee)
+	   (procedure/open? callee))
+      (generate/static-link
+       block
+       callee
+       (if (procedure-interface-optimizible? callee)
+	   (optimized-combination-ordering block operator operands callee)
+	   (standard-combination-ordering operator operands)))
+      (standard-combination-ordering operator operands)))
+
+(define (optimized-combination-ordering block operator operands callee)
+  (transmit-values (sort-subproblems/out-of-line operands callee)
+    (lambda (prefix integrated non-integrated)
+      (set-subproblem-types! integrated continuation-type/effect)
+      (set-subproblem-types! non-integrated continuation-type/push)
+      (push-unassigned block
+		       prefix
+		       (append! integrated non-integrated (list operator))))))
+
+(define (standard-combination-ordering operator operands)
+  (set-subproblem-types! operands continuation-type/push)
+  (reverse (cons operator operands)))
+
+(define (generate/static-link block procedure rest)
+  (if (stack-block/static-link? (procedure-block procedure))
+      (cons (make-push block (block-parent (procedure-block procedure))) rest)
+      rest))
+
+(define (push-unassigned block n rest)
+  (let ((unassigned (make-constant (scode/make-unassigned-object))))
+    (let loop ((n n) (rest rest))
+      (if (zero? n)
+	  rest
+	  (loop (-1+ n)
+		(cons (make-push block unassigned) rest))))))
+
+(define (make-push block rvalue)
+  (make-subproblem (make-null-cfg)
+		   (virtual-continuation/make block continuation-type/push)
+		   rvalue))
+
+(define (set-subproblem-types! subproblems type)
+  (for-each (lambda (subproblem)
+	      (set-subproblem-type! subproblem type))
+	    subproblems))
+
+(define (sort-subproblems/out-of-line subproblems callee)
+  (transmit-values
+      (sort-integrated (procedure-original-required callee)
+		       subproblems
+		       '()
+		       '())
+    (lambda (required subproblems integrated non-integrated)
+      (if (null? required)
+	  (transmit-values
+	      (sort-integrated (procedure-original-optional callee)
+			       subproblems
+			       integrated
+			       non-integrated)
+	    (lambda (optional subproblems integrated non-integrated)
+	      (let ((rest (procedure-original-rest callee)))
+		(cond ((not (null? optional))
+		       (return-3 (if rest
+				     0
+				     ;; In this case the caller will
+				     ;; make slots for the optionals.
+				     (length optional))
+				 integrated
+				 non-integrated))
+		      ((and rest (lvalue-integrated? rest))
+		       (return-3 0
+				 (append! (reverse subproblems) integrated)
+				 non-integrated))
+		      (else
+		       (return-3 0
+				 integrated
+				 (append! (reverse subproblems)
+					  non-integrated)))))))
+	  ;; This is a wrong number of arguments case, so the code
+	  ;; we generate will not be any good.
+	  (return-3 0 integrated non-integrated)))))
+
+(define (sort-integrated lvalues subproblems integrated non-integrated)
+  (cond ((or (null? lvalues) (null? subproblems))
+	 (return-4 lvalues subproblems integrated non-integrated))
+	((lvalue-integrated? (car lvalues))
+	 (sort-integrated (cdr lvalues)
+			  (cdr subproblems)
+			  (cons (car subproblems) integrated)
+			  non-integrated))
+	(else
+	 (sort-integrated (cdr lvalues)
+			  (cdr subproblems)
+			  integrated
+			  (cons (car subproblems) non-integrated)))))
+
+(define (operator-type operator)
+  (let ((callee (rvalue-known-value operator)))
+    (cond ((not callee)
+	   (if (reference? operator)
+	       continuation-type/effect
+	       continuation-type/apply))
+	  ((rvalue/constant? callee)
+	   (if (normal-primitive-procedure? (constant-value callee))
+	       continuation-type/effect
+	       continuation-type/apply))
+	  ((rvalue/procedure? callee)
+	   (case (procedure/type callee)
+	     ((OPEN-EXTERNAL OPEN-INTERNAL) continuation-type/effect)
+	     ((CLOSURE) continuation-type/push)
+	     ((IC) continuation-type/apply)
+	     (else (error "Unknown procedure type" callee))))
+	  (else
+	   continuation-type/apply))))
+
+(define-integrable continuation-type/apply
+  continuation-type/push)
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/simple.scm b/v7/src/compiler/fgopt/simple.scm
new file mode 100644
index 000000000..2c688c208
--- /dev/null
+++ b/v7/src/compiler/fgopt/simple.scm
@@ -0,0 +1,130 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.1 1987/12/04 19:28:21 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Argument Simplicity Analysis
+
+(declare (usual-integrations))
+
+(package (simplicity-analysis)
+
+(define-export (simplicity-analysis parallels)
+  (for-each (lambda (parallel)
+	      (for-each (lambda (subproblem)
+			  (set-subproblem-simple?! subproblem 'UNKNOWN))
+			(parallel-subproblems parallel)))
+	    parallels)
+  (for-each (lambda (parallel)
+	      (if (let ((application (parallel-application-node parallel)))
+		    (and application
+			 (application/combination? application)
+			 (combination/inline? application)))
+		  (for-each %subproblem-simple?
+			    (parallel-subproblems parallel))))
+	    parallels))
+
+(define (%subproblem-simple? subproblem)
+  (let ((simple? (subproblem-simple? subproblem)))
+    (if (eq? simple? 'UNKNOWN)
+	(let ((simple?
+	       (and (rvalue-simple? (subproblem-rvalue subproblem))
+		    (or (not (subproblem-canonical? subproblem))
+			(node-simple? (subproblem-entry-node subproblem)
+				      (subproblem-continuation subproblem))))))
+	  (set-subproblem-simple?! subproblem simple?)
+	  simple?)
+	simple?)))
+
+(define (node-simple? node continuation)
+  ((cfg-node-case (tagged-vector/tag node)
+     ((PARALLEL) parallel-simple?)
+     ((APPLICATION)
+      (case (application-type node)
+	((COMBINATION) combination-simple?)
+	((RETURN) return-simple?)
+	(else (error "Unknown application type" node))))
+     ((VIRTUAL-RETURN) virtual-return-simple?)
+     ((ASSIGNMENT) assignment-simple?)
+     ((DEFINITION) definition-simple?)
+     ((TRUE-TEST) true-test-simple?)
+     ((FG-NOOP) fg-noop-simple?))
+   node continuation))
+
+(define (parallel-simple? parallel continuation)
+  (and (for-all? (parallel-subproblems parallel) %subproblem-simple?)
+       (node-simple? (snode-next parallel) continuation)))
+
+(define (combination-simple? combination continuation)
+  (and (combination/inline? combination)
+       (continuation-simple? (combination/continuation combination)
+			     continuation)))
+
+(define (return-simple? return continuation)
+  (continuation-simple? (return/operator return) continuation))
+
+(define (virtual-return-simple? return continuation)
+  (continuation-simple? (virtual-return-operator return) continuation))
+
+(define (continuation-simple? rvalue continuation)
+  (or (eq? rvalue continuation)
+      (and (rvalue/continuation? rvalue)
+	   (node-simple? (continuation/entry-node rvalue) continuation))))
+
+(define (assignment-simple? assignment continuation)
+  (and (lvalue-simple? (assignment-lvalue assignment))
+       (rvalue-simple? (assignment-rvalue assignment))
+       (node-simple? (snode-next assignment) continuation)))
+
+(define (definition-simple? definition continuation)
+  (and (lvalue-simple? (definition-lvalue definition))
+       (rvalue-simple? (definition-rvalue definition))
+       (node-simple? (snode-next definition) continuation)))
+
+(define (true-test-simple? true-test continuation)
+  (and (rvalue-simple? (true-test-rvalue true-test))
+       (node-simple? (pnode-consequent true-test) continuation)
+       (node-simple? (pnode-alternative true-test) continuation)))
+
+(define (fg-noop-simple? fg-noop continuation)
+  (node-simple? (snode-next fg-noop) continuation))
+
+(define (rvalue-simple? rvalue)
+  (or (not (rvalue/reference? rvalue))
+      (let ((lvalue (reference-lvalue rvalue)))
+	(or (lvalue-known-value lvalue)
+	    (lvalue-simple? lvalue)))))
+
+(define (lvalue-simple? lvalue)
+  (not (block-passed-out? (variable-block lvalue))))
+
+)
\ No newline at end of file