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 / blktyp.scm next >
Text File  |  1999-01-02  |  21KB  |  592 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: blktyp.scm,v 4.16 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 1988, 1989, 1990, 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. ;;;; Environment Type Assignment
  23. ;;; package: (compiler fg-optimizer setup-block-types)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (setup-block-types! root-block)
  28.   (define (loop block)
  29.     (enumeration-case block-type (block-type block)
  30.       ((PROCEDURE)
  31.        (if (block-passed-out? block)
  32.        (block-type! block block-type/ic)
  33.        (begin
  34.          (block-type! block block-type/stack)
  35.          (maybe-close-procedure! (block-procedure block)))))
  36.       ((CONTINUATION)
  37.        (for-each loop (block-children block)))
  38.       ((EXPRESSION)
  39.        (if (not (block-passed-out? block))
  40.        (error "Expression block not passed out" block))
  41.        (block-type! block block-type/ic))
  42.       (else
  43.        (error "Illegal block type" block))))
  44.  
  45.   (define (block-type! block type)
  46.     (set-block-type! block type)
  47.     (for-each loop (block-children block)))
  48.   
  49.   (loop root-block)
  50.   (if compiler:use-multiclosures?
  51.       (merge-closure-blocks! root-block)))
  52.  
  53. (define (merge-closure-blocks! root-block)
  54.   (define (loop block update?)
  55.     (enumeration-case block-type (block-type block)
  56.      ((STACK)
  57.       (let ((procedure (block-procedure block)))
  58.     (if (procedure/full-closure? procedure)
  59.         (let ((closure-block (block-parent block)))
  60.           (if (eq? closure-block (block-shared-block closure-block))
  61.           (or (attempt-child-graft block procedure update?)
  62.               (and update? (update-closure! procedure))))))
  63.     (examine-children block
  64.               (or (attempt-children-merge block procedure update?)
  65.                   update?))))
  66.      ((IC CONTINUATION EXPRESSION)
  67.       (examine-children block update?))
  68.      (else
  69.       (error "Illegal block type" block))))
  70.   
  71.   (define (examine-children block update?)
  72.     (for-each (lambda (child)
  73.         (loop child update?))
  74.           (original-block-children block)))
  75.  
  76.   (loop root-block false))
  77.  
  78. (define (original-block-children block)
  79.   (append (block-disowned-children block)
  80.       (list-transform-positive
  81.           (block-children block)
  82.         (lambda (block*)
  83.           (eq? block (original-block-parent block*))))))
  84.  
  85. (define (maybe-close-procedure! procedure)
  86.   (if (eq? true (procedure-closure-context procedure))
  87.       (let ((block (procedure-block procedure))
  88.         (previously-trivial? (procedure/trivial-closure? procedure))
  89.         (original-parent (procedure-target-block procedure)))
  90.     (let ((parent (block-parent block)))
  91.       (set-procedure-closure-context!
  92.        procedure
  93.        (make-reference-context original-parent))
  94.       (with-values
  95.           (lambda ()
  96.         (let ((uninteresting-variable?
  97.                (lambda (variable)
  98.              (or (lvalue-integrated? variable)
  99.                  (let ((value (lvalue-known-value variable)))
  100.                    (and value
  101.                     (or (eq? value procedure)
  102.                     (and (rvalue/procedure? value)
  103.                          (procedure/trivial-or-virtual?
  104.                           value)))))))))
  105.           (find-closure-bindings
  106.            original-parent
  107.            (list-transform-negative (block-free-variables block)
  108.              (lambda (lvalue)
  109.                (or (uninteresting-variable? lvalue)
  110.                (begin
  111.                  (set-variable-closed-over?! lvalue true)
  112.                  false))))
  113.            '()
  114.            (list-transform-negative
  115.                (block-variables-nontransitively-free block)
  116.              uninteresting-variable?))))
  117.         (lambda (closure-block closure-block?)
  118.           (transfer-block-child! block parent closure-block)
  119.           (set-procedure-closure-size!
  120.            procedure
  121.            (cond (closure-block?
  122.               (compute-closure-offsets! closure-block
  123.                         (closure-first-offset 1 0)))
  124.              (closure-block 1)
  125.              (else 0)))))
  126.       (set-procedure-closure-cons! procedure '(NORMAL))
  127.       (if previously-trivial?
  128.           (if (not (procedure/trivial-closure? procedure))
  129.           (error "trivial procedure becoming non-trivial" procedure))
  130.           (if (procedure/trivial-closure? procedure)
  131.           (warn "non-trivial procedure becoming trivial"
  132.             procedure)))))))
  133.  
  134. (define (attempt-child-graft block procedure update?)
  135.   (let ((block* (block-nearest-closure-ancestor
  136.          (procedure-target-block procedure))))
  137.     (and block*
  138.      (let ((closure-block (block-parent block))
  139.            (ancestor-block (block-shared-block (block-parent block*))))
  140.        (and (for-all?
  141.          (refilter-variables (block-bound-variables closure-block)
  142.                      update? procedure)
  143.          (let ((bvars (block-bound-variables ancestor-block)))
  144.            (lambda (var)
  145.              (or (memq var bvars)
  146.              (let ((val (lvalue-known-value var)))
  147.                (and val
  148.                 (if (rvalue/block? val)
  149.                     (eq? val ancestor-block)
  150.                     (and (rvalue/procedure? val)
  151.                      (procedure/full-closure? val)
  152.                      (eq? (block-shared-block
  153.                            (procedure-closing-block val))
  154.                           ancestor-block)))))))))
  155.         (graft-child! procedure ancestor-block closure-block))))))
  156.  
  157. (define (graft-child! procedure ancestor-block closure-block)
  158.   (for-each
  159.    (lambda (var)
  160.      (if (and (lvalue-known-value var)
  161.           (not (variable-closed-over? var))
  162.           (let* ((sblock (block-nearest-closure-ancestor
  163.                   (variable-block var)))
  164.              (cblock (and sblock (block-parent sblock))))
  165.         (and cblock
  166.              (eq? (block-shared-block cblock) ancestor-block))))
  167.      (lvalue-put! var 'INTEGRATED ancestor-block)))
  168.    (procedure-variables procedure))
  169.   (graft-block! '(DESCENDANT) ancestor-block closure-block procedure)
  170.   true)
  171.  
  172. (define (update-closure! procedure)
  173.   (let ((closure-block (procedure-closing-block procedure)))
  174.     (if (not (eq? (block-shared-block closure-block) closure-block))
  175.     (error "update-closure!: Updating shared closure" procedure))
  176.     (let ((vars (refilter-variables (block-bound-variables closure-block)
  177.                     true procedure)))
  178.       (set-block-bound-variables! closure-block vars)
  179.       (set-procedure-closure-size!
  180.        procedure
  181.        (compute-closure-offsets! closure-block
  182.                  (closure-block-first-offset
  183.                   closure-block))))))
  184.  
  185. (define (refilter-variables bvars filter? procedure)
  186.   (if (not filter?)
  187.       bvars
  188.       (let loop ((vars (reverse bvars))
  189.          (real '())
  190.          (blocks '()))
  191.     (cond ((not (null? vars))
  192.            (let* ((var (car vars))
  193.               (ind (variable-indirection var)))
  194.          (if ind
  195.              (loop (cdr vars)
  196.                (if (memq (car ind) real)
  197.                    real
  198.                    (cons (car ind) real))
  199.                blocks)
  200.              (let ((val (lvalue-known-value var)))
  201.                (cond ((not val)
  202.                   (loop (cdr vars)
  203.                     (cons var real)
  204.                     blocks))
  205.                  ((rvalue/block? val)
  206.                   ;; This should not be found since this is
  207.                   ;; only the result of this procedure itself,
  208.                   ;; or link-children!, and either way, it
  209.                   ;; should not be called after that point.
  210.                   (error "refilter-variables: Block found"
  211.                      procedure))
  212.                  #|
  213.                  ;; This doesn't work because these variables
  214.                  ;; have not been indirected, so the eventual
  215.                  ;; lookup will fail.
  216.                  ;; We need to think about whether they can be
  217.                  ;; indirected always.
  218.                  ((and (rvalue/procedure? val)
  219.                    (procedure/closure? val))
  220.                   (let ((block
  221.                      (block-shared-block
  222.                       (procedure-closing-block val))))
  223.                 (if (memq block blocks)
  224.                     (loop (cdr vars)
  225.                       real
  226.                       blocks)
  227.                     (loop (cdr vars)
  228.                       (cons var real)
  229.                       (cons block blocks)))))
  230.                  |#
  231.                  (else
  232.                   (loop (cdr vars)
  233.                     (cons var real)
  234.                     blocks)))))))
  235.           ((null? real)
  236.            ;; Only non-trivial closures passed here.
  237.            (error "refilter-variables: becoming trivial!" procedure))
  238.           (else real)))))
  239.  
  240. (define (attempt-children-merge block procedure update?)
  241.   (let ((closure-children
  242.      (list-transform-positive
  243.          (original-block-children block)
  244.        (lambda (block*)
  245.          (let ((procedure* (block-procedure block*)))
  246.            (and procedure*
  247.             (procedure/full-closure? procedure*)))))))
  248.     (and (not (null? closure-children))
  249.      (list-split
  250.       closure-children
  251.       (lambda (block*)
  252.         (procedure-get (block-procedure block*) 'UNCONDITIONAL))
  253.       (lambda (unconditional conditional)
  254.         (and (not (null? unconditional))
  255.          (or (not (null? conditional))
  256.              (not (null? (cdr unconditional))))
  257.          (merge-children! block procedure
  258.                   unconditional conditional
  259.                   update?)))))))
  260.  
  261. (define (merge-children! block procedure unconditional conditional update?)
  262.   (let ((ic-parent
  263.      (let ((block
  264.         (list-search-positive unconditional
  265.           (lambda (block*)
  266.             (block-parent (block-parent block*))))))
  267.        (and block
  268.         (block-parent (block-parent block)))))
  269.     (closed-over-variables
  270.      (refilter-variables
  271.       (reduce-right eq-set-union
  272.             '()
  273.             (map (lambda (block*)
  274.                    (block-bound-variables (block-parent block*)))
  275.                  unconditional))
  276.       update? (block-procedure (car unconditional)))))
  277.     (let loop ((conditional conditional)
  278.            (block-closed (reverse unconditional)))
  279.       (cond ((not (null? conditional))
  280.          (loop (cdr conditional)
  281.            (let* ((block* (car conditional))
  282.               (closure-block (block-parent block*)))
  283.              (if (and (or (not (block-parent closure-block))
  284.                   ic-parent)
  285.                   (for-all?
  286.                    (refilter-variables
  287.                 (block-bound-variables closure-block)
  288.                 update? (block-procedure block*))
  289.                    (lambda (var)
  290.                  (or (lvalue-implicit? var unconditional)
  291.                      (let ((ind (variable-indirection var)))
  292.                        (memq (if ind
  293.                          (car ind)
  294.                          var)
  295.                          closed-over-variables))))))
  296.              (cons (car conditional) block-closed)
  297.              block-closed))))
  298.         ((null? (cdr block-closed))
  299.          false)
  300.         (else
  301.          (link-children! block procedure (reverse block-closed)
  302.                  ic-parent closed-over-variables))))))
  303.  
  304. (define closure-redirection-tag (intern "#[closure-redirection]"))
  305.  
  306. (define (link-children! block procedure block-closed ic-parent variables)
  307.   ;; Possible improvement: the real free variables may be references
  308.   ;; to closure ancestors.  At this point, all of them can be merged
  309.   ;; with the ancestor parent!  This should be pretty rare, but...
  310.   (list-split
  311.    variables
  312.    (lambda (var)
  313.      (lvalue-implicit? var block-closed))
  314.    (lambda (removable real)
  315.      (if (and (null? real) (not ic-parent))
  316.      (error "link-children!: Trivial multiclosure" block-closed variables))
  317.      (let ((letrec-names (procedure-names procedure))
  318.        (indirection-var (make-variable block closure-redirection-tag))
  319.        (shared-block
  320.         (make-closure-block
  321.          ic-parent
  322.          (reduce-right eq-set-union
  323.                '()
  324.                (map (lambda (block*)
  325.                   (block-free-variables (block-parent block*)))
  326.                 block-closed))
  327.          real
  328.          '())))
  329.        (set-variable-closed-over?! indirection-var true)
  330.        (let ((cache (list shared-block)))
  331.      (set-lvalue-initial-values! indirection-var cache)
  332.      (set-lvalue-values-cache! indirection-var cache)
  333.      (set-lvalue-known-value! indirection-var shared-block))
  334.        ;; what follows is a kludge to communicate with
  335.        ;; rtlgen/rgproc.scm
  336.        (set-procedure-names! procedure
  337.                  (cons indirection-var letrec-names))
  338.        (set-procedure-values! procedure
  339.                   (cons shared-block (procedure-values procedure)))
  340.        (set-block-bound-variables! block
  341.                    (append (block-bound-variables block)
  342.                        (list indirection-var)))
  343.        (set-block-entry-number! shared-block 0)
  344.        (for-each
  345.     (let ((pair `(INDIRECTED . ,indirection-var)))
  346.       (lambda (block)
  347.         (graft-block! pair shared-block
  348.               (block-parent block) (block-procedure block))))
  349.     block-closed)
  350.        (let ((pair (cons indirection-var true)))
  351.      (for-each
  352.       (lambda (removable)
  353.         (if (not (memq removable letrec-names))
  354.         (error "link-children!: non-letrec removable" removable))
  355.         (set-variable-indirection! removable pair))
  356.       removable)
  357.      (for-each
  358.       (lambda (name)
  359.         (if (not (variable-indirection name))
  360.         (let ((proc (lvalue-known-closure name)))
  361.           (if (and proc
  362.                (eq? (block-shared-block
  363.                  (procedure-closing-block proc))
  364.                 shared-block))
  365.               (set-variable-indirection! name pair)))))
  366.       letrec-names)
  367.      true)))))
  368.  
  369. (define (graft-block! how-consed block block* procedure*)
  370.   (if (or (closure-procedure-needs-external-descriptor? procedure*)
  371.       ;; Known lexpr closures are invoked through apply.
  372.       (procedure-rest procedure*))
  373.       (let ((entry (block-entry-number block)))
  374.     (if (zero? entry)
  375.         (set-block-procedure! block procedure*))
  376.     (set-block-entry-number! block (1+ entry))
  377.     (set-block-entry-number! block* entry))
  378.       (set-block-entry-number! block* 0))
  379.   (let ((parent (block-parent block))
  380.     (parent* (block-parent block*)))
  381.     (cond ((not parent*)
  382.        (if parent
  383.            (set-block-parent! block* parent)))
  384.       ((not parent)
  385.        (set-block-parent! block parent*)
  386.        (for-each (lambda (block**)
  387.                (set-block-parent! block** parent*))
  388.              (block-grafted-blocks block)))
  389.       ((not (eq? parent parent*))
  390.        (error "graft-block!: Differing parents" block block*))))
  391.   (set-procedure-closure-cons! procedure* how-consed)
  392.   (set-block-shared-block! block* block)
  393.   ;; Note that the list of grafted blocks are in decreasing entry
  394.   ;; number order, except for those that have 0 as their entry number
  395.   ;; (and thus don't need entries).  This is used to advantage in
  396.   ;; make-non-trivial-closure-cons in rtlgen/rgrval.scm .
  397.   (let ((new-grafts (cons block* (block-grafted-blocks block))))
  398.     (set-block-grafted-blocks! block new-grafts)
  399.     (for-each (let ((bvars (block-bound-variables block)))
  400.         (lambda (block*)
  401.           (set-block-bound-variables! block* bvars)
  402.           (let ((size
  403.              (compute-closure-offsets!
  404.               block*
  405.               (closure-block-first-offset block*))))
  406.             (if (not (null? (block-children block*)))
  407.             (set-procedure-closure-size!
  408.              (block-procedure (car (block-children block*)))
  409.              size)))))
  410.           (cons block new-grafts))))
  411.  
  412. ;;; Utilities that should live elsewhere
  413.  
  414. (define (indirection-block-procedure block)
  415.   (or (block-procedure block)
  416.       (if (null? (block-grafted-blocks block))
  417.       (error "indirection-block-procedure: Bad indirection block" block)
  418.       (block-procedure
  419.        (car (block-children
  420.          (car (block-grafted-blocks block))))))))
  421.  
  422. (define (lvalue-implicit? var blocks)
  423.   (let ((val (lvalue-known-value var)))
  424.     (and val
  425.      (rvalue/procedure? val)
  426.      (memq (procedure-block val) blocks))))
  427.  
  428. (define (lvalue-known-closure var)
  429.   (let ((val (lvalue-known-value var)))
  430.     (and val
  431.      (rvalue/procedure? val)
  432.      (procedure/full-closure? val)
  433.      val)))
  434.  
  435. (define-integrable (procedure/full-closure? proc)
  436.   (and (procedure/closure? proc)
  437.        (not (procedure/trivial-closure? proc))))
  438.  
  439. (define (list-split list predicate recvr)
  440.   (let split ((list list)
  441.           (recvr recvr))
  442.     (if (not (pair? list))
  443.     (recvr '() '())
  444.     (let ((next (car list)))
  445.       (split (cdr list)
  446.          (if (predicate next)
  447.              (lambda (win lose)
  448.                (recvr (cons next win) lose))
  449.              (lambda (win lose)
  450.                (recvr win (cons next lose)))))))))
  451.  
  452. (define (find-closure-bindings block free-variables bound-variables
  453.                    variables-nontransitively-free)
  454.   (if (or (not block) (ic-block? block))
  455.       (let ((grandparent (and (not (null? free-variables)) block)))
  456.     (if (null? bound-variables)
  457.         (values grandparent false)
  458.         (values
  459.          (make-closure-block grandparent
  460.                  free-variables
  461.                  bound-variables
  462.                  variables-nontransitively-free)
  463.          true)))
  464.       (with-values
  465.       (lambda ()
  466.         (filter-bound-variables (block-bound-variables block)
  467.                     free-variables
  468.                     bound-variables))
  469.     (lambda (free-variables bound-variables)
  470.       (find-closure-bindings (original-block-parent block)
  471.                  free-variables
  472.                  bound-variables
  473.                  variables-nontransitively-free)))))
  474.  
  475. (define (filter-bound-variables bindings free-variables bound-variables)
  476.   (cond ((null? bindings)
  477.      (values free-variables bound-variables))
  478.     ((memq (car bindings) free-variables)
  479.      (filter-bound-variables (cdr bindings)
  480.                  (delq! (car bindings) free-variables)
  481.                  (cons (car bindings) bound-variables)))
  482.     (else
  483.      (filter-bound-variables (cdr bindings)
  484.                  free-variables
  485.                  bound-variables))))
  486.  
  487. (define (make-closure-block parent free-variables bound-variables
  488.                 variables-nontransitively-free)
  489.   (let ((block (make-block parent 'CLOSURE)))
  490.     (set-block-free-variables! block free-variables)
  491.     (set-block-bound-variables! block bound-variables)
  492.     (set-block-variables-nontransitively-free!
  493.      block
  494.      variables-nontransitively-free)
  495.     (set-block-shared-block! block block)
  496.     (set-block-entry-number! block 1)
  497.     (set-block-grafted-blocks! block '())
  498.     block))
  499.  
  500. (define (compute-closure-offsets! block offset)
  501.   (if block
  502.       (let ((parent (block-parent block)))
  503.     (do ((variables (block-bound-variables block) (cdr variables))
  504.          (size (if (and parent (ic-block/use-lookup? parent)) 1 0)
  505.            (1+ size))
  506.          (table '()
  507.             (cons (cons (car variables) (+ offset size))
  508.               table)))
  509.         ((null? variables)
  510.          (set-block-closure-offsets! block table)
  511.          size)
  512.       (if (lvalue-integrated? (car variables))
  513.           (error "compute-closure-offsets!: integrated lvalue"
  514.              (car variables)))))
  515.       0))
  516.  
  517. ;;;; Reference contexts in which procedures are closed.
  518. ;;; Needed to determine the access paths of free variables to close over.
  519.  
  520. (define (setup-closure-contexts! expression procedures)
  521.   (with-new-node-marks
  522.    (lambda ()
  523.      (setup-closure-contexts/node (expression-entry-node expression))
  524.      (for-each
  525.       (lambda (procedure)
  526.     (setup-closure-contexts/next (procedure-entry-node procedure)))
  527.       procedures))))
  528.  
  529. (define (setup-closure-contexts/next node)
  530.   (if (and node (not (node-marked? node)))
  531.       (setup-closure-contexts/node node)))
  532.  
  533. (define (setup-closure-contexts/node node)
  534.   (node-mark! node)
  535.   (cfg-node-case (tagged-vector/tag node)
  536.     ((PARALLEL)
  537.      (for-each
  538.       (lambda (subproblem)
  539.     (let ((prefix (subproblem-prefix subproblem)))
  540.       (if (not (cfg-null? prefix))
  541.           (setup-closure-contexts/next (cfg-entry-node prefix))))
  542.     (if (not (subproblem-canonical? subproblem))
  543.         (setup-closure-contexts/rvalue
  544.          (virtual-continuation/context
  545.           (subproblem-continuation subproblem))
  546.          (subproblem-rvalue subproblem))))
  547.       (parallel-subproblems node))
  548.      (setup-closure-contexts/next (snode-next node)))
  549.     ((APPLICATION)
  550.      (if (application/return? node)
  551.      (let ((context (application-context node)))
  552.        (setup-closure-contexts/rvalue context (application-operator node))
  553.        (for-each (lambda (operand)
  554.                (setup-closure-contexts/rvalue context operand))
  555.              (application-operands node))))
  556.      (setup-closure-contexts/next (snode-next node)))
  557.     ((VIRTUAL-RETURN)
  558.      (let ((context (virtual-return-context node)))
  559.        (setup-closure-contexts/rvalue context (virtual-return-operand node))
  560.        (let ((continuation (virtual-return-operator node)))
  561.      (if (virtual-continuation/reified? continuation)
  562.          (setup-closure-contexts/rvalue
  563.           context
  564.           (virtual-continuation/reification continuation)))))
  565.      (setup-closure-contexts/next (snode-next node)))
  566.     ((ASSIGNMENT)
  567.      (setup-closure-contexts/rvalue (assignment-context node)
  568.                     (assignment-rvalue node))
  569.      (setup-closure-contexts/next (snode-next node)))
  570.     ((DEFINITION)
  571.      (setup-closure-contexts/rvalue (definition-context node)
  572.                     (definition-rvalue node))
  573.      (setup-closure-contexts/next (snode-next node)))
  574.     ((TRUE-TEST)
  575.      (setup-closure-contexts/rvalue (true-test-context node)
  576.                     (true-test-rvalue node))
  577.      (setup-closure-contexts/next (pnode-consequent node))
  578.      (setup-closure-contexts/next (pnode-alternative node)))
  579.     ((STACK-OVERWRITE POP FG-NOOP)
  580.      (setup-closure-contexts/next (snode-next node)))))
  581.  
  582. (define (setup-closure-contexts/rvalue context rvalue)
  583.   (if (and (rvalue/procedure? rvalue)
  584.        (let ((context* (procedure-closure-context rvalue)))
  585.          (and (reference-context? context*)
  586.           (begin
  587.             (if (not (eq? (reference-context/block context)
  588.                   (reference-context/block context*)))
  589.             (error "mismatched reference contexts"
  590.                    context context*))
  591.             (not (eq? context context*))))))
  592.       (set-procedure-closure-context! rvalue context)))