From 449ac41e4b90c1a8a7a274be48058069c6eb347e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 9 Jun 1987 19:56:56 +0000
Subject: [PATCH] Initial revision

---
 v7/src/compiler/fgopt/folcon.scm | 136 +++++++++++++++
 v7/src/compiler/fgopt/outer.scm  | 146 ++++++++++++++++
 v7/src/compiler/fgopt/simapp.scm | 144 ++++++++++++++++
 v7/src/compiler/rtlopt/rcse2.scm | 275 +++++++++++++++++++++++++++++++
 4 files changed, 701 insertions(+)
 create mode 100644 v7/src/compiler/fgopt/folcon.scm
 create mode 100644 v7/src/compiler/fgopt/outer.scm
 create mode 100644 v7/src/compiler/fgopt/simapp.scm
 create mode 100644 v7/src/compiler/rtlopt/rcse2.scm

diff --git a/v7/src/compiler/fgopt/folcon.scm b/v7/src/compiler/fgopt/folcon.scm
new file mode 100644
index 000000000..fafbed6f9
--- /dev/null
+++ b/v7/src/compiler/fgopt/folcon.scm
@@ -0,0 +1,136 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 1.1 1987/06/09 19:53:48 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. |#
+
+;;;; Dataflow Analysis: Constant Folding
+
+(declare (usual-integrations))
+
+(package (fold-constants)
+
+;;;; Fold constants
+
+(define-export (fold-constants vnodes combinations receiver)
+  (define (loop vnodes combinations)
+    (let ((unknown-vnodes (eliminate-known-nodes vnodes)))
+      (fold-combinations combinations
+	(lambda (any-folded? not-folded)
+	  (if any-folded?
+	      (loop unknown-vnodes not-folded)
+	      (receiver unknown-vnodes not-folded))))))
+  (loop vnodes combinations))
+
+(define (eliminate-known-nodes vnodes)
+  (let ((knowable-nodes
+	 (list-transform-positive vnodes
+	   (lambda (vnode)
+	     (and (not (or (vnode-unknowable? vnode)
+			   ;; Does this really matter?  Seems like it
+			   ;; should be a noop if there is only one
+			   ;; value.
+			   (and (variable? vnode)
+				(variable-assigned? vnode))))
+		  (let ((procedures (vnode-procedures vnode))
+			(values (vnode-values vnode)))
+		    (if (null? values)
+			(and (not (null? procedures))
+			     (null? (cdr procedures)))
+			(and (null? procedures)
+			     (null? (cdr values))
+			     (let ((value (car values)))
+			       (or (block? value)
+				   (and (constant? value)
+					(object-immutable?
+					 (constant-value value)))))))))))))
+    (for-each vnode-knowable! knowable-nodes)
+    (transitive-closure delete-if-known! knowable-nodes))
+  ;; **** Could flush KNOWABLE? and UNKNOWABLE? marks at this point.
+  (list-transform-negative vnodes vnode-known?))
+
+(define (delete-if-known! vnode)
+  (if (and (not (vnode-known? vnode))
+	   (null? (vnode-backward-links vnode)))
+      (let ((value (car (if (null? (vnode-procedures vnode))
+			    (vnode-values vnode)
+			    (vnode-procedures vnode))))
+	    (forward-links (vnode-forward-links vnode)))
+	(vnode-delete! vnode)
+	(for-each (lambda (vnode*)
+		    ;; This is needed because, previously, VNODE*
+		    ;; inherited this value from VNODE.
+		    (vnode-connect! vnode* value)
+		    (if (vnode-knowable? vnode*)
+			(enqueue-node! vnode*)))
+		  forward-links)
+	(set-vnode-known-value! vnode value))))
+
+(define (fold-combinations combinations receiver)
+  (if (null? combinations)
+      (receiver false '())
+      (fold-combinations (cdr combinations)
+	(lambda (any-folded? not-folded)
+	  (if (fold-combination (car combinations))
+	      (receiver true not-folded)
+	      (receiver any-folded? (cons (car combinations) not-folded)))))))
+
+(define (fold-combination combination)
+  (let ((operator (combination-operator combination))
+	(operands (combination-operands combination)))
+    (and (subproblem-known-constant? operator)
+	 (all-known-constants? operands)
+	 (let ((operator (subproblem-constant-value operator)))
+	   (and (operator-constant-foldable? operator)
+		(begin (let ((value
+			      (make-constant
+			       (apply operator
+				      (map subproblem-constant-value
+					   operands))))
+			     (cvalue (combination-value combination)))
+			 (vnode-known! cvalue value)
+			 (set-vnode-known-value! cvalue value))
+		       (set-combination-constant?! combination true)
+		       ;; Discard useless information to save space.
+		       (let ((block (combination-block combination)))
+			 (set-block-combinations!
+			  block
+			  (delq! combination (block-combinations block))))
+		       (set-combination-operator! combination false)
+		       (set-combination-operands! combination '())
+		       (set-combination-procedures! combination '())
+		       (set-combination-known-operator! combination false)
+		       true))))))
+
+(define all-known-constants?
+  (for-all? subproblem-known-constant?))
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/outer.scm b/v7/src/compiler/fgopt/outer.scm
new file mode 100644
index 000000000..d4ea406b7
--- /dev/null
+++ b/v7/src/compiler/fgopt/outer.scm
@@ -0,0 +1,146 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 1.1 1987/06/09 19:53:18 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. |#
+
+;;;; Dataflow Analysis: Outer Analysis
+
+(declare (usual-integrations))
+
+(package (outer-analysis)
+
+;;;; Outer analysis
+
+;;; When this pass is completed, any combination which is known to
+;;; call only known procedures contains all of the procedural
+;;; arguments in its COMBINATION-PROCEDURES slot.  This is taken
+;;; advantage of by the closure analysis.
+
+(define more-unknowable-vnodes?)
+
+(define-export (outer-analysis blocks vnodes combinations procedures
+			       quotations)
+  (fluid-let ((more-unknowable-vnodes? false))
+    (define (loop)
+      (if more-unknowable-vnodes?
+	  (begin (set! more-unknowable-vnodes? false)
+		 (for-each check-combination combinations)
+		 (loop))))
+    (for-each analyze-block blocks)
+    ;; Don't bother to analyze ACCESSes now.
+    (for-each (lambda (vnode)
+		(if (access? vnode) (make-vnode-unknowable! vnode)))
+	      vnodes)
+    (for-each (lambda (quotation)
+		(let ((value (quotation-value quotation)))
+		  (if (vnode? value)
+		      (for-each make-procedure-externally-visible!
+				(vnode-procedures value)))))
+	      quotations)
+    (for-each prepare-combination combinations)
+    (loop)))
+
+(define (analyze-block block)
+  (if (ic-block? block)
+      (begin (if (block-outer? block)
+		 (for-each make-vnode-externally-visible!
+			   (block-free-variables block)))
+	     (for-each make-vnode-externally-visible!
+		       (block-bound-variables block)))))
+
+(define (prepare-combination combination)
+  (set-combination-procedures!
+   combination
+   (mapcan (lambda (operand)
+	     (list-copy (subproblem-procedures operand)))
+	   (combination-operands combination)))
+  (if (not (null? (subproblem-values (combination-operator combination))))
+      (begin (combination-operator-unknowable! combination)
+	     (make-vnode-unknowable! (combination-value combination)))))
+
+(define any-primitives?
+  (there-exists? primitive-procedure-constant?))
+
+(define (check-combination combination)
+  (if (subproblem-unknowable? (combination-operator combination))
+      (begin (combination-operator-unknowable! combination)
+	     (make-vnode-unknowable! (combination-value combination))))
+  (if (any-unknowable-subproblems? (combination-operands combination))
+      (make-vnode-unknowable! (combination-value combination))))
+
+(define any-unknowable-subproblems?
+  (there-exists? subproblem-unknowable?))
+
+(define (combination-operator-unknowable! combination)
+  (let ((procedures (combination-procedures combination)))
+    (set-combination-procedures! combination '())
+    (for-each make-procedure-externally-visible! procedures)))
+
+(define (make-vnode-externally-visible! vnode)
+  (if (not (vnode-externally-visible? vnode))
+      (begin (set! more-unknowable-vnodes? true)
+	     (vnode-externally-visible! vnode)
+	     (vnode-unknowable! vnode)
+	     (make-vnode-forward-links-unknowable! vnode)
+	     (for-each make-procedure-externally-visible!
+		       (vnode-procedures vnode)))))
+
+(define (make-procedure-externally-visible! procedure)
+  (if (not (procedure-externally-visible? procedure))
+      (begin (procedure-externally-visible! procedure)
+	     (closure-procedure! procedure)
+	     (for-each make-vnode-unknowable! (procedure-required procedure))
+	     (for-each make-vnode-unknowable! (procedure-optional procedure))
+	     (if (procedure-rest procedure)
+		 ;; This is not really unknowable -- it is a list
+		 ;; whose length and elements are unknowable.
+		 (make-vnode-unknowable! (procedure-rest procedure)))
+	     (for-each make-procedure-externally-visible!
+		       (rvalue-procedures (procedure-value procedure))))))
+
+(define (make-vnode-unknowable! vnode)
+  (if (not (vnode-unknowable? vnode))
+      (begin (set! more-unknowable-vnodes? true)
+	     (vnode-unknowable! vnode)
+	     (make-vnode-forward-links-unknowable! vnode))))
+
+(define (make-vnode-forward-links-unknowable! vnode)
+  ;; No recursion is needed here because the graph is transitively
+  ;; closed, and thus the forward links of a node's forward links are
+  ;; a subset of the node's forward links.
+  (for-each (lambda (vnode)
+	      (if (not (vnode-unknowable? vnode))
+		  (begin (set! more-unknowable-vnodes? true)
+			 (vnode-unknowable! vnode))))
+	    (vnode-forward-links vnode)))
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/simapp.scm b/v7/src/compiler/fgopt/simapp.scm
new file mode 100644
index 000000000..7079b6bca
--- /dev/null
+++ b/v7/src/compiler/fgopt/simapp.scm
@@ -0,0 +1,144 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 1.1 1987/06/09 19:52:58 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. |#
+
+;;;; Dataflow Analysis: Simulate Application
+
+(declare (usual-integrations))
+
+(package (simulate-application)
+
+;;;; Simulate Application
+
+(define-export (simulate-application vnodes combinations)
+  (for-each (lambda (vnode)
+	      (set-vnode-procedures-cache! vnode
+					   (vnode-initial-procedures vnode)))
+	    vnodes)
+  (for-each (lambda (combination)
+	      (set-combination-procedures! combination '()))
+	    combinations)
+  (transitive-closure process-combination combinations)
+  (for-each (lambda (vnode)
+	      (set-vnode-procedures-cache! vnode 'NOT-CACHED))
+	    vnodes))
+
+(define (process-combination combination)
+  (set-combination-procedures!
+   combination
+   (let ((operator (subproblem-value (combination-operator combination)))
+	 (old (combination-procedures combination))
+	 (apply-procedure
+	  (procedure-applicator (combination-operands combination)
+				(combination-value combination))))
+     (define (process-vnode vnode)
+       (let ((new (vnode-procedures-cache vnode)))
+	 (define (loop procedures)
+	   ;; We can use `eq?' here because we assume that
+	   ;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
+	   ;; This is also noted at the definition of `eq-set-union'.
+	   (if (eq? procedures old)
+	       new
+	       (begin (apply-procedure (car procedures))
+		      (loop (cdr procedures)))))
+	 (loop new)))
+     (cond ((vnode? operator)
+	    (process-vnode operator))
+	   ((reference? operator)
+	    (process-vnode (reference-variable operator)))
+	   ((not (null? old))
+	    (error "Encountered constant-operator combination twice"
+		   combination))
+	   (else
+	    (if (procedure? operator)
+		(apply-procedure operator))
+	    true)))))
+
+(define (procedure-applicator operands combination-value)
+  (let ((number-supplied (length operands)))
+    (lambda (procedure)
+      (let ((number-required (length (procedure-required procedure)))
+	    (number-optional (length (procedure-optional procedure)))
+	    (rest (procedure-rest procedure)))
+	(cond ((< number-supplied number-required)
+	       (warn "Too few arguments" procedure operands))
+	      (rest
+	       (if (<= number-supplied (+ number-required number-optional))
+		   ((vnode-connect!:constant (make-constant '())) rest)
+		   ;; Can make this a LIST rvalue when that is implemented.
+		   (vnode-unknowable! rest)))
+	      ((> number-supplied (+ number-required number-optional))
+	       (warn "Too many arguments" procedure operands))))
+      (for-each vnode-connect!
+		(append (procedure-required procedure)
+			(procedure-optional procedure))
+		operands)
+      ((vnode-connect!:vnode (procedure-value procedure)) combination-value))))
+
+(define-integrable (vnode-connect! vnode operand)
+  ((&vnode-connect! (subproblem-value operand)) vnode))
+
+(define ((vnode-connect!:procedure procedure) vnode)
+  (let ((procedures (vnode-initial-procedures vnode)))
+    (if (not (memq procedure procedures))
+	(set-vnode-initial-procedures! vnode (cons procedure procedures))))
+  (let ((procedures (vnode-procedures-cache vnode)))
+    (if (not (memq procedure procedures))
+	(begin (enqueue-nodes! (vnode-combinations vnode))
+	       (set-vnode-procedures-cache! vnode
+					    (cons procedure procedures))))))
+
+(define (vnode-connect!:vnode from)
+  (define (self to)
+    (if (not (memq from (vnode-backward-links to)))
+	(begin (enqueue-nodes! (vnode-combinations to))
+	       (set-vnode-backward-links! to
+					  (cons from
+						(vnode-backward-links to)))
+	       (set-vnode-forward-links! from
+					 (cons to (vnode-forward-links from)))
+	       (set-vnode-procedures-cache!
+		to
+		(eq-set-union (vnode-procedures-cache from)
+			      (vnode-procedures-cache to)))
+	       (for-each (lambda (backward)
+			   ((vnode-connect!:vnode backward) to))
+			 (vnode-backward-links from))
+	       (for-each self (vnode-forward-links to)))))
+  self)
+
+(define &vnode-connect!
+  (standard-rvalue-operation vnode-connect!:constant vnode-connect!:procedure
+			     vnode-connect!:vnode))
+
+)
\ No newline at end of file
diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm
new file mode 100644
index 000000000..cd0459728
--- /dev/null
+++ b/v7/src/compiler/rtlopt/rcse2.scm
@@ -0,0 +1,275 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 1.1 1987/06/09 19:56:56 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. |#
+
+;;;; RTL Common Subexpression Elimination
+;;;  Based on the GNU C Compiler
+
+(declare (usual-integrations))
+
+;;;; Canonicalization
+
+(define (expression-replace! statement-expression set-statement-expression!
+			     statement receiver)
+  ;; Replace the expression by its cheapest equivalent.  Returns two
+  ;; values: (1) a flag which is true iff the expression is volatile;
+  ;; and (2) a thunk which, when called, will insert the expression in
+  ;; the hash table, returning the element.  Do not call the thunk if
+  ;; the expression is volatile.
+  (let ((expression
+	 (expression-canonicalize (statement-expression statement))))
+    (full-expression-hash expression
+      (lambda (hash volatile? in-memory?)
+	(let ((element
+	       (find-cheapest-valid-element expression hash volatile?)))
+	  (define (finish expression hash volatile? in-memory?)
+	    (set-statement-expression! statement expression)
+	    (receiver
+	     volatile?
+	     (expression-inserter expression element hash in-memory?)))
+	  (if element
+	      (let ((expression (element-expression element)))
+		(full-expression-hash expression
+		  (lambda (hash volatile? in-memory?)
+		    (finish expression hash volatile? in-memory?))))
+	      (finish expression hash volatile? in-memory?)))))))
+
+(define ((expression-inserter expression element hash in-memory?))
+  (or element
+      (begin (if (rtl:register? expression)
+		 (set-register-expression! (rtl:register-number expression)
+					   expression)
+		 (mention-registers! expression))
+	     (let ((element* (hash-table-insert! hash expression false)))
+	       (set-element-in-memory?! element* in-memory?)
+	       (element-first-value element*)))))
+
+(define (expression-canonicalize expression)
+  (if (rtl:register? expression)
+      (or (register-expression
+	   (quantity-first-register
+	    (get-register-quantity (rtl:register-number expression))))
+	  expression)
+      (rtl:map-subexpressions expression expression-canonicalize)))
+
+;;;; Invalidation
+
+(define (non-object-invalidate!)
+  (hash-table-delete-class!
+   (lambda (element)
+     (memq (rtl:expression-type (element-expression element))
+	   '(OBJECT->ADDRESS OBJECT->DATUM OBJECT->TYPE)))))
+
+(define (element-address-varies? element)
+  (and (element-in-memory? element)
+       (expression-address-varies? (element-expression element))))
+
+(define (expression-address-varies? expression)
+  (if (memq (rtl:expression-type expression)
+	    '(OFFSET PRE-INCREMENT POST-INCREMENT))
+      (let ((expression (rtl:address-register expression)))
+	(not (or (= regnum:regs-pointer (rtl:register-number expression))
+		 (= regnum:frame-pointer (rtl:register-number expression)))))
+      (rtl:any-subexpression? expression expression-address-varies?)))
+
+(define (expression-invalidate! expression)
+  ;; Delete any expression which refers to this expression from the
+  ;; table.
+  (if (rtl:register? expression)
+      (register-expression-invalidate! expression)
+      (hash-table-delete-class!
+       (lambda (element)
+	 (expression-refers-to? (element-expression element) expression)))))
+
+(define-integrable (stack-pointer-invalidate!)
+  (register-expression-invalidate! (interpreter-stack-pointer)))
+
+(define (register-expression-invalidate! expression)
+  ;; Invalidate a register expression.  These expressions are handled
+  ;; specially for efficiency -- the register is marked invalid but we
+  ;; delay searching the hash table for relevant expressions.
+  (let ((hash (expression-hash expression)))
+    (register-invalidate! (rtl:register-number expression))
+    (hash-table-delete! hash (hash-table-lookup hash expression))))
+
+(define (register-invalidate! register)
+  (let ((next (register-next-equivalent register))
+	(previous (register-previous-equivalent register))
+	(quantity (get-register-quantity register)))
+    (set-register-tick! register (1+ (register-tick register)))
+    (if next
+	(set-register-previous-equivalent! next previous)
+	(set-quantity-last-register! quantity previous))
+    (if previous
+	(set-register-next-equivalent! previous next)
+	(set-quantity-first-register! quantity next))
+    (set-register-quantity! register (new-quantity register))
+    (set-register-next-equivalent! register false)
+    (set-register-previous-equivalent! register false)))
+
+;;;; Destination Insertion
+
+(define (insert-register-destination! expression element)
+  ;; Insert EXPRESSION, which should be a register expression, into
+  ;; the hash table as the destination of an assignment.  ELEMENT is
+  ;; the hash table element for the value being assigned to
+  ;; EXPRESSION.
+  (let ((class (element->class element))
+	(register (rtl:register-number expression)))
+    (define (register-equivalence! quantity)
+      (set-register-quantity! register quantity)
+      (let ((last (quantity-last-register quantity)))
+	(if last
+	    (begin (set-register-next-equivalent! last register)
+		   (set-register-previous-equivalent! register last))
+	    (begin (set-quantity-first-register! quantity register)
+		   (set-quantity-last-register! quantity register))))
+      (set-register-next-equivalent! register false)
+      (set-quantity-last-register! quantity register))
+
+    (set-register-expression! register expression)
+    (if class
+	(let ((expression (element-expression class)))
+	  (cond ((rtl:register? expression)
+		 (register-equivalence!
+		  (get-register-quantity (rtl:register-number expression)))))))
+    (set-element-in-memory?!
+     (hash-table-insert! (expression-hash expression) expression class)
+     false)))
+
+(define (insert-memory-destination! expression element hash)
+  (let ((class (element->class element)))
+    (mention-registers! expression)
+    (set-element-in-memory?! (hash-table-insert! hash expression class) true)))
+
+(define (mention-registers! expression)
+  (if (rtl:register? expression)
+      (let ((register (rtl:register-number expression)))
+	(remove-invalid-references! register)
+	(set-register-in-table! register (register-tick register)))
+      (rtl:for-each-subexpression expression mention-registers!)))
+
+(define (remove-invalid-references! register)
+  ;; If REGISTER is invalid, delete all expressions which refer to it
+  ;; from the hash table.
+  (if (let ((in-table (register-in-table register)))
+	(and (not (negative? in-table))
+	     (not (= in-table (register-tick register)))))
+      (let ((expression (register-expression register)))
+	(hash-table-delete-class!
+	 (lambda (element)
+	   (let ((expression* (element-expression element)))
+	     (and (not (rtl:register? expression*))
+		  (expression-refers-to? expression* expression))))))))
+
+;;;; Table Search
+
+(define (find-cheapest-expression expression hash volatile?)
+  ;; Find the cheapest equivalent expression for EXPRESSION.
+  (let ((element (find-cheapest-valid-element expression hash volatile?)))
+    (if element
+	(element-expression element)
+	expression)))
+
+(define (find-cheapest-valid-element expression hash volatile?)
+  ;; Find the cheapest valid hash table element for EXPRESSION.
+  ;; Returns false if no such element exists or if EXPRESSION is
+  ;; VOLATILE?.
+  (and (not volatile?)
+       (let ((element (hash-table-lookup hash expression)))
+	 (and element
+	      (let ((element* (element-first-value element)))
+		(if (eq? element element*)
+		    element
+		    (let loop ((element element*))
+		      (and element
+			   (let ((expression (element-expression element)))
+			     (if (or (rtl:register? expression)
+				     (expression-valid? expression))
+				 element
+				 (loop (element-next-value element))))))))))))
+
+(define (expression-valid? expression)
+  ;; True iff all registers mentioned in EXPRESSION have valid values
+  ;; in the hash table.
+  (if (rtl:register? expression)
+      (let ((register (rtl:register-number expression)))
+	(= (register-in-table register) (register-tick register)))
+      (rtl:all-subexpressions? expression expression-valid?)))
+
+(define (element->class element)
+  ;; Return the cheapest element in the hash table which has the same
+  ;; value as ELEMENT.  This is necessary because ELEMENT may have
+  ;; been deleted due to register or memory invalidation.
+  (and element
+       ;; If ELEMENT has been deleted from the hash table,
+       ;; CLASS will be false.  [ref crock-1]
+       (or (element-first-value element)
+	   (element->class (element-next-value element)))))
+
+;;;; Expression Hash
+
+(define (expression-hash expression)
+  (full-expression-hash expression
+    (lambda (hash do-not-record? hash-arg-in-memory?)
+      hash)))
+
+(define (full-expression-hash expression receiver)
+  (let ((do-not-record? false)
+	(hash-arg-in-memory? false))
+    (define (loop expression)
+      (let ((type (rtl:expression-type expression)))
+	(+ (symbol-hash type)
+	   (case type
+	     ((REGISTER)
+	      (quantity-number
+	       (get-register-quantity (rtl:register-number expression))))
+	     ((OFFSET)
+	      (set! hash-arg-in-memory? true)
+	      (continue expression))
+	     ((PRE-INCREMENT POST-INCREMENT)
+	      (set! hash-arg-in-memory? true)
+	      (set! do-not-record? true)
+	      0)
+	     (else (continue expression))))))
+
+    (define (continue expression)
+      (rtl:reduce-subparts expression + 0 loop
+	(lambda (object)
+	  (cond ((integer? object) object)
+		((symbol? object) (symbol-hash object))
+		((string? object) (string-hash object))
+		(else (hash object))))))
+
+    (let ((hash (loop expression)))
+      (receiver (modulo hash n-buckets) do-not-record? hash-arg-in-memory?))))
\ No newline at end of file
-- 
2.25.1