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 / base / blocks.scm < prev    next >
Text File  |  1999-01-02  |  12KB  |  349 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: blocks.scm,v 4.14 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 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 model data structures
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. #|
  28.  
  29. Interpreter compatible (hereafter, IC) blocks are vectors with an
  30. implementation dependent number of reserved slots at the beginning,
  31. followed by the variable bindings for that frame, in the usual order.
  32. The parent of such a frame is always an IC block or a global block,
  33. but extracting a pointer to that parent from the frame is again
  34. implementation dependent and possibly a complex operation.  During the
  35. execution of an IC procedure, the block pointer is kept in the ENV
  36. register.
  37.  
  38. Perfect closure blocks are vectors whose slots contain the values for
  39. the free variables in a closure procedure.  The ordering of these
  40. slots is arbitrary.
  41.  
  42. Imperfect closure blocks are similar, except that the first slot of
  43. the vector points to the parent, which is always an IC block.
  44.  
  45. Stack blocks are contiguous regions of the stack.  A stack block
  46. pointer is the address of that portion of the block which is nearest
  47. to the top of the stack (on the 68000, the most negative address in
  48. the block.)
  49.  
  50. In closure and stack blocks, variables which the analyzer can
  51. guarantee will not be modified have their values stored directly in
  52. the block.  For all other variables, the binding slot in the block
  53. contains a pointer to a cell which contains the value.
  54.  
  55. Note that blocks of type CONTINUATION never have any children.  This
  56. is because the body of a continuation is always generated separately
  57. from the continuation, and then "glued" into place afterwards.
  58.  
  59. |#
  60.  
  61. (define-rvalue block
  62.   type            ;block type (see below)
  63.   parent        ;lexically enclosing parent
  64.   children        ;lexically enclosed children
  65.   disowned-children    ;children whose `parent' used to be this block
  66.   frame-size        ;for stack-allocated frames, size in words
  67.   procedure        ;procedure for which this is invocation block, if any
  68.   bound-variables    ;list of variables bound by this block
  69.   free-variables    ;list of variables free in this block or any children
  70.   variables-nontransitively-free
  71.               ;list of variables free in this block
  72.   declarations        ;list of declarations
  73.   applications        ;list of applications lexically within this block
  74.   interned-variables    ;alist of interned SCode variable objects
  75.   closure-offsets    ;for closure block, alist of bound variable offsets
  76.   debugging-info    ;dbg-block, if used
  77.   (stack-link        ;for stack block, adjacent block on stack
  78.    shared-block)    ;for multi closures, the official block
  79.   (static-link?        ;for stack block, true iff static link to parent
  80.    entry-number)    ;for multi closures, entry number
  81.   (popping-limits    ;for stack block (see continuation analysis)
  82.    grafted-blocks)    ;for multi closures, list of blocks that share
  83.   popping-limit        ;for stack block (see continuation analysis)
  84.   layout-frozen?    ;used by frame reuse to tell parameter
  85.             ;analysis not to alter this block's layout
  86.             ;(i.e., don't make any of the block's
  87.             ;procedure's parameters be passed by register)
  88.   )
  89.  
  90. (define *blocks*)
  91.  
  92. (define (make-block parent type)
  93.   (let ((block
  94.      (make-rvalue block-tag (enumeration/name->index block-types type)
  95.               parent '() '() false false '()'() '() '() '() '() '()
  96.               false false 'UNKNOWN 'UNKNOWN 'UNKNOWN false)))
  97.     (if parent
  98.     (set-block-children! parent (cons block (block-children parent))))
  99.     (set! *blocks* (cons block *blocks*))
  100.     block))
  101.  
  102. (define-vector-tag-unparser block-tag
  103.   (lambda (state block)
  104.     ((standard-unparser
  105.       (symbol->string 'BLOCK)
  106.       (lambda (state block)
  107.     (unparse-object state
  108.             (enumeration/index->name block-types
  109.                          (block-type block)))
  110.     (let ((procedure (block-procedure block)))
  111.       (if (and procedure (rvalue/procedure? procedure))
  112.           (begin
  113.         (unparse-string state " ")
  114.         (unparse-label state (procedure-label procedure)))))))
  115.      state block)))
  116.  
  117. (define-integrable (rvalue/block? rvalue)
  118.   (eq? (tagged-vector/tag rvalue) block-tag))
  119.  
  120. (define (add-block-application! block application)
  121.   (set-block-applications! block
  122.                (cons application (block-applications block))))
  123.  
  124. (define (intern-scode-variable! block name)
  125.   (let ((entry (assq name (block-interned-variables block))))
  126.     (if entry
  127.     (cdr entry)
  128.     (let ((variable (scode/make-variable name)))
  129.       (set-block-interned-variables!
  130.        block
  131.        (cons (cons name variable) (block-interned-variables block)))
  132.       variable))))
  133.  
  134. (define block-passed-out?
  135.   rvalue-%passed-out?)
  136.  
  137. ;;;; Block Type
  138.  
  139. (define-enumeration block-type
  140.   (closure    ;heap-allocated closing frame, compiler format
  141.    continuation    ;continuation invocation frame
  142.    expression    ;execution frame for expression (indeterminate type)
  143.    ic        ;interpreter compatible heap-allocated frame
  144.    procedure    ;invocation frame for procedure (indeterminate type)
  145.    stack    ;invocation frame for procedure, stack-allocated
  146.    ))
  147.  
  148. (define (ic-block? block)
  149.   (let ((type (block-type block)))
  150.     (or (eq? type block-type/ic)
  151.     (eq? type block-type/expression))))
  152.  
  153. (define-integrable (closure-block? block)
  154.   (eq? (block-type block) block-type/closure))
  155.  
  156. (define-integrable (stack-block? block)
  157.   (eq? (block-type block) block-type/stack))
  158.  
  159. (define-integrable (continuation-block? block)
  160.   (eq? (block-type block) block-type/continuation))
  161.  
  162. (define (block/external? block)
  163.   (and (stack-block? block)
  164.        (not (stack-parent? block))))
  165.  
  166. (define (block/internal? block)
  167.   (and (stack-block? block)
  168.        (stack-parent? block)))
  169.  
  170. (define (stack-parent? block)
  171.   (and (block-parent block)
  172.        (stack-block? (block-parent block))))
  173.  
  174. (define (ic-block/use-lookup? block)
  175.   (or (rvalue/procedure? (block-procedure block))
  176.       (not compiler:cache-free-variables?)))
  177.  
  178. ;;;; Block Inheritance
  179.  
  180. (define (block-ancestor-or-self? block block*)
  181.   (or (eq? block block*)
  182.       (block-ancestor? block block*)))
  183.  
  184. (define (block-ancestor? block block*)
  185.   (define (loop block)
  186.     (and block
  187.      (or (eq? block block*)
  188.          (loop (block-parent block)))))
  189.   (loop (block-parent block)))
  190.  
  191. (define-integrable (block-child? block block*)
  192.   (eq? block (block-parent block*)))
  193.  
  194. (define-integrable (block-sibling? block block*)
  195.   ;; Assumes that at least one block has a parent.
  196.   (eq? (block-parent block) (block-parent block*)))
  197.  
  198. (define (block-nearest-common-ancestor block block*)
  199.   (let loop
  200.       ((join false)
  201.        (ancestry (block-ancestry block))
  202.        (ancestry* (block-ancestry block*)))
  203.     (if (and (not (null? ancestry))
  204.          (not (null? ancestry*))
  205.          (eq? (car ancestry) (car ancestry*)))
  206.     (loop (car ancestry) (cdr ancestry) (cdr ancestry*))
  207.     join)))
  208.  
  209. (define (block-farthest-uncommon-ancestor block block*)
  210.   (let loop
  211.       ((ancestry (block-ancestry block))
  212.        (ancestry* (block-ancestry block*)))
  213.     (and (not (null? ancestry))
  214.      (if (and (not (null? ancestry*))
  215.           (eq? (car ancestry) (car ancestry*)))
  216.          (loop (cdr ancestry) (cdr ancestry*))
  217.          (car ancestry)))))
  218.  
  219. (define (block-ancestry block)
  220.   (let loop ((block (block-parent block)) (path (list block)))
  221.     (if block
  222.     (loop (block-parent block) (cons block path))
  223.     path)))
  224.  
  225. (define (block-partial-ancestry block ancestor)
  226.   ;; (assert (or (not ancestor) (block-ancestor-or-self? block ancestor)))
  227.   (if (eq? block ancestor)
  228.       '()
  229.       (let loop ((block (block-parent block)) (path (list block)))
  230.     (if (eq? block ancestor)
  231.         path
  232.         (loop (block-parent block) (cons block path))))))
  233.  
  234. (define (find-outermost-block block)
  235.   ;; Should this check whether it is an expression/ic block or not?
  236.   (if (block-parent block)
  237.       (find-outermost-block (block-parent block))
  238.       block))
  239.  
  240. (define (stack-block/external-ancestor block)
  241.   (let ((parent (block-parent block)))
  242.     (if (and parent (stack-block? parent))
  243.     (stack-block/external-ancestor parent)
  244.     block)))
  245.  
  246. (define (block/external-ancestor block)
  247.   (if (stack-block? block)
  248.       (stack-block/external-ancestor block)
  249.       block))
  250.  
  251. (define (stack-block/ancestor-distance block offset join)
  252.   (let loop ((block block) (n offset))
  253.     (if (eq? block join)
  254.     n
  255.     (loop (block-parent block)
  256.           (+ n (block-frame-size block))))))
  257.  
  258. (define (for-each-block-descendant! block procedure)
  259.   (let loop ((block block))
  260.     (procedure block)
  261.     (for-each loop (block-children block))))
  262.  
  263. (define-integrable (stack-block/static-link? block)
  264.   (block-static-link? block))
  265.  
  266. (define-integrable (stack-block/continuation-lvalue block)
  267.   (procedure-continuation-lvalue (block-procedure block)))
  268.  
  269. (define (block/dynamic-link? block)
  270.   (and (stack-block? block)
  271.        (stack-block/dynamic-link? block)))
  272.  
  273. (define (stack-block/dynamic-link? block)
  274.   (and (stack-parent? block)
  275.        (internal-block/dynamic-link? block)))
  276.  
  277. (define-integrable (internal-block/dynamic-link? block)
  278.   (not (block-popping-limit block)))
  279.  
  280. (define-integrable (original-block-parent block)
  281.   ;; This only works for the invocation blocks of procedures (not
  282.   ;; continuations), and it assumes that all procedures' target-block
  283.   ;; fields have been initialized (i.e. the environment optimizer has
  284.   ;; been run).
  285.   (let ((procedure (block-procedure block)))
  286.     (and procedure
  287.      (rvalue/procedure? procedure)
  288.      (procedure-target-block procedure))))
  289.  
  290. #|
  291. (define (disown-block-child! block child)
  292.   (set-block-children! block (delq! child (block-children block)))
  293.   (if (eq? block (original-block-parent child))
  294.       (set-block-disowned-children! block
  295.                     (cons child (block-disowned-children block))))
  296.   unspecific)
  297.  
  298. (define (own-block-child! block child)
  299.   (set-block-parent! child block)
  300.   (set-block-children! block (cons child (block-children block)))
  301.   (if (eq? block (original-block-parent child))
  302.       (set-block-disowned-children! block
  303.                     (delq! child (block-disowned-children block))))
  304.   unspecific)
  305. |#
  306.  
  307. (define (transfer-block-child! child block block*)
  308.   ;; equivalent to
  309.   ;; (begin
  310.   ;;   (disown-block-child! block child)
  311.   ;;   (own-block-child! block* child))
  312.   ;; but faster.
  313.   (let ((original-parent (original-block-parent child)))
  314.     (set-block-children! block (delq! child (block-children block)))
  315.     (if (eq? block original-parent)
  316.     (set-block-disowned-children!
  317.      block
  318.      (cons child (block-disowned-children block))))
  319.     (set-block-parent! child block*)
  320.     (if block*
  321.     (begin
  322.       (set-block-children! block* (cons child (block-children block*)))
  323.       (if (eq? block* original-parent)
  324.           (set-block-disowned-children!
  325.            block*
  326.            (delq! child (block-disowned-children block*))))))))
  327.  
  328. (define-integrable (block-number-of-entries block)
  329.   (block-entry-number block))
  330.  
  331. (define (closure-block-entry-number block)
  332.   (if (eq? block (block-shared-block block))
  333.       0
  334.       (block-entry-number block)))
  335.  
  336. (define (closure-block-first-offset block)
  337.   (let ((block* (block-shared-block block)))
  338.     (closure-first-offset (block-entry-number block*)
  339.               (if (eq? block block*)
  340.                   0
  341.                   (block-entry-number block)))))
  342.  
  343. (define (block-nearest-closure-ancestor block)
  344.   (let loop ((block block) (last false))
  345.     (and block
  346.      (if (stack-block? block)
  347.          (loop (block-parent block) block)
  348.          (and (closure-block? block)
  349.           last)))))