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 / refctx.scm < prev    next >
Text File  |  1999-01-02  |  12KB  |  316 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: refctx.scm,v 1.3 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. ;;;; Reference Contexts
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;; In general, generating code for variable (and block) references
  27. ;;; requires only two pieces of knowledge: the block in which the
  28. ;;; reference occurs, and the block being referenced (in the case of
  29. ;;; variables, the latter is the block in which the variable is
  30. ;;; bound).  Usually the location of the parent of a given block is
  31. ;;; precisely known, e.g. as a stack offset from that block, and in
  32. ;;; cases where different locations are possible, an explicit static
  33. ;;; link is used to provide that location.
  34.  
  35. ;;; In the case where static links are normally used, it is sometimes
  36. ;;; possible to bypass a static link for a particular reference: this
  37. ;;; because the knowledge of the reference's position within the
  38. ;;; program's control structure implies that the parent block is in a
  39. ;;; known location.  In other words, even though that parent block can
  40. ;;; have several different locations relative to its child, from that
  41. ;;; particular place in the program only one of those locations is
  42. ;;; possible.
  43.  
  44. ;;; Reference contexts are a mechanism to capture this kind of control
  45. ;;; structure dependent knowledge.  Basically, every point in the flow
  46. ;;; graph that does some kind of environment reference keeps a pointer
  47. ;;; to a reference context.  These reference contexts can be
  48. ;;; independently changed to annotate interesting facts.
  49.  
  50. (define reference-context-tag
  51.   ;; This tag is used to prevent `define-structure' from redefining
  52.   ;; the variable `reference-context'.
  53.   "reference-context")
  54.  
  55. (define-structure (reference-context
  56.            (type vector)
  57.            (named reference-context-tag)
  58.            (constructor make-reference-context (block))
  59.            (conc-name reference-context/))
  60.   (block false read-only true)
  61.   (offset false)
  62.   (adjacent-parents '()))
  63.  
  64. (define-integrable (reference-context/procedure context)
  65.   (block-procedure (reference-context/block context)))
  66.  
  67. (define-integrable (reference-context/adjacent-parent? context block)
  68.   (memq block (reference-context/adjacent-parents context)))
  69.  
  70. (define (add-reference-context/adjacent-parents! context blocks)
  71.   (set-reference-context/adjacent-parents!
  72.    context
  73.    (eq-set-union blocks (reference-context/adjacent-parents context))))
  74.  
  75. #|
  76. (define (node/reference-context node)
  77.   (cfg-node-case (tagged-vector/tag node)
  78.     ((APPLICATION) (application-context node))
  79.     ((VIRTUAL-RETURN) (virtual-return-context node))
  80.     ((ASSIGNMENT) (assignment-context node))
  81.     ((DEFINITION) (definition-context node))
  82.     ((STACK-OVERWRITE) (stack-overwrite-context node))
  83.     ((TRUE-TEST) (true-test-context node))
  84.     ((PARALLEL POP FG-NOOP) false)))
  85. |#
  86.  
  87. ;;; Once the FG graph has been constructed, this procedure will walk
  88. ;;; over it and install reference contexts in all the right places.
  89. ;;; It will also guarantee that all of the rvalues associated with a
  90. ;;; particular CFG node have the same context as the node.  This means
  91. ;;; that subsequently it is only necessary to walk over the CFG nodes
  92. ;;; and modify their contexts.
  93.  
  94. (define (initialize-reference-contexts! expression procedures)
  95.   (with-new-node-marks
  96.    (lambda ()
  97.      (initialize-contexts/node (expression-entry-node expression))
  98.      (for-each (lambda (procedure)
  99.          (initialize-contexts/next (procedure-entry-node procedure)))
  100.            procedures))))
  101.  
  102. (define (initialize-contexts/next node)
  103.   (if (and node (not (node-marked? node)))
  104.       (initialize-contexts/node node)))
  105.  
  106. (define (initialize-contexts/node node)
  107.   (node-mark! node)
  108.   (cfg-node-case (tagged-vector/tag node)
  109.     ((PARALLEL)
  110.      (initialize-contexts/parallel node)
  111.      (initialize-contexts/next (snode-next node)))
  112.     ((APPLICATION)
  113.      (initialize-contexts/application node)
  114.      (initialize-contexts/next (snode-next node)))
  115.     ((VIRTUAL-RETURN)
  116.      (initialize-contexts/virtual-return node)
  117.      (initialize-contexts/next (snode-next node)))
  118.     ((ASSIGNMENT)
  119.      (initialize-contexts/assignment node)
  120.      (initialize-contexts/next (snode-next node)))
  121.     ((DEFINITION)
  122.      (initialize-contexts/definition node)
  123.      (initialize-contexts/next (snode-next node)))
  124.     ((STACK-OVERWRITE)
  125.      (initialize-contexts/stack-overwrite node)
  126.      (initialize-contexts/next (snode-next node)))
  127.     ((POP FG-NOOP)
  128.      (initialize-contexts/next (snode-next node)))
  129.     ((TRUE-TEST)
  130.      (initialize-contexts/true-test node)
  131.      (initialize-contexts/next (pnode-consequent node))
  132.      (initialize-contexts/next (pnode-alternative node)))))
  133.  
  134. (define (initialize-contexts/parallel parallel)
  135.   (for-each
  136.    (lambda (subproblem)
  137.      (let ((prefix (subproblem-prefix subproblem)))
  138.        (if (not (cfg-null? prefix))
  139.        (initialize-contexts/next (cfg-entry-node prefix))))
  140.      (if (subproblem-canonical? subproblem)
  141.      (initialize-contexts/reference (subproblem-rvalue subproblem))
  142.      (let* ((continuation (subproblem-continuation subproblem))
  143.         (old (virtual-continuation/context continuation))
  144.         (new (guarantee-context old)))
  145.        (if new
  146.            (begin
  147.          (set-virtual-continuation/context! continuation new)
  148.          (initialize-contexts/rvalue
  149.           old new
  150.           (subproblem-rvalue subproblem)))))))
  151.    (parallel-subproblems parallel)))
  152.  
  153. (define (initialize-contexts/application application)
  154.   (let* ((old (application-context application))
  155.      (new (guarantee-context old)))
  156.     (if new
  157.     (begin
  158.       (set-application-context! application new)
  159.       (if (application/return? application)
  160.           (begin
  161.         (initialize-contexts/rvalue old new
  162.                         (application-operator application))
  163.         (for-each (lambda (operand)
  164.                 (initialize-contexts/rvalue old new operand))
  165.               (application-operands application)))))))
  166.   unspecific)
  167.  
  168. (define (initialize-contexts/virtual-return return)
  169.   (let* ((old (virtual-return-context return))
  170.      (new (guarantee-context old)))
  171.     (if new
  172.     (begin
  173.       (set-virtual-return-context! return new)
  174.       (initialize-contexts/rvalue old new (virtual-return-operand return))
  175.       (let ((continuation (virtual-return-operator return)))
  176.         (if (virtual-continuation/reified? continuation)
  177.         (initialize-contexts/rvalue
  178.          old
  179.          new
  180.          (virtual-continuation/reification continuation))
  181.         (guarantee-context! old new continuation
  182.                     virtual-continuation/context
  183.                     set-virtual-continuation/context!)))))))
  184.  
  185. (define (initialize-contexts/assignment assignment)
  186.   (let* ((old (assignment-context assignment))
  187.      (new (guarantee-context old)))
  188.     (if new
  189.     (begin
  190.       (set-assignment-context! assignment new)
  191.       (initialize-contexts/rvalue old new
  192.                       (assignment-rvalue assignment))))))
  193.  
  194. (define (initialize-contexts/definition assignment)
  195.   (let* ((old (definition-context assignment))
  196.      (new (guarantee-context old)))
  197.     (if new
  198.     (begin
  199.       (set-definition-context! assignment new)
  200.       (initialize-contexts/rvalue old new
  201.                       (definition-rvalue assignment))))))
  202.  
  203. (define (initialize-contexts/stack-overwrite assignment)
  204.   (let* ((old (stack-overwrite-context assignment))
  205.      (new (guarantee-context old)))
  206.     (if new
  207.     (set-stack-overwrite-context! assignment new)))
  208.   unspecific)
  209.  
  210. (define (initialize-contexts/true-test true-test)
  211.   (let* ((old (true-test-context true-test))
  212.      (new (guarantee-context old)))
  213.     (if new
  214.     (begin
  215.       (set-true-test-context! true-test new)
  216.       (initialize-contexts/rvalue old new (true-test-rvalue true-test))))))
  217.  
  218. (define (initialize-contexts/rvalue old new rvalue)
  219.   (enumeration-case rvalue-type (tagged-vector/index rvalue)
  220.     ((REFERENCE)
  221.      (if (variable/value-variable? (reference-lvalue rvalue))
  222.      (initialize-contexts/reference rvalue)
  223.      (guarantee-context! old new rvalue
  224.                  reference-context set-reference-context!)))
  225.     ((UNASSIGNED-TEST)
  226.      (guarantee-context! old new rvalue
  227.              unassigned-test-context set-unassigned-test-context!))
  228.     ((PROCEDURE)
  229.      (let ((context (procedure-closure-context rvalue)))
  230.        (cond ((reference? context)
  231.           (initialize-contexts/reference context))
  232. #|
  233.          ;; Unnecessary because no procedures have closure
  234.          ;; contexts when initialize-contexts is run.
  235.          ((block? context)
  236.           (guarantee-context! old new rvalue
  237.                   procedure-closure-context
  238.                   set-procedure-closure-context!))
  239. |#
  240.          )))))
  241.  
  242. (define (initialize-contexts/reference rvalue)
  243.   (set-reference-context! rvalue
  244.               (make-reference-context (reference-context rvalue))))
  245.  
  246. (define-integrable (guarantee-context! old new object context set-context!)
  247.   (guarantee-context!/check-old old (context object))
  248.   (set-context! object new)
  249.   unspecific)
  250.  
  251. (define (guarantee-context!/check-old old context)
  252.   (if (not (eq? old context))
  253.       (error "Reference context mismatch" old context)))
  254.  
  255. (define (guarantee-context old)
  256.   (and (block? old)
  257.        (make-reference-context old)))
  258.  
  259. (define (modify-reference-contexts! node limit modification)
  260.   (with-new-node-marks
  261.    (lambda ()
  262.      (if limit (node-mark! limit))
  263.      (modify-contexts/node modification node))))
  264.  
  265. (define (modify-contexts/node modification node)
  266.   (node-mark! node)
  267.   (cfg-node-case (tagged-vector/tag node)
  268.     ((PARALLEL)
  269.      (for-each
  270.       (lambda (subproblem)
  271.     (let ((prefix (subproblem-prefix subproblem)))
  272.       (if (not (cfg-null? prefix))
  273.           (modify-contexts/next modification (cfg-entry-node prefix))))
  274.     (if (not (subproblem-canonical? subproblem))
  275.         (modification
  276.          (virtual-continuation/context
  277.           (subproblem-continuation subproblem)))))
  278.       (parallel-subproblems node))
  279.      (modify-contexts/next modification (snode-next node)))
  280.     ((APPLICATION)
  281.      (modification (application-context node))
  282.      (modify-contexts/operator modification (application-operator node))
  283.      (modify-contexts/next modification (snode-next node)))
  284.     ((VIRTUAL-RETURN)
  285.      (modification (virtual-return-context node))
  286.      (let ((continuation (virtual-return-operator node)))
  287.        (if (virtual-continuation/reified? continuation)
  288.        (modify-contexts/operator
  289.         modification
  290.         (virtual-continuation/reification continuation))
  291.        (modification (virtual-continuation/context continuation))))
  292.      (modify-contexts/next modification (snode-next node)))
  293.     ((ASSIGNMENT)
  294.      (modification (assignment-context node))
  295.      (modify-contexts/next modification (snode-next node)))
  296.     ((DEFINITION)
  297.      (modification (definition-context node))
  298.      (modify-contexts/next modification (snode-next node)))
  299.     ((STACK-OVERWRITE)
  300.      (modification (stack-overwrite-context node))
  301.      (modify-contexts/next modification (snode-next node)))
  302.     ((POP FG-NOOP)
  303.      (modify-contexts/next modification (snode-next node)))
  304.     ((TRUE-TEST)
  305.      (modification (true-test-context node))
  306.      (modify-contexts/next modification (pnode-consequent node))
  307.      (modify-contexts/next modification (pnode-alternative node)))))
  308.  
  309. (define (modify-contexts/operator modification rvalue)
  310.   (let ((value (rvalue-known-value rvalue)))
  311.     (if (and value (rvalue/procedure? value))
  312.     (modify-contexts/next modification (procedure-entry-node value)))))
  313.  
  314. (define (modify-contexts/next modification node)
  315.   (if (and node (not (node-marked? node)))
  316.       (modify-contexts/node modification node)))