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 / contan.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  216 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: contan.scm,v 4.10 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 1988, 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. ;;;; Continuation Analysis
  23.  
  24. (declare (usual-integrations))
  25.  
  26. #|
  27.  
  28. The continuation analysis is responsible for determining when static
  29. or dynamic links are to be used.
  30.  
  31. Static links
  32. ------------
  33.  
  34. We compute the `block-stack-link': this is another block, which is
  35. known to be immediately adjacent (away from the top of the stack) to
  36. the given block on the stack, and is also a descendent of the parent.
  37. If we can't compute a favorable block of this type, we set
  38. `block-stack-link' to #F and use a static link.  Static links are
  39. currently avoided in only two cases:
  40.  
  41. - The procedure is always invoked in a position which is tail
  42. recursive with respect to the parent.  In this case the parent block
  43. is the stack link.  Note that this includes the case where the
  44. continuation is always externally supplied (passed in).
  45.  
  46. - The procedure is always invoked with a particular continuation which
  47. has the procedure's parent as an ancestor.  The parent frame can then
  48. be found from the continuation's frame.  The adjacent block is the
  49. continuation's block.
  50.  
  51. Remarks:
  52.  
  53. This analysis can be improved in the following way: Multiple
  54. continuations as in the second case above are fine as long as the
  55. parent can be obtained from all of them by the same access path.
  56.  
  57. Dynamic links
  58. -------------
  59.  
  60. We compute the "popping limits" of a procedure's continuation
  61. variable.  A popping limit is the farthest ancestor of the procedure's
  62. block that is to be popped when invoking a known continuation; what we
  63. collect is the set of popping limits for all of the known
  64. continuations.  If this set is not a singleton, we must use a dynamic
  65. link.  However, even if the set is not a singleton, it is useful
  66. information: many tail recursive combinations do not need to use the
  67. dynamic link to adjust the stack, because they are only going to
  68. discard that portion of the stack that is common to all of the popping
  69. limits.
  70.  
  71. This code takes advantage of the fact that the continuation variable
  72. is not referenced in blocks other than the procedure's block.  This
  73. may change if call-with-current-continuation is handled specially.
  74.  
  75. |#
  76.  
  77. (define (continuation-analysis blocks)
  78.   (for-each
  79.    (lambda (block)
  80.      (if (stack-block? block)
  81.      (begin
  82.        (set-block-stack-link! block (compute-block-stack-link block))
  83.        (let ((popping-limits (compute-block-popping-limits block)))
  84.          (set-block-popping-limits! block popping-limits)
  85.          (set-block-popping-limit! block
  86.                        (and (not (null? popping-limits))
  87.                         (null? (cdr popping-limits))
  88.                         (car popping-limits)))))))
  89.    blocks))
  90.  
  91. (define (compute-block-stack-link block)
  92.   (and (stack-parent? block)
  93.        (let ((lvalue (stack-block/continuation-lvalue block))
  94.          (parent (block-parent block)))
  95.      (if (with-new-lvalue-marks
  96.           (lambda ()
  97.         (let ((end (stack-block/continuation-lvalue parent)))
  98.           (define (loop lvalue)
  99.             (lvalue-mark! lvalue)
  100.             (and (not (lvalue/external-source? lvalue))
  101.              (null? (lvalue-initial-values lvalue))
  102.              (memq end (lvalue-backward-links lvalue))
  103.              (for-all? (lvalue-initial-backward-links lvalue)
  104.                    next)))
  105.  
  106.           (define (next lvalue)
  107.             (if (lvalue-marked? lvalue)
  108.             true
  109.             (loop lvalue)))
  110.  
  111.           (lvalue-mark! end)
  112.           (loop lvalue))))
  113.  
  114.          ;; Most interesting case: we're always in a tail
  115.          ;; recursive position with respect to our parent.  Note
  116.          ;; that we didn't bother to check whether any of the
  117.          ;; intermediate procedures were closures: if that is
  118.          ;; true, we'd better be a closure as well.
  119.          parent
  120.  
  121.          ;; Acceptable substitute: we're a subproblem of someone
  122.          ;; who is a child of the parent.
  123.          (let ((value (lvalue-known-value lvalue)))
  124.            (and value
  125.             (let ((block (continuation/block value)))
  126.               (and (block-ancestor? block parent)
  127.                block))))))))
  128.  
  129. (define (setup-block-static-links! blocks)
  130.   (for-each
  131.    (lambda (block)
  132.      (if (stack-block? block)
  133.      (set-block-static-link?! block (compute-block-static-link? block))))
  134.    blocks))
  135.  
  136. (define (compute-block-static-link? block)
  137.   ;; (and (not (block/no-free-references? block)) ...)
  138.   (let ((parent (block-parent block)))
  139.     (and parent
  140.      (cond ((stack-block? parent) (not (block-stack-link block)))
  141.            ((ic-block? parent) (ic-block/use-lookup? parent))
  142.            (else true)))))
  143.  
  144. (define (block/no-free-references? block)
  145.   (and (for-all? (block-free-variables block)
  146.      (lambda (variable)
  147.        (or (lvalue-integrated? variable)
  148.            (let ((block (variable-block variable)))
  149.          (and (ic-block? block)
  150.               (not (ic-block/use-lookup? block)))))))
  151.        (let loop ((block* block))
  152.      (and (not
  153.            (there-exists? (block-applications block*)
  154.          (lambda (application)
  155.            (let ((block*
  156.               (if (application/combination? application)
  157.                   (let ((adjustment
  158.                      (combination/frame-adjustment
  159.                       application)))
  160.                 (and adjustment
  161.                      (cdr adjustment)))
  162.                   (block-popping-limit
  163.                    (reference-context/block
  164.                 (application-context application))))))
  165.              (and block* (block-ancestor? block block*))))))
  166.           (for-all? (block-children block*) loop)))))
  167.  
  168. (define (compute-block-popping-limits block)
  169.   (let ((external (stack-block/external-ancestor block)))
  170.     (map->eq-set
  171.      (lambda (join)
  172.        (cond ((not join) external)
  173.          ((eq? join block) block)
  174.          (else (block-farthest-uncommon-ancestor block join))))
  175.      (let ((external-lvalue (stack-block/continuation-lvalue external))
  176.        (ancestry (block-partial-ancestry block external)))
  177.        (with-new-lvalue-marks
  178.     (lambda ()
  179.       (define (loop lvalue)
  180.         (lvalue-mark! lvalue)
  181.         (if (lvalue/external-source? lvalue)
  182.         (error "internal continuation is external source" lvalue))
  183.         (eq-set-union
  184.          (join-blocks lvalue external ancestry)
  185.          (map-union next (lvalue-initial-backward-links lvalue))))
  186.  
  187.       (define (next lvalue)
  188.         (cond ((lvalue-marked? lvalue)
  189.            '())
  190.           ((eq? lvalue external-lvalue)
  191.            (lvalue-mark! lvalue)
  192.            (eq-set-adjoin false
  193.                   (join-blocks lvalue external ancestry)))
  194.           (else
  195.            (loop lvalue))))
  196.  
  197.       (next (stack-block/continuation-lvalue block))))))))
  198.  
  199. (define (join-blocks lvalue external ancestry)
  200.   (map->eq-set
  201.    (lambda (block*)
  202.      (and (block-ancestor-or-self? block* external)
  203.       (let loop
  204.           ((ancestry ancestry)
  205.            (ancestry* (block-partial-ancestry block* external))
  206.            (join external))
  207.         (if (and (not (null? ancestry))
  208.              (not (null? ancestry*))
  209.              (eq? (car ancestry) (car ancestry*)))
  210.         (loop (cdr ancestry)
  211.               (cdr ancestry*)
  212.               (car ancestry))
  213.         join))))
  214.    (map->eq-set block-parent
  215.         (map continuation/block
  216.              (lvalue-initial-values lvalue)))))