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 / rdflow.scm < prev    next >
Encoding:
Text File  |  1999-11-08  |  8.2 KB  |  242 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rdflow.scm,v 1.4 1999/11/08 18:29:19 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 Dataflow Analysis
  23. ;;; package: (compiler rtl-optimizer rtl-dataflow-analysis)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (rtl-dataflow-analysis rgraphs)
  28.   (for-each (lambda (rgraph)
  29.           (let ((rnodes (generate-dataflow-graph rgraph)))
  30.         (set-rgraph-register-value-classes!
  31.          rgraph
  32.          (vector-map (lambda (rnode)
  33.                    (and rnode
  34.                     (rnode/value-class rnode)))
  35.                  rnodes))
  36.         (generate-known-values! rnodes)
  37.         (set-rgraph-register-known-values!
  38.          rgraph
  39.          (vector-map (lambda (rnode)
  40.                    (and rnode
  41.                     (rnode/known-value rnode)))
  42.                  rnodes))))
  43.         rgraphs))
  44.  
  45. (define (rnode/value-class rnode)
  46.   (let ((union
  47.      (reduce value-class/nearest-common-ancestor
  48.          false
  49.          ;; Here we assume that no member of
  50.          ;; `rnode/values' is a register expression.
  51.          (map rtl:expression-value-class
  52.               (rnode/values rnode)))))
  53.     ;; Really this test should look for non-leaf value
  54.     ;; classes, except that the "immediate" class (which is
  55.     ;; the only other non-leaf class) is generated by the
  56.     ;; `machine-constant' expression.  The `machine-constant'
  57.     ;; expression should be typed so that its class could be
  58.     ;; more precisely determined.
  59.     (if (and (pseudo-register? (rnode/register rnode))
  60.          (or (eq? union value-class=value)
  61.          (eq? union value-class=word)
  62.          (eq? union value-class=unboxed)))
  63.     (error "mixed-class register" rnode union))
  64.     union))
  65.  
  66. (define-structure (rnode
  67.            (conc-name rnode/)
  68.            (constructor make-rnode (register))
  69.            (print-procedure
  70.             (unparser/standard-method 'RNODE
  71.               (lambda (state rnode)
  72.             (unparse-object state (rnode/register rnode))))))
  73.   (register false read-only true)
  74.   (forward-links '())
  75.   (backward-links '())
  76.   (initial-values '())
  77.   (values '())
  78.   (known-value false)
  79.   (classified-values))
  80.  
  81. (define (generate-dataflow-graph rgraph)
  82.   (let ((rnodes (make-vector (rgraph-n-registers rgraph) false)))
  83.     (for-each (lambda (bblock)
  84.         (bblock-walk-forward bblock
  85.           (lambda (rinst)
  86.             (walk-rtl rnodes (rinst-rtl rinst)))))
  87.           (rgraph-bblocks rgraph))
  88.     (for-each-rnode rnodes
  89.       (lambda (rnode)
  90.     (set-rnode/values!
  91.      rnode
  92.      (rtx-set/union* (rnode/initial-values rnode)
  93.              (map rnode/initial-values
  94.                   (rnode/backward-links rnode))))))
  95.     rnodes))
  96.  
  97. (define (for-each-rnode rnodes procedure)
  98.   (for-each-vector-element rnodes
  99.     (lambda (rnode)
  100.       (if rnode
  101.       (procedure rnode)))))
  102.  
  103. (define (walk-rtl rnodes rtl)
  104.   (let ((get-rnode
  105.      (lambda (expression)
  106.        (let ((register (rtl:register-number expression)))
  107.          (or (vector-ref rnodes register)
  108.          (let ((rnode (make-rnode register)))
  109.            (vector-set! rnodes register rnode)
  110.            rnode))))))
  111.     (if (rtl:assign? rtl)
  112.     (let ((address (rtl:assign-address rtl))
  113.           (expression (rtl:assign-expression rtl)))
  114.       (if (rtl:pseudo-register-expression? address)
  115.           (let ((target (get-rnode address)))
  116.         (if (rtl:pseudo-register-expression? expression)
  117.             (rnode/connect! target (get-rnode expression))
  118.             (add-rnode/initial-value! target expression))))))
  119.     (let loop ((rtl rtl))
  120.       (rtl:for-each-subexpression rtl
  121.     (lambda (expression)
  122.       (if (rtl:volatile-expression? expression)
  123.           (if (or (rtl:post-increment? expression)
  124.               (rtl:pre-increment? expression))
  125.           (add-rnode/initial-value!
  126.            (get-rnode (rtl:address-register expression))
  127.            expression)
  128.           (error "Unknown volatile expression" expression))
  129.           (loop expression)))))))
  130.  
  131. (define (add-rnode/initial-value! target expression)
  132.   (let ((values (rnode/initial-values target)))
  133.     (if (not (there-exists? values
  134.            (lambda (value)
  135.          (rtl:expression=? expression value))))
  136.     (set-rnode/initial-values! target
  137.                    (cons expression values)))))
  138.  
  139. (define (rnode/connect! target source)
  140.   (if (not (memq source (rnode/backward-links target)))
  141.       (begin
  142.     (set-rnode/backward-links! target
  143.                    (cons source (rnode/backward-links target)))
  144.     (set-rnode/forward-links! source
  145.                   (cons target (rnode/forward-links source)))
  146.     (for-each (lambda (source) (rnode/connect! target source))
  147.           (rnode/backward-links source))
  148.     (for-each (lambda (target) (rnode/connect! target source))
  149.           (rnode/forward-links target)))))
  150.  
  151. (define (generate-known-values! rnodes)
  152.   (for-each-rnode rnodes
  153.     (lambda (rnode)
  154.       (set-rnode/classified-values! rnode
  155.                     (map expression->classified-value
  156.                      (rnode/values rnode)))))
  157.   (for-each-rnode rnodes
  158.     (lambda (rnode)
  159.       (let ((expression (initial-known-value (rnode/classified-values rnode))))
  160.     (set-rnode/known-value! rnode expression)
  161.     (if (not (memq expression '(UNDETERMINED #F)))
  162.         (set-rnode/classified-values! rnode '())))))
  163.   (let loop ()
  164.     (let ((new-constant? false))
  165.       (for-each-rnode rnodes
  166.     (lambda (rnode)
  167.       (if (eq? (rnode/known-value rnode) 'UNDETERMINED)
  168.           (let ((values
  169.              (values-substitution-step
  170.               rnodes
  171.               (rnode/classified-values rnode))))
  172.         (if (there-exists? values
  173.               (lambda (value)
  174.             (eq? (car value) 'SUBSTITUTABLE-REGISTERS)))
  175.             (set-rnode/classified-values! rnode values)
  176.             (let ((expression (values-unique-expression values)))
  177.               (if expression (set! new-constant? true))
  178.               (set-rnode/known-value! rnode expression)
  179.               (set-rnode/classified-values! rnode '())))))))
  180.       (if new-constant? (loop))))
  181.   (for-each-rnode rnodes
  182.     (lambda (rnode)
  183.       (if (eq? (rnode/known-value rnode) 'UNDETERMINED)
  184.       (begin
  185.         (set-rnode/known-value!
  186.          rnode
  187.          (values-unique-expression (rnode/classified-values rnode)))
  188.         (set-rnode/classified-values! rnode '()))))))
  189.  
  190. (define (expression->classified-value expression)
  191.   (cons (cond ((rtl:constant-expression? expression)
  192.            'CONSTANT)
  193.           ((rtl:contains-no-substitutable-registers? expression)
  194.            'NO-SUBSTITUTABLE-REGISTERS)
  195.           (else
  196.            'SUBSTITUTABLE-REGISTERS))
  197.     expression))
  198.  
  199. (define (initial-known-value values)
  200.   (and (not (null? values))
  201.        (not (there-exists? values
  202.           (lambda (value)
  203.         (rtl:volatile-expression? (cdr value)))))
  204.        (let loop ((value (car values)) (rest (cdr values)))
  205.      (cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED)
  206.            ((null? rest) (values-unique-expression values))
  207.            (else (loop (car rest) (cdr rest)))))))
  208.  
  209. (define (values-unique-expression values)
  210.   (let ((class (caar values))
  211.     (expression (cdar values)))
  212.     (and (for-all? (cdr values)
  213.        (lambda (value)
  214.          (and (eq? class (car value))
  215.           (rtl:expression=? expression (cdr value)))))
  216.      expression)))
  217.  
  218. (define (values-substitution-step rnodes values)
  219.   (map (lambda (value)
  220.      (if (eq? (car value) 'SUBSTITUTABLE-REGISTERS)
  221.          (let ((substitution? false))
  222.            (let ((expression
  223.               (let loop ((expression (cdr value)))
  224.             (if (rtl:register? expression)
  225.                 (let ((value
  226.                    (register-known-value rnodes expression)))
  227.                   (if value
  228.                   (begin (set! substitution? true) value)
  229.                   expression))
  230.                 (rtl:map-subexpressions expression loop)))))
  231.          (if substitution?
  232.              (expression->classified-value expression)
  233.              value)))
  234.          value))
  235.        values))
  236.  
  237. (define (register-known-value rnodes expression)
  238.   (let ((rnode (vector-ref rnodes (rtl:register-number expression))))
  239.     (and rnode
  240.      (let ((value (rnode/known-value rnode)))
  241.        (and (not (eq? value 'UNDETERMINED))
  242.         value)))))