From cca24fdad2709c2a2567737a6b2f4b90fcb5571d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 11 Aug 1988 20:11:14 +0000 Subject: [PATCH] Various efficiency and organization changes. Eliminate `copy-cache' slot from `element' objects, reusing `cost' for that purpose during the copy phase. --- v7/src/compiler/rtlopt/rcse1.scm | 60 +++--- v7/src/compiler/rtlopt/rcse2.scm | 343 +++++++++++++++--------------- v7/src/compiler/rtlopt/rcseep.scm | 24 ++- v7/src/compiler/rtlopt/rcseht.scm | 127 +++++------ v7/src/compiler/rtlopt/rcserq.scm | 15 +- 5 files changed, 283 insertions(+), 286 deletions(-) diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index d53e762ec..61e25cff7 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -32,7 +32,7 @@ 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 +;;;; RTL Common Subexpression Elimination: Codewalker ;;; Based on the GNU C Compiler (declare (usual-integrations)) @@ -48,7 +48,8 @@ MIT in each case. |# (*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))) @@ -82,7 +83,8 @@ MIT in each case. |# (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*) @@ -91,16 +93,17 @@ MIT in each case. |# (list-copy *stack-reference-quantities*))) (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))) @@ -125,10 +128,10 @@ MIT in each case. |# (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)) @@ -179,7 +182,6 @@ MIT in each case. |# hash insert-source! memory-invalidate!))))) - (else (let ((address (expression-canonicalize address))) (rtl:set-assign-address! statement address) @@ -205,8 +207,7 @@ MIT in each case. |# (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 @@ -215,7 +216,7 @@ MIT in each case. |# memory-invalidate!))))) (notice-push/pop! address))))) (notice-push/pop! (rtl:assign-expression statement))))) - + (define (notice-push/pop! expression) ;; **** Kludge. Works only because stack-pointer ;; gets used in very fixed way by code generator. @@ -260,15 +261,15 @@ MIT in each case. |# 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!) @@ -277,7 +278,7 @@ MIT in each case. |# (define (method/noop statement) statement - 'DONE) + unspecific) (define-cse-method 'POP-RETURN method/noop) @@ -295,25 +296,16 @@ MIT in each case. |# (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)))) - + (define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP (lambda (statement) (expression-replace! rtl:invocation-prefix:move-frame-up-locative @@ -374,7 +366,7 @@ MIT in each case. |# rtl:interpreter-call:unbound?-environment rtl:set-interpreter-call:unbound?-environment! interpreter-register:unbound?) - + (define (define-assignment-method type get-environment set-environment! get-value set-value!) @@ -383,7 +375,7 @@ MIT in each case. |# (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!))))))) diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index 17cfe6822..77efe443d 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -52,17 +52,20 @@ MIT in each case. |# (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 @@ -89,67 +92,101 @@ MIT in each case. |# (else (rtl:map-subexpressions expression expression-canonicalize)))) -;;;; 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?)))) + +;;;; 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))))) -;;;; Destination Insertion +;;;; Insertion (define (insert-register-destination! expression element) ;; Insert EXPRESSION, which should be a register expression, into @@ -158,20 +195,22 @@ MIT in each case. |# ;; 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)))) @@ -180,13 +219,15 @@ MIT in each case. |# (stack-reference-quantity expression)))))) (set-element-in-memory?! (hash-table-insert! (expression-hash expression) expression class) - false))) - + 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))) @@ -196,18 +237,20 @@ MIT in each case. |# ;; 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))))) @@ -216,98 +259,50 @@ MIT in each case. |# (lambda (element) (let ((expression* (element-expression element))) (and (not (rtl:register? expression*)) - (expression-refers-to? expression* expression)))))))) + (expression-refers-to? expression* expression))))))) + unspecific) -;;;; 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))))) - -;;;; 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 diff --git a/v7/src/compiler/rtlopt/rcseep.scm b/v7/src/compiler/rtlopt/rcseep.scm index 99d45b750..0aa04c3da 100644 --- a/v7/src/compiler/rtlopt/rcseep.scm +++ b/v7/src/compiler/rtlopt/rcseep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.3 1988/05/09 19:54:46 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.4 1988/08/11 20:10:58 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -77,4 +77,24 @@ MIT in each case. |# (define-integrable (interpreter-register-reference? expression) (and (rtl:offset? expression) - (interpreter-regs-pointer? (rtl:offset-register expression)))) \ No newline at end of file + (interpreter-regs-pointer? (rtl:offset-register expression)))) + +(define (expression-non-object? expression) + (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-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?))) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm index 01ad2a70d..24cd6c30e 100644 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -61,8 +61,7 @@ MIT in each case. |# (previous-hash false) (next-value false) (previous-value false) - (first-value false) - (copy-cache false)) + (first-value false)) (set-type-object-description! element @@ -74,18 +73,16 @@ MIT in each case. |# (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))))) (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)) @@ -142,7 +139,8 @@ MIT in each case. |# (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)) @@ -152,63 +150,56 @@ MIT in each case. |# (begin (if (predicate element) (hash-table-delete! i element)) (bucket-loop (element-next-hash element))) - (table-loop (1+ i))))))) + (table-loop (1+ i)))))) + unspecific) -(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 diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm index f638b1143..931ca310d 100644 --- a/v7/src/compiler/rtlopt/rcserq.scm +++ b/v7/src/compiler/rtlopt/rcserq.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.2 1988/06/14 08:44:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.3 1988/08/11 20:11:14 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -57,12 +57,11 @@ MIT in each case. |# quantity))) (define (new-quantity register) - (make-quantity (generate-quantity-number) register register)) - -(define (generate-quantity-number) - (let ((n *next-quantity-number*)) - (set! *next-quantity-number* (1+ *next-quantity-number*)) - n)) + (make-quantity (let ((n *next-quantity-number*)) + (set! *next-quantity-number* (1+ *next-quantity-number*)) + n) + register + register)) (define *next-quantity-number*) @@ -98,7 +97,7 @@ MIT in each case. |# (vector-copy (vector-ref register-tables 3)) (vector-copy (vector-ref register-tables 4)) (vector-copy (vector-ref register-tables 5)))) - + (define *register-tables*) (define-integrable (register-quantity register) -- 2.25.1