From f21adaacb8dc0b4eb22067130cbae6b33fef3c97 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 12 Dec 1988 21:33:15 +0000
Subject: [PATCH] Initial revision

---
 v7/src/compiler/base/refctx.scm   | 328 ++++++++++++++++++++++++++++++
 v7/src/compiler/fgopt/reord.scm   | 316 ++++++++++++++++++++++++++++
 v7/src/compiler/fgopt/reuse.scm   | 295 +++++++++++++++++++++++++++
 v7/src/compiler/fgopt/subfre.scm  | 132 ++++++++++++
 v7/src/compiler/rtlgen/fndvar.scm | 173 ++++++++++++++++
 5 files changed, 1244 insertions(+)
 create mode 100644 v7/src/compiler/base/refctx.scm
 create mode 100644 v7/src/compiler/fgopt/reord.scm
 create mode 100644 v7/src/compiler/fgopt/reuse.scm
 create mode 100644 v7/src/compiler/fgopt/subfre.scm
 create mode 100644 v7/src/compiler/rtlgen/fndvar.scm

diff --git a/v7/src/compiler/base/refctx.scm b/v7/src/compiler/base/refctx.scm
new file mode 100644
index 000000000..f12fb4193
--- /dev/null
+++ b/v7/src/compiler/base/refctx.scm
@@ -0,0 +1,328 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/refctx.scm,v 1.1 1988/12/12 21:32:12 cph Rel $
+
+Copyright (c) 1988 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. |#
+
+;;;; Reference Contexts
+
+(declare (usual-integrations))
+
+;;; In general, generating code for variable (and block) references
+;;; requires only two pieces of knowledge: the block in which the
+;;; reference occurs, and the block being referenced (in the case of
+;;; variables, the latter is the block in which the variable is
+;;; bound).  Usually the location of the parent of a given block is
+;;; precisely known, e.g. as a stack offset from that block, and in
+;;; cases where different locations are possible, an explicit static
+;;; link is used to provide that location.
+
+;;; In the case where static links are normally used, it is sometimes
+;;; possible to bypass a static link for a particular reference: this
+;;; because the knowledge of the reference's position within the
+;;; program's control structure implies that the parent block is in a
+;;; known location.  In other words, even though that parent block can
+;;; have several different locations relative to its child, from that
+;;; particular place in the program only one of those locations is
+;;; possible.
+
+;;; Reference contexts are a mechanism to capture this kind of control
+;;; structure dependent knowledge.  Basically, every point in the flow
+;;; graph that does some kind of environment reference keeps a pointer
+;;; to a reference context.  These reference contexts can be
+;;; independently changed to annotate interesting facts.
+
+(define reference-context-tag
+  ;; This tag is used to prevent `define-structure' from redefining
+  ;; the variable `reference-context'.
+  "reference-context")
+
+(define-structure (reference-context
+		   (named reference-context-tag)
+		   (constructor make-reference-context (block))
+		   (conc-name reference-context/))
+  (block false read-only true)
+  (offset false)
+  (adjacent-parents '()))
+
+(define-integrable (reference-context/procedure context)
+  (block-procedure (reference-context/block context)))
+
+(define-integrable (reference-context/adjacent-parent? context block)
+  (memq block (reference-context/adjacent-parents context)))
+
+(define (add-reference-context/adjacent-parents! context blocks)
+  (set-reference-context/adjacent-parents!
+   context
+   (eq-set-union blocks (reference-context/adjacent-parents context))))
+
+#|
+(define (node/reference-context node)
+  (cfg-node-case (tagged-vector/tag node)
+    ((APPLICATION) (application-context node))
+    ((VIRTUAL-RETURN) (virtual-return-context node))
+    ((ASSIGNMENT) (assignment-context node))
+    ((DEFINITION) (definition-context node))
+    ((STACK-OVERWRITE) (stack-overwrite-context node))
+    ((TRUE-TEST) (true-test-context node))
+    ((PARALLEL POP FG-NOOP) false)))
+|#
+
+;;; Once the FG graph has been constructed, this procedure will walk
+;;; over it and install reference contexts in all the right places.
+;;; It will also guarantee that all of the rvalues associated with a
+;;; particular CFG node have the same context as the node.  This means
+;;; that subsequently it is only necessary to walk over the CFG nodes
+;;; and modify their contexts.
+
+(define (initialize-reference-contexts! expression procedures)
+  (with-new-node-marks
+   (lambda ()
+     (initialize-contexts/node (expression-entry-node expression))
+     (for-each (lambda (procedure)
+		 (initialize-contexts/next (procedure-entry-node procedure)))
+	       procedures))))
+
+(define (initialize-contexts/next node)
+  (if (and node (not (node-marked? node)))
+      (initialize-contexts/node node)))
+
+(define (initialize-contexts/node node)
+  (node-mark! node)
+  (cfg-node-case (tagged-vector/tag node)
+    ((PARALLEL)
+     (initialize-contexts/parallel node)
+     (initialize-contexts/next (snode-next node)))
+    ((APPLICATION)
+     (initialize-contexts/application node)
+     (initialize-contexts/next (snode-next node)))
+    ((VIRTUAL-RETURN)
+     (initialize-contexts/virtual-return node)
+     (initialize-contexts/next (snode-next node)))
+    ((ASSIGNMENT)
+     (initialize-contexts/assignment node)
+     (initialize-contexts/next (snode-next node)))
+    ((DEFINITION)
+     (initialize-contexts/definition node)
+     (initialize-contexts/next (snode-next node)))
+    ((STACK-OVERWRITE)
+     (initialize-contexts/stack-overwrite node)
+     (initialize-contexts/next (snode-next node)))
+    ((POP FG-NOOP)
+     (initialize-contexts/next (snode-next node)))
+    ((TRUE-TEST)
+     (initialize-contexts/true-test node)
+     (initialize-contexts/next (pnode-consequent node))
+     (initialize-contexts/next (pnode-alternative node)))))
+
+(define (initialize-contexts/parallel parallel)
+  (for-each
+   (lambda (subproblem)
+     (let ((prefix (subproblem-prefix subproblem)))
+       (if (not (cfg-null? prefix))
+	   (initialize-contexts/next (cfg-entry-node prefix))))
+     (if (subproblem-canonical? subproblem)
+	 (initialize-contexts/reference (subproblem-rvalue subproblem))
+	 (let* ((continuation (subproblem-continuation subproblem))
+		(old (virtual-continuation/context continuation))
+		(new (guarantee-context old)))
+	   (if new
+	       (begin
+		 (set-virtual-continuation/context! continuation new)
+		 (initialize-contexts/rvalue
+		  old new
+		  (subproblem-rvalue subproblem)))))))
+   (parallel-subproblems parallel)))
+
+(define (initialize-contexts/application application)
+  (let* ((old (application-context application))
+	 (new (guarantee-context old)))
+    (if new
+	(begin
+	  (set-application-context! application new)
+	  (if (application/return? application)
+	      (begin
+		(initialize-contexts/rvalue old new
+					    (application-operator application))
+		(for-each (lambda (operand)
+			    (initialize-contexts/rvalue old new operand))
+			  (application-operands application)))))))
+  unspecific)
+
+(define (initialize-contexts/virtual-return return)
+  (let* ((old (virtual-return-context return))
+	 (new (guarantee-context old)))
+    (if new
+	(begin
+	  (set-virtual-return-context! return new)
+	  (initialize-contexts/rvalue old new (virtual-return-operand return))
+	  (let ((continuation (virtual-return-operator return)))
+	    (if (virtual-continuation/reified? continuation)
+		(initialize-contexts/rvalue
+		 old
+		 new
+		 (virtual-continuation/reification continuation))
+		(guarantee-context! old new continuation
+				    virtual-continuation/context
+				    set-virtual-continuation/context!)))))))
+
+(define (initialize-contexts/assignment assignment)
+  (let* ((old (assignment-context assignment))
+	 (new (guarantee-context old)))
+    (if new
+	(begin
+	  (set-assignment-context! assignment new)
+	  (initialize-contexts/rvalue old new
+				      (assignment-rvalue assignment))))))
+
+(define (initialize-contexts/definition assignment)
+  (let* ((old (definition-context assignment))
+	 (new (guarantee-context old)))
+    (if new
+	(begin
+	  (set-definition-context! assignment new)
+	  (initialize-contexts/rvalue old new
+				      (definition-rvalue assignment))))))
+
+(define (initialize-contexts/stack-overwrite assignment)
+  (let* ((old (stack-overwrite-context assignment))
+	 (new (guarantee-context old)))
+    (if new
+	(set-stack-overwrite-context! assignment new)))
+  unspecific)
+
+(define (initialize-contexts/true-test true-test)
+  (let* ((old (true-test-context true-test))
+	 (new (guarantee-context old)))
+    (if new
+	(begin
+	  (set-true-test-context! true-test new)
+	  (initialize-contexts/rvalue old new (true-test-rvalue true-test))))))
+
+(define (initialize-contexts/rvalue old new rvalue)
+  (enumeration-case rvalue-type (tagged-vector/index rvalue)
+    ((REFERENCE)
+     (if (variable/value-variable? (reference-lvalue rvalue))
+	 (initialize-contexts/reference rvalue)
+	 (guarantee-context! old new rvalue
+			     reference-context set-reference-context!)))
+    ((UNASSIGNED-TEST)
+     (guarantee-context! old new rvalue
+			 unassigned-test-context set-unassigned-test-context!))
+    ((PROCEDURE)
+     (let ((context (procedure-closure-context rvalue)))
+       (cond ((reference? context)
+	      (initialize-contexts/reference context))
+#|
+	     ;; Unnecessary because no procedures have closure
+	     ;; contexts when initialize-contexts is run.
+	     ((block? context)
+	      (guarantee-context! old new rvalue
+				  procedure-closure-context
+				  set-procedure-closure-context!))
+|#
+	     )))))
+
+(define (initialize-contexts/reference rvalue)
+  (set-reference-context! rvalue
+			  (make-reference-context (reference-context rvalue))))
+
+(define-integrable (guarantee-context! old new object context set-context!)
+  (guarantee-context!/check-old old (context object))
+  (set-context! object new)
+  unspecific)
+
+(define (guarantee-context!/check-old old context)
+  (if (not (eq? old context))
+      (error "Reference context mismatch" old context)))
+
+(define (guarantee-context old)
+  (and (block? old)
+       (make-reference-context old)))
+
+(define (modify-reference-contexts! node limit modification)
+  (with-new-node-marks
+   (lambda ()
+     (if limit (node-mark! limit))
+     (modify-contexts/node modification node))))
+
+(define (modify-contexts/node modification node)
+  (node-mark! node)
+  (cfg-node-case (tagged-vector/tag node)
+    ((PARALLEL)
+     (for-each
+      (lambda (subproblem)
+	(let ((prefix (subproblem-prefix subproblem)))
+	  (if (not (cfg-null? prefix))
+	      (modify-contexts/next modification (cfg-entry-node prefix))))
+	(if (not (subproblem-canonical? subproblem))
+	    (modification
+	     (virtual-continuation/context
+	      (subproblem-continuation subproblem)))))
+      (parallel-subproblems node))
+     (modify-contexts/next modification (snode-next node)))
+    ((APPLICATION)
+     (modification (application-context node))
+     (modify-contexts/operator modification (application-operator node))
+     (modify-contexts/next modification (snode-next node)))
+    ((VIRTUAL-RETURN)
+     (modification (virtual-return-context node))
+     (let ((continuation (virtual-return-operator node)))
+       (if (virtual-continuation/reified? continuation)
+	   (modify-contexts/operator
+	    modification
+	    (virtual-continuation/reification continuation))
+	   (modification (virtual-continuation/context continuation))))
+     (modify-contexts/next modification (snode-next node)))
+    ((ASSIGNMENT)
+     (modification (assignment-context node))
+     (modify-contexts/next modification (snode-next node)))
+    ((DEFINITION)
+     (modification (definition-context node))
+     (modify-contexts/next modification (snode-next node)))
+    ((STACK-OVERWRITE)
+     (modification (stack-overwrite-context node))
+     (modify-contexts/next modification (snode-next node)))
+    ((POP FG-NOOP)
+     (modify-contexts/next modification (snode-next node)))
+    ((TRUE-TEST)
+     (modification (true-test-context node))
+     (modify-contexts/next modification (pnode-consequent node))
+     (modify-contexts/next modification (pnode-alternative node)))))
+
+(define (modify-contexts/operator modification rvalue)
+  (let ((value (rvalue-known-value rvalue)))
+    (if (and value (rvalue/procedure? value))
+	(modify-contexts/next modification (procedure-entry-node value)))))
+
+(define (modify-contexts/next modification node)
+  (if (and node (not (node-marked? node)))
+      (modify-contexts/node modification node)))
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/reord.scm b/v7/src/compiler/fgopt/reord.scm
new file mode 100644
index 000000000..35bdeb16f
--- /dev/null
+++ b/v7/src/compiler/fgopt/reord.scm
@@ -0,0 +1,316 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reord.scm,v 1.1 1988/12/12 21:33:00 cph Rel $
+
+Copyright (c) 1988 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. |#
+
+;;;; Parallel assignment problem
+
+(declare (usual-integrations))
+
+#|
+
+Reordering algorithm for operands in tail recursive combinations.  The
+problem is NP-hard, so the solution below is not optimal, but it does
+pretty well.
+
+The program below solves the 1-4 vars case optimally, and does an
+almost perfect job on 5 (it loses in less than 2% of the cases).  The
+behavior of the program is conceptually quadratic, but since lists are
+used to represent the adjacency matrix (rather than bit strings), it
+could perform cubically if the matrix was dense.  In practice, the
+matrix is often very sparse, so quadratic is a better expectation of
+performance.
+
+The program below is guaranteed to find an ordering which requires no
+temporaries if one exists.  Thus if the reordering found requires none
+or one temporary, it is an optimal solution.
+
+The algorithm is a greedy algorithm:
+
+- It chooses a variable on which no others depend first, it then
+removes it from the graph.  This guarantees the optimality when no
+temporaries are needed.
+
+- If there are none, it chooses a variable according to a set of
+heuristics, and removes it from the graph.  The collection of
+heuristics has been found (empirically) to be complete for n = 3 or 4,
+and to do fairly well for n = 5.  All of the heuristics choose one of
+the nodes with the highest degree (most dependencies + dependents)
+giving preference to dependencies, dependents, or balance.
+
+Note that "self-loops" (edges from a variable to itself) are
+eliminated at the outset, since they don't have any effect on the
+number of assignments of any ordering.
+
+|#
+
+;;;; Graph Abstraction
+
+(define-structure (node
+		   (constructor make-node
+				(target
+				 value
+				 original-dependencies
+				 original-dependents)))
+  ;; An assignment representing a target variable (or static link) and
+  ;; an expression which will be assigned to the target.
+  (target false read-only true)
+  (value false read-only true)
+
+  ;; The set of assignments on whose targets the value of this
+  ;; assignment depends.
+  original-dependencies
+
+  ;; The set of assignments whose values depend on this assignment's
+  ;; target.
+  original-dependents
+
+  ;; Copies of the above; modified during the reordering algorithm.
+  (dependencies (list-copy original-dependencies))
+  (dependents (list-copy original-dependents)))
+
+(define (make-node-set targets values dependency-sets)
+  (map (lambda (target value dependencies)
+	 (make-node target
+		    value
+		    dependencies
+		    (let loop
+			((targets targets)
+			 (dependency-sets dependency-sets))
+		      (cond ((null? targets)
+			     '())
+			    ;; Why no self-dependents?
+			    ((and (not (eq? target (car targets)))
+				  (memq target (car dependency-sets)))
+			     (cons (car targets)
+				   (loop (cdr targets)
+					 (cdr dependency-sets))))
+			    (else
+			     (loop (cdr targets)
+				   (cdr dependency-sets)))))))
+       targets
+       values
+       dependency-sets))
+
+(define-integrable (copy-node-set nodes)
+  (map node-copy nodes))
+
+(define (node-copy node)
+  (make-node (node-target node)
+	     (node-value node)
+	     (node-original-dependencies node)
+	     (node-original-dependents node)))
+
+;;;; Reordering
+
+(define (reorder-assignments nodes)
+  ;; Optimize trivial cases
+  (let ((n-nodes (length nodes)))
+    (case n-nodes
+      ((0 1)
+       nodes)
+      ((2)
+       (if (zero? (add-up-cost nodes))
+	   nodes
+	   (reverse nodes)))
+      ((3)
+       (reorder! nodes find-index-most/dependencies))
+      (else
+       (let loop ((heuristics heuristics) (nodes nodes) (cost n-nodes))
+	 (if (null? heuristics)
+	     nodes
+	     (let* ((nodes* (reorder! (copy-node-set nodes) (car heuristics)))
+		    (cost* (add-up-cost nodes*)))
+	       (cond ((< cost* 2) nodes*)
+		     ((< cost* cost) (loop (cdr heuristics) nodes* cost*))
+		     (else (loop (cdr heuristics) nodes cost))))))))))
+
+(define (add-up-cost nodes)
+  (if (null? nodes)
+      0
+      (let loop ((nodes nodes) (cost 0))
+	(if (null? (cdr nodes))
+	    cost
+	    (loop (cdr nodes)
+		  (if (first-node-needs-temporary? nodes) (1+ cost) cost))))))
+
+(define (first-node-needs-temporary? nodes)
+  (there-exists? (cdr nodes)
+    (let ((target (node-target (car nodes))))
+      (lambda (node)
+	(memq target (node-original-dependencies node))))))
+
+(define (reorder! nodes find-index)
+  ;; This is expensive.  It could be done for all at once,
+  ;; but for now...
+  (let ((nodes (list->vector nodes)))
+    (let ((last (-1+ (vector-length nodes))))
+      (let loop ((index 0))
+	(if (< index last)
+	    (begin
+	      (let* ((i (find-index nodes index last))
+		     (node (vector-ref nodes i))
+		     (target (node-target node)))
+		(let loop ((low index))
+		  (if (<= low last)
+		      (begin
+			(let ((node* (vector-ref nodes low)))
+			  (if (not (eq? node* node))
+			      (begin
+				(set-node-dependencies!
+				 node*
+				 (delq! target (node-dependencies node*)))
+				(set-node-dependents!
+				 node*
+				 (delq! target (node-dependents node*))))))
+			(loop (1+ low)))))
+		(vector-set! nodes i (vector-ref nodes index))
+		(vector-set! nodes index node))
+	      (loop (1+ index))))))
+    (vector->list nodes)))
+
+;;;; Heuristics
+
+(define (find-index-maker decision)
+  (lambda (nodes low high)
+    (let ((node (vector-ref nodes low)))
+      (if (null? (node-dependents node))
+	  low
+	  (let loop
+	      ((i (1+ low))
+	       (index low)
+	       (dependencies (length (node-dependencies node)))
+	       (dependents (length (node-dependents node))))
+	    (if (> i high)
+		index
+		(let ((node (vector-ref nodes i)))
+		  (if (null? (node-dependents node))
+		      i
+		      (let ((dependencies* (length (node-dependencies node)))
+			    (dependents* (length (node-dependents node))))
+			(if (decision dependencies dependents
+				      dependencies* dependents*)
+			    (loop (1+ i) i dependencies* dependents*)
+			    (loop (1+ i)
+				  index dependencies dependents)))))))))))
+
+#|
+
+;;; This version chooses the node with the most dependencies.
+;;; Among equals it gives preference to those with the most total.
+
+(define find-index-most-dependencies
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (if (= dependencies* dependencies)
+	 (> dependents* dependents)
+	 (> dependencies* dependencies)))))
+
+;;; This version chooses the node with the most dependents.
+;;; Among equals it gives preference to those with the most total.
+
+(define find-index-most-dependents
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (if (= dependents* dependents)
+	 (> dependencies* dependencies)
+	 (> dependents* dependents)))))
+
+|#
+
+;;; This version chooses the node with the most total edges.
+;;; Among equals it gives preference to those with an approximately
+;;; equal number of dependencies and dependents.
+
+(define find-index-most/balanced
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (let ((total (+ dependencies dependents))
+	   (total* (+ dependencies* dependents*)))
+       (if (= total* total)
+	   (< (abs (- dependencies* dependents*))
+	      (abs (- dependencies dependents)))
+	   (> total* total))))))
+
+;;; This version chooses the node with the most total edges.
+;;; Among equals it gives preference to those with the most
+;;; dependencies.
+
+(define find-index-most/dependencies
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (let ((total (+ dependencies dependents))
+	   (total* (+ dependencies* dependents*)))
+       (if (= total* total)
+	   (> dependencies* dependencies)
+	   (> total* total))))))
+
+;;; This version chooses the node with the most total edges.
+;;; Among equals it gives preference to those with the most
+;;; dependents.
+
+(define find-index-most/dependents
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (let ((total (+ dependencies dependents))
+	   (total* (+ dependencies* dependents*)))
+       (if (= total* total)
+	   (> dependents* dependents)
+	   (> total* total))))))
+
+;;; The following two are like the two above but have preference to
+;;; the right rather than the left.
+
+(define find-index-most/dependencies-
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (let ((total (+ dependencies dependents))
+	   (total* (+ dependencies* dependents*)))
+       (if (= total* total)
+	   (>= dependencies* dependencies)
+	   (> total* total))))))
+
+(define find-index-most/dependents-
+  (find-index-maker
+   (lambda (dependencies dependents dependencies* dependents*)
+     (let ((total (+ dependencies dependents))
+	   (total* (+ dependencies* dependents*)))
+       (if (= total* total)
+	   (>= dependents* dependents)
+	   (> total* total))))))
+
+(define heuristics
+  (list find-index-most/dependencies
+	find-index-most/dependents
+	find-index-most/dependencies-
+	find-index-most/dependents-
+	find-index-most/balanced))
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/reuse.scm b/v7/src/compiler/fgopt/reuse.scm
new file mode 100644
index 000000000..33a2a22d6
--- /dev/null
+++ b/v7/src/compiler/fgopt/reuse.scm
@@ -0,0 +1,295 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.1 1988/12/12 21:32:29 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; Reduction Combinations: Frame Reuse
+
+(declare (usual-integrations))
+
+(define (setup-frame-adjustments applications)
+  (for-each
+   (lambda (combination)
+     (if (application/combination? combination)
+	 (set-combination/frame-adjustment!
+	  combination
+	  (let ((block (combination/block combination)))
+	    (let ((adjustment
+		   (let ((callee (combination/model combination)))
+		     (let ((callee-internal?
+			    (and callee
+				 (rvalue/procedure? callee)
+				 (procedure/open-internal? callee)))
+			   (caller (block-procedure block)))
+		       (and (not (combination/inline? combination))
+			    (return-operator/reduction?
+			     (combination/continuation combination))
+			    (rvalue/procedure? caller)
+			    (not (procedure/ic? caller))
+			    (cond ((procedure/external? caller)
+				   (and (not callee-internal?) block))
+				  (callee-internal?
+				   (let ((block* (procedure-block callee)))
+				     (and (not (block-child? block block*))
+					  (block-farthest-uncommon-ancestor
+					   block
+					   (block-parent block*)))))
+				  (else
+				   (stack-block/external-ancestor block))))))))
+	      (and adjustment
+		   (if (for-all? (block-popping-limits block)
+			 (lambda (limit)
+			   (block-ancestor-or-self? adjustment limit)))
+		       (cons 'KNOWN adjustment)
+		       (let ((limit (block-popping-limit block)))
+			 (if limit
+			     (cons 'KNOWN
+				   (if (block-ancestor? adjustment limit)
+				       adjustment
+				       limit))
+			     (cons 'UNKNOWN adjustment))))))))))
+   applications))
+
+(define (order-subproblems/maybe-overwrite-block combination subproblems rest
+						 if-no-overwrite)
+  (let ((caller-block (combination/block combination))
+	;; This reduces code size.
+	(if-no-overwrite (lambda () (if-no-overwrite))))
+    (let ((overwritten-block
+	   (let ((adjustment (combination/frame-adjustment combination)))
+	     (and adjustment
+		  (eq? (car adjustment) 'KNOWN)
+		  (cdr adjustment)))))
+      (if overwritten-block
+	  (with-values
+	      (lambda ()
+		(subproblems->nodes subproblems
+				    caller-block
+				    overwritten-block))
+	    (lambda (terminal-nodes non-terminal-nodes extra-subproblems)
+	      (if (< (length non-terminal-nodes) reuse-size-limit)
+		  (begin
+		    (set-combination/reuse-existing-frame?! combination
+							    overwritten-block)
+		    (linearize-subproblems!
+		     continuation-type/push
+		     extra-subproblems
+		     (order-subproblems/overwrite-block caller-block
+							overwritten-block
+							terminal-nodes
+							non-terminal-nodes
+							rest)))
+		  (if-no-overwrite))))
+	  (if-no-overwrite)))))
+
+(define reuse-size-limit 7)
+
+(define (subproblems->nodes subproblems caller-block overwritten-block)
+  (with-values
+      (lambda ()
+	(let ((n-subproblems (length subproblems)))
+	  (let ((targets
+		 (overwritten-objects caller-block
+				      overwritten-block
+				      n-subproblems)))
+	    (let ((n-targets (length targets))
+		  (make-nodes
+		   (lambda (subproblems)
+		      ;; The subproblems are given to us in pushing order.
+		     (let ((subproblems (reverse subproblems)))
+		       (make-node-set
+			targets
+			subproblems
+			(map (subproblem/dependency-set targets
+							overwritten-block)
+			     subproblems))))))
+	      (if (< n-targets n-subproblems)
+		  (values (make-nodes (list-head subproblems n-targets))
+			  (list-tail subproblems n-targets))
+		  (values (make-nodes subproblems) '()))))))
+    (lambda (nodes extra-subproblems)
+      (with-values
+	  (lambda ()
+	    (discriminate-items nodes
+	      (lambda (node)
+		(let ((dependents (node-original-dependents node)))
+		  (or (null? dependents)
+		      (and (null? (cdr dependents))
+			   (eq? (node-target (car dependents))
+				(node-target node))))))))
+	(lambda (terminal-nodes non-terminal-nodes)
+	  (values terminal-nodes non-terminal-nodes extra-subproblems))))))
+
+(define (overwritten-objects caller-block overwritten-block overwriting-size)
+  (let ((stack-layout
+	 (let loop ((block caller-block))
+	   (if (eq? block overwritten-block)
+	       (block-layout block)
+	       (append! (block-layout block) (loop (block-parent block)))))))
+    (let ((n-items (length stack-layout)))
+      (if (< overwriting-size n-items)
+	  (list-tail stack-layout (- n-items overwriting-size))
+	  stack-layout))))
+
+(define (block-layout block)
+  ;; When representing static links or closures in the result, we use
+  ;; `block' rather than its parent, because it simplifies locating
+  ;; the parent pointer on the stack.
+  (let ((procedure (block-procedure block)))
+    (append
+     (procedure-names procedure)
+     (if (and (procedure/closure? procedure)
+	      (closure-procedure-needs-operator? procedure))
+	 (list block)
+	 '())
+     (cdr (procedure-required procedure))
+     (procedure-optional procedure)
+     (if (procedure-rest procedure) (list (procedure-rest procedure)) '())
+     (if (and (not (procedure/closure? procedure))
+	      (stack-block/static-link? block))
+	 (list block)
+	 '()))))
+
+(define (subproblem/dependency-set targets overwritten-block)
+  (let ((block (and (memq overwritten-block targets) overwritten-block)))
+    (if (not block)
+	(lambda (subproblem)
+	  (list-transform-positive (subproblem-free-variables subproblem)
+	    (lambda (variable)
+	      (memq variable targets))))
+	(lambda (subproblem)
+	  (let loop
+	      ((variables (subproblem-free-variables subproblem))
+	       (dependencies '())
+	       (block-dependency false))
+	    (cond ((null? variables)
+		   (if (or block-dependency
+			   (let ((rvalue (subproblem-rvalue subproblem)))
+			     (and (rvalue/block? rvalue)
+				  (block-ancestor? block rvalue))))
+		       (cons block dependencies)
+		       dependencies))
+		  ((memq (car variables) targets)
+		   (loop (cdr variables)
+			 (cons (car variables) dependencies)
+			 block-dependency))
+		  (else
+		   (loop (cdr variables)
+			 dependencies
+			 (or block-dependency
+			     (block-dependency? block (car variables)))))))))))
+
+(define (block-dependency? block variable)
+  (let ((definition-block (variable-block variable)))
+    (if (ic-block? definition-block)
+	(and (not (ic-block/use-lookup? definition-block))
+	     (block-ancestor? block definition-block))
+	(let ((value (lvalue-known-value variable)))
+	  (or (and value
+		   (rvalue/procedure? value)
+		   (procedure/closure? value)
+		   (eq? value (block-procedure block)))
+	      (block-ancestor? block definition-block)
+	      (let loop ((block block))
+		(if (closure-block? block)
+		    (memq variable (block-bound-variables block))
+		    (let ((parent (block-parent block)))
+		      (and parent (loop parent))))))))))
+(define (order-subproblems/overwrite-block caller-block
+					   overwritten-block
+					   terminal-nodes
+					   non-terminal-nodes
+					   rest)
+  (let ((node
+	 (trivial-assignments
+	  terminal-nodes
+	  (generate-assignments (reorder-assignments non-terminal-nodes)
+				rest))))
+      (if (not (eq? caller-block overwritten-block))
+	  (modify-reference-contexts! node rest
+	    (let ((blocks
+		   (block-partial-ancestry caller-block overwritten-block)))
+	      (lambda (context)
+		(add-reference-context/adjacent-parents! context blocks)))))
+      node))
+
+(define (generate-assignments nodes rest)
+  (cond ((null? nodes)
+	 rest)
+	((first-node-needs-temporary? nodes)
+	 (linearize-subproblem!
+	  (if (for-all? (cdr nodes)
+		(lambda (node)
+		  (subproblem-simple? (node-value node))))
+	      continuation-type/register
+	      continuation-type/push)
+	  (node-value (car nodes))
+	  (generate-assignments (cdr nodes)
+				(overwrite (car nodes) rest))))
+	(else
+	 (trivial-assignment (car nodes)
+			     (generate-assignments (cdr nodes) rest)))))
+
+(define (trivial-assignments nodes rest)
+  (let loop ((nodes nodes))
+    (if (null? nodes)
+	rest
+	(trivial-assignment (car nodes) (loop (cdr nodes))))))
+
+(define (trivial-assignment node rest)
+  (if (node/noop? node)
+      rest
+      (linearize-subproblem! continuation-type/register
+			     (node-value node)
+			     (overwrite node rest))))
+
+(define (node/noop? node)
+  (let ((target (node-target node))
+	(subproblem (node-value node)))
+    (and (cfg-null? (subproblem-prefix subproblem))
+	 (let ((rvalue (subproblem-rvalue subproblem)))
+	   (cond ((rvalue/reference? rvalue)
+		  (let ((variable (reference-lvalue rvalue)))
+		    (and (eq? target variable)
+			 (not (variable-in-cell? variable)))))
+		 ((rvalue/block? rvalue)
+		  (and (block? target)
+		       (eq? (block-parent target) rvalue)))
+		 (else false))))))
+
+(define (overwrite node rest)
+  (let ((subproblem (node-value node)))
+    (scfg*node->node!
+     (make-stack-overwrite (subproblem-context subproblem)
+			   (node-target node)
+			   (subproblem-continuation subproblem))
+     rest)))
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/subfre.scm b/v7/src/compiler/fgopt/subfre.scm
new file mode 100644
index 000000000..84c857dd4
--- /dev/null
+++ b/v7/src/compiler/fgopt/subfre.scm
@@ -0,0 +1,132 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.1 1988/12/12 21:32:46 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; Subproblem Free Variables
+
+(declare (usual-integrations))
+
+(define (compute-subproblem-free-variables parallels)
+  (for-each (lambda (parallel)
+	      (for-each (lambda (subproblem)
+			  (set-subproblem-free-variables! subproblem 'UNKNOWN))
+			(parallel-subproblems parallel)))
+	    parallels)
+  (for-each (lambda (parallel)
+	      (for-each walk-subproblem (parallel-subproblems parallel)))
+	    parallels))
+
+(define (new-subproblem/compute-free-variables! subproblem)
+  (walk-subproblem subproblem))
+
+(define (walk-subproblem subproblem)
+  (let ((free (subproblem-free-variables subproblem)))
+    (if (eq? free 'UNKNOWN)
+	(let ((free
+	       (let ((free (walk-rvalue (subproblem-rvalue subproblem))))
+		 (if (subproblem-canonical? subproblem)
+		     (eq-set-union
+		      free
+		      (walk-node (subproblem-entry-node subproblem)))
+		     free))))
+	  (set-subproblem-free-variables! subproblem free)
+	  free)
+	free)))
+
+(define (walk-next next free)
+  (if next
+      (eq-set-union (walk-node next) free)
+      free))
+
+(define (walk-node node)
+  (cfg-node-case (tagged-vector/tag node)
+    ((PARALLEL)
+     (walk-next (snode-next node)
+		(map-union walk-subproblem (parallel-subproblems node))))
+    ((APPLICATION)
+     (walk-next
+      (snode-next node)
+      (eq-set-union (walk-rvalue (application-operator node))
+		    (map-union walk-rvalue (application-operands node)))))
+    ((VIRTUAL-RETURN)
+     (walk-next
+      (snode-next node)
+      (let ((operator (virtual-return-operator node))
+	    (free (walk-rvalue (virtual-return-operand node))))
+	(cond ((not (virtual-continuation? operator))
+	       (eq-set-union (walk-rvalue operator) free))
+	      ((virtual-continuation/reified? operator)
+	       (eq-set-union
+		(walk-rvalue (virtual-continuation/reification operator))
+		free))
+	      (else free)))))
+    ((ASSIGNMENT)
+     (walk-next
+      (snode-next node)
+      (eq-set-union (walk-lvalue (assignment-lvalue node))
+		    (walk-rvalue (assignment-rvalue node)))))
+    ((DEFINITION)
+     (walk-next
+      (snode-next node)
+      (eq-set-union (walk-lvalue (definition-lvalue node))
+		    (walk-rvalue (definition-rvalue node)))))
+    ((TRUE-TEST)
+     (walk-next (pnode-consequent node)
+		(walk-next (pnode-alternative node)
+			   (walk-rvalue (true-test-rvalue node)))))
+    ((FG-NOOP)
+     (walk-next (snode-next node) '()))))
+
+(define (map-union procedure items)
+  (let loop ((items items) (set '()))
+    (if (null? items)
+	set
+	(loop (cdr items)
+	      (eq-set-union (procedure (car items)) set)))))
+
+(define (walk-rvalue rvalue)
+  (enumeration-case rvalue-type (tagged-vector/index rvalue)
+    ((REFERENCE) (walk-lvalue (reference-lvalue rvalue)))
+    ((PROCEDURE)
+     (if (procedure-continuation? rvalue)
+	 (walk-next (continuation/entry-node rvalue) '())
+	 (list-transform-negative
+	     (block-free-variables (procedure-block rvalue))
+	   lvalue-integrated?)))
+    (else '())))
+
+(define (walk-lvalue lvalue)
+  (let ((value (lvalue-known-value lvalue)))
+    (cond ((not value) (list lvalue))
+	  ((lvalue-integrated? lvalue) (walk-rvalue value))
+	  (else (eq-set-adjoin lvalue (walk-rvalue value))))))
\ No newline at end of file
diff --git a/v7/src/compiler/rtlgen/fndvar.scm b/v7/src/compiler/rtlgen/fndvar.scm
new file mode 100644
index 000000000..bfff64ea7
--- /dev/null
+++ b/v7/src/compiler/rtlgen/fndvar.scm
@@ -0,0 +1,173 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.1 1988/12/12 21:33:15 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; RTL Generation: Variable Locatives
+
+(declare (usual-integrations))
+
+(define (find-variable context variable if-compiler if-ic if-cached)
+  (if (variable/value-variable? variable)
+      (if-compiler
+       (let ((continuation (reference-context/procedure context)))
+	 (if (continuation/ever-known-operator? continuation)
+	     (continuation/register continuation)
+	     register:value)))
+      (find-variable-internal context variable
+	(lambda (locative)
+	  (if-compiler
+	   (if (variable-in-cell? variable)
+	       (rtl:make-fetch locative)
+	       locative)))
+	(lambda (block locative)
+	  (cond ((variable-in-known-location? context variable)
+		 (if-compiler
+		  (rtl:locative-offset locative
+				       (variable-offset block variable))))
+		((ic-block/use-lookup? block)
+		 (if-ic locative (variable-name variable)))
+		(else
+		 (if-cached (variable-name variable))))))))
+
+(define (find-known-variable context variable)
+  (find-variable context variable identity-procedure
+    (lambda (environment name)
+      environment
+      (error "Known variable found in IC frame" name))
+    (lambda (name)
+      (error "Known variable found in IC frame" name))))
+
+(define (find-closure-variable context variable)
+  (find-variable-internal context variable
+    identity-procedure
+    (lambda (block locative)
+      block locative
+      (error "Closure variable in IC frame" variable))))
+
+(define (find-variable-internal context variable if-compiler if-ic)
+  (let ((rvalue (lvalue-known-value variable)))
+    (if (and rvalue
+	     (rvalue/procedure? rvalue)
+	     (procedure/closure? rvalue)
+	     (block-ancestor-or-self? (reference-context/block context)
+				      (procedure-block rvalue)))
+	(begin
+	  ;; This is just for paranoia.
+	  (if (procedure/trivial-closure? rvalue)
+	      (error "Trivial closure value encountered"))
+	  (if-compiler
+	   (block-ancestor-or-self->locative
+	    context
+	    (procedure-block rvalue)
+	    0
+	    (procedure-closure-offset rvalue))))
+	(find-block/variable context variable
+	  (lambda (offset-locative)
+	    (lambda (block locative)
+	      (if-compiler
+	       (offset-locative locative (variable-offset block variable)))))
+	  if-ic))))
+
+(define (find-definition-variable context lvalue)
+  (find-block/variable context lvalue
+    (lambda (offset-locative)
+      offset-locative
+      (lambda (block locative)
+	block locative
+	(error "Definition of compiled variable" lvalue)))
+    (lambda (block locative)
+      block
+      (values locative (variable-name lvalue)))))
+
+(define (find-block/variable context variable if-known if-ic)
+  (with-values
+      (lambda ()
+	(find-block context
+		    0
+		    (lambda (block)
+		      (if (not block)
+			  (error "Unable to find variable" variable))
+		      (or (memq variable (block-bound-variables block))
+			  (and (not (block-parent block))
+			       (memq variable
+				     (block-free-variables block)))))))
+    (lambda (block locative)
+      ((enumeration-case block-type (block-type block)
+	 ((STACK) (if-known stack-locative-offset))
+	 ((CLOSURE) (if-known rtl:locative-offset))
+	 ((IC) if-ic)
+	 (else (error "Illegal result type" block)))
+       block locative))))
+
+(define (nearest-ic-block-expression context)
+  (with-values
+      (lambda ()
+	(find-block context 0 (lambda (block) (not (block-parent block)))))
+    (lambda (block locative)
+      (if (not (ic-block? block))
+	  (error "NEAREST-IC-BLOCK-EXPRESSION: No IC block"))
+      locative)))
+
+(define (closure-ic-locative context block)
+  (with-values
+      (lambda ()
+	(find-block context 0 (lambda (block*) (eq? block* block))))
+    (lambda (block locative)
+      (if (not (ic-block? block))
+	  (error "Closure parent not IC block"))
+      locative)))
+
+(define (block-ancestor-or-self->locative context block prefix suffix)
+  (stack-locative-offset
+   (with-values
+       (lambda ()
+	 (find-block context prefix (lambda (block*) (eq? block* block))))
+     (lambda (block* locative)
+       (if (not (eq? block* block))
+	   (error "Block is not an ancestor" context block))
+       locative))
+   suffix))
+
+(define (popping-limit/locative context block prefix suffix)
+  (rtl:make-address
+   (block-ancestor-or-self->locative context
+				     block
+				     prefix
+				     (+ (block-frame-size block) suffix))))
+
+(define (block-closure-locative context)
+  ;; BLOCK must be the invocation block of a closure.
+  (stack-locative-offset
+   (rtl:make-fetch register:stack-pointer)
+   (+ (procedure-closure-offset (reference-context/procedure context))
+      (reference-context/offset context))))
\ No newline at end of file
-- 
2.25.1