#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.114 1987/09/03 05:12:54 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.1 1987/12/08 13:55:03 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define *branch-queue*)
(define (common-subexpression-elimination rgraphs)
- (with-new-node-marks
- (lambda ()
- (for-each cse-rgraph rgraphs))))
+ (with-new-node-marks (lambda () (for-each cse-rgraph rgraphs))))
(define (cse-rgraph rgraph)
(fluid-let ((*current-rgraph* rgraph)
(*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! *initial-queue* (edge-right-node edge)))
(rgraph-initial-edges rgraph))
(fluid-let ((*register-tables*
(register-tables/make (rgraph-n-registers rgraph)))
- (*hash-table*))
+ (*hash-table*)
+ (*stack-offset*)
+ (*stack-reference-quantities*))
(continue-walk))))
(define (continue-walk)
(cond ((not (null? *branch-queue*))
(let ((entry (car *branch-queue*)))
(set! *branch-queue* (cdr *branch-queue*))
- (set! *register-tables* (caar entry))
- (set! *hash-table* (cdar entry))
+ (let ((state (car entry)))
+ (set! *register-tables* (state/register-tables state))
+ (set! *hash-table* (state/hash-table state))
+ (set! *stack-offset* (state/stack-offset state))
+ (set! *stack-reference-quantities*
+ (state/stack-reference-quantities state)))
(walk-bblock (cdr entry))))
((not (queue-empty? *initial-queue*))
- (state:reset!)
+ (state/reset!)
(walk-bblock (dequeue! *initial-queue*)))))
-(define (state:reset!)
- (register-tables/reset! *register-tables*)
- (set! *hash-table* (make-hash-table)))
+(define-structure (state (type vector) (conc-name state/))
+ (register-tables false read-only true)
+ (hash-table false read-only true)
+ (stack-offset false read-only true)
+ (stack-reference-quantities false read-only true))
-(define (state:get)
- (cons (register-tables/copy *register-tables*)
- (hash-table-copy *hash-table*)))
+(define (state/reset!)
+ (register-tables/reset! *register-tables*)
+ (set! *hash-table* (make-hash-table))
+ (set! *stack-offset* 0)
+ (set! *stack-reference-quantities* '()))
+
+(define (state/get)
+ (make-state (register-tables/copy *register-tables*)
+ (hash-table-copy *hash-table*)
+ *stack-offset*
+ (list-copy *stack-reference-quantities*)))
\f
(define (walk-bblock bblock)
(define (loop rinst)
(begin (if (node-previous>1? alternative)
(enqueue! *initial-queue* alternative)
(set! *branch-queue*
- (cons (cons (state:get) alternative)
+ (cons (cons (state/get) alternative)
*branch-queue*)))
(walk-bblock consequent)))
(walk-next consequent))
(and bblock (not (node-marked? bblock))))
(define (walk-next bblock)
- (if (node-previous>1? bblock) (state:reset!))
+ (if (node-previous>1? bblock) (state/reset!))
(walk-bblock bblock))
(define (define-cse-method type method)
statement
(lambda (volatile? insert-source!)
(let ((address (rtl:assign-address statement)))
- (if (rtl:register? address)
- (begin
- (register-expression-invalidate! address)
- (if (and (not volatile?)
- (not (rtl:machine-register-expression?
- (rtl:assign-expression statement)))
- ;; This is a kludge. If the address is the
- ;; frame pointer, then the source is the stack
- ;; pointer. If this is not done then some of
- ;; the references to stack locations use the
- ;; stack pointer instead of the frame pointer.
- ;; This is not a bug but I want the stack
- ;; addressing to be uniform for now. -- cph
- (not (interpreter-frame-pointer? address)))
- (insert-register-destination! address (insert-source!))))
+ (cond ((rtl:register? address)
+ (register-expression-invalidate! address)
+ (if (and (not volatile?)
+ (not (rtl:machine-register-expression?
+ (rtl:assign-expression statement))))
+ (insert-register-destination! address (insert-source!))))
+ ((stack-reference? address)
+ (stack-reference-invalidate! address)
+ (if (not volatile?)
+ (insert-stack-destination! address (insert-source!))))
+ (else
\f
- (let ((address (expression-canonicalize address)))
- (rtl:set-assign-address! statement address)
- (full-expression-hash address
- (lambda (hash volatile?* in-memory?*)
- (let ((memory-invalidate!
- (cond ((and (memq (rtl:expression-type address)
- '(PRE-INCREMENT POST-INCREMENT))
- (or (interpreter-stack-pointer?
- (rtl:address-register address))
- (interpreter-free-pointer?
- (rtl:address-register address))))
- (lambda ()
- (register-expression-invalidate!
- (rtl:address-register address))))
- ((expression-address-varies? address)
- (lambda ()
- (hash-table-delete-class!
- element-in-memory?)))
- (else
- (lambda ()
- (hash-table-delete!
- hash
- (hash-table-lookup hash address))
- (hash-table-delete-class!
- element-address-varies?))))))
- (cond (volatile?* (memory-invalidate!))
- ((not volatile?)
- (let ((address
- (find-cheapest-expression address hash
- false)))
- (let ((element (insert-source!)))
- (memory-invalidate!)
- (insert-memory-destination!
- address
- element
- (modulo (+ (symbol-hash 'ASSIGN) hash)
- n-buckets)))))))))))))))
+ (let ((address (expression-canonicalize address)))
+ (rtl:set-assign-address! statement address)
+ (full-expression-hash address
+ (lambda (hash volatile?* in-memory?*)
+ (let ((memory-invalidate!
+ (cond ((stack-push/pop? address)
+ (lambda () 'DONE))
+ ((and (memq (rtl:expression-type address)
+ '(PRE-INCREMENT POST-INCREMENT))
+ (interpreter-free-pointer?
+ (rtl:address-register address)))
+ (lambda ()
+ (register-expression-invalidate!
+ (rtl:address-register address))))
+ ((expression-address-varies? address)
+ (lambda ()
+ (hash-table-delete-class!
+ element-in-memory?)))
+ (else
+ (lambda ()
+ (hash-table-delete!
+ hash
+ (hash-table-lookup hash address))
+ (hash-table-delete-class!
+ element-address-varies?))))))
+ (cond (volatile?* (memory-invalidate!))
+ ((not volatile?)
+ (let ((address
+ (find-cheapest-expression address hash
+ false)))
+ (let ((element (insert-source!)))
+ (memory-invalidate!)
+ (insert-memory-destination!
+ address
+ element
+ (modulo (+ (symbol-hash 'ASSIGN) hash)
+ (hash-table-size))))))))))
+ ;; **** Kludge. Works only because stack-pointer
+ ;; gets used in very fixed way by code generator.
+ (if (stack-push/pop? address)
+ (stack-pointer-adjust!
+ (rtl:address-number address))))))))))
\f
(define (trivial-action volatile? insert-source!)
(if (not volatile?)
(define (method/noop statement)
'DONE)
-(define-cse-method 'RETURN method/noop)
+(define-cse-method 'POP-RETURN method/noop)
(define-cse-method 'PROCEDURE-HEAP-CHECK method/noop)
(define-cse-method 'CONTINUATION-HEAP-CHECK method/noop)
(define-cse-method 'INVOCATION:APPLY method/noop)
(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop)
(define-cse-method 'INVOCATION:UUO-LINK method/noop)
-(define (method/invalidate-stack statement)
+(define (method/trash-stack statement)
+ (stack-invalidate!)
(stack-pointer-invalidate!))
-(define-cse-method 'SETUP-LEXPR method/invalidate-stack)
-(define-cse-method 'MESSAGE-SENDER:VALUE method/invalidate-stack)
-(define-cse-method 'MESSAGE-RECEIVER:CLOSURE method/invalidate-stack)
-(define-cse-method 'MESSAGE-RECEIVER:STACK method/invalidate-stack)
-(define-cse-method 'MESSAGE-RECEIVER:SUBPROBLEM method/invalidate-stack)
+(define-cse-method 'SETUP-LEXPR method/trash-stack)
+(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP method/trash-stack)
+(define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK method/trash-stack)
(define-cse-method 'INTERPRETER-CALL:ENCLOSE
(lambda (statement)
- (stack-pointer-invalidate!)
+ (let ((n (rtl:interpreter-call:enclose-size statement)))
+ (stack-region-invalidate! 0 n)
+ (stack-pointer-adjust! n))
(expression-invalidate! (interpreter-register:enclose))))
(define-cse-method 'INVOCATION:CACHE-REFERENCE
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.1 1987/12/08 13:55:35 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(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)))
+ (cond ((rtl:register? expression)
+ (or (register-expression
+ (quantity-first-register
+ (get-register-quantity (rtl:register-number expression))))
+ expression))
+ ((stack-reference? expression)
+ (let ((register
+ (quantity-first-register
+ (stack-reference-quantity expression))))
+ (or (and register (register-expression register))
+ expression)))
+ (else
+ (rtl:map-subexpressions expression expression-canonicalize))))
\f
;;;; Invalidation
(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)))))
+ (not (= regnum:regs-pointer
+ (rtl:register-number (rtl:address-register expression))))
(rtl:any-subexpression? expression expression-address-varies?)))
(define (expression-invalidate! expression)
(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
(let ((expression (element-expression class)))
(cond ((rtl:register? expression)
(register-equivalence!
- (get-register-quantity (rtl:register-number expression)))))))
+ (get-register-quantity (rtl:register-number expression))))
+ ((stack-reference? expression)
+ (register-equivalence!
+ (stack-reference-quantity expression))))))
(set-element-in-memory?!
(hash-table-insert! (expression-hash expression) expression class)
false)))
+\f
+(define (insert-stack-destination! expression element)
+ (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
+ expression
+ (element->class element))
+ false))
(define (insert-memory-destination! expression element hash)
(let ((class (element->class element)))
(quantity-number
(get-register-quantity (rtl:register-number expression))))
((OFFSET)
- (set! hash-arg-in-memory? true)
- (continue expression))
+ ;; 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))))
((PRE-INCREMENT POST-INCREMENT)
(set! hash-arg-in-memory? true)
(set! do-not-record? true)
(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
+ (receiver (modulo hash (hash-table-size))
+ do-not-record?
+ hash-arg-in-memory?))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 1.5 1987/05/18 23:26:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 4.1 1987/12/08 13:56:02 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
((REGISTER)
(register-equivalent? x y))
((OFFSET)
- (and (register-equivalent? (rtl:offset-register x)
- (rtl:offset-register y))
- (= (rtl:offset-number x)
- (rtl:offset-number y))))
+ (let ((rx (rtl:offset-register x)))
+ (and (register-equivalent? rx (rtl:offset-register y))
+ (if (interpreter-stack-pointer? rx)
+ (eq? (stack-reference-quantity x)
+ (stack-reference-quantity y))
+ (= (rtl:offset-number x)
+ (rtl:offset-number y))))))
(else
(rtl:match-subexpressions x y loop))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 1.3 1987/05/07 00:18:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.1 1987/12/08 13:55:52 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define n-buckets 31)
-
(define (make-hash-table)
- (make-vector n-buckets false))
+ (make-vector 31 false))
(define *hash-table*)
+(define-integrable (hash-table-size)
+ (vector-length *hash-table*))
+
(define-integrable (hash-table-ref hash)
(vector-ref *hash-table* hash))
(define-integrable (hash-table-set! hash element)
(vector-set! *hash-table* hash element))
-(define element-tag (make-vector-tag false 'ELEMENT))
-(define element? (tagged-vector-predicate element-tag))
-
-(define-vector-slots element 1
- expression cost in-memory?
- next-hash previous-hash
- next-value previous-value first-value
- copy-cache)
-
-(define (make-element expression)
- (vector element-tag expression false false false false false false false
- false))
+(define-structure (element
+ (constructor %make-element)
+ (constructor make-element (expression))
+ (print-procedure (standard-unparser 'ELEMENT false)))
+ (expression false read-only true)
+ (cost false)
+ (in-memory? false)
+ (next-hash false)
+ (previous-hash false)
+ (next-value false)
+ (previous-value false)
+ (first-value false)
+ (copy-cache false))
+
+(set-type-object-description!
+ element
+ (lambda (element)
+ `((ELEMENT-EXPRESSION ,(element-expression element))
+ (ELEMENT-COST ,(element-cost element))
+ (ELEMENT-IN-MEMORY? ,(element-in-memory? element))
+ (ELEMENT-NEXT-HASH ,(element-next-hash 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)))))
\f
(define (hash-table-lookup hash expression)
(define (loop element)
(define (per-element element previous)
(and element
(let ((element*
- (vector element-tag
- (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)))
+ (%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)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.4 1987/08/07 17:07:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.1 1987/12/08 13:55:45 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define quantity-tag (make-vector-tag false 'QUANTITY))
-(define quantity? (tagged-vector-predicate quantity-tag))
-(define-vector-slots quantity 1 number first-register last-register)
+(define-structure (quantity
+ (copier quantity-copy)
+ (print-procedure (standard-unparser 'QUANTITY false)))
+ (number false read-only true)
+ (first-register false)
+ (last-register false))
+
+(set-type-object-description!
+ quantity
+ (lambda (quantity)
+ `((QUANTITY-NUMBER ,(quantity-number quantity))
+ (QUANTITY-FIRST-REGISTER ,(quantity-first-register quantity))
+ (QUANTITY-LAST-REGISTER ,(quantity-last-register quantity)))))
-(define *next-quantity-number*)
+(define (get-register-quantity register)
+ (or (register-quantity register)
+ (let ((quantity (new-quantity register)))
+ (set-register-quantity! register quantity)
+ 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))
-(define (make-quantity number first-register last-register)
- (vector quantity-tag number first-register last-register))
-
-(define (new-quantity register)
- (make-quantity (generate-quantity-number) register register))
-
-(define (quantity-copy quantity)
- (make-quantity (quantity-number quantity)
- (quantity-first-register quantity)
- (quantity-last-register quantity)))
-
-(define (get-register-quantity register)
- (or (register-quantity register)
- (let ((quantity (new-quantity register)))
- (set-register-quantity! register quantity)
- quantity)))
+(define *next-quantity-number*)
\f
(define (register-tables/make n-registers)
(vector (make-vector n-registers)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 1.1 1987/03/19 00:49:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 4.1 1987/12/08 13:56:09 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Common Subexpression Elimination: Stack References
-;;; Based on the GNU C Compiler
(declare (usual-integrations))
\f
(define *stack-offset*)
(define *stack-reference-quantities*)
+(define (stack-push/pop? expression)
+ (and (memq (rtl:expression-type expression) '(PRE-INCREMENT POST-INCREMENT))
+ (interpreter-stack-pointer? (rtl:address-register expression))))
+
(define (stack-reference? expression)
(and (eq? (rtl:expression-type expression) 'OFFSET)
(interpreter-stack-pointer? (rtl:address-register expression))))
projects / mit-scheme.git / commitdiff