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 / lvalue.scm < prev    next >
Text File  |  1999-01-02  |  13KB  |  371 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lvalue.scm,v 4.21 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. ;;;; Left (Hand Side) Values
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;; IMPORTANT: Change transform/make-lvalue and the call to
  27. ;; define-type-definition in macros.scm whenever a field is added or
  28. ;; deleted!
  29.  
  30. (define-root-type lvalue
  31.   generation        ;generation mark for graph walking
  32.   alist            ;property list
  33.   initial-forward-links    ;lvalues that sink values directly from here
  34.   initial-backward-links ;lvalues that source values directly to here
  35.   forward-links        ;transitive closure of initial-forward-links
  36.   backward-links    ;transitive closure of initial-backward-links
  37.   initial-values    ;rvalues that are possible sources
  38.   values-cache        ;(see `lvalue-values')
  39.   known-value        ;either #F or the rvalue which is the unique value
  40.   applications        ;applications whose operators are this lvalue
  41.   passed-in?        ;true iff this lvalue gets an unknown value
  42.   passed-out?        ;true iff this lvalue passes its value to unknown place
  43.   source-links        ;backward links with circularities removed
  44.   )
  45.  
  46. ;;; Note that the rvalues stored in `initial-values', `values-cache',
  47. ;;; and `known-value' are NEVER references.
  48.  
  49. (define *lvalues*)
  50.  
  51. ;;; converted to a macro.
  52. ;;; (define (make-lvalue tag . extra)
  53. ;;;   (let ((lvalue
  54. ;;;      (list->vector
  55. ;;;       (cons* tag false '() '() '() '() '() '() 'NOT-CACHED
  56. ;;;          false '() false false '() extra))))
  57. ;;;     (set! *lvalues* (cons lvalue *lvalues*))
  58. ;;;     lvalue))
  59.  
  60. (define (add-lvalue-application! lvalue application)
  61.   (set-lvalue-applications! lvalue
  62.                 (cons application
  63.                   (lvalue-applications lvalue))))
  64.  
  65. (define-lvalue variable
  66.   block        ;block in which variable is defined
  67.   name        ;name of variable [symbol]
  68.   assignments    ;true iff variable appears in an assignment
  69.   in-cell?    ;true iff variable requires cell at runtime
  70.   normal-offset    ;offset of variable within `block'
  71.   declarations    ;list of declarations for this variable
  72.   closed-over?    ;true iff a closure references it freely.
  73.   register    ;register for parameters passed in registers
  74.   stack-overwrite-target?
  75.         ;true iff variable is the target of a stack overwrite
  76.   indirection    ;alias for this variable (variable . boolean) or #f
  77.   source-node    ;virtual-return that initializes this variable, or #f
  78.   )
  79.  
  80. (define continuation-variable/type variable-in-cell?)
  81. (define set-continuation-variable/type! set-variable-in-cell?!)
  82.  
  83. (define (make-variable block name)
  84.   (make-lvalue variable-tag block name '() false false '() false false
  85.            false false false))
  86.  
  87. (define variable-assoc
  88.   (association-procedure eq? variable-name))
  89.  
  90. (define (variable-offset block variable)
  91.   (if (closure-block? block)
  92.       (cdr (assq variable (block-closure-offsets block)))
  93.       (variable-normal-offset variable)))
  94.  
  95. (define-vector-tag-unparser variable-tag
  96.   (standard-unparser (symbol->string 'VARIABLE)
  97.     (lambda (state variable)
  98.       (unparse-object state (variable-name variable)))))
  99.  
  100. (define-integrable (lvalue/variable? lvalue)
  101.   (eq? (tagged-vector/tag lvalue) variable-tag))
  102.  
  103. (let-syntax
  104.     ((define-named-variable
  105.       (macro (name)
  106.     (let ((symbol (intern (string-append "#[" (symbol->string name) "]"))))
  107.       `(BEGIN (DEFINE-INTEGRABLE
  108.             (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK)
  109.             (MAKE-VARIABLE BLOCK ',symbol))
  110.           (DEFINE-INTEGRABLE
  111.             (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE)
  112.             (EQ? (VARIABLE-NAME LVALUE) ',symbol))
  113.           (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE)
  114.             (AND (VARIABLE? LVALUE)
  115.              (EQ? (VARIABLE-NAME LVALUE) ',symbol))))))))
  116.   (define-named-variable continuation)
  117.   (define-named-variable value))
  118.  
  119. (define (variable/register variable)
  120.   (let ((maybe-delayed-register (variable-register variable)))
  121.     (if (promise? maybe-delayed-register)
  122.     (force maybe-delayed-register)
  123.     maybe-delayed-register)))
  124.  
  125. ;;;; Linking
  126.  
  127. ;;; Eventually, links may be triples consisting of a source, a sink,
  128. ;;; and a set of paths.  Each path will be an ordered sequence of
  129. ;;; actions.  Actions will keep track of what paths they are part of,
  130. ;;; and paths will keep track of what links they are part of.  But for
  131. ;;; now, this significantly cheaper representation will do.
  132.  
  133. (define (lvalue-connect! lvalue rvalue)
  134.   (if (rvalue/reference? rvalue)
  135.       (lvalue-connect!:lvalue lvalue (reference-lvalue rvalue))
  136.       (lvalue-connect!:rvalue lvalue rvalue)))
  137.  
  138. (define (lvalue-connect!:rvalue lvalue rvalue)
  139.   (if (not (memq rvalue (lvalue-initial-values lvalue)))
  140.       (set-lvalue-initial-values! lvalue
  141.                   (cons rvalue
  142.                     (lvalue-initial-values lvalue)))))
  143.  
  144. (define (lvalue-connect!:lvalue to from)
  145.   (if (not (memq from (lvalue-initial-backward-links to)))
  146.       (begin
  147.     (set-lvalue-initial-backward-links!
  148.      to
  149.      (cons from (lvalue-initial-backward-links to)))
  150.     (set-lvalue-initial-forward-links!
  151.      from
  152.      (cons to (lvalue-initial-forward-links from)))))
  153.   (letrec ((connect
  154.         (lambda (to from)
  155.           (if (not (memq from (lvalue-backward-links to)))
  156.           (begin
  157.             (set-lvalue-backward-links!
  158.              to
  159.              (cons from (lvalue-backward-links to)))
  160.             (set-lvalue-forward-links!
  161.              from
  162.              (cons to (lvalue-forward-links from)))
  163.             (for-each (lambda (from) (connect to from))
  164.                   (lvalue-backward-links from))
  165.             (for-each (lambda (to) (connect to from))
  166.                   (lvalue-forward-links to)))))))
  167.     (connect to from)))
  168.  
  169. (define (lvalue-values lvalue)
  170.   ;; No recursion is needed here because the dataflow graph is
  171.   ;; transitively closed when this is run.
  172.   (if (eq? 'NOT-CACHED (lvalue-values-cache lvalue))
  173.       (let ((values
  174.          (eq-set-union* (lvalue-initial-values lvalue)
  175.                 (map lvalue-initial-values
  176.                  (lvalue-backward-links lvalue)))))
  177.     (set-lvalue-values-cache! lvalue values)
  178.     values)
  179.       (lvalue-values-cache lvalue)))
  180.  
  181. (define (reset-lvalue-cache! lvalue)
  182.   (set-lvalue-values-cache! lvalue 'NOT-CACHED)
  183.   (for-each (lambda (lvalue)
  184.           (set-lvalue-values-cache! lvalue 'NOT-CACHED))
  185.         (lvalue-forward-links lvalue)))
  186.  
  187. ;;;; Attributes
  188.  
  189. (package (with-new-lvalue-marks lvalue-marked? lvalue-mark!)
  190.  
  191.   (define-export (with-new-lvalue-marks thunk)
  192.     (fluid-let ((*generation* (make-generation)))
  193.       (thunk)))
  194.  
  195.   (define-export (lvalue-marked? lvalue)
  196.     (eq? (lvalue-generation lvalue) *generation*))
  197.  
  198.   (define-export (lvalue-mark! lvalue)
  199.     (set-lvalue-generation! lvalue *generation*))
  200.  
  201.   (define *generation*)
  202.  
  203.   (define make-generation
  204.     (let ((generation 0))
  205.       (named-lambda (make-generation)
  206.     (let ((value generation))
  207.       (set! generation (1+ generation))
  208.       value)))))
  209.  
  210. (define (lvalue-get lvalue key)
  211.   (let ((entry (assq key (lvalue-alist lvalue))))
  212.     (and entry
  213.      (cdr entry))))
  214.  
  215. (define (lvalue-put! lvalue key item)
  216.   (let ((entry (assq key (lvalue-alist lvalue))))
  217.     (if entry
  218.     (set-cdr! entry item)
  219.     (set-lvalue-alist! lvalue
  220.                (cons (cons key item) (lvalue-alist lvalue))))))
  221.  
  222. (define (lvalue-remove! lvalue key)
  223.   (set-lvalue-alist! lvalue (del-assq! key (lvalue-alist lvalue))))
  224.  
  225. (define (variable-assigned! variable assignment)
  226.   (set-variable-assignments!
  227.    variable
  228.    (cons assignment (variable-assignments variable))))
  229.  
  230. (define-integrable (variable-assigned? variable)
  231.   (not (null? (variable-assignments variable))))
  232.  
  233. ;; Note:
  234. ;; If integration of known block values (first class environments) is
  235. ;; ever done, the package "optimization" transformations in
  236. ;; fggen/canon and fggen/fggen may break.  There is a hidden reference
  237. ;; to the environment variable from lambda expressions closed in that
  238. ;; context.  The variable can be eliminated if there are no references
  239. ;; and there are no lambda expressions implicitely referencing it.
  240.  
  241. (define (lvalue-integrated? lvalue)
  242.   (let ((value (lvalue-known-value lvalue)))
  243.     (and value
  244.      (or (rvalue/constant? value)
  245.          (and (rvalue/procedure? value)
  246.           (procedure/virtually-open? value))
  247.          (lvalue-get lvalue 'INTEGRATED))
  248.      (if (lvalue/variable? lvalue)
  249.          (let ((block (variable-block lvalue)))
  250.            (if (stack-block? block)
  251.            (let ((procedure (block-procedure block)))
  252.              (cond ((procedure-always-known-operator? procedure)
  253.                 true)
  254.                ((or (memq lvalue
  255.                       (cdr (procedure-required procedure)))
  256.                 (memq lvalue (procedure-optional procedure))
  257.                 (eq? lvalue (procedure-rest procedure)))
  258.                 false)
  259.                (else true)))
  260.            true))
  261.          true))))
  262.  
  263. (define (variable-unused? variable)
  264.   (or (lvalue-integrated? variable)
  265.       (variable-indirection variable)))
  266.  
  267. (define (lvalue=? lvalue lvalue*)
  268.   (or (eq? lvalue lvalue*)
  269.       (eq-set-same-set? (lvalue/source-set lvalue)
  270.             (lvalue/source-set lvalue*))))
  271.  
  272. (define (lvalue/unique-source lvalue)
  273.   (let ((source-set (lvalue/source-set lvalue)))
  274.     (and (not (null? source-set))
  275.      (null? (cdr source-set))
  276.      (car source-set))))
  277.  
  278. (define (lvalue/source-set lvalue)
  279.   (list-transform-positive
  280.       (eq-set-adjoin lvalue (lvalue-backward-links lvalue))
  281.     lvalue/source?))
  282.  
  283. (define (lvalue/external-source-set lvalue)
  284.   (list-transform-positive
  285.       (eq-set-adjoin lvalue (lvalue-backward-links lvalue))
  286.     lvalue/external-source?))
  287.  
  288. (define (lvalue/source? lvalue)
  289.   (or (lvalue/external-source? lvalue)
  290.       (lvalue/internal-source? lvalue)))
  291.  
  292. (define-integrable (lvalue/external-source? lvalue)
  293.   ;; (number? (lvalue-passed-in? lvalue))
  294.   (let ((passed-in? (lvalue-passed-in? lvalue)))
  295.     (and passed-in?
  296.      (not (eq? passed-in? 'INHERITED)))))
  297.  
  298. (define-integrable (lvalue/internal-source? lvalue)
  299.   (not (null? (lvalue-initial-values lvalue))))
  300.  
  301. (define (variable-in-known-location? context variable)
  302.   (or (variable/value-variable? variable)
  303.       (let ((definition-block (variable-block variable)))
  304.     (or (not (ic-block? definition-block))
  305.         ;; If the block has no procedure, then we know nothing
  306.         ;; about the locations of its bindings.
  307.         (let ((reference-block (reference-context/block context)))
  308.           (and (rvalue/procedure? (block-procedure reference-block))
  309.            ;; If IC reference in same block as definition,
  310.            ;; then incremental definitions cannot screw us.
  311.            (eq? reference-block definition-block)
  312.            ;; Make sure that IC variables are bound!  A
  313.            ;; variable that is not bound by the code being
  314.            ;; compiled still has a "definition" block, which
  315.            ;; is the outermost IC block of the expression in
  316.            ;; which the variable is referenced.
  317.            (memq variable
  318.              (block-bound-variables reference-block))))))))
  319.  
  320. ;; This is not in use anywhere!  What is it for? -- Arthur & GJR 1/93
  321.  
  322. #|
  323.  
  324. (define (lvalue/articulation-points lvalue)
  325.   ;; This won't work if (memq lvalue (lvalue-backward-links lvalue))?
  326.   (let ((articulation-points '())
  327.     (number-tag "number-tag"))
  328.     (let ((articulation-point!
  329.        (lambda (lvalue)
  330.          (if (not (memq lvalue articulation-points))
  331.          (begin
  332.            (set! articulation-points (cons lvalue articulation-points))
  333.            unspecific))))
  334.       (allocate-number!
  335.        (let ((n 0))
  336.          (lambda ()
  337.            (let ((number n))
  338.          (set! n (1+ n))
  339.          number)))))
  340.       (with-new-lvalue-marks
  341.        (lambda ()
  342.      (let loop ((lvalue lvalue) (parent false) (number (allocate-number!)))
  343.        (lvalue-mark! lvalue)
  344.        (lvalue-put! lvalue number-tag number)
  345.        (if (lvalue/source? lvalue)
  346.            number
  347.            (apply min
  348.               (cons number
  349.                 (map (lambda (link)
  350.                    (cond ((not (lvalue-marked? link))
  351.                       (let ((low
  352.                          (loop link
  353.                                lvalue
  354.                                (allocate-number!))))
  355.                         (if (<= number low)
  356.                         (articulation-point! lvalue))
  357.                         low))
  358.                      ((eq? link parent)
  359.                       number)
  360.                      (else
  361.                       (lvalue-get link number-tag))))
  362.                  (lvalue-initial-backward-links lvalue)))))))))
  363.     (set! articulation-points
  364.       (sort (delq! lvalue articulation-points)
  365.         (lambda (x y)
  366.           (< (lvalue-get x number-tag) (lvalue-get y number-tag)))))
  367.     (for-each (lambda (lvalue) (lvalue-remove! lvalue number-tag))
  368.           (cons lvalue (lvalue-backward-links lvalue)))
  369.     articulation-points))
  370.  
  371. |#