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 / fgopt / varind.scm < prev   
Text File  |  1999-01-02  |  3KB  |  85 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: varind.scm,v 1.5 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989, 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. ;;;; Variable Indirections
  23. ;;; package: (compiler fg-optimizer variable-indirection)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-variable-indirections! lvalues)
  28.   (with-new-lvalue-marks
  29.    (lambda ()
  30.      (for-each (lambda (lvalue)
  31.          (if (and (lvalue/variable? lvalue)
  32.               (not (variable/continuation-variable? lvalue))
  33.               (not (variable/value-variable? lvalue)))
  34.              (initialize-variable-indirection! lvalue)))
  35.            lvalues))))
  36.  
  37. (define (initialize-variable-indirection! variable)
  38.   (if (and (not (lvalue-marked? variable))
  39.        (not (variable-indirection variable)))
  40.       (begin
  41.     (lvalue-mark! variable)
  42.     (let ((block (variable-block variable)))
  43.       (and (not (lvalue-known-value variable))
  44.            (null? (variable-assignments variable))
  45.            (not (variable-closed-over? variable))
  46.            (not (lvalue/source? variable))
  47.            (not (block-passed-out? block))
  48.            (let ((indirection
  49.               (let ((possibility
  50.                  (let ((links
  51.                     (lvalue-initial-backward-links variable)))
  52.                    (and (not (null? links))
  53.                     (null? (cdr links))
  54.                     (car links)))))
  55.             (and possibility
  56.                  (lvalue/variable? possibility)
  57.                  (null? (variable-assignments possibility))
  58.                  (not (variable-closed-over? possibility))
  59.                  (let ((block* (variable-block possibility)))
  60.                    (and (not (block-passed-out? block*))
  61.                     (block-ancestor? block block*)))
  62.                  (begin
  63.                    (initialize-variable-indirection! possibility)
  64.                    (or (variable-indirection possibility)
  65.                    (cons possibility false)))))))
  66.          (if indirection
  67.              (let ((indirection-variable (car indirection)))
  68.                (set-variable-indirection! variable indirection)
  69.                (let ((variables
  70.                   (block-variables-nontransitively-free block)))
  71.              (if (not (memq indirection-variable variables))
  72.                  (set-block-variables-nontransitively-free!
  73.                   block
  74.                   (cons indirection-variable variables))))
  75.                (let ((block* (variable-block indirection-variable)))
  76.              (let loop ((block block))
  77.                (let ((variables (block-free-variables block)))
  78.                  (if (not (memq indirection-variable variables))
  79.                  (begin
  80.                    (set-block-free-variables!
  81.                     block
  82.                     (cons indirection-variable variables))
  83.                    (let ((parent (block-parent block)))
  84.                      (if (not (eq? parent block*))
  85.                      (loop parent))))))))))))))))