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 / simapp.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  186 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: simapp.scm,v 4.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Dataflow Analysis: Simulate Application
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (simulate-application lvalues applications)
  27.   (for-each initialize-lvalue-cache! lvalues)
  28.   (for-each (lambda (application)
  29.           (set-application-operators! application '()))
  30.         applications)
  31.   (transitive-closure false process-application applications)
  32.   (for-each reset-lvalue-cache! lvalues))
  33.  
  34. (define (process-application application)
  35.   (set-application-operators!
  36.    application
  37.    (let ((operator (application-operator application)))
  38.      ((method-table-lookup process-application-methods
  39.                (tagged-vector/index operator))
  40.       (application-operators application)
  41.       operator
  42.       (operator-applicator application)))))
  43.  
  44. (define process-application-methods
  45.   (make-method-table rvalue-types
  46.              (lambda (old operator apply-operator)
  47.                old apply-operator
  48.                (warn "Possible inapplicable operator" operator)
  49.                operator)))
  50.  
  51. (let ((processor
  52.        (lambda (old operator apply-operator)
  53.      (if (not (null? old))
  54.          (error "Encountered constant-operator application twice"
  55.             operator))
  56.      (apply-operator operator)
  57.      operator)))
  58.   (define-method-table-entry 'PROCEDURE process-application-methods processor)
  59.   (define-method-table-entry 'CONSTANT process-application-methods processor))
  60.  
  61. (define-method-table-entry 'REFERENCE process-application-methods
  62.   (lambda (old operator apply-operator)
  63.     (let ((new (lvalue-values-cache (reference-lvalue operator))))
  64.       (let loop ((operators new))
  65.     ;; We can use `eq?' here because we assume that
  66.     ;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
  67.     ;; This is also noted at the definition of `eq-set-union'.
  68.     (if (eq? operators old)
  69.         new
  70.         (begin (apply-operator (car operators))
  71.            (loop (cdr operators))))))))
  72.  
  73. (define (operator-applicator application)
  74.   (let ((operands (application-operands application)))
  75.     (let ((number-supplied (length operands)))
  76.       (lambda (operator)
  77.     (cond ((rvalue/procedure? operator)
  78.            (set-procedure-applications!
  79.         operator
  80.         (cons application (procedure-applications operator)))
  81.            (if (not (procedure-arity-correct? operator number-supplied))
  82.            (warn "Wrong number of arguments" operator operands))
  83.            ;; We should have some kind of LIST rvalue type to handle
  84.            ;; the case of rest parameters, but for now we just
  85.            ;; define them to be passed-in.  This is handled
  86.            ;; specially in that part of the analysis.
  87.            (let loop
  88.            ((parameters
  89.              (append (procedure-required operator)
  90.                  (procedure-optional operator)))
  91.             (operands operands))
  92.          (if (not (null? parameters))
  93.              (if (null? operands)
  94.              (for-each lvalue-unassigned! parameters)
  95.              (begin
  96.                (lvalue-connect! (car parameters) (car operands))
  97.                (loop (cdr parameters) (cdr operands)))))))
  98.           ((rvalue/constant? operator)
  99.            (let ((value (constant-value operator))
  100.              (argument-count (-1+ number-supplied)))
  101.          (if (not
  102.               (cond ((eq? value compiled-error-procedure)
  103.                  (positive? argument-count))
  104.                 ((scode/procedure? value)
  105.                  (procedure-arity-valid? value argument-count))
  106.                 (else
  107.                  (if (not (unassigned-reference-trap? value))
  108.                  (warn "Possible inapplicable operator" value))
  109.                  true)))
  110.              (warn
  111.               "Procedure called with wrong number of arguments"
  112.               value
  113.               number-supplied))))
  114.           (else
  115.            (warn "Possible inapplicable operator" operator)))))))
  116.  
  117. (define (initialize-lvalue-cache! lvalue)
  118.   (set-lvalue-values-cache! lvalue (lvalue-values lvalue)))
  119.  
  120. (define (lvalue-values lvalue)
  121.   ;; This is slow but works even with cycles in the DFG.
  122.   (let ((lvalues '()))
  123.     (let loop ((lvalue lvalue))
  124.       (if (not (memq lvalue lvalues))
  125.       (begin (set! lvalues (cons lvalue lvalues))
  126.          (for-each loop (lvalue-backward-links lvalue)))))
  127.     (eq-set-union* (lvalue-initial-values (car lvalues))
  128.            (map lvalue-initial-values (cdr lvalues)))))
  129.  
  130. (define (lvalue-unassigned! lvalue)
  131.   (lvalue-connect! lvalue (make-constant (make-unassigned-reference-trap))))
  132.  
  133. (define-integrable (lvalue-connect! lvalue rvalue)
  134.   (if (rvalue/reference? rvalue)
  135.       (lvalue-connect!:lvalue lvalue (reference-lvalue rvalue))
  136.       (lvalue-connect!:rvalue lvalue rvalue)))
  137.  
  138. (define (lvalue-connect!:rvalue lvalue rvalue)
  139.   (if (not (memq rvalue (lvalue-initial-values lvalue)))
  140.       (begin
  141.     (set-lvalue-initial-values! lvalue
  142.                     (cons rvalue
  143.                       (lvalue-initial-values lvalue)))
  144.     (if (not (memq rvalue (lvalue-values-cache lvalue)))
  145.         (begin
  146.           (update-lvalue-cache! lvalue rvalue)
  147.           (for-each (lambda (lvalue)
  148.               (if (not (memq rvalue (lvalue-values-cache lvalue)))
  149.                   (update-lvalue-cache! lvalue rvalue)))
  150.             (lvalue-forward-links lvalue)))))))
  151.  
  152. (define (update-lvalue-cache! lvalue rvalue)
  153.   (enqueue-nodes! (lvalue-applications lvalue))
  154.   (set-lvalue-values-cache! lvalue
  155.                 (cons rvalue
  156.                   (lvalue-values-cache lvalue))))
  157.  
  158. (define (lvalue-connect!:lvalue to from)
  159.   (if (not (memq from (lvalue-initial-backward-links to)))
  160.       (begin
  161.     (set-lvalue-initial-backward-links!
  162.      to
  163.      (cons from (lvalue-initial-backward-links to)))
  164.     (set-lvalue-initial-forward-links!
  165.      from
  166.      (cons to (lvalue-initial-forward-links from)))))
  167.   (letrec ((connect
  168.         (lambda (to from)
  169.           (if (not (memq from (lvalue-backward-links to)))
  170.           (begin
  171.             (enqueue-nodes! (lvalue-applications to))
  172.             (set-lvalue-backward-links!
  173.              to
  174.              (cons from (lvalue-backward-links to)))
  175.             (set-lvalue-forward-links!
  176.              from
  177.              (cons to (lvalue-forward-links from)))
  178.             (set-lvalue-values-cache!
  179.              to
  180.              (eq-set-union (lvalue-values-cache from)
  181.                    (lvalue-values-cache to)))
  182.             (for-each (lambda (from) (connect to from))
  183.                   (lvalue-backward-links from))
  184.             (for-each (lambda (to) (connect to from))
  185.                   (lvalue-forward-links to)))))))
  186.     (connect to from)))