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 / sideff.scm < prev    next >
Text File  |  1999-01-02  |  15KB  |  437 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: sideff.scm,v 1.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 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. ;;;; Side effect analysis
  23. ;;; package: (compiler fg-optimizer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Computing the call graphs
  28.  
  29. (package (compute-call-graph! clear-call-graph!)
  30.  
  31. (define-export (compute-call-graph! procedures)
  32.   ;; This is only needed because the fields in the
  33.   ;; procedure objects are reused.
  34.   (clear-call-graph! procedures)
  35.   (for-each find&memoize-callees! procedures))
  36.  
  37. (define (find&memoize-callees! procedure)
  38.   (let loop ((apps (block-applications (procedure-block procedure)))
  39.          (constants '())
  40.          (procedures '()))
  41.     (cond ((null? apps)
  42.        (memoize-callees! procedure constants procedures))
  43.       ((not (application/combination? (car apps)))
  44.        (loop (cdr apps) constants procedures))
  45.       (else
  46.        (let* ((operator (application-operator (car apps)))
  47.           (nconsts
  48.            (eq-set-union
  49.             (list-transform-positive
  50.             (rvalue-values operator)
  51.               rvalue/constant?)
  52.             constants)))
  53.          (loop (cdr apps)
  54.            (if (or (not (rvalue-passed-in? operator))
  55.                ;; This is only possible if it was
  56.                ;; declared CONSTANT.
  57.                (rvalue-known-value operator))
  58.                nconsts
  59.                ;; It is a passed in reference.
  60.                (eq-set-adjoin
  61.             (reference-lvalue operator)
  62.             nconsts))
  63.            (eq-set-union
  64.             (list-transform-positive
  65.             (rvalue-values operator)
  66.               #|
  67.               ;; This is unnecessary as long as we treat continuations
  68.               ;; specially and treat cwcc as an unknown procedure.
  69.               (lambda (val)
  70.             (and (rvalue/procedure? val)
  71.                  (not (procedure-continuation? val))))
  72.               |#
  73.               rvalue/procedure?)
  74.             procedures)))))))
  75.  
  76. (define-export (clear-call-graph! procedures)
  77.   (for-each (lambda (procedure)
  78.           (set-procedure-initial-callees! procedure '())
  79.           (set-procedure-callees! procedure '())
  80.           (set-procedure-callers! procedure '()))
  81.         procedures))
  82.  
  83. (define (memoize-callees! procedure constants callees)
  84.   (set-procedure-initial-callees! procedure (cons constants callees))
  85.   (for-each (lambda (callee)
  86.           (add-caller&callee! procedure callee))
  87.         callees))
  88.  
  89. ;; This transitively completes the call graph.  Two procedures are
  90. ;; related by a caller/callee relationship if there is a path by which
  91. ;; the caller calls the callee.
  92.  
  93. (define (add-caller&callee! caller callee)
  94.   (let ((callees (procedure-callees caller)))
  95.     (if (not (memq callee callees))
  96.     (begin
  97.       (set-procedure-callees! caller
  98.                   (cons callee callees))
  99.       (set-procedure-callers! callee
  100.                   (cons caller
  101.                     (procedure-callers callee)))
  102.       (for-each
  103.        (lambda (callee^2)
  104.          (add-caller&callee! caller callee^2))
  105.        (procedure-callees callee))
  106.       (for-each
  107.        (lambda (caller^2)
  108.          (add-caller&callee! caller^2 callee))
  109.        (procedure-callers caller))))
  110.     'DONE))
  111.  
  112. ) ;; package
  113.  
  114. (package (side-effect-analysis)
  115.  
  116. ;; IMPORTANT: This assumes that the call graph has been computed.
  117.  
  118. (define-export (side-effect-analysis procs&conts applications)
  119.   (let ((procedures
  120.      (list-transform-negative procs&conts procedure-continuation?)))
  121.     (if (not compiler:analyze-side-effects?)
  122.     (for-each (lambda (proc)
  123.             (set-procedure-side-effects!
  124.              proc
  125.              (list '(ARBITRARY BYPASSED))))
  126.           procedures)
  127.     (begin
  128.       (for-each setup-side-effects! procedures)
  129.       (for-each compute-side-effects! procedures)
  130.       (transitive-closure
  131.        false
  132.        (lambda (item)
  133.          (if (application? item)
  134.          (analyze-combination! item)
  135.          (analyze-procedure! item)))
  136.        (append procedures
  137.            (list-transform-positive
  138.             applications
  139.               application/combination?)))))))
  140.  
  141. (define (setup-side-effects! procedure)
  142.   (let ((assigned-vars
  143.      (let ((block (procedure-block procedure)))
  144.        (list-transform-positive
  145.            (block-free-variables block)
  146.          (lambda (variable)
  147.            (there-exists?
  148.         (variable-assignments variable)
  149.         (lambda (assignment)
  150.           (eq? (reference-context/block
  151.             (assignment-context assignment))
  152.                block)))))))
  153.     (arbitrary-callees
  154.      (list-transform-negative
  155.          (car (procedure-initial-callees procedure))
  156.        (lambda (object)
  157.          (if (lvalue/variable? object)
  158.          (variable/side-effect-free? object)
  159.          (constant/side-effect-free? object))))))
  160.     (set-procedure-side-effects!
  161.      procedure
  162.      `(,@(if (null? assigned-vars)
  163.          '()
  164.          (list `(ASSIGNMENT ,@assigned-vars)))
  165.        ,@(if (null? arbitrary-callees)
  166.          '()
  167.          (list `(ARBITRARY ,@arbitrary-callees)))))))
  168.  
  169. (define (variable/side-effect-free? variable)
  170.   (let ((decls (variable-declarations variable)))
  171.     (or (memq 'SIDE-EFFECT-FREE decls)
  172.     (memq 'PURE-FUNCTION decls)
  173.     (and (memq 'USUAL-DEFINITION decls)
  174.          (side-effect-free-variable?
  175.           (variable-name variable))))))
  176.  
  177. (define (constant/side-effect-free? constant)
  178.   (and (rvalue/constant? constant)            ; Paranoia
  179.        (let ((val (constant-value constant)))
  180.      (and (not (eq? val compiled-error-procedure))    ; Hmm.
  181.           (if (primitive-procedure? val)
  182.           (side-effect-free-primitive? val)
  183.           (not (procedure-object? val)))))))
  184.  
  185. (define (process-derived-assignments! procedure variables effects)
  186.   (let* ((block (procedure-block procedure))
  187.      (modified-variables
  188.       (list-transform-negative
  189.           variables
  190.         (lambda (var)
  191.           ;; The theoretical closing limit of this variable would be give
  192.           ;; a more precise bound, but we don't have that information.
  193.           (and (not (variable-closed-over? var))
  194.            (block-ancestor-or-self? (variable-block var) block))))))
  195.     (if (null? modified-variables)
  196.     effects
  197.     (let ((place (assq 'DERIVED-ASSIGNMENT effects)))
  198.       (if (false? place)
  199.           (cons (cons 'DERIVED-ASSIGNMENT modified-variables)
  200.             effects)
  201.           (begin (set-cdr! place
  202.                    (append! modified-variables (cdr place)))
  203.              effects))))))
  204.  
  205. ;;;; Procedure side effects
  206.  
  207. (define (compute-side-effects! procedure)
  208.   ;; There is no point in computing further if this procedure has
  209.   ;; arbitrary side effects.
  210.   (let ((my-effects (procedure-side-effects procedure)))
  211.     (if (not (assq 'ARBITRARY my-effects))
  212.     (begin
  213.       (for-each
  214.        (lambda (callee)
  215.          (if (not (eq? callee procedure))
  216.          (let dispatch-loop ((effects (procedure-side-effects callee)))
  217.            (if (null? effects)
  218.                'DONE
  219.                (begin
  220.              (case (caar effects)
  221.                ((ARBITRARY DERIVED-ARBITRARY RANDOM)
  222.                 (let ((place (assq 'DERIVED-ARBITRARY my-effects)))
  223.                   (if (false? place)
  224.                   (set! my-effects
  225.                     (cons `(DERIVED-ARBITRARY ,callee)
  226.                           my-effects)))))
  227.                ((ASSIGNMENT DERIVED-ASSIGNMENT)
  228.                 (set! my-effects
  229.                   (process-derived-assignments!
  230.                    procedure
  231.                    (cdar effects)
  232.                    my-effects)))
  233.                (else
  234.                 (error
  235.                  "compute-side-effects!: Unknown side-effect class"
  236.                  (caar effects))
  237.                 (let ((place (assq 'RANDOM my-effects)))
  238.                   (if (false? place)
  239.                   (set! my-effects
  240.                     (cons '(RANDOM) my-effects))))))
  241.              (dispatch-loop (cdr effects)))))))
  242.        (procedure-callees procedure))
  243.       (set-procedure-side-effects! procedure my-effects)))
  244.     'DONE))
  245.  
  246. ;;; Determine whether the procedure computes a simple value.
  247.  
  248. (define (analyze-procedure! procedure)
  249.   (if (and (not (procedure-continuation? procedure)) ;; paranoia
  250.        (null? (procedure-side-effects procedure))
  251.        (not (procedure/simplified? procedure)))
  252.       (let ((pcont (procedure-continuation-lvalue procedure)))
  253.     (and (not (lvalue-passed-out? pcont))
  254.          (let ((r/lvalue (continuation-variable/returned-value pcont)))
  255.            (and r/lvalue
  256.             (value/available? r/lvalue (procedure-block procedure))
  257.             (begin
  258.               (simplify-procedure! procedure r/lvalue)
  259.               (and (value/independent? r/lvalue
  260.                            (procedure-block procedure))
  261.                (procedure-always-known-operator? procedure)
  262.                (begin (procedure/trivial! procedure 'BETA)
  263.                   (enqueue-nodes!
  264.                    (procedure-applications procedure)))))))))))
  265.  
  266. (define (continuation-variable/returned-value lvalue)
  267.   (define (test-return return)
  268.     (if (not (application/return? return))
  269.     (begin
  270.       (error "continuation variable invoked in non-return application"
  271.          return)
  272.       false)
  273.     (let ((value (return/operand return)))
  274.       (or (and (or (rvalue/constant? value)
  275.                (rvalue/procedure? value))
  276.            value)
  277.           #|
  278.           ;; This is not sufficient.
  279.           (and (rvalue/reference? value)
  280.            (reference-lvalue value))
  281.           |#
  282.           ))))
  283.  
  284.   (define (compare r/lvalue returns lvalues)
  285.     (cond ((not (null? returns))
  286.        (and (eq? r/lvalue (test-return (car returns)))
  287.         (compare r/lvalue (cdr returns) lvalues)))
  288.       ((not (null? lvalues))
  289.        (compare r/lvalue
  290.             (lvalue-applications (car lvalues))
  291.             (cdr lvalues)))
  292.       (else
  293.        r/lvalue)))
  294.  
  295.   (let find ((returns '())
  296.          (lvalues (eq-set-adjoin lvalue (lvalue-forward-links lvalue))))
  297.     (if (not (null? returns))
  298.     (let ((result (test-return (car returns))))
  299.       (and result (compare result (cdr returns) lvalues)))
  300.     (and (not (null? lvalues))
  301.          (find (lvalue-applications (car lvalues))
  302.            (cdr lvalues))))))
  303.  
  304. ;;; Determine whether the call should be punted
  305.  
  306. (define (analyze-combination! app)
  307.   (define (simplify-combination! value)
  308.     (combination/constant! app
  309.                (r/lvalue->rvalue (combination/context app) value))
  310.     (let ((procedure (block-procedure (application-block app))))
  311.       (if (rvalue/procedure? procedure)
  312.       (enqueue-node! procedure))))
  313.  
  314.   (define (check value op-vals)
  315.     (if (and value
  316.          (for-all? op-vals
  317.                (lambda (proc)
  318.              (and (rvalue/procedure? proc)
  319.                   (eq? value
  320.                    (procedure/simplified-value
  321.                     proc
  322.                     (application-block app)))))))
  323.     (simplify-combination! value)))
  324.  
  325.   (define (check-operators operator)
  326.     (let ((vals (rvalue-values operator)))
  327.       (and (not (null? vals))
  328.        (let ((proc (car vals)))
  329.          (and (rvalue/procedure? proc)
  330.           (check (procedure/simplified-value proc
  331.                              (application-block app))
  332.              (cdr vals)))))))
  333.  
  334.   (and (application/combination? app)
  335.        (let ((operator (application-operator app))
  336.          (cont (combination/continuation app)))
  337.      (and (not (rvalue-passed-in? operator))
  338.           (for-all? (rvalue-values operator)
  339.             (lambda (proc)
  340.               (and (rvalue/procedure? proc)
  341.                    (null? (procedure-side-effects proc)))))
  342.           (cond ((rvalue/procedure? cont)
  343.              (if (eq? (continuation/type cont)
  344.                   continuation-type/effect)
  345.              (simplify-combination! (make-constant false))
  346.              (let ((val (lvalue-known-value
  347.                      (continuation/parameter cont))))
  348.                (if val
  349.                    (and (value/available? val
  350.                               (application-block app))
  351.                     (simplify-combination! val))
  352.                    (check-operators operator)))))
  353.             ((and (rvalue/reference? cont)
  354.               (eq? (continuation-variable/type
  355.                 (reference-lvalue cont))
  356.                    continuation-type/effect))
  357.              (simplify-combination! (make-constant false)))
  358.             (else
  359.              (check-operators operator)))))))
  360.  
  361. (define (value/test-generator block-test)
  362.   (lambda (r/lvalue block)
  363.     (if (lvalue/variable? r/lvalue)
  364.     (block-test block (variable-block r/lvalue))
  365.     (or (rvalue/constant? r/lvalue)
  366.         (and (rvalue/procedure? r/lvalue)
  367.          (if (procedure/closure? r/lvalue)
  368.              (or (procedure/trivial-closure? r/lvalue)
  369.              #|
  370.              ;; We need to change the rtl generator to avoid
  371.              ;; closing the procedure within itself
  372.              (block-ancestor-or-self?
  373.               block
  374.               (procedure-block r/lvalue))
  375.              |#
  376.              )
  377.              (block-test block
  378.                  (procedure-closing-block r/lvalue))))))))
  379.  
  380. (define value/independent?
  381.   (value/test-generator
  382.    (lambda (block definition-block)
  383.      (declare (integrate block definition-block))
  384.      (not (block-ancestor-or-self? definition-block block)))))
  385.  
  386. (define value/available?
  387.   (value/test-generator 
  388.    (lambda (block definition-block)
  389.      (declare (integrate block definition-block))
  390.      (block-ancestor-or-self? block definition-block))))
  391.  
  392. (define-integrable (r/lvalue->rvalue context r/lvalue)
  393.   (if (lvalue/variable? r/lvalue)
  394.       (make-reference context r/lvalue false)
  395.       r/lvalue))
  396.  
  397. (define (procedure/trivial! procedure kind)
  398.   (let ((kinds (procedure-get procedure 'TRIVIAL)))
  399.     (cond ((or (not kinds) (null? kinds))
  400.        (procedure-put! procedure 'TRIVIAL (list kind)))
  401.       ((not (memq kind kinds))
  402.        (procedure-put! procedure 'TRIVIAL (cons kind kinds))))))
  403.  
  404. (define (simplify-procedure! procedure r/lvalue)
  405.   ;; **** Kludge! `make-application' requires that a block be given,
  406.   ;; rather than a context, because this is how "fggen" builds things.
  407.   ;; So we must pass the block and then clobber it after.
  408.   (if (procedure-get procedure 'SIMPLIFIED)
  409.       (error "procedure/trivial!: Already simplified" procedure))
  410.   (procedure-put! procedure 'SIMPLIFIED r/lvalue)
  411.   (let ((block (procedure-block procedure)))
  412.     (let ((context (make-reference-context block)))
  413.       (let ((application
  414.          (cfg-entry-node
  415.           (make-return block
  416.                (make-reference
  417.                 context
  418.                 (procedure-continuation-lvalue procedure)
  419.                 true)
  420.                (r/lvalue->rvalue context r/lvalue)))))
  421.     (set-application-context! application context)
  422.     (set-procedure-entry-node! procedure application)))))
  423.  
  424. (define (procedure/simplified-value procedure block)
  425.   (let ((node (procedure-entry-node procedure)))
  426.     (and (application? node)
  427.      (application/return? node)
  428.      (let ((value
  429.         (let ((operand (return/operand node)))
  430.           (if (rvalue/reference? operand)
  431.               (reference-lvalue operand)
  432.               (rvalue-known-value operand)))))
  433.        (and value
  434.         (value/available? value block)
  435.         value)))))
  436.  
  437. ) ;; package