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 / rtlbase / rtlcfg.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  205 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rtlcfg.scm,v 4.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 1988, 1989, 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 CFG Nodes
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-snode sblock)
  27. (define-pnode pblock)
  28.  
  29. (define-vector-slots bblock 6
  30.   instructions
  31.   live-at-entry
  32.   live-at-exit
  33.   (new-live-at-exit register-map)
  34.   label
  35.   continuations)
  36.  
  37. (define-vector-slots sblock 12
  38.   continuation)
  39.  
  40. (define (make-sblock instructions)
  41.   (make-pnode sblock-tag instructions false false false false '() false))
  42.  
  43. (define-vector-slots pblock 12
  44.   consequent-lap-generator
  45.   alternative-lap-generator)
  46.  
  47. (define (make-pblock instructions)
  48.   (make-pnode pblock-tag instructions false false false false '() false false))
  49.  
  50. (define-integrable (statement->srtl statement)
  51.   (snode->scfg (make-sblock (make-rtl-instruction statement))))
  52.  
  53. (define-integrable (predicate->prtl predicate)
  54.   (pnode->pcfg (make-pblock (make-rtl-instruction predicate))))
  55.  
  56. (let ((bblock-describe
  57.        (lambda (bblock)
  58.      (descriptor-list bblock
  59.               instructions
  60.               live-at-entry
  61.               live-at-exit
  62.               register-map
  63.               label
  64.               continuations))))
  65.   (set-vector-tag-description!
  66.    sblock-tag
  67.    (lambda (sblock)
  68.      (append! ((vector-tag-description snode-tag) sblock)
  69.           (bblock-describe sblock)
  70.           (descriptor-list sblock
  71.                    continuation))))
  72.   (set-vector-tag-description!
  73.    pblock-tag
  74.    (lambda (pblock)
  75.      (append! ((vector-tag-description pnode-tag) pblock)
  76.           (bblock-describe pblock)
  77.           (descriptor-list pblock
  78.                    consequent-lap-generator
  79.                    alternative-lap-generator)))))
  80.  
  81. (define-integrable (bblock-reversed-instructions bblock)
  82.   (rinst-reversed (bblock-instructions bblock)))
  83.  
  84. (define (bblock-compress! bblock limit-predicate)
  85.   (let ((walk-next?
  86.      (if limit-predicate
  87.          (lambda (next) (and next (not (limit-predicate next))))
  88.          (lambda (next) next))))
  89.     (let walk-bblock ((bblock bblock))
  90.       (if (not (node-marked? bblock))
  91.       (begin
  92.         (node-mark! bblock)
  93.         (if (sblock? bblock)
  94.         (let ((next (snode-next bblock)))
  95.           (if (walk-next? next)
  96.               (begin
  97.             (if (null? (cdr (node-previous-edges next)))
  98.                 (begin
  99.                   (set-rinst-next!
  100.                    (rinst-last (bblock-instructions bblock))
  101.                    (bblock-instructions next))
  102.                   (set-bblock-instructions!
  103.                    next
  104.                    (bblock-instructions bblock))
  105.                   (snode-delete! bblock)))
  106.             (walk-bblock next))))
  107.         (begin
  108.           (let ((consequent (pnode-consequent bblock)))
  109.             (if (walk-next? consequent)
  110.             (walk-bblock consequent)))
  111.           (let ((alternative (pnode-alternative bblock)))
  112.             (if (walk-next? alternative)
  113.             (walk-bblock alternative))))))))))
  114.  
  115. (define (bblock-walk-forward bblock procedure)
  116.   (let loop ((rinst (bblock-instructions bblock)))
  117.     (procedure rinst)
  118.     (if (rinst-next rinst) (loop (rinst-next rinst)))))
  119.  
  120. (define (bblock-walk-backward bblock procedure)
  121.   (let loop ((rinst (bblock-instructions bblock)))
  122.     (if (rinst-next rinst) (loop (rinst-next rinst)))
  123.     (procedure rinst)))
  124.  
  125. (define (bblock-label! bblock)
  126.   (or (bblock-label bblock)
  127.       (let ((label (generate-label)))
  128.     (set-bblock-label! bblock label)
  129.     label)))
  130.  
  131. (define (bblock-perform-deletions! bblock)
  132.   (define (loop rinst)
  133.     (let ((next
  134.        (and (rinst-next rinst)
  135.         (loop (rinst-next rinst)))))
  136.       (if (rinst-rtl rinst)
  137.       (begin (set-rinst-next! rinst next)
  138.          rinst)
  139.       next)))
  140.   (let ((instructions (loop (bblock-instructions bblock))))
  141.     (if instructions
  142.     (set-bblock-instructions! bblock instructions)
  143.     (begin
  144.       (snode-delete! bblock)
  145.       (set-rgraph-bblocks! *current-rgraph*
  146.                    (delq! bblock
  147.                       (rgraph-bblocks *current-rgraph*)))))))
  148.  
  149. (define-integrable (pcfg/prefer-consequent! pcfg)
  150.   (pcfg/prefer-branch! 'CONSEQUENT pcfg))
  151.  
  152. (define-integrable (pcfg/prefer-alternative! pcfg)
  153.   (pcfg/prefer-branch! 'ALTERNATIVE pcfg))
  154.  
  155. (define (pcfg/prefer-branch! branch pcfg)
  156.   (let loop ((bblock (cfg-entry-node pcfg)))
  157.     (cond ((pblock? bblock)
  158.        (cfg-node-put! bblock cfg/prefer-branch/tag branch))
  159.       ((sblock? bblock)
  160.        (loop (snode-next bblock)))
  161.       (else
  162.        (error "PCFG/PREFER-BRANCH!: Unknown bblock type" bblock))))
  163.   pcfg)
  164.  
  165. (define-integrable (pnode/preferred-branch pnode)
  166.   (cfg-node-get pnode cfg/prefer-branch/tag))
  167.  
  168. (define cfg/prefer-branch/tag
  169.   (intern "#[(compiler)cfg/prefer-branch]"))
  170.  
  171. ;;;; RTL Instructions
  172.  
  173. (define-vector-slots rinst 0
  174.   rtl
  175.   dead-registers
  176.   next)
  177.  
  178. (define (make-rtl-instruction rtl)
  179.   (vector rtl '() false))
  180.  
  181. (define-integrable (rinst-dead-register? rinst register)
  182.   (memq register (rinst-dead-registers rinst)))
  183.  
  184. (define (rinst-last rinst)
  185.   (if (rinst-next rinst)
  186.       (rinst-last (rinst-next rinst))
  187.       rinst))
  188.  
  189. (define (rinst-disconnect-previous! bblock rinst)
  190.   (let loop ((rinst* (bblock-instructions bblock)))
  191.     (if (eq? rinst (rinst-next rinst*))
  192.     (set-rinst-next! rinst* false)
  193.     (loop (rinst-next rinst*)))))
  194.  
  195. (define (rinst-length rinst)
  196.   (let loop ((rinst rinst) (length 0))
  197.     (if rinst
  198.     (loop (rinst-next rinst) (1+ length))
  199.     length)))
  200.  
  201. (define (rinst-reversed rinst)
  202.   (let loop ((rinst rinst) (result '()))
  203.     (if rinst
  204.     (loop (rinst-next rinst) (cons rinst result))
  205.     result)))