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 / simple.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  116 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: simple.scm,v 4.7 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 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. ;;;; Argument Simplicity Analysis
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (simplicity-analysis parallels)
  27.   (for-each (lambda (parallel)
  28.           (for-each (lambda (subproblem)
  29.               (set-subproblem-simple?! subproblem 'UNKNOWN))
  30.             (parallel-subproblems parallel)))
  31.         parallels)
  32.   (for-each (lambda (parallel)
  33.           (for-each walk/subproblem (parallel-subproblems parallel)))
  34.         parallels))
  35.  
  36. (define (walk/subproblem subproblem)
  37.   (if (eq? (subproblem-simple? subproblem) 'UNKNOWN)
  38.       (update-subproblem! subproblem))
  39.   (subproblem-simple? subproblem))
  40.  
  41. (define (new-subproblem/compute-simplicity! subproblem)
  42.   ;; This is currently used only when `subproblem' has no prefix; if
  43.   ;; other kinds of subproblems are supplied here, we might need to
  44.   ;; worry about changing the node walker to handle those types of
  45.   ;; nodes that are introduced later in the optimization process.
  46.   (update-subproblem! subproblem))
  47.  
  48. (define (update-subproblem! subproblem)
  49.   (set-subproblem-simple?!
  50.    subproblem
  51.    (if (subproblem-canonical? subproblem)
  52.        (walk/node (subproblem-entry-node subproblem)
  53.           (subproblem-continuation subproblem))
  54.        (and (walk/rvalue (subproblem-rvalue subproblem))
  55.         (let ((prefix (subproblem-prefix subproblem)))
  56.           (if (cfg-null? prefix)
  57.           true
  58.           (walk/node (cfg-entry-node prefix) false))))))
  59.   unspecific)
  60.  
  61. (define (walk/node node continuation)
  62.   (cfg-node-case (tagged-vector/tag node)
  63.     ((PARALLEL)
  64.      (and (for-all? (parallel-subproblems node) walk/subproblem)
  65.       (walk/next (snode-next node) continuation)))
  66.     ((APPLICATION)
  67.      (case (application-type node)
  68.        ((COMBINATION)
  69.     (if (combination/simple-inline? node)
  70.         (walk/return-operator (combination/continuation node) continuation)
  71.         (let ((callee (rvalue-known-value (combination/operator node))))
  72.           (and callee
  73.            (rvalue/procedure? callee)
  74.            (procedure-inline-code? callee)
  75.            (walk/next (procedure-entry-node callee) continuation)))))
  76.        ((RETURN)
  77.     (walk/return-operator (return/operator node) continuation))
  78.        (else
  79.     (error "Unknown application type" node))))
  80.     ((ASSIGNMENT)
  81.      (and (walk/lvalue (assignment-lvalue node))
  82.       (walk/rvalue (assignment-rvalue node))
  83.       (walk/next (snode-next node) continuation)))
  84.     ((DEFINITION)
  85.      (and (walk/lvalue (definition-lvalue node))
  86.       (walk/rvalue (definition-rvalue node))
  87.       (walk/next (snode-next node) continuation)))
  88.     ((TRUE-TEST)
  89.      (and (walk/rvalue (true-test-rvalue node))
  90.       (walk/next (pnode-consequent node) continuation)
  91.       (walk/next (pnode-alternative node) continuation)))
  92.     ((VIRTUAL-RETURN FG-NOOP)
  93.      (walk/next (snode-next node) continuation))))
  94.  
  95. (define (walk/next node continuation)
  96.   (if node
  97.       (walk/node node continuation)
  98.       (not continuation)))
  99.  
  100. (define (walk/return-operator operator continuation)
  101.   (and (return-operator/subproblem? operator)
  102.        (if (eq? operator continuation)
  103.        true
  104.        (walk/next (continuation/entry-node operator) continuation))))
  105.  
  106. (define (walk/rvalue rvalue)
  107.   (if (rvalue/reference? rvalue)
  108.       (let ((lvalue (reference-lvalue rvalue)))
  109.     (if (or (variable/value-variable? lvalue)
  110.         (lvalue-known-value lvalue))
  111.         true
  112.         (walk/lvalue lvalue)))
  113.       true))
  114.  
  115. (define (walk/lvalue lvalue)
  116.   (not (block-passed-out? (variable-block lvalue))))