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 / ctypes.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  294 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: ctypes.scm,v 4.16 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. ;;;; Compiler CFG Datatypes
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Application
  27.  
  28. (define-snode application
  29.   type
  30.   context
  31.   operator
  32.   operands
  33.   (parallel-node owner)
  34.   (operators        ;used in simulate-application
  35.    args-passed-out?)    ;used in outer-analysis
  36.   operand-values    ;set by outer-analysis, used by identify-closure-limits
  37.   continuation-push
  38.   model            ;set by identify-closure-limits, used in generation
  39.   frame-adjustment    ;set by setup-frame-adjustments, used in generation
  40.   reuse-existing-frame?    ;set by setup-frame-adjustments, used in generation
  41.   )
  42.  
  43. (define *applications*)
  44.  
  45. (define (make-application type block operator operands continuation-push)
  46.   (let ((application
  47.      (make-snode application-tag
  48.              type block operator operands false '() '()
  49.              continuation-push false false false)))
  50.     (set! *applications* (cons application *applications*))
  51.     (add-block-application! block application)
  52.     (if (rvalue/reference? operator)
  53.     (add-lvalue-application! (reference-lvalue operator) application))
  54.     (make-scfg application '())))
  55.  
  56. (define-vector-tag-unparser application-tag
  57.   (lambda (state application)
  58.     ((case (application-type application)
  59.        ((COMBINATION)
  60.     (standard-unparser (symbol->string 'COMBINATION) false))
  61.        ((RETURN)
  62.     (standard-unparser (symbol->string 'RETURN)
  63.       (lambda (state return)
  64.         (unparse-object state (return/operand return)))))
  65.        (else
  66.     (standard-unparser (symbol->string 'APPLICATION)
  67.       (lambda (state application)
  68.         (unparse-object state (application-type application))))))
  69.      state application)))
  70.  
  71. (define-integrable (application-block application)
  72.   (reference-context/block (application-context application)))
  73.  
  74. (define-snode parallel
  75.   application-node
  76.   subproblems)
  77.  
  78. (define *parallels*)
  79.  
  80. (define (make-parallel application subproblems)
  81.   (let ((parallel (make-snode parallel-tag false subproblems)))
  82.     (set-parallel-application-node! parallel application)
  83.     (set-application-parallel-node! application parallel)
  84.     (set! *parallels* (cons parallel *parallels*))
  85.     (snode->scfg parallel)))
  86.  
  87. (define (make-combination block continuation operator operands
  88.               continuation-push)
  89.   (let ((application
  90.      (make-application 'COMBINATION
  91.                block
  92.                (subproblem-rvalue operator)
  93.                (cons continuation
  94.                  (map subproblem-rvalue operands))
  95.                continuation-push)))
  96.     (scfg*scfg->scfg!
  97.      (make-parallel (cfg-entry-node application) (cons operator operands))
  98.      application)))
  99.  
  100. (define-integrable (application/combination? application)
  101.   (eq? (application-type application) 'COMBINATION))
  102.  
  103. (define-integrable combination/context application-context)
  104. (define-integrable combination/operator application-operator)
  105. (define-integrable combination/inliner application-operators)
  106. (define-integrable set-combination/inliner! set-application-operators!)
  107. (define-integrable combination/frame-size application-operand-values)
  108. (define-integrable set-combination/frame-size! set-application-operand-values!)
  109. (define-integrable combination/inline? combination/inliner)
  110. (define-integrable combination/continuation-push application-continuation-push)
  111. (define-integrable combination/model application-model)
  112. (define-integrable set-combination/model! set-application-model!)
  113. (define-integrable combination/frame-adjustment application-frame-adjustment)
  114. (define-integrable set-combination/frame-adjustment!
  115.   set-application-frame-adjustment!)
  116. (define-integrable combination/reuse-existing-frame?
  117.   application-reuse-existing-frame?)
  118. (define-integrable set-combination/reuse-existing-frame?!
  119.   set-application-reuse-existing-frame?!)
  120.  
  121. (define-integrable (combination/block combination)
  122.   (reference-context/block (combination/context combination)))
  123.  
  124. (define-integrable (combination/continuation combination)
  125.   (car (application-operands combination)))
  126.  
  127. (define-integrable (combination/operands combination)
  128.   (cdr (application-operands combination)))
  129.  
  130. (define (combination/simple-inline? combination)
  131.   (let ((inliner (combination/inliner combination)))
  132.     (and inliner
  133.      (not (inliner/internal-close-coding? inliner)))))
  134.  
  135. (define-structure (inliner (type vector) (conc-name inliner/))
  136.   (handler false read-only true)
  137.   (generator false read-only true)
  138.   operands
  139.   internal-close-coding?)
  140.  
  141. (define-integrable (make-return block continuation rvalue)
  142.   (make-application 'RETURN block continuation (list rvalue) false))
  143.  
  144. (define-integrable (application/return? application)
  145.   (eq? (application-type application) 'RETURN))
  146.  
  147. (define-integrable return/context application-context)
  148. (define-integrable return/operator application-operator)
  149. (define-integrable return/continuation-push application-continuation-push)
  150. (define-integrable return/equivalence-class application-model)
  151. (define-integrable set-return/equivalence-class! set-application-model!)
  152.  
  153. (define-integrable (return/operand return)
  154.   (car (application-operands return)))
  155.  
  156. ;;; This method of handling constant combinations has the feature that
  157. ;;; such combinations are handled exactly like RETURNs by the
  158. ;;; procedure classification phase, which occurs after all constant
  159. ;;; combinations have been identified.
  160.  
  161. (define (combination/constant! combination rvalue)
  162.   (let ((continuation (combination/continuation combination)))
  163.     (for-each (lambda (continuation)
  164.         (set-continuation/combinations!
  165.          continuation
  166.          (delq! combination (continuation/combinations continuation)))
  167.         (set-continuation/returns!
  168.          continuation
  169.          (cons combination (continuation/returns continuation))))
  170.           (rvalue-values continuation))
  171.     (for-each (lambda (operator)
  172.         (if (rvalue/procedure? operator)
  173.             (delete-procedure-application! operator combination)))
  174.           (rvalue-values (combination/operator combination)))
  175.     (set-application-type! combination 'RETURN)
  176.     (set-application-operator! combination continuation)
  177.     (set-application-operands! combination (list rvalue))
  178.     (let ((push (combination/continuation-push combination)))
  179.       (if (and push (rvalue-known-value continuation))
  180.       (set-virtual-continuation/type! (virtual-return-operator push)
  181.                       continuation-type/effect)))))
  182.  
  183. ;;;; Miscellaneous Node Types
  184.  
  185. (define-snode assignment
  186.   context
  187.   lvalue
  188.   rvalue)
  189.  
  190. ;; (define *assignments*)
  191.  
  192. (define (make-assignment block lvalue rvalue)
  193.   (lvalue-connect! lvalue rvalue)
  194.   (let ((assignment (make-snode assignment-tag block lvalue rvalue)))
  195.     ;; (set! *assignments* (cons assignment *assignments*))
  196.     (variable-assigned! lvalue assignment)
  197.     (snode->scfg assignment)))
  198.  
  199. (define-integrable (node/assignment? node)
  200.   (eq? (tagged-vector/tag node) assignment-tag))
  201.  
  202. (define-snode definition
  203.   context
  204.   lvalue
  205.   rvalue)
  206.  
  207. (define (make-definition block lvalue rvalue)
  208.   (lvalue-connect! lvalue rvalue)
  209.   (snode->scfg (make-snode definition-tag block lvalue rvalue)))
  210.  
  211. (define-integrable (node/definition? node)
  212.   (eq? (tagged-vector/tag node) definition-tag))
  213.  
  214. (define-pnode true-test
  215.   context
  216.   rvalue)
  217.  
  218. (define (make-true-test block rvalue)
  219.   (pnode->pcfg (make-pnode true-test-tag block rvalue)))
  220.  
  221. (define-integrable (node/true-test? node)
  222.   (eq? (tagged-vector/tag node) true-test-tag))
  223.  
  224. (define-snode fg-noop)
  225.  
  226. (define (make-fg-noop)
  227.   (make-snode fg-noop-tag))
  228.  
  229. (define-integrable (node/fg-noop? node)
  230.   (eq? (tagged-vector/tag node) fg-noop-tag))
  231.  
  232. (cfg-node-tag/noop! fg-noop-tag)
  233.  
  234. (define-snode virtual-return
  235.   context
  236.   operator
  237.   operand)
  238.  
  239. (define (make-virtual-return block operator operand)
  240.   (snode->scfg (make-snode virtual-return-tag block operator operand)))
  241.  
  242. (define-integrable (node/virtual-return? node)
  243.   (eq? (tagged-vector/tag node) virtual-return-tag))
  244.  
  245. (define-integrable (virtual-return/target-lvalue return)
  246.   (cfg-node-get return virtual-return/target-lvalue/tag))
  247.  
  248. (define-integrable (set-virtual-return/target-lvalue! return lvalue)
  249.   (cfg-node-put! return virtual-return/target-lvalue/tag lvalue))
  250.  
  251. (define virtual-return/target-lvalue/tag
  252.   "target-lvalue")
  253.  
  254. (define (make-push block rvalue)
  255.   (make-virtual-return block
  256.                (virtual-continuation/make block continuation-type/push)
  257.                rvalue))
  258.  
  259. (define-snode pop
  260.   continuation)
  261.  
  262. (define (make-pop continuation)
  263.   (snode->scfg (make-snode pop-tag continuation)))
  264.  
  265. (define-integrable (node/pop? node)
  266.   (eq? (tagged-vector/tag node) pop-tag))
  267.  
  268. (define-snode stack-overwrite
  269.   context
  270.   target
  271.   continuation)
  272.  
  273. (define (make-stack-overwrite block target continuation)
  274.   (snode->scfg (make-snode stack-overwrite-tag block target continuation)))
  275.  
  276. (define-integrable (node/stack-overwrite? node)
  277.   (eq? (tagged-vector/tag node) stack-overwrite-tag))
  278.  
  279. ;;; Node Properties
  280.  
  281. (define-integrable (node/subgraph-color node)
  282.   (cfg-node-get node node/subgraph-color-tag))
  283.  
  284. (define-integrable (set-node/subgraph-color! node color)
  285.   (cfg-node-put! node node/subgraph-color-tag color))
  286.  
  287. (define node/subgraph-color-tag
  288.   "subgraph-color-tag")
  289.  
  290. (define-structure (subgraph-color
  291.            (conc-name subgraph-color/)
  292.            (constructor make-subgraph-color ()))
  293.   (nodes '())
  294.   (rgraph false))