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 / rlife.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  6.5 KB  |  175 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rlife.scm,v 1.61 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 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 Register Lifetime Analysis
  23. ;;;  Based on the GNU C Compiler
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (lifetime-analysis rgraphs)
  28.   (for-each walk-rgraph rgraphs))
  29.  
  30. (define (walk-rgraph rgraph)
  31.   (let ((n-registers (rgraph-n-registers rgraph))
  32.     (bblocks (rgraph-bblocks rgraph)))
  33.     (set-rgraph-register-bblock! rgraph (make-vector n-registers false))
  34.     (set-rgraph-register-n-refs! rgraph (make-vector n-registers 0))
  35.     (set-rgraph-register-n-deaths! rgraph (make-vector n-registers 0))
  36.     (set-rgraph-register-live-length! rgraph (make-vector n-registers 0))
  37.     (set-rgraph-register-crosses-call?! rgraph
  38.                     (make-bit-string n-registers false))
  39.     (for-each (lambda (bblock)
  40.         (set-bblock-live-at-entry! bblock (make-regset n-registers))
  41.         (set-bblock-live-at-exit! bblock (make-regset n-registers))
  42.         (set-bblock-new-live-at-exit! bblock
  43.                           (make-regset n-registers)))
  44.           bblocks)
  45.     (fluid-let ((*current-rgraph* rgraph))
  46.       (walk-bblocks bblocks))
  47.     (for-each (lambda (bblock)
  48.         (set-bblock-new-live-at-exit! bblock false))
  49.           (rgraph-bblocks rgraph))))
  50.  
  51. (define (walk-bblocks bblocks)
  52.   (let ((changed? false))
  53.     (define (loop first-pass?)
  54.       (for-each (lambda (bblock)
  55.           (if (or first-pass?
  56.               (not (regset=? (bblock-live-at-exit bblock)
  57.                      (bblock-new-live-at-exit bblock))))
  58.               (begin (set! changed? true)
  59.                  (regset-copy! (bblock-live-at-exit bblock)
  60.                        (bblock-new-live-at-exit bblock))
  61.                  (regset-copy! (bblock-live-at-entry bblock)
  62.                        (bblock-live-at-exit bblock))
  63.                  (propagate-block bblock)
  64.                  (for-each-previous-node bblock
  65.                    (lambda (bblock*)
  66.                  (regset-union!
  67.                   (bblock-new-live-at-exit bblock*)
  68.                   (bblock-live-at-entry bblock)))))))
  69.         bblocks)
  70.       (if changed?
  71.       (begin (set! changed? false)
  72.          (loop false))
  73.       (for-each (lambda (bblock)
  74.               (regset-copy! (bblock-live-at-entry bblock)
  75.                     (bblock-live-at-exit bblock))
  76.               (propagate-block&delete! bblock))
  77.             bblocks)))
  78.     (loop true)))
  79.  
  80. (define (propagate-block bblock)
  81.   (propagation-loop bblock
  82.     (lambda (dead live rinst)
  83.       (update-live-registers! (bblock-live-at-entry bblock)
  84.                   dead
  85.                   live
  86.                   (rinst-rtl rinst)
  87.                   false false))))
  88.  
  89. (define (propagate-block&delete! bblock)
  90.   (for-each-regset-member (bblock-live-at-entry bblock)
  91.     (lambda (register)
  92.       (set-register-bblock! register 'NON-LOCAL)))
  93.   (propagation-loop bblock
  94.     (lambda (dead live rinst)
  95.       (let ((rtl (rinst-rtl rinst))
  96.         (old (bblock-live-at-entry bblock)))
  97.     (if (rtl:invocation? rtl)
  98.         (for-each-regset-member old register-crosses-call!))
  99.     (if (instruction-dead? rtl old)
  100.         (set-rinst-rtl! rinst false)
  101.         (begin
  102.           (update-live-registers! old dead live rtl bblock rinst)
  103.           (for-each-regset-member old increment-register-live-length!))))))
  104.   (bblock-perform-deletions! bblock))
  105.  
  106. (define (propagation-loop bblock procedure)
  107.   (let ((dead (regset-allocate (rgraph-n-registers *current-rgraph*)))
  108.     (live (regset-allocate (rgraph-n-registers *current-rgraph*))))
  109.     (bblock-walk-backward bblock
  110.       (lambda (rinst)
  111.     (regset-clear! dead)
  112.     (regset-clear! live)
  113.     (procedure dead live rinst)))))
  114.  
  115. (define (update-live-registers! old dead live rtl bblock rinst)
  116.   (mark-set-registers! old dead rtl bblock)
  117.   (mark-used-registers! old live rtl bblock rinst)
  118.   (regset-difference! old dead)
  119.   (regset-union! old live))
  120.  
  121. (define (mark-set-registers! needed dead rtl bblock)
  122.   ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
  123.   ;; modes, since they are only used on the stack pointer.
  124.   needed
  125.   (if (rtl:assign? rtl)
  126.       (let ((address (rtl:assign-address rtl)))
  127.     (if (interesting-register? address)
  128.         (let ((register (rtl:register-number address)))
  129.           (regset-adjoin! dead register)
  130.           (if bblock (record-register-reference register bblock)))))))
  131.  
  132. (define (mark-used-registers! needed live rtl bblock rinst)
  133.   (define (loop expression)
  134.     (if (interesting-register? expression)
  135.     (let ((register (rtl:register-number expression)))
  136.       (regset-adjoin! live register)
  137.       (if bblock
  138.           (begin (record-register-reference register bblock)
  139.              (if (and (not (regset-member? needed register))
  140.                   (not (rinst-dead-register? rinst register)))
  141.              (begin (set-rinst-dead-registers!
  142.                  rinst
  143.                  (cons register
  144.                        (rinst-dead-registers rinst)))
  145.                 (increment-register-n-deaths! register))))))
  146.     (rtl:for-each-subexpression expression loop)))
  147.   (if (and (rtl:assign? rtl)
  148.        (rtl:register? (rtl:assign-address rtl)))
  149.       (if (let ((register (rtl:register-number (rtl:assign-address rtl))))
  150.         (or (machine-register? register)
  151.         (regset-member? needed register)))
  152.       (loop (rtl:assign-expression rtl)))
  153.       (rtl:for-each-subexpression rtl loop)))
  154.  
  155. (define (record-register-reference register bblock)
  156.   (let ((bblock* (register-bblock register)))
  157.     (cond ((not bblock*)
  158.        (set-register-bblock! register bblock))
  159.       ((not (eq? bblock bblock*))
  160.        (set-register-bblock! register 'NON-LOCAL)))
  161.     (increment-register-n-refs! register)))
  162.  
  163. (define (instruction-dead? rtl needed)
  164.   (and (rtl:assign? rtl)
  165.        (let ((address (rtl:assign-address rtl)))
  166.      (and (rtl:register? address)
  167.           (let ((register (rtl:register-number address)))
  168.         (and (pseudo-register? register)
  169.              (not (regset-member? needed register))))))
  170.        (not (rtl:expression-contains? (rtl:assign-expression rtl)
  171.                       rtl:volatile-expression?))))
  172.  
  173. (define (interesting-register? expression)
  174.   (and (rtl:register? expression)
  175.        (pseudo-register? (rtl:register-number expression))))