--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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)))))
+\f
+(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)))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+(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))))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; 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))))))))
+\f
+;;;; 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)))))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff