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 / order.scm < prev    next >
Text File  |  2000-05-03  |  15KB  |  444 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: order.scm,v 4.17 2000/05/03 19:18:28 cph Exp $
  4.  
  5. Copyright (c) 1988-1990, 1999, 2000 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. (define (subproblem-ordering parallels)
  27.   (for-each (lambda (parallel)
  28.           (order-parallel! parallel #f))
  29.         parallels))
  30.  
  31. (define (order-parallel! parallel constraints)
  32.   constraints ;ignore
  33.   (let ((previous-edges (node-previous-edges parallel))
  34.     (next-edge (snode-next-edge parallel)))
  35.     (let ((rest (edge-next-node next-edge)))
  36.       (if rest
  37.       (begin
  38.         (edges-disconnect-right! previous-edges)
  39.         (edge-disconnect! next-edge)
  40.         (with-values
  41.         (lambda ()
  42.           (order-subproblems/application
  43.            (parallel-application-node parallel)
  44.            (parallel-subproblems parallel)
  45.            rest))
  46.           (lambda (cfg subproblem-order)
  47.         subproblem-order
  48.         (edges-connect-right! previous-edges cfg)
  49.         cfg)))))))
  50.  
  51. (define (order-subproblems/application application subproblems rest)
  52.   (case (application-type application)
  53.     ((COMBINATION)
  54.      (if (and (combination/inline? application)
  55.           (or (combination/simple-inline? application)
  56.           (not (return-operator/reduction?
  57.             (combination/continuation application)))))
  58.      (order-subproblems/inline application subproblems rest)
  59.      (order-subproblems/out-of-line application subproblems rest)))
  60.     ((RETURN)
  61.      (values
  62.       (linearize-subproblems! continuation-type/effect subproblems '() rest)
  63.       subproblems))
  64.     (else
  65.      (error "Unknown application type" application))))
  66.  
  67. (define (linearize-subproblems! continuation-type subproblems alist rest)
  68.   (set-subproblem-types! subproblems continuation-type)
  69.   (linearize-subproblems subproblems alist rest))
  70.  
  71. (define (linearize-subproblem! continuation-type subproblem lvalue rest)
  72.   (set-subproblem-type! subproblem continuation-type)
  73.   (linearize-subproblem subproblem lvalue rest))
  74.  
  75. (define (linearize-subproblems subproblems alist rest)
  76.   (let loop ((subproblems subproblems))
  77.     (if (null? subproblems)
  78.     rest
  79.     (linearize-subproblem (car subproblems)
  80.                   (let ((entry (assq (car subproblems) alist)))
  81.                 (and entry
  82.                      (cdr entry)))
  83.                   (loop (cdr subproblems))))))
  84.  
  85. (define (linearize-subproblem subproblem lvalue rest)
  86.   (let ((continuation (subproblem-continuation subproblem))
  87.     (prefix (subproblem-prefix subproblem)))
  88.     (if (subproblem-canonical? subproblem)
  89.     (begin
  90.       (let ((node (continuation/entry-node continuation)))
  91.         (cond ((not node)
  92.            (set-continuation/entry-node! continuation rest))
  93.           ((and (cfg-node/noop? node)
  94.             (not (snode-next-edge node)))
  95.            (create-edge! node set-snode-next-edge! rest))
  96.           (else
  97.            (error "Attempt to reattach continuation body"
  98.               continuation))))
  99.       (cfg-entry-node prefix))
  100.     (scfg*node->node!
  101.      prefix
  102.      (scfg*node->node!
  103.       (if (eq? continuation-type/effect
  104.            (virtual-continuation/type continuation))
  105.           (make-null-cfg)
  106.           (let ((cfg
  107.              (make-virtual-return
  108.               (virtual-continuation/context continuation)
  109.               continuation
  110.               (subproblem-rvalue subproblem))))
  111.         (if lvalue
  112.             (let ((node (cfg-entry-node cfg)))
  113.               (set-variable-source-node! lvalue node)
  114.               (set-virtual-return/target-lvalue! node lvalue)))
  115.         cfg))
  116.       rest)))))
  117.  
  118. (define (order-subproblems/inline combination subproblems rest)
  119.   (let ((inliner (combination/inliner combination))
  120.     (context (combination/context combination)))
  121.     (let ((operator (car subproblems))
  122.       (operands
  123.        (list-filter-indices (cdr subproblems) (inliner/operands inliner))))
  124.       (set-inliner/operands! inliner operands)
  125.       (with-values
  126.       (lambda ()
  127.         (discriminate-items operands subproblem-simple?))
  128.     (lambda (simple complex)
  129.       (if (null? complex)
  130.           (begin
  131.         (inline-subproblem-types! context
  132.                       simple
  133.                       continuation-type/register)
  134.         (values
  135.          (linearize-subproblem! continuation-type/effect
  136.                     operator
  137.                     #f
  138.                     (linearize-subproblems simple
  139.                                    '()
  140.                                    rest))
  141.          (cons operator simple)))
  142.           (let ((push-set (cdr complex))
  143.             (value-set (cons (car complex) simple)))
  144.         (inline-subproblem-types! context
  145.                       push-set
  146.                       continuation-type/push)
  147.         (inline-subproblem-types! context
  148.                       value-set
  149.                       continuation-type/register)
  150.         (values
  151.          (linearize-subproblem!
  152.           continuation-type/effect
  153.           operator
  154.           #f
  155.           (linearize-subproblems
  156.            push-set
  157.            '()
  158.            (linearize-subproblems
  159.             value-set
  160.             '()
  161.             (scfg*node->node!
  162.              (scfg*->scfg!
  163.               (reverse!
  164.                (map (lambda (subproblem)
  165.                   (let ((continuation
  166.                      (subproblem-continuation subproblem)))
  167.                 (if (eq? (continuation*/type continuation)
  168.                      continuation-type/effect)
  169.                     (make-null-cfg)
  170.                     (make-pop continuation))))
  171.                 push-set)))
  172.              rest))))
  173.          (cons operator (append push-set value-set))))))))))
  174.  
  175. (define (inline-subproblem-types! context subproblems continuation-type)
  176.   (for-each
  177.    (lambda (subproblem)
  178.      (set-subproblem-type!
  179.       subproblem
  180.       (if (let ((rvalue (subproblem-rvalue subproblem)))
  181.         (or (rvalue-known-constant? rvalue)
  182.         (and (rvalue/reference? rvalue)
  183.              (not (variable/value-variable? (reference-lvalue rvalue)))
  184.              (reference-to-known-location? rvalue))))
  185.       (begin
  186.         (update-subproblem-contexts! context subproblem)
  187.         continuation-type/effect)
  188.       continuation-type)))
  189.    subproblems))
  190.  
  191. (define (order-subproblems/out-of-line combination subproblems rest)
  192.   (let ((alist (add-defaulted-subproblems! combination subproblems)))
  193.     (with-values
  194.     (combination-ordering (combination/context combination)
  195.                   (car subproblems)
  196.                   (cdr subproblems)
  197.                   (combination/model combination))
  198.       (lambda (effect-subproblems push-subproblems)
  199.     (set-combination/frame-size! combination (length push-subproblems))
  200.     (with-values
  201.         (lambda ()
  202.           (order-subproblems/maybe-overwrite-block
  203.            combination push-subproblems rest alist
  204.            (lambda ()
  205.          (values (linearize-subproblems! continuation-type/push
  206.                          push-subproblems
  207.                          alist
  208.                          rest)
  209.              push-subproblems))))
  210.       (lambda (cfg push-subproblem-order)
  211.         (values (linearize-subproblems! continuation-type/effect
  212.                         effect-subproblems
  213.                         alist
  214.                         cfg)
  215.             (append effect-subproblems push-subproblem-order))))))))
  216.  
  217. (define (add-defaulted-subproblems! combination subproblems)
  218.   (let ((model (combination/model combination)))
  219.     (if (and model
  220.          (rvalue/procedure? model)
  221.          (stack-block? (procedure-block model))
  222.          (or (procedure-always-known-operator? model)
  223.          (not (procedure-rest model))))
  224.     (let ((n-unassigned
  225.            (let ((n-supplied (length (cdr subproblems)))
  226.              (n-required
  227.               (length (cdr (procedure-original-required model)))))
  228.          (let ((n-expected
  229.             (+ n-required
  230.                (length (procedure-original-optional model)))))
  231.            (if (or (< n-supplied n-required)
  232.                (and (> n-supplied n-expected)
  233.                 (not (procedure-rest model))))
  234.                (warn "wrong number of arguments"
  235.                  n-supplied
  236.                  (error-irritant/noise char:newline)
  237.                  (error-irritant/noise "in call to procedure")
  238.                  (procedure-name model)
  239.                  (error-irritant/noise char:newline)
  240.                  (error-irritant/noise
  241.                   "minimum/maximum number of arguments:")
  242.                  n-required
  243.                  n-expected))
  244.            (- n-expected n-supplied))))
  245.           (parallel (application-parallel-node combination)))
  246.       (if (positive? n-unassigned)
  247.           (set-parallel-subproblems!
  248.            parallel
  249.            (append! subproblems
  250.             (make-unassigned-subproblems
  251.              (combination/context combination)
  252.              n-unassigned
  253.              '()))))
  254.       (let ((parameters
  255.          (append (cdr (procedure-original-required model))
  256.              (procedure-original-optional model)))
  257.         (arguments (cdr (parallel-subproblems parallel))))
  258.         (map (lambda (variable subproblem)
  259.            (cons subproblem variable))
  260.          parameters
  261.          (let ((n-parameters (length parameters)))
  262.            (if (> (length arguments) n-parameters)
  263.                (list-head arguments n-parameters)
  264.                arguments)))))
  265.     '())))
  266.  
  267. (define (combination-ordering context operator operands model)
  268.   (let ((standard
  269.      (lambda ()
  270.        (handle-operator context
  271.                 operator
  272.                 (operator-needed? (subproblem-rvalue operator))
  273.                 '()
  274.                 (reverse operands))))
  275.     (optimized
  276.      (lambda ()
  277.        (optimized-combination-ordering context operator operands model)))
  278.     (known
  279.      (lambda ()
  280.        (known-combination-ordering context operator operands model))))
  281.     (if (and model (rvalue/procedure? model))
  282.     (let ((model-block (procedure-block model)))
  283.       (if (not (stack-block? model-block))
  284.           standard
  285.           (let ((thunk
  286.              (cond ((procedure-always-known-operator? model) optimized)
  287.                ;; The behavior of known lexpr closures should
  288.                ;; be improved at least when the listification
  289.                ;; is trivial (0 or 1 args).
  290.                ((procedure-rest model) standard)
  291.                (else known))))
  292.         (if (and (procedure/open? model)
  293.              (stack-block/static-link? model-block))
  294.             (lambda ()
  295.               (with-values thunk
  296.             (lambda (effect-subproblems push-subproblems)
  297.               (values
  298.                effect-subproblems
  299.                (cons (new-subproblem context
  300.                          (block-parent model-block))
  301.                  push-subproblems)))))
  302.             thunk))))
  303.     standard)))
  304.  
  305. (define (optimized-combination-ordering context operator operands callee)
  306.   (with-values
  307.       (lambda ()
  308.     (sort-subproblems/out-of-line operands callee))
  309.     (lambda (integrated non-integrated)
  310.       (handle-operator context
  311.                operator
  312.                (operator-needed? (subproblem-rvalue operator))
  313.                integrated
  314.                non-integrated))))
  315.  
  316. (define (known-combination-ordering context operator operands procedure)
  317.   (if (and (not (procedure/closure? procedure))
  318.        (not (procedure-virtual-closure? procedure)))
  319.       (error "known-combination-ordering: known non-closure" procedure))
  320.   (handle-operator
  321.    context
  322.    operator
  323.    (or (not (rvalue-known-value (subproblem-rvalue operator)))
  324.        (and (procedure/closure? procedure)
  325.         (closure-procedure-needs-operator? procedure)))
  326.    '()
  327.    (reverse operands)))
  328.  
  329. (define (handle-operator context operator operator-needed? effect push)
  330.   (if operator-needed?
  331.       (values effect (append! push (list operator)))
  332.       (begin
  333.     (update-subproblem-contexts! context operator)
  334.     (values (cons operator effect) push))))
  335.  
  336. (define (make-unassigned-subproblems context n rest)
  337.   (let ((unassigned (make-constant (make-unassigned-reference-trap))))
  338.     (let loop ((n n) (rest rest))
  339.       (if (zero? n)
  340.       rest
  341.       (loop (-1+ n)
  342.         (cons (new-subproblem context unassigned) rest))))))
  343.  
  344. (define (new-subproblem context rvalue)
  345.   (let ((subproblem
  346.      (make-subproblem
  347.       (make-null-cfg)
  348.       (virtual-continuation/make
  349.        (make-reference-context (reference-context/block context))
  350.        continuation-type/value)
  351.       rvalue)))
  352.     (new-subproblem/compute-simplicity! subproblem)
  353.     (new-subproblem/compute-free-variables! subproblem)
  354.     subproblem))
  355.  
  356. (define (set-subproblem-types! subproblems type)
  357.   (for-each (lambda (subproblem)
  358.           (set-subproblem-type! subproblem type))
  359.         subproblems))
  360.  
  361. (define (sort-subproblems/out-of-line all-subproblems callee)
  362.   (with-values
  363.       (lambda ()
  364.     (sort-integrated (cdr (procedure-original-required callee))
  365.              all-subproblems
  366.              '()
  367.              '()))
  368.     (lambda (subproblems integrated non-integrated)
  369.       (with-values
  370.       (lambda ()
  371.         (sort-integrated (procedure-original-optional callee)
  372.                  subproblems
  373.                  integrated
  374.                  non-integrated))
  375.     (lambda (subproblems integrated non-integrated)
  376.       (let ((rest (procedure-original-rest callee)))
  377.         (cond ((and (not (null? subproblems)) (not rest))
  378.            ;; This is a wrong number of arguments case, so
  379.            ;; the code we generate will not be any good.
  380.            ;; The extra arguments are dropped!
  381.            (values integrated
  382.                non-integrated))
  383.           ((and rest (variable-unused? rest))
  384.            (values (append! (reverse subproblems) integrated)
  385.                non-integrated))
  386.           (else
  387.            (values integrated
  388.                (append! (reverse subproblems)
  389.                     non-integrated))))))))))
  390.  
  391. (define (sort-integrated lvalues subproblems integrated non-integrated)
  392.   (cond ((null? lvalues)
  393.      (values subproblems integrated non-integrated))
  394.     ((null? subproblems)
  395.      (error "sort-integrated: not enough subproblems" lvalues))
  396.     ((variable-unused? (car lvalues))
  397.      (sort-integrated (cdr lvalues)
  398.               (cdr subproblems)
  399.               (cons (car subproblems) integrated)
  400.               non-integrated))
  401.     (else
  402.      (sort-integrated (cdr lvalues)
  403.               (cdr subproblems)
  404.               integrated
  405.               (cons (car subproblems) non-integrated)))))
  406.  
  407. (define (operator-needed? operator)
  408.   (let ((callee (rvalue-known-value operator)))
  409.     (cond ((not callee)
  410.        (or (not (reference? operator))
  411.            (reference-to-known-location? operator)))
  412.       ((rvalue/constant? callee)
  413.        (not (primitive-procedure? (constant-value callee))))
  414.       ((rvalue/procedure? callee)
  415.        (case (procedure/type callee)
  416.          ((OPEN-EXTERNAL OPEN-INTERNAL) #f)
  417.          ((TRIVIAL-CLOSURE) (procedure-rest callee))
  418.          ((CLOSURE IC) #t)
  419.          (else (error "Unknown procedure type" callee))))
  420.       (else #t))))
  421.  
  422. (define (update-subproblem-contexts! context subproblem)
  423.   (if (not (subproblem-canonical? subproblem))
  424.       (update-rvalue-contexts! context (subproblem-rvalue subproblem))))
  425.  
  426. (define (update-rvalue-contexts! context rvalue)
  427.   (let ((check-old
  428.      (lambda (context*)
  429.        (if (not (eq? (reference-context/block context)
  430.              (reference-context/block context*)))
  431.            (error "mismatched reference contexts" context context*))
  432.        (not (eq? context context*)))))
  433.     (enumeration-case rvalue-type (tagged-vector/index rvalue)
  434.       ((REFERENCE)
  435.        (if (check-old (reference-context rvalue))
  436.        (set-reference-context! rvalue context)))
  437.       ((UNASSIGNED-TEST)
  438.        (if (check-old (unassigned-test-context rvalue))
  439.        (set-unassigned-test-context! rvalue context)))
  440.       ((PROCEDURE)
  441.        (if (let ((context* (procedure-closure-context rvalue)))
  442.          (and (reference-context? context*)
  443.           (check-old context*)))
  444.        (set-procedure-closure-context! rvalue context))))))