home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / rtlopt / rcse2.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  11.5 KB  |  305 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rcse2.scm,v 4.14 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 1990, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; RTL Common Subexpression Elimination
  23. ;;;  Based on the GNU C Compiler
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Canonicalization
  28.  
  29. (define (expression-replace! statement-expression set-statement-expression!
  30.                  statement receiver)
  31.   ;; Replace the expression by its cheapest equivalent.  Returns two
  32.   ;; values: (1) a flag which is true iff the expression is volatile;
  33.   ;; and (2) a thunk which, when called, will insert the expression in
  34.   ;; the hash table, returning the element.  Do not call the thunk if
  35.   ;; the expression is volatile.
  36.   (let ((expression
  37.      (expression-canonicalize (statement-expression statement))))
  38.     (full-expression-hash expression
  39.       (lambda (hash volatile? in-memory?)
  40.     (let ((element
  41.            (find-cheapest-valid-element expression hash volatile?)))
  42.       (let ((finish
  43.          (lambda (expression hash volatile? in-memory?)
  44.            (set-statement-expression! statement expression)
  45.            (receiver volatile?
  46.                  (expression-inserter expression
  47.                           element
  48.                           hash
  49.                           in-memory?)))))
  50.         (if element
  51.         (let ((expression (element-expression element)))
  52.           (full-expression-hash expression
  53.             (lambda (hash volatile? in-memory?)
  54.               (finish expression hash volatile? in-memory?))))
  55.         (finish expression hash volatile? in-memory?))))))))
  56.  
  57. (define ((expression-inserter expression element hash in-memory?))
  58.   (or element
  59.       (begin
  60.     (if (rtl:register? expression)
  61.         (set-register-expression! (rtl:register-number expression)
  62.                       expression)
  63.         (mention-registers! expression))
  64.     (let ((element* (hash-table-insert! hash expression false)))
  65.       (set-element-in-memory?! element* in-memory?)
  66.       (element-first-value element*)))))
  67.  
  68. (define (expression-canonicalize expression)
  69.   (cond ((rtl:register? expression)
  70.      (or (register-expression
  71.           (quantity-first-register
  72.            (get-register-quantity (rtl:register-number expression))))
  73.          expression))
  74.     ((stack-reference? expression)
  75.      (let ((register
  76.         (quantity-first-register
  77.          (stack-reference-quantity expression))))
  78.        (or (and register (register-expression register))
  79.            expression)))
  80.     (else
  81.      (rtl:map-subexpressions expression expression-canonicalize))))
  82.  
  83. ;;;; Hash
  84.  
  85. (define (expression-hash expression)
  86.   (full-expression-hash expression
  87.     (lambda (hash do-not-record? hash-arg-in-memory?)
  88.       do-not-record? hash-arg-in-memory?
  89.       hash)))
  90.  
  91. (define (full-expression-hash expression receiver)
  92.   (let ((do-not-record? false)
  93.     (hash-arg-in-memory? false))
  94.     (define (loop expression)
  95.       (let ((type (rtl:expression-type expression)))
  96.     (+ (symbol-hash type)
  97.        (case type
  98.          ((REGISTER)
  99.           (quantity-number
  100.            (get-register-quantity (rtl:register-number expression))))
  101.          ((OFFSET)
  102.           ;; Note that stack-references do not get treated as
  103.           ;; memory for purposes of invalidation.  This is because
  104.           ;; (supposedly) no one ever accesses the stack directly
  105.           ;; except the compiler's output, which is explicit.
  106.           (if (interpreter-stack-pointer? (rtl:offset-base expression))
  107.           (quantity-number (stack-reference-quantity expression))
  108.           (begin
  109.             (set! hash-arg-in-memory? true)
  110.             (continue expression))))
  111.          ((BYTE-OFFSET)
  112.           (set! hash-arg-in-memory? true)
  113.           (continue expression))
  114.          ((PRE-INCREMENT POST-INCREMENT)
  115.           (set! hash-arg-in-memory? true)
  116.           (set! do-not-record? true)
  117.           0)
  118.          (else
  119.           (continue expression))))))
  120.  
  121.     (define (continue expression)
  122.       (rtl:reduce-subparts expression + 0 loop
  123.     (lambda (object)
  124.       (cond ((integer? object) (inexact->exact object))
  125.         ((symbol? object) (symbol-hash object))
  126.         ((string? object) (string-hash object))
  127.         (else (hash object))))))
  128.  
  129.     (let ((hash (loop expression)))
  130.       (receiver (modulo hash (hash-table-size))
  131.         do-not-record?
  132.         hash-arg-in-memory?))))
  133.  
  134. ;;;; Table Search
  135.  
  136. (define (find-cheapest-expression expression hash volatile?)
  137.   ;; Find the cheapest equivalent expression for EXPRESSION.
  138.   (let ((element (find-cheapest-valid-element expression hash volatile?)))
  139.     (if element
  140.     (element-expression element)
  141.     expression)))
  142.  
  143. (define (find-cheapest-valid-element expression hash volatile?)
  144.   ;; Find the cheapest valid hash table element for EXPRESSION.
  145.   ;; Returns false if no such element exists or if EXPRESSION is
  146.   ;; VOLATILE?.
  147.   (and (not volatile?)
  148.        (let ((element (hash-table-lookup hash expression)))
  149.      (and element
  150.           (let ((element* (element-first-value element)))
  151.         (if (eq? element element*)
  152.             element
  153.             (let loop ((element element*))
  154.               (and element
  155.                (let ((expression (element-expression element)))
  156.                  (if (or (rtl:register? expression)
  157.                      (expression-valid? expression))
  158.                  element
  159.                  (loop (element-next-value element))))))))))))
  160.  
  161. (define (expression-valid? expression)
  162.   ;; True iff all registers mentioned in EXPRESSION have valid values
  163.   ;; in the hash table.
  164.   (if (rtl:register? expression)
  165.       (let ((register (rtl:register-number expression)))
  166.     (= (register-in-table register) (register-tick register)))
  167.       (rtl:all-subexpressions? expression expression-valid?)))
  168.  
  169. (define (element->class element)
  170.   ;; Return the cheapest element in the hash table which has the same
  171.   ;; value as `element'.  This is necessary because `element' may have
  172.   ;; been deleted due to register or memory invalidation.
  173.   (and element
  174.        ;; If `element' has been deleted from the hash table,
  175.        ;; `element-first-value' will be false.  [ref crock-1]
  176.        (or (element-first-value element)
  177.        (element->class (element-next-value element)))))
  178.  
  179. ;;;; Insertion
  180.  
  181. (define (insert-register-destination! expression element)
  182.   ;; Insert EXPRESSION, which should be a register expression, into
  183.   ;; the hash table as the destination of an assignment.  ELEMENT is
  184.   ;; the hash table element for the value being assigned to
  185.   ;; EXPRESSION.
  186.   (let ((register (rtl:register-number expression)))
  187.     (set-register-expression! register expression)
  188.     (let ((quantity (get-element-quantity element)))
  189.       (if quantity
  190.       (begin
  191.         (set-register-quantity! register quantity)
  192.         (let ((last (quantity-last-register quantity)))
  193.           (cond ((not last)
  194.              (set-quantity-first-register! quantity register)
  195.              (set-register-next-equivalent! register false))
  196.             (else
  197.              (set-register-next-equivalent! last register)
  198.              (set-register-previous-equivalent! register last))))
  199.         (set-quantity-last-register! quantity register)))))
  200.   (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
  201.                            expression
  202.                            (element->class element))
  203.                false))
  204.  
  205. (define (insert-stack-destination! expression element)
  206.   (let ((quantity (get-element-quantity element)))
  207.     (if quantity
  208.     (set-stack-reference-quantity! expression quantity)))
  209.   (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
  210.                            expression
  211.                            (element->class element))
  212.                false))
  213.  
  214. (define (get-element-quantity element)
  215.   (let loop ((element (element->class element)))
  216.     (and element
  217.      (let ((expression (element-expression element)))
  218.        (cond ((rtl:register? expression)
  219.           (get-register-quantity (rtl:register-number expression)))
  220.          ((stack-reference? expression)
  221.           (stack-reference-quantity expression))
  222.          (else
  223.           (loop (element-next-value element))))))))
  224.  
  225. (define (insert-memory-destination! expression element hash)
  226.   (let ((class (element->class element)))
  227.     (mention-registers! expression)
  228.     ;; Optimization: if class and hash are both false, hash-table-insert!
  229.     ;; makes an element which is not connected to the rest of the table.
  230.     ;; In that case, there is no need to make an element at all.
  231.     (if (or class hash)
  232.     (set-element-in-memory?! (hash-table-insert! hash expression class)
  233.                  true))))
  234.  
  235. (define (mention-registers! expression)
  236.   (if (rtl:register? expression)
  237.       (let ((register (rtl:register-number expression)))
  238.     (remove-invalid-references! register)
  239.     (set-register-in-table! register (register-tick register)))
  240.       (rtl:for-each-subexpression expression mention-registers!)))
  241.  
  242. (define (remove-invalid-references! register)
  243.   ;; If REGISTER is invalid, delete from the hash table all
  244.   ;; expressions which refer to it.
  245.   (if (let ((in-table (register-in-table register)))
  246.     (and (not (negative? in-table))
  247.          (not (= in-table (register-tick register)))))
  248.       (let ((expression (register-expression register)))
  249.     (hash-table-delete-class!
  250.      (lambda (element)
  251.        (let ((expression* (element-expression element)))
  252.          (and (not (rtl:register? expression*))
  253.           (expression-refers-to? expression* expression)))))))
  254.   unspecific)
  255.  
  256. ;;;; Invalidation
  257.  
  258. (define (non-object-invalidate!)
  259.   (hash-table-delete-class!
  260.    (lambda (element)
  261.      (not (rtl:object-valued-expression? (element-expression element))))))
  262.  
  263. (define (varying-address-invalidate!)
  264.   (hash-table-delete-class!
  265.    (lambda (element)
  266.      (and (element-in-memory? element)
  267.       (expression-address-varies? (element-expression element))))))
  268.  
  269. (define (expression-invalidate! expression)
  270.   ;; Delete from the table any expression which refers to this
  271.   ;; expression.
  272.   (if (rtl:register? expression)
  273.       (register-expression-invalidate! expression)
  274.       (hash-table-delete-class!
  275.        (lambda (element)
  276.      (expression-refers-to? (element-expression element) expression)))))
  277.  
  278. (define (register-expression-invalidate! expression)
  279.   ;; Invalidate a register expression.  These expressions are handled
  280.   ;; specially for efficiency -- the register is marked invalid but we
  281.   ;; delay searching the hash table for relevant expressions.
  282.   (let ((register (rtl:register-number expression))
  283.     (hash (expression-hash expression)))
  284.     (register-invalidate! register)
  285.     ;; If we're invalidating the stack pointer, delete its entries
  286.     ;; immediately.
  287.     (if (interpreter-stack-pointer? expression)
  288.     (mention-registers! expression)
  289.     (hash-table-delete! hash (hash-table-lookup hash expression)))))
  290.  
  291. (define (register-invalidate! register)
  292.   (let ((next (register-next-equivalent register))
  293.     (previous (register-previous-equivalent register))
  294.     (quantity (get-register-quantity register)))
  295.     (set-register-tick! register (1+ (register-tick register)))
  296.     (if next
  297.     (set-register-previous-equivalent! next previous)
  298.     (set-quantity-last-register! quantity previous))
  299.     (if previous
  300.     (set-register-next-equivalent! previous next)
  301.     (set-quantity-first-register! quantity next))
  302.     (set-register-quantity! register (new-quantity register))
  303.     (set-register-next-equivalent! register false)
  304.     (set-register-previous-equivalent! register false))
  305.   unspecific)