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 / folcon.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  236 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: folcon.scm,v 4.9 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. ;;;; Constant Folding
  23. ;; Package: (compiler fg-optimizer fold-constants)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (fold-constants lvalues applications)
  28.   #|
  29.   ;; This is needed only if we use the version of eliminate-known-nodes
  30.   ;; commented out below.
  31.   ;; 
  32.   ;; Initialize
  33.   ;; a. Remove circularities
  34.   (for-each (lambda (lvalue)
  35.           (set-lvalue-source-links!
  36.            lvalue
  37.            (list-transform-negative
  38.            (lvalue-backward-links lvalue)
  39.          (lambda (lvalue*)
  40.            (memq lvalue (lvalue-backward-links lvalue*))))))
  41.         lvalues)
  42.   ;; b. Remove nop nodes
  43.   (transitive-closure false delete-if-nop! lvalues)
  44.   |#
  45.   ;; Do the actual work
  46.   (let loop
  47.       ((lvalues lvalues)
  48.        (combinations
  49.     (list-transform-positive applications application/combination?)))
  50.     (let ((unknown-lvalues (eliminate-known-nodes lvalues)))
  51.       (transmit-values (fold-combinations combinations)
  52.     (lambda (any-folded? not-folded)
  53.       (if any-folded?
  54.           (loop unknown-lvalues not-folded)
  55.           not-folded))))))
  56.  
  57. #|
  58. (define (delete-if-nop! lvalue)
  59.   (if (and (not (lvalue-passed-in? lvalue))
  60.        (null? (lvalue-values lvalue))
  61.        (null? (lvalue-source-links lvalue)))
  62.       (for-each
  63.        (lambda (lvalue*)
  64.      (set-lvalue-source-links!
  65.       lvalue*
  66.       (delq! lvalue (lvalue-source-links lvalue*)))
  67.      (enqueue-node! lvalue*))
  68.        (lvalue-forward-links lvalue))))
  69. |#
  70.  
  71. #|
  72. (define (eliminate-known-nodes lvalues)
  73.   (let ((knowable-nodes
  74.      (list-transform-positive lvalues
  75.        (lambda (lvalue)
  76.          (and (not (or (lvalue-passed-in? lvalue)
  77.                (and (variable? lvalue)
  78.                 (variable-assigned? lvalue)
  79.                 (not (memq 'CONSTANT
  80.                        (variable-declarations lvalue))))))
  81.           (let ((values (lvalue-values lvalue)))
  82.             (and (not (null? values))
  83.              (null? (cdr values))
  84.              (or (rvalue/procedure? (car values))
  85.                  (rvalue/constant? (car values))))))))))
  86.     (with-new-lvalue-marks
  87.      (lambda ()
  88.        (for-each lvalue-mark! knowable-nodes)
  89.        (transitive-closure false delete-if-known! knowable-nodes))))
  90.   (list-transform-negative lvalues lvalue-known-value))
  91.  
  92. (define (delete-if-known! lvalue)
  93.   (if (and (not (lvalue-known-value lvalue))
  94.        (for-all? (lvalue-source-links lvalue) lvalue-known-value))
  95.       (let ((value (car (lvalue-values lvalue))))
  96.     (for-each (lambda (lvalue*)
  97.             (if (lvalue-marked? lvalue*)
  98.             (enqueue-node! lvalue*)))
  99.           (lvalue-forward-links lvalue))
  100.     (set-lvalue-known-value! lvalue value))))
  101. |#
  102.  
  103. (define (eliminate-known-nodes lvalues)
  104.   (list-transform-negative lvalues
  105.     (lambda (lvalue)
  106.       (and (not (or (lvalue-passed-in? lvalue)
  107.             (and (variable? lvalue)
  108.              (variable-assigned? lvalue)
  109.              (not (memq 'CONSTANT
  110.                     (variable-declarations lvalue))))))
  111.        (let ((values (lvalue-values lvalue)))
  112.          (and (not (null? values))
  113.           (null? (cdr values))
  114.           (let ((value (car values)))
  115.             (and (or (rvalue/procedure? value)
  116.                  (rvalue/constant? value))
  117.              (begin
  118.                (set-lvalue-known-value! lvalue value)
  119.                true)))))))))
  120.  
  121. #|
  122. (define (fold-combinations combinations)
  123.   (if (null? combinations)
  124.       (return-2 false '())
  125.       (transmit-values (fold-combinations (cdr combinations))
  126.     (lambda (any-folded? not-folded)
  127.       (if (fold-combination (car combinations))
  128.           (return-2 true not-folded)
  129.           (return-2 any-folded? (cons (car combinations) not-folded)))))))
  130. |#
  131.  
  132. (define (fold-combinations combinations)
  133.   ;; (return-2 any-folded? not-folded)
  134.   (let ((left combinations)
  135.     (any-folded? false)
  136.     (not-folded '()))
  137.     (let restart-loop ()
  138.       (with-simple-restart 'CONTINUE
  139.     "Skip this constant-folding operation"
  140.     (lambda ()
  141.       (let fold-loop ()
  142.         (if (not (null? left))
  143.         (begin
  144.           (if (fold-combination (car left))
  145.               (set! any-folded? true)
  146.               (set! not-folded (cons (car left) not-folded)))
  147.           (set! left (cdr left))
  148.           (fold-loop))))))
  149.       (if (not (null? left))
  150.       (begin
  151.         ;; This means that folding the current combination caused an error,
  152.         ;; and the user decided to skip.
  153.         (set! not-folded (cons (car left) not-folded))
  154.         (set! left (cdr left))
  155.         (restart-loop))))
  156.     (return-2 any-folded? (reverse! not-folded))))
  157.  
  158. (define (fold-combination combination)
  159.   (let ((operator (combination/operator combination))
  160.     (continuation (combination/continuation combination))
  161.     (operands (combination/operands combination)))
  162.     (and (constant-foldable-operator? operator)
  163.      ;; (rvalue-known? continuation)
  164.      ;; (uni-continuation? (rvalue-known-value continuation))
  165.      (for-all? operands rvalue-known-constant?)
  166.      (let ((op (constant-foldable-operator-value operator)))
  167.        (and (or (arity-correct? op (length operands))
  168.             (begin
  169.               (error "fold-combination: Wrong number of arguments"
  170.                  op (length operands))
  171.               false))
  172.         (let ((constant
  173.                (make-constant
  174.             (apply op (map rvalue-constant-value operands)))))
  175.           (combination/constant! combination constant)
  176.           (for-each (lambda (value)
  177.                   (if (uni-continuation? value)
  178.                   (maybe-fold-lvalue!
  179.                    (uni-continuation/parameter value)
  180.                    constant)))
  181.                 (rvalue-values continuation))
  182.           true))))))
  183.  
  184. (define (maybe-fold-lvalue! lvalue constant)
  185.   (lvalue-connect!:rvalue lvalue constant)
  186.   (reset-lvalue-cache! lvalue)
  187.   (let ((val (lvalue-passed-in? lvalue)))
  188.     (if (or (false? val) (eq? val 'INHERITED))         ; (not (number? val))
  189.     (error "maybe-fold-lvalue!: Folding a non source!" lvalue)
  190.     (let ((new (-1+ val)))
  191.       (cond ((not (zero? new))
  192.          (set-lvalue-passed-in?! lvalue new))
  193.         ((recompute-lvalue-passed-in! lvalue)
  194.          (for-each (lambda (lvalue)
  195.                  ;; We don't recompute-lvalue-passed-in!
  196.                  ;; recursively because the forward-link
  197.                  ;; relationship is transitively closed.
  198.                  (if (eq? (lvalue-passed-in? lvalue) 'INHERITED)
  199.                  (recompute-lvalue-passed-in! lvalue)))
  200.                (lvalue-forward-links lvalue))))))))
  201.  
  202. ;; This returns true if the lvalue went from passed-in to not
  203. ;; passed-in.  It initializes the value to false because it may
  204. ;; be in its own backward-link list.
  205.  
  206. (define (recompute-lvalue-passed-in! lvalue)
  207.   (set-lvalue-passed-in?! lvalue false)
  208.   (if (there-exists? (lvalue-backward-links lvalue) lvalue-passed-in?)
  209.       (begin
  210.     (set-lvalue-passed-in?! lvalue 'INHERITED)
  211.     ;; The assignment would return the right value, but this is clearer.
  212.     false)
  213.       true))
  214.  
  215. (define (constant-foldable-operator? rv)
  216.   (or (and (rvalue-known-constant? rv)
  217.        (let ((val (rvalue-constant-value rv)))
  218.          (and (primitive-procedure? val)
  219.           (constant-foldable-primitive? val))))
  220.       (and (rvalue/reference? rv)
  221.        ;; (not (reference-known-value rv))
  222.        (not (reference-to-known-location? rv))
  223.        (let ((var (reference-lvalue rv)))
  224.          (and (memq 'USUAL-DEFINITION (variable-declarations var))
  225.           (constant-foldable-variable? (variable-name var)))))))
  226.  
  227. (define (constant-foldable-operator-value rv)
  228.   (if (rvalue/reference? rv)
  229.       (variable-usual-definition (variable-name (reference-lvalue rv)))
  230.       (rvalue-constant-value rv)))  
  231.  
  232. (define (arity-correct? proc n)
  233.   (let ((arity (procedure-arity proc)))
  234.     (and (>= n (car arity))
  235.      (or (null? (cdr arity))
  236.          (<= n (cdr arity))))))