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 / rcseht.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  6.3 KB  |  192 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rcseht.scm,v 4.13 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-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: Hash Table Abstraction
  23. ;;;  Based on the GNU C Compiler
  24. ;;; package: (compiler rtl-cse)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (make-hash-table)
  29.   (make-vector 31 false))
  30.  
  31. (define *hash-table*)
  32.  
  33. (define-integrable (hash-table-size)
  34.   (vector-length *hash-table*))
  35.  
  36. (define-integrable (hash-table-ref hash)
  37.   (vector-ref *hash-table* hash))
  38.  
  39. (define-integrable (hash-table-set! hash element)
  40.   (vector-set! *hash-table* hash element))
  41.  
  42. (define-structure (element
  43.            (constructor %make-element)
  44.            (constructor make-element (expression))
  45.            (print-procedure
  46.             (standard-unparser (symbol->string 'ELEMENT) false)))
  47.   (expression false read-only true)
  48.   (cost false)
  49.   (in-memory? false)
  50.   (next-hash false)
  51.   (previous-hash false)
  52.   (next-value false)
  53.   (previous-value false)
  54.   (first-value false))
  55.  
  56. (define (hash-table-lookup hash expression)
  57.   (let loop ((element (hash-table-ref hash)))
  58.     (and element
  59.      (if (let ((expression* (element-expression element)))
  60.            (or (eq? expression expression*)
  61.            (expression-equivalent? expression expression* true)))
  62.          element
  63.          (loop (element-next-hash element))))))
  64.  
  65. (define (hash-table-insert! hash expression class)
  66.   (let ((element (make-element expression))
  67.     (cost (rtl:expression-cost expression)))
  68.     (set-element-cost! element cost)
  69.     (if hash
  70.     (begin
  71.       (let ((next (hash-table-ref hash)))
  72.         (set-element-next-hash! element next)
  73.         (if next (set-element-previous-hash! next element)))
  74.       (hash-table-set! hash element)))
  75.     (cond ((not class)
  76.        (set-element-first-value! element element))
  77.       ((or (< cost (element-cost class))
  78.            (and (= cost (element-cost class))
  79.             (rtl:register? expression)
  80.             (not (rtl:register? (element-expression class)))))
  81.        (set-element-next-value! element class)
  82.        (set-element-previous-value! class element)
  83.        (let loop ((x element))
  84.          (if x
  85.          (begin
  86.            (set-element-first-value! x element)
  87.            (loop (element-next-value x))))))
  88.       (else
  89.        (set-element-first-value! element class)
  90.        (let loop ((previous class) (next (element-next-value class)))
  91.          (cond ((not next)
  92.             (set-element-next-value! element false)
  93.             (set-element-next-value! previous element)
  94.             (set-element-previous-value! element previous))
  95.            ((or (< cost (element-cost next))
  96.             (and (= cost (element-cost next))
  97.                  (or (rtl:register? expression)
  98.                  (not (rtl:register?
  99.                        (element-expression next))))))
  100.             (set-element-next-value! element next)
  101.             (set-element-previous-value! next element)
  102.             (set-element-next-value! previous element)
  103.             (set-element-previous-value! element previous))
  104.            (else
  105.             (loop next (element-next-value next)))))))
  106.     element))
  107.  
  108. (define (hash-table-delete! hash element)
  109.   (if element
  110.       (begin
  111.        ;; **** Mark this element as removed.  [ref crock-1]
  112.        (set-element-first-value! element false)
  113.        (let ((next (element-next-value element))
  114.          (previous (element-previous-value element)))
  115.      (if next (set-element-previous-value! next previous))
  116.      (if previous
  117.          (set-element-next-value! previous next)
  118.          (let loop ((element next))
  119.            (if element
  120.            (begin
  121.              (set-element-first-value! element next)
  122.              (loop (element-next-value element)))))))
  123.        (let ((next (element-next-hash element))
  124.          (previous (element-previous-hash element)))
  125.      (if next (set-element-previous-hash! next previous))
  126.      (if previous
  127.          (set-element-next-hash! previous next)
  128.          (hash-table-set! hash next))))))
  129.  
  130. (define (hash-table-delete-class! predicate)
  131.   (let table-loop ((i 0))
  132.     (if (< i (hash-table-size))
  133.     (let bucket-loop ((element (hash-table-ref i)))
  134.       (if element
  135.           (begin
  136.         (if (predicate element) (hash-table-delete! i element))
  137.         (bucket-loop (element-next-hash element)))
  138.           (table-loop (1+ i)))))))
  139.  
  140. (define (hash-table-copy table)
  141.   ;; During this procedure, the `element-cost' slots of `table' are
  142.   ;; reused as "broken hearts".
  143.   (let ((elements (vector->list table)))
  144.     (let ((elements*
  145.        (map (lambda (element)
  146.           (let per-element ((element element) (previous false))
  147.             (and element
  148.              (let ((element*
  149.                 (%make-element
  150.                  (element-expression element)
  151.                  (element-cost element)
  152.                  (element-in-memory? element)
  153.                  false
  154.                  previous
  155.                  (element-next-value element)
  156.                  (element-previous-value element)
  157.                  (element-first-value element))))
  158.                (set-element-cost! element element*)
  159.                (set-element-next-hash!
  160.                 element*
  161.                 (per-element (element-next-hash element)
  162.                      element*))
  163.                element*))))
  164.         elements)))
  165.       (letrec ((per-element
  166.         (lambda (element)
  167.           (if element
  168.               (begin
  169.             (if (element-first-value element)
  170.                 (set-element-first-value!
  171.                  element
  172.                  (element-cost (element-first-value element))))
  173.             (if (element-previous-value element)
  174.                 (set-element-previous-value!
  175.                  element
  176.                  (element-cost (element-previous-value element))))
  177.             (if (element-next-value element)
  178.                 (set-element-next-value!
  179.                  element
  180.                  (element-cost (element-next-value element))))
  181.             (per-element (element-next-hash element)))))))
  182.     (for-each per-element elements*))
  183.       (letrec ((per-element
  184.         (lambda (element)
  185.           (if element
  186.               (begin
  187.             (set-element-cost!
  188.              element
  189.              (element-cost (element-cost element)))
  190.             (per-element (element-next-hash element)))))))
  191.     (for-each per-element elements))
  192.       (list->vector elements*))))