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 / rerite.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  6.2 KB  |  185 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rerite.scm,v 1.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 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 Rewriting
  23. ;;; package: (compiler rtl-optimizer rtl-rewriting)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-structure (rewriting-rules
  28.            (conc-name rewriting-rules/)
  29.            (constructor make-rewriting-rules ()))
  30.   (assignment '())
  31.   (statement '())
  32.   (register '())
  33.   (expression '())
  34.   (generic '()))
  35.  
  36. (define rules:pre-cse (make-rewriting-rules))
  37. (define rules:post-cse (make-rewriting-rules))
  38.  
  39. (define (rtl-rewriting:pre-cse rgraphs)
  40.   (walk-rgraphs rules:pre-cse rgraphs))
  41.  
  42. (define (rtl-rewriting:post-cse rgraphs)
  43.   (walk-rgraphs rules:post-cse rgraphs))
  44.  
  45. (define (add-rewriting-rule! pattern result-procedure)
  46.   (new-rewriting-rule! rules:post-cse pattern result-procedure))
  47.  
  48. (define (add-pre-cse-rewriting-rule! pattern result-procedure)
  49.   (new-rewriting-rule! rules:pre-cse pattern result-procedure))
  50.  
  51. (define (walk-rgraphs rules rgraphs)
  52.   (if (not (and (null? (rewriting-rules/assignment rules))
  53.         (null? (rewriting-rules/statement rules))
  54.         (null? (rewriting-rules/register rules))
  55.         (null? (rewriting-rules/expression rules))
  56.         (null? (rewriting-rules/generic rules))))
  57.       (for-each (lambda (rgraph)
  58.           (walk-rgraph rules rgraph))
  59.         rgraphs)))
  60.  
  61. (define (walk-rgraph rules rgraph)
  62.   (fluid-let ((*current-rgraph* rgraph))
  63.     (for-each (lambda (bblock) (walk-bblock rules bblock))
  64.           (rgraph-bblocks rgraph))))
  65.  
  66. (define (walk-bblock rules bblock)
  67.   (bblock-walk-forward bblock
  68.     (lambda (rinst)
  69.       (walk-rinst rules rinst))))
  70.  
  71. (define (walk-rinst rules rinst)
  72.   (let ((rtl (rinst-rtl rinst)))
  73.     ;; Typically there will be few rules, and few instructions that
  74.     ;; match, so it is worth checking before rewriting anything.
  75.     (if (or (match-rtl-statement rules rtl)
  76.         (rtl:any-subexpression? rtl
  77.           (letrec ((loop
  78.             (lambda (expression)
  79.               (or (match-rtl-expression rules expression)
  80.                   (rtl:any-subexpression? expression loop)))))
  81.         loop)))
  82.     (set-rinst-rtl!
  83.      rinst
  84.      (let loop
  85.          ((rtl
  86.            (rtl:map-subexpressions rtl
  87.          (letrec ((loop
  88.                (lambda (expression)
  89.                  (let ((match-result
  90.                     (match-rtl-expression rules expression)))
  91.                    (if match-result
  92.                    (loop (match-result))
  93.                    expression)))))
  94.            loop))))
  95.        (let ((match-result (match-rtl-statement rules rtl)))
  96.          (if match-result
  97.          (loop (match-result))
  98.          rtl)))))))
  99.  
  100. (define (match-rtl-statement rules rtl)
  101.   (or (if (rtl:assign? rtl)
  102.       (pattern-lookup (rewriting-rules/assignment rules) rtl)
  103.       (let ((entries
  104.          (assq (rtl:expression-type rtl)
  105.                (rewriting-rules/statement rules))))
  106.         (and entries
  107.          (pattern-lookup (cdr entries) rtl))))
  108.       (pattern-lookup (rewriting-rules/generic rules) rtl)))
  109.  
  110. (define (match-rtl-expression rules expression)
  111.   (or (if (rtl:register? expression)
  112.       (pattern-lookup (rewriting-rules/register rules) expression)
  113.       (let ((entries
  114.          (assq (rtl:expression-type expression)
  115.                (rewriting-rules/expression rules))))
  116.         (and entries
  117.          (pattern-lookup (cdr entries) expression))))
  118.       (pattern-lookup (rewriting-rules/generic rules) expression)))
  119.  
  120. (define (new-rewriting-rule! rules pattern result-procedure)
  121.   (let ((entry (cons pattern result-procedure)))
  122.     (if (not (and (pair? pattern) (symbol? (car pattern))))
  123.     (set-rewriting-rules/generic! rules
  124.                       (cons entry
  125.                         (rewriting-rules/generic rules)))
  126.     (let ((keyword (car pattern)))
  127.       (cond ((eq? keyword 'ASSIGN)
  128.          (set-rewriting-rules/assignment!
  129.           rules
  130.           (cons entry (rewriting-rules/assignment rules))))
  131.         ((eq? keyword 'REGISTER)
  132.          (set-rewriting-rules/register!
  133.           rules
  134.           (cons entry (rewriting-rules/register rules))))
  135.         ((memq keyword rtl:expression-types)
  136.          (let ((entries
  137.             (assq keyword (rewriting-rules/expression rules))))
  138.            (if entries
  139.                (set-cdr! entries (cons entry (cdr entries)))
  140.                (set-rewriting-rules/expression!
  141.             rules
  142.             (cons (list keyword entry)
  143.                   (rewriting-rules/expression rules))))))
  144.         ((or (memq keyword rtl:statement-types)
  145.              (memq keyword rtl:predicate-types))
  146.          (let ((entries
  147.             (assq keyword (rewriting-rules/statement rules))))
  148.            (if entries
  149.                (set-cdr! entries (cons entry (cdr entries)))
  150.                (set-rewriting-rules/statement!
  151.             rules
  152.             (cons (list keyword entry)
  153.                   (rewriting-rules/statement rules))))))
  154.         (else
  155.          (error "illegal RTL type" keyword))))))
  156.   pattern)
  157.  
  158. (define-rule add-pre-cse-rewriting-rule!
  159.   (OBJECT->ADDRESS (? source))
  160.   (QUALIFIER (value-class=address? (rtl:expression-value-class source)))
  161.   source)
  162.  
  163. ;; KLUDGE!  This is unsafe, but currently works.
  164. ;; Probably closure bumping should not use byte-offset-address, and use
  165. ;; a new rtl type, but...
  166.  
  167. (define-rule add-pre-cse-rewriting-rule!
  168.   (CONS-POINTER (MACHINE-CONSTANT (? type))
  169.         (REGISTER (? datum register-known-value)))
  170.   (QUALIFIER
  171.    (and (= (ucode-type compiled-entry) type)
  172.     (rtl:byte-offset-address? datum)
  173.     (let ((v (let ((v (rtl:byte-offset-address-base datum)))
  174.            (if (rtl:register? v)
  175.                (register-known-value (rtl:register-number v))
  176.                v))))
  177.       (and v
  178.            (rtl:object->address? v)))))
  179.   (rtl:make-byte-offset-address
  180.    (rtl:object->address-expression
  181.     (let ((v (rtl:byte-offset-address-base datum)))
  182.       (if (rtl:register? v)
  183.       (register-known-value (rtl:register-number v))
  184.       v)))
  185.    (rtl:byte-offset-address-offset datum)))