#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.10 1988/06/14 08:44:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.11 1988/08/11 20:10:34 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; RTL Common Subexpression Elimination
+;;;; RTL Common Subexpression Elimination: Codewalker
;;; Based on the GNU C Compiler
(declare (usual-integrations))
(*next-quantity-number* 0)
(*initial-queue* (make-queue))
(*branch-queue* '()))
- (for-each (lambda (edge) (enqueue! *initial-queue* (edge-right-node edge)))
+ (for-each (lambda (edge)
+ (enqueue!/unsafe *initial-queue* (edge-right-node edge)))
(rgraph-initial-edges rgraph))
(fluid-let ((*register-tables*
(register-tables/make (rgraph-n-registers rgraph)))
(register-tables/reset! *register-tables*)
(set! *hash-table* (make-hash-table))
(set! *stack-offset* 0)
- (set! *stack-reference-quantities* '()))
+ (set! *stack-reference-quantities* '())
+ unspecific)
(define (state/get)
(make-state (register-tables/copy *register-tables*)
(list-copy *stack-reference-quantities*)))
\f
(define (walk-bblock bblock)
- (define (loop rinst)
+ (let loop ((rinst (bblock-instructions bblock)))
(let ((rtl (rinst-rtl rinst)))
((if (eq? (rtl:expression-type rtl) 'ASSIGN)
cse/assign
- (cdr (or (assq (rtl:expression-type rtl) cse-methods)
- (error "Missing CSE method" (car rtl)))))
+ (let ((entry (assq (rtl:expression-type rtl) cse-methods)))
+ (if (not entry)
+ (error "Missing CSE method" (rtl:expression-type rtl)))
+ (cdr entry)))
rtl))
(if (rinst-next rinst)
(loop (rinst-next rinst))))
- (loop (bblock-instructions bblock))
(node-mark! bblock)
(if (sblock? bblock)
(let ((next (snode-next bblock)))
(walk-next alternative)
(continue-walk))))))
-(define (walk-next? bblock)
+(define-integrable (walk-next? bblock)
(and bblock (not (node-marked? bblock))))
-(define (walk-next bblock)
+(define-integrable (walk-next bblock)
(if (node-previous>1? bblock) (state/reset!))
(walk-bblock bblock))
hash
insert-source!
memory-invalidate!)))))
-\f
(else
(let ((address (expression-canonicalize address)))
(rtl:set-assign-address! statement address)
(hash-table-delete!
hash
(hash-table-lookup hash address))
- (hash-table-delete-class!
- element-address-varies?))))))
+ (varying-address-invalidate!))))))
(if (or volatile? volatile?*)
(memory-invalidate!)
(assignment-memory-insertion address
memory-invalidate!)))))
(notice-push/pop! address)))))
(notice-push/pop! (rtl:assign-expression statement)))))
-
+\f
(define (notice-push/pop! expression)
;; **** Kludge. Works only because stack-pointer
;; gets used in very fixed way by code generator.
rtl:eq-test-expression-1 rtl:set-eq-test-expression-1!
rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!)
+(define-trivial-one-arg-method 'FIXNUM-PRED-1-ARG
+ rtl:fixnum-pred-1-arg-operand rtl:set-fixnum-pred-1-arg-operand!)
+
(define-trivial-two-arg-method 'FIXNUM-PRED-2-ARGS
rtl:fixnum-pred-2-args-operand-1 rtl:set-fixnum-pred-2-args-operand-1!
rtl:fixnum-pred-2-args-operand-2 rtl:set-fixnum-pred-2-args-operand-2!)
(define-trivial-one-arg-method 'TRUE-TEST
rtl:true-test-expression rtl:set-true-test-expression!)
-(define-trivial-one-arg-method 'FIXNUM-PRED-1-ARG
- rtl:fixnum-pred-1-arg-operand rtl:set-fixnum-pred-1-arg-operand!)
-
(define-trivial-one-arg-method 'TYPE-TEST
rtl:type-test-expression rtl:set-type-test-expression!)
\f
(define (method/noop statement)
statement
- 'DONE)
+ unspecific)
(define-cse-method 'POP-RETURN method/noop)
(define-cse-method 'INVOCATION:PRIMITIVE method/noop)
(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop)
-(define-cse-method 'INVOCATION:CACHE-REFERENCE
- (lambda (statement)
- (expression-replace! rtl:invocation:cache-reference-name
- rtl:set-invocation:cache-reference-name!
- statement
- trivial-action)))
-
-(define-cse-method 'INVOCATION:LOOKUP
- (lambda (statement)
- (expression-replace! rtl:invocation:lookup-environment
- rtl:set-invocation:lookup-environment!
- statement
- trivial-action)))
+(define-trivial-one-arg-method 'INVOCATION:CACHE-REFERENCE
+ rtl:invocation:cache-reference-name rtl:set-invocation:cache-reference-name!)
+(define-trivial-one-arg-method 'INVOCATION:LOOKUP
+ rtl:invocation:lookup-environment rtl:set-invocation:lookup-environment!)
(define-cse-method 'CONS-CLOSURE
(lambda (statement)
statement
(expression-invalidate! (interpreter-register:enclose))))
-\f
+
(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
(lambda (statement)
(expression-replace! rtl:invocation-prefix:move-frame-up-locative
rtl:interpreter-call:unbound?-environment
rtl:set-interpreter-call:unbound?-environment!
interpreter-register:unbound?)
-\f
+
(define (define-assignment-method type
get-environment set-environment!
get-value set-value!)
(expression-replace! get-value set-value! statement trivial-action)
(expression-replace! get-environment set-environment! statement
(lambda (volatile? insert-source!)
- (hash-table-delete-class! element-address-varies?)
+ (varying-address-invalidate!)
(non-object-invalidate!)
(if (not volatile?) (insert-source!)))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.8 1988/06/14 08:44:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.9 1988/08/11 20:10:45 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(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?)))))))
+ (let ((finish
+ (lambda (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
(else
(rtl:map-subexpressions expression expression-canonicalize))))
\f
-;;;; Invalidation
+;;;; Hash
-(define (non-object-invalidate!)
- (hash-table-delete-class!
- (lambda (element)
- (let ((expression (element-expression element)))
- (if (rtl:register? expression)
- (or (register-contains-address? (rtl:register-number expression))
- (register-contains-fixnum? (rtl:register-number expression)))
- (memq (rtl:expression-type expression)
- '(OBJECT->ADDRESS OBJECT->DATUM
- OBJECT->TYPE
- OBJECT->FIXNUM
- CHAR->ASCII
- OFFSET-ADDRESS
- VARIABLE-CACHE
- ASSIGNMENT-CACHE)))))))
+(define (expression-hash expression)
+ (full-expression-hash expression
+ (lambda (hash do-not-record? hash-arg-in-memory?)
+ do-not-record? hash-arg-in-memory?
+ hash)))
-(define (element-address-varies? element)
- (and (element-in-memory? element)
- (expression-address-varies? (element-expression element))))
+(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)
+ ;; Note that stack-references do not get treated as
+ ;; memory for purposes of invalidation. This is because
+ ;; (supposedly) no one ever accesses the stack directly
+ ;; except the compiler's output, which is explicit.
+ (if (interpreter-stack-pointer? (rtl:offset-register expression))
+ (quantity-number (stack-reference-quantity expression))
+ (begin (set! hash-arg-in-memory? true)
+ (continue expression))))
+ ((BYTE-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 (expression-address-varies? expression)
- (and (not (interpreter-register-reference? expression))
- (or (memq (rtl:expression-type expression)
- '(OFFSET BYTE-OFFSET PRE-INCREMENT POST-INCREMENT)))
- (rtl:any-subexpression? expression expression-address-varies?)))
+ (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))))))
-(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)))))
+ (let ((hash (loop expression)))
+ (receiver (modulo hash (hash-table-size))
+ do-not-record?
+ hash-arg-in-memory?))))
+\f
+;;;; Table Search
-(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 (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 (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)))
+(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,
+ ;; `element-first-value' will be false. [ref crock-1]
+ (or (element-first-value element)
+ (element->class (element-next-value element)))))
\f
-;;;; Destination Insertion
+;;;; Insertion
(define (insert-register-destination! expression element)
;; Insert EXPRESSION, which should be a register expression, into
;; 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)))
+ (let ((expression (element-expression class))
+ (register-equivalence!
+ (lambda (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))))
(cond ((rtl:register? expression)
(register-equivalence!
(get-register-quantity (rtl:register-number expression))))
(stack-reference-quantity expression))))))
(set-element-in-memory?!
(hash-table-insert! (expression-hash expression) expression class)
- false)))
-\f
+ false))
+ unspecific)
+
(define (insert-stack-destination! expression element)
(set-element-in-memory?! (hash-table-insert! (expression-hash expression)
expression
(element->class element))
- false))
+ false)
+ unspecific)
(define (insert-memory-destination! expression element hash)
(let ((class (element->class element)))
;; In that case, there is no need to make an element at all.
(if (or class hash)
(set-element-in-memory?! (hash-table-insert! hash expression class)
- true))))
+ true)))
+ unspecific)
(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!)))
+ (rtl:for-each-subexpression expression mention-registers!))
+ unspecific)
(define (remove-invalid-references! register)
- ;; If REGISTER is invalid, delete all expressions which refer to it
- ;; from the hash table.
+ ;; If REGISTER is invalid, delete from the hash table all
+ ;; expressions which refer to it.
(if (let ((in-table (register-in-table register)))
(and (not (negative? in-table))
(not (= in-table (register-tick register)))))
(lambda (element)
(let ((expression* (element-expression element)))
(and (not (rtl:register? expression*))
- (expression-refers-to? expression* expression))))))))
+ (expression-refers-to? expression* expression)))))))
+ unspecific)
\f
-;;;; Table Search
+;;;; Invalidation
-(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 (non-object-invalidate!)
+ (hash-table-delete-class!
+ (lambda (element)
+ (expression-non-object? (element-expression element)))))
-(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 (varying-address-invalidate!)
+ (hash-table-delete-class!
+ (lambda (element)
+ (and (element-in-memory? element)
+ (expression-address-varies? (element-expression element))))))
-(define (expression-valid? expression)
- ;; True iff all registers mentioned in EXPRESSION have valid values
- ;; in the hash table.
+(define (expression-invalidate! expression)
+ ;; Delete from the table any expression which refers to this
+ ;; expression.
(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?)
- 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)
- ;; Note that stack-references do not get treated as
- ;; memory for purposes of invalidation. This is because
- ;; (supposedly) no one ever accesses the stack directly
- ;; except the compiler's output, which is explicit.
- (if (interpreter-stack-pointer? (rtl:offset-register expression))
- (quantity-number (stack-reference-quantity expression))
- (begin (set! hash-arg-in-memory? true)
- (continue expression))))
- ((BYTE-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))))))
+ (register-expression-invalidate! expression)
+ (hash-table-delete-class!
+ (lambda (element)
+ (expression-refers-to? (element-expression element) expression)))))
- (let ((hash (loop expression)))
- (receiver (modulo hash (hash-table-size))
- do-not-record?
- hash-arg-in-memory?))))
\ No newline at end of file
+(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))
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.4 1988/06/14 08:44:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.5 1988/08/11 20:11:06 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(previous-hash false)
(next-value false)
(previous-value false)
- (first-value false)
- (copy-cache false))
+ (first-value false))
(set-type-object-description!
element
(ELEMENT-PREVIOUS-HASH ,(element-previous-hash element))
(ELEMENT-NEXT-VALUE ,(element-next-value element))
(ELEMENT-PREVIOUS-VALUE ,(element-previous-value element))
- (ELEMENT-FIRST-VALUE ,(element-first-value element))
- (ELEMENT-COPY-CACHE ,(element-copy-cache element)))))
+ (ELEMENT-FIRST-VALUE ,(element-first-value element)))))
\f
(define (hash-table-lookup hash expression)
- (define (loop element)
+ (let loop ((element (hash-table-ref hash)))
(and element
(if (let ((expression* (element-expression element)))
(or (eq? expression expression*)
(expression-equivalent? expression expression* true)))
element
- (loop (element-next-hash element)))))
- (loop (hash-table-ref hash)))
+ (loop (element-next-hash element))))))
(define (hash-table-insert! hash expression class)
(let ((element (make-element expression))
(if next (set-element-previous-hash! next previous))
(if previous
(set-element-next-hash! previous next)
- (hash-table-set! hash next))))))
+ (hash-table-set! hash next)))))
+ unspecific)
(define (hash-table-delete-class! predicate)
(let table-loop ((i 0))
(begin (if (predicate element)
(hash-table-delete! i element))
(bucket-loop (element-next-hash element)))
- (table-loop (1+ i)))))))
+ (table-loop (1+ i))))))
+ unspecific)
\f
-(define hash-table-copy
- (let ()
- (define (copy-loop elements)
- (define (per-element element previous)
- (and element
- (let ((element*
- (%make-element (element-expression element)
- (element-cost element)
- (element-in-memory? element)
- (per-element (element-next-hash element)
- element)
- previous
- (element-next-value element)
- (element-previous-value element)
- (element-first-value element)
- element)))
- (set-element-copy-cache! element element*)
- element*)))
- (if (null? elements)
- '()
- (cons (per-element (car elements) false)
- (copy-loop (cdr elements)))))
-
- (define (update-values! elements)
- (define (per-element element)
- (if element
- (begin (if (element-first-value element)
- (set-element-first-value!
- element
- (element-copy-cache (element-first-value element))))
- (if (element-previous-value element)
- (set-element-previous-value!
- element
- (element-copy-cache (element-previous-value element))))
- (if (element-next-value element)
- (set-element-next-value!
- element
- (element-copy-cache (element-next-value element))))
- (per-element (element-next-hash element)))))
- (if (not (null? elements))
- (begin (per-element (car elements))
- (update-values! (cdr elements)))))
-
- (define (reset-caches! elements)
- (define (per-element element)
- (if element
- (begin (set-element-copy-cache! element false)
- (per-element (element-next-hash element)))))
- (if (not (null? elements))
- (begin (per-element (car elements))
- (reset-caches! (cdr elements)))))
-
- (named-lambda (hash-table-copy table)
- (let ((elements (vector->list table)))
- (let ((elements* (copy-loop elements)))
- (update-values! elements*)
- (reset-caches! elements)
- (list->vector elements*))))))
\ No newline at end of file
+(define (hash-table-copy table)
+ ;; During this procedure, the `element-cost' slots of `table' are
+ ;; reused as "broken hearts".
+ (let ((elements (vector->list table)))
+ (let ((elements*
+ (map (lambda (element)
+ (let per-element ((element element) (previous false))
+ (and element
+ (let ((element*
+ (%make-element
+ (element-expression element)
+ (element-cost element)
+ (element-in-memory? element)
+ (per-element (element-next-hash element)
+ element)
+ previous
+ (element-next-value element)
+ (element-previous-value element)
+ (element-first-value element))))
+ (set-element-cost! element element*)
+ element*))))
+ elements)))
+ (letrec ((per-element
+ (lambda (element)
+ (if element
+ (begin
+ (if (element-first-value element)
+ (set-element-first-value!
+ element
+ (element-cost (element-first-value element))))
+ (if (element-previous-value element)
+ (set-element-previous-value!
+ element
+ (element-cost (element-previous-value element))))
+ (if (element-next-value element)
+ (set-element-next-value!
+ element
+ (element-cost (element-next-value element))))
+ (per-element (element-next-hash element)))))))
+ (for-each per-element elements*))
+ (letrec ((per-element
+ (lambda (element)
+ (if element
+ (begin
+ (set-element-cost!
+ element
+ (element-cost (element-cost element)))
+ (per-element (element-next-hash element)))))))
+ (for-each per-element elements))
+ (list->vector elements*))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff