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 / param.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  279 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: param.scm,v 1.4 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. ;;;; Argument Ordering Analysis
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Procedure parameter analysis
  27. #|
  28.  
  29. A procedure is eligible for having its parameters be placed in
  30. registers (i.e. the procedure is "registerizable") if the procedure
  31. will be inlined and the frame reuse routine has not tried to overwrite
  32. anything in the stack frame of this procedure or the stack frame
  33. associated with any ancestors of this procedure's block.
  34.  
  35. Assuming that a procedure is registerizable, the parameter analysis
  36. phase determines which of it's parameters will indeed be passed in
  37. registers.
  38.  
  39. A parameter will be passed in a register if all references to that
  40. parameter in the procedure occur before any calls to complex
  41. procedures. A complex procedure is essentially a non-inlined,
  42. non-open-coded procedure. Additionally, we must check to make sure
  43. that there are no references to the parameter in any closures or
  44. descendent blocks. Note that inlined and open-coded procedures that
  45. are called within the analysed procedure are considered to be part of
  46. that procedure.
  47.  
  48. At certain times (when we hit an as yet unordered parallel) we have
  49. the opportunity to suggest an ordering of subproblems for a particular
  50. parallel. We take that opportunity to request an ordering which would
  51. place a reference to a parameter before any calls to complex procedures.
  52. The order-parallel! procedure is free to ignore our suggestions.
  53.  
  54. A major deficit with the current scheme is the restriction on
  55. registerizable procedures caused by the frame reuse stuff. The frame
  56. reuse code is very aggressive and consequently there are very few
  57. occasions where we can in fact place parameters in registers. The
  58. problem is that the frame reuse code needs to know the stack layout,
  59. but the placing of parameters in registers affects the use of the
  60. stack. And because the parameter analysis code may call the subproblem
  61. ordering code which may call the frame reuse code, we have a very
  62. tricky timing problem. The correct solution may be to use a relaxation
  63. technique and iterate the subproblem ordering so that we can put more
  64. parameters in registers.
  65.  
  66. |#
  67.  
  68. (define (parameter-analysis procedure)
  69.   (fluid-let ((*inlined-procedures* '()))
  70.     (let ((interesting-parameters
  71.        (list-transform-positive (procedure-required procedure)
  72.          interesting-variable?)))
  73.       (if interesting-parameters
  74.       (let ((registerizable-parameters
  75.          (with-new-node-marks
  76.           (lambda ()
  77.             (walk-node-for-search
  78.              (procedure-entry-node procedure))))))
  79.         ;; We have to check here if this procedure's block layout
  80.         ;; has been frozen by the frame reuse stuff which may
  81.         ;; have been called due to a call to order-parallel!
  82.         (if (block-layout-frozen? (procedure-block procedure))
  83.         '()
  84.         (eq-set-difference
  85.          (eq-set-difference interesting-parameters
  86.                     registerizable-parameters)
  87.          (bad-free-variables procedure))))
  88.       '()))))
  89.  
  90. (define (walk-node-for-search node)
  91.   (if (and node
  92.        (or (node-marked? node)
  93.            (begin
  94.          (node-mark! node)
  95.          (not (node-previous>1? node)))))
  96.       (or (node/bad-variables node)
  97.       (cond ((and (application? node)
  98.               (application/combination? node)
  99.               (not (combination/simple-inline? node))
  100.               (not (let ((operator
  101.                   (rvalue-known-value
  102.                    (application-operator node))))
  103.                  (and operator
  104.                   (rvalue/procedure? operator)
  105.                   (procedure-inline-code? operator)))))
  106.          (walk-next node walk-node-for-variables))
  107.         ((parallel? node)
  108.          (walk-node-for-search
  109.           (order-parallel!
  110.            node
  111.            (let ((subproblems (parallel-subproblems node)))
  112.              (if (for-all? subproblems subproblem-simple?)
  113.              false
  114.              (complex-parallel-constraints
  115.               subproblems
  116.               (walk-next node walk-node-for-variables)))))))
  117.         (else
  118.          (walk-next node walk-node-for-search))))
  119.       '()))
  120.  
  121. (define (walk-next node walker)
  122.   (cond ((application? node)
  123.      (case (application-type node)
  124.        ((COMBINATION)
  125.         (let ((operator (rvalue-known-value (application-operator node))))
  126.           (if (and operator
  127.                (rvalue/procedure? operator)
  128.                (procedure-inline-code? operator))
  129.           (begin
  130.             (set! *inlined-procedures*
  131.               (cons operator *inlined-procedures*))
  132.             (walker (procedure-entry-node operator)))
  133.           (walk-continuation (combination/continuation node) walker))))
  134.        ((RETURN)
  135.         (walk-continuation (return/operator node) walker))
  136.        (else
  137.         (error "Illegal application type" node))))
  138.     ((snode? node)
  139.      (walker (snode-next node)))
  140.     ((pnode? node)
  141.      (eq-set-union (walker (pnode-consequent node))
  142.                (walker (pnode-alternative node))))
  143.     (else
  144.      (error "Illegal node" node))))
  145.  
  146. (define *inlined-procedures*)
  147.  
  148. (define (walk-continuation continuation walker)
  149.   (let ((rvalue (rvalue-known-value continuation)))
  150.     (walker (and rvalue (continuation/entry-node rvalue)))))
  151.  
  152. (define (walk-node-for-variables node)
  153.   (if node
  154.       (if (parallel? node)
  155.       (walk-node-for-variables (order-parallel! node false))
  156.       (begin
  157.         (node-mark! node)
  158.         (or (node/bad-variables node)
  159.         (let ((bad-variables
  160.                (eq-set-union
  161.             (with-values (lambda () (find-node-values node))
  162.               values->variables)
  163.             (walk-next node walk-node-for-variables))))
  164.           (set-node/bad-variables! node bad-variables)
  165.           bad-variables))))
  166.       '()))
  167.  
  168. (define (find-node-values node)
  169.   (let ((finish
  170.      (lambda (lvalue rvalue)
  171.        (values lvalue (if rvalue (list rvalue) '())))))
  172.     (cfg-node-case (tagged-vector/tag node)
  173.       ((APPLICATION)
  174.        (case (application-type node)
  175.      ((COMBINATION)
  176.       (values false
  177.           (cons (combination/operator node)
  178.             (combination/operands node))))
  179.      ((RETURN)
  180.       (finish false (return/operand node)))
  181.      (else
  182.       (error "Illegal application type" node))))
  183.       ((VIRTUAL-RETURN)
  184.        (finish false (virtual-return-operand node)))
  185.       ((ASSIGNMENT)
  186.        (finish (assignment-lvalue node)
  187.            (assignment-rvalue node)))
  188.       ((DEFINITION)
  189.        (finish (definition-lvalue node)
  190.            (definition-rvalue node)))
  191.       ((STACK-OVERWRITE)
  192.        (values (let ((target (stack-overwrite-target node)))
  193.          (and (lvalue? target) target))
  194.            '()))
  195.       ((PARALLEL)
  196.        (values false
  197.            (append-map subproblem-free-variables
  198.                (parallel-subproblems node))))
  199.       ((POP FG-NOOP)
  200.        (values false '()))
  201.       ((TRUE-TEST)
  202.        (finish false (true-test-rvalue node))))))
  203.  
  204. (define (values->variables lvalue rvalues)
  205.   (eq-set-union
  206.    (list->eq-set
  207.     (and lvalue
  208.      (lvalue/variable? lvalue)
  209.      (interesting-variable? lvalue)
  210.      (list lvalue)))
  211.    (map->eq-set (lambda (rvalue) (reference-lvalue rvalue))
  212.         (list-transform-positive rvalues
  213.           (lambda (rvalue)
  214.             (and (rvalue/reference? rvalue)
  215.              (let ((lvalue (reference-lvalue rvalue)))
  216.                (and lvalue
  217.                 (lvalue/variable? lvalue)
  218.                 (interesting-variable? lvalue)))))))))
  219.  
  220. (define (complex-parallel-constraints subproblems vars-referenced-later)
  221.   (with-values (lambda () (discriminate-items subproblems subproblem-simple?))
  222.     (lambda (simple complex)
  223.       (let ((discriminate-by-bad-vars
  224.          (lambda (subproblems)
  225.            (discriminate-items subproblems
  226.          (lambda (subproblem)
  227.            (there-exists? (subproblem-free-variables subproblem)
  228.              (lambda (var)
  229.                (memq var vars-referenced-later)))))))
  230.         (constraint-graph (make-constraint-graph)))
  231.     (with-values (lambda () (discriminate-by-bad-vars simple))
  232.       (lambda (good-simples bad-simples)
  233.         (with-values (lambda () (discriminate-by-bad-vars complex))
  234.           (lambda (good-complex bad-complex)
  235.         (add-constraint-set! good-simples
  236.                      good-complex
  237.                      constraint-graph)
  238.         (add-constraint-set! good-complex
  239.                      (append bad-simples bad-complex)
  240.                      constraint-graph)))
  241.         constraint-graph))))))
  242.  
  243. (define-integrable (node/bad-variables node)
  244.   (cfg-node-get node node/bad-variables-tag))
  245.  
  246. (define-integrable (set-node/bad-variables! node refs)
  247.   (cfg-node-put! node node/bad-variables-tag refs))
  248.  
  249. (define node/bad-variables-tag
  250.   "bad-variables-tag")
  251.  
  252. (define (bad-free-variables procedure)
  253.   (append-map block-variables-nontransitively-free
  254.           (list-transform-negative
  255.           (cdr (linearize-block-tree (procedure-block procedure)))
  256.         (lambda (block)
  257.           (memq (block-procedure block) *inlined-procedures*)))))
  258.  
  259. ;;; Since the order of this linearization is not important we could
  260. ;;; make this routine more efficient. I'm not sure that it is worth
  261. ;;; it. If anyone does change it you should probably alter the line in
  262. ;;; bad-free-variables that says "(cdr (line..." to
  263. ;;; "(delq block (line..."
  264. (define (linearize-block-tree block)
  265.   (let ((children
  266.      (append (block-children block) (block-disowned-children block))))
  267.     (if (null? children)
  268.     (list block)
  269.     (cons block (append-map! linearize-block-tree children)))))
  270.  
  271. (define (interesting-variable? variable)
  272.   ;;; variables that will be in cells are eliminated from
  273.   ;;; being put in registers because I couldn't figure out
  274.   ;;; how to get the right code generated for them. Oh well,
  275.   ;;; sigh! 
  276.   (not (or (variable-assigned? variable)
  277.        (variable-stack-overwrite-target? variable)
  278.        (variable/continuation-variable? variable)
  279.        (variable/value-variable? variable))))