--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/sideff.scm,v 1.1 1988/12/06 18:57:56 jinx Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Side effect analysis
+
+(declare (usual-integrations))
+\f
+;;;; Computing the call graphs
+
+(package (compute-call-graph! clear-call-graph!)
+
+(define-export (compute-call-graph! procedures)
+ ;; This is only needed because the fields in the
+ ;; procedure objects are reused.
+ (clear-call-graph! procedures)
+ (for-each find&memoize-callees! procedures))
+
+(define (find&memoize-callees! procedure)
+ (let loop ((apps (block-applications (procedure-block procedure)))
+ (constants '())
+ (procedures '()))
+ (cond ((null? apps)
+ (memoize-callees! procedure constants procedures))
+ ((not (application/combination? (car apps)))
+ (loop (cdr apps) constants procedures))
+ (else
+ (let* ((operator (application-operator (car apps)))
+ (nconsts
+ (eq-set-union
+ (list-transform-positive
+ (rvalue-values operator)
+ rvalue/constant?)
+ constants)))
+ (loop (cdr apps)
+ (if (or (not (rvalue-passed-in? operator))
+ ;; This is only possible if it was
+ ;; declared CONSTANT.
+ (rvalue-known-value operator))
+ nconsts
+ ;; It is a passed in reference.
+ (eq-set-adjoin
+ (reference-lvalue operator)
+ nconsts))
+ (eq-set-union
+ (list-transform-positive
+ (rvalue-values operator)
+ #|
+ ;; This is unnecessary as long as we treat continuations
+ ;; specially and treat cwcc as an unknown procedure.
+ (lambda (val)
+ (and (rvalue/procedure? val)
+ (not (procedure-continuation? val))))
+ |#
+ rvalue/procedure?)
+ procedures)))))))
+\f
+(define-export (clear-call-graph! procedures)
+ (for-each (lambda (procedure)
+ (set-procedure-initial-callees! procedure '())
+ (set-procedure-callees! procedure '())
+ (set-procedure-callers! procedure '()))
+ procedures))
+
+(define (memoize-callees! procedure constants callees)
+ (set-procedure-initial-callees! procedure (cons constants callees))
+ (for-each (lambda (callee)
+ (add-caller&callee! procedure callee))
+ callees))
+
+;; This transitively completes the call graph. Two procedures are
+;; related by a caller/callee relationship if there is a path by which
+;; the caller calls the callee.
+
+(define (add-caller&callee! caller callee)
+ (let ((callees (procedure-callees caller)))
+ (if (not (memq callee callees))
+ (begin
+ (set-procedure-callees! caller
+ (cons callee callees))
+ (set-procedure-callers! callee
+ (cons caller
+ (procedure-callers callee)))
+ (for-each
+ (lambda (callee^2)
+ (add-caller&callee! caller callee^2))
+ (procedure-callees callee))
+ (for-each
+ (lambda (caller^2)
+ (add-caller&callee! caller^2 callee))
+ (procedure-callers caller))))
+ 'DONE))
+
+) ;; package
+\f
+(package (side-effect-analysis)
+
+;; IMPORTANT: This assumes that the call graph has been computed.
+
+(define-export (side-effect-analysis procs&conts applications)
+ (let ((procedures
+ (list-transform-negative procs&conts procedure-continuation?)))
+ (if (not compiler:analyze-side-effects?)
+ (for-each (lambda (proc)
+ (set-procedure-side-effects!
+ proc
+ (list '(ARBITRARY BYPASSED))))
+ procedures)
+ (begin
+ (for-each setup-side-effects! procedures)
+ (for-each compute-side-effects! procedures)
+ (transitive-closure
+ false
+ (lambda (item)
+ (if (application? item)
+ (analyze-combination! item)
+ (analyze-procedure! item)))
+ (append procedures
+ (list-transform-positive
+ applications
+ application/combination?)))))))
+
+(define (setup-side-effects! procedure)
+ (let ((assigned-vars
+ (let ((block (procedure-block procedure)))
+ (list-transform-positive
+ (block-free-variables block)
+ (lambda (variable)
+ (there-exists?
+ (variable-assignments variable)
+ (lambda (assignment)
+ (eq? (assignment-block assignment)
+ block)))))))
+ (arbitrary-callees
+ (list-transform-negative
+ (car (procedure-initial-callees procedure))
+ (lambda (object)
+ (if (lvalue/variable? object)
+ (variable/side-effect-free? object)
+ (constant/side-effect-free? object))))))
+ (set-procedure-side-effects!
+ procedure
+ `(,@(if (null? assigned-vars)
+ '()
+ (list `(ASSIGNMENT ,@assigned-vars)))
+ ,@(if (null? arbitrary-callees)
+ '()
+ (list `(ARBITRARY ,@arbitrary-callees)))))))
+\f
+(define (variable/side-effect-free? variable)
+ (let ((decls (variable-declarations variable)))
+ (or (memq 'SIDE-EFFECT-FREE decls)
+ (memq 'PURE-FUNCTION decls)
+ (and (memq 'USUAL-DEFINITION decls)
+ (side-effect-free-variable?
+ (variable-name variable))))))
+
+(define (constant/side-effect-free? constant)
+ (and (rvalue/constant? constant) ; Paranoia
+ (let ((val (constant-value constant)))
+ (and (not (eq? val compiled-error-procedure)) ; Hmm.
+ (if (primitive-procedure? val)
+ (side-effect-free-primitive? val)
+ (not (procedure-object? val)))))))
+
+(define (process-derived-assignments! procedure variables effects)
+ (let* ((block (procedure-block procedure))
+ (modified-variables
+ (list-transform-negative
+ variables
+ (lambda (var)
+ ;; The theoretical closing limit of this variable would be give
+ ;; a more precise bound, but we don't have that information.
+ (and (not (variable-closed-over? var))
+ (block-ancestor-or-self? (variable-block var) block))))))
+ (if (null? modified-variables)
+ effects
+ (let ((place (assq 'DERIVED-ASSIGNMENT effects)))
+ (if (false? place)
+ (cons (cons 'DERIVED-ASSIGNMENT modified-variables)
+ effects)
+ (begin (set-cdr! place
+ (append! modified-variables (cdr place)))
+ effects))))))
+\f
+;;;; Procedure side effects
+
+(define (compute-side-effects! procedure)
+ ;; There is no point in computing further if this procedure has
+ ;; arbitrary side effects.
+ (let ((my-effects (procedure-side-effects procedure)))
+ (if (not (assq 'ARBITRARY my-effects))
+ (begin
+ (for-each
+ (lambda (callee)
+ (if (not (eq? callee procedure))
+ (let dispatch-loop ((effects (procedure-side-effects callee)))
+ (if (null? effects)
+ 'DONE
+ (begin
+ (case (caar effects)
+ ((ARBITRARY DERIVED-ARBITRARY RANDOM)
+ (let ((place (assq 'DERIVED-ARBITRARY my-effects)))
+ (if (false? place)
+ (set! my-effects
+ (cons `(DERIVED-ARBITRARY ,callee)
+ my-effects)))))
+ ((ASSIGNMENT DERIVED-ASSIGNMENT)
+ (set! my-effects
+ (process-derived-assignments!
+ procedure
+ (cdar effects)
+ my-effects)))
+ (else
+ (error
+ "compute-side-effects!: Unknown side-effect class"
+ (caar effects))
+ (let ((place (assq 'RANDOM my-effects)))
+ (if (false? place)
+ (set! my-effects
+ (cons '(RANDOM) my-effects))))))
+ (dispatch-loop (cdr effects)))))))
+ (procedure-callees procedure))
+ (set-procedure-side-effects! procedure my-effects)))
+ 'DONE))
+\f
+;;; Determine whether the procedure computes a simple value.
+
+(define (analyze-procedure! procedure)
+ (if (and (not (procedure-continuation? procedure)) ;; paranoia
+ (null? (procedure-side-effects procedure))
+ (not (procedure/simplified? procedure)))
+ (let ((pcont (procedure-continuation-lvalue procedure)))
+ (and (not (lvalue-passed-out? pcont))
+ (let ((r/lvalue (continuation-variable/returned-value pcont)))
+ (and r/lvalue
+ (value/available? r/lvalue (procedure-block procedure))
+ (begin
+ (simplify-procedure! procedure r/lvalue)
+ (and (value/independent? r/lvalue
+ (procedure-block procedure))
+ (procedure-always-known-operator? procedure)
+ (begin (procedure/trivial! procedure 'BETA)
+ (enqueue-nodes!
+ (procedure-applications procedure)))))))))))
+
+(define (continuation-variable/returned-value lvalue)
+ (define (test-return return)
+ (if (not (application/return? return))
+ (begin
+ (error "continuation variable invoked in non-return application"
+ return)
+ false)
+ (let ((value (return/operand return)))
+ (or (and (or (rvalue/constant? value)
+ (rvalue/procedure? value))
+ value)
+ #|
+ ;; This is not sufficient.
+ (and (rvalue/reference? value)
+ (reference-lvalue value))
+ |#
+ ))))
+
+ (define (compare r/lvalue returns lvalues)
+ (cond ((not (null? returns))
+ (and (eq? r/lvalue (test-return (car returns)))
+ (compare r/lvalue (cdr returns) lvalues)))
+ ((not (null? lvalues))
+ (compare r/lvalue
+ (lvalue-applications (car lvalues))
+ (cdr lvalues)))
+ (else
+ r/lvalue)))
+
+ (let find ((returns '())
+ (lvalues (eq-set-adjoin lvalue (lvalue-forward-links lvalue))))
+ (if (not (null? returns))
+ (let ((result (test-return (car returns))))
+ (and result (compare result (cdr returns) lvalues)))
+ (and lvalues
+ (find (lvalue-applications (car lvalues))
+ (cdr lvalues))))))
+\f
+;;; Determine whether the call should be punted
+
+(define (analyze-combination! app)
+ (define (simplify-combination! value)
+ (combination/trivial! app value)
+ (enqueue-node! (block-procedure (application-block app))))
+
+ (define (check value op-vals)
+ (if (and value
+ (for-all? op-vals
+ (lambda (proc)
+ (and (rvalue/procedure? proc)
+ (eq? value
+ (procedure/simplified-value
+ proc
+ (application-block app)))))))
+ (simplify-combination! value)))
+
+ (define (check-operators operator)
+ (let ((vals (rvalue-values operator)))
+ (and (not (null? vals))
+ (let ((proc (car vals)))
+ (and (rvalue/procedure? proc)
+ (check (procedure/simplified-value proc
+ (application-block app))
+ (cdr vals)))))))
+
+ (and (application/combination? app)
+ (let ((operator (application-operator app))
+ (cont (combination/continuation app)))
+ (and (not (rvalue-passed-in? operator))
+ (for-all? (rvalue-values operator)
+ (lambda (proc)
+ (and (rvalue/procedure? proc)
+ (null? (procedure-side-effects proc)))))
+ (cond ((rvalue/procedure? cont)
+ (if (eq? (continuation/type cont)
+ continuation-type/effect)
+ (simplify-combination! (make-constant false))
+ (let ((val (lvalue-known-value
+ (continuation/parameter cont))))
+ (if val
+ (and (value/available? val
+ (application-block app))
+ (simplify-combination! val))
+ (check-operators operator)))))
+ ((and (rvalue/reference? cont)
+ (eq? (continuation-variable/type
+ (reference-lvalue cont))
+ continuation-type/effect))
+ (simplify-combination! (make-constant false)))
+ (else
+ (check-operators operator)))))))
+\f
+(define (value/test-generator block-test)
+ (lambda (r/lvalue block)
+ (if (lvalue/variable? r/lvalue)
+ (block-test block (variable-block r/lvalue))
+ (or (rvalue/constant? r/lvalue)
+ (and (rvalue/procedure? r/lvalue)
+ (if (procedure/closure? r/lvalue)
+ (or (procedure/trivial-closure? r/lvalue)
+ #|
+ ;; We need to change the rtl generator to avoid
+ ;; closing the procedure within itself
+ (block-ancestor-or-self?
+ block
+ (procedure-block r/lvalue))
+ |#
+ )
+ (block-test block
+ (procedure-closing-block r/lvalue))))))))
+
+(define value/independent?
+ (value/test-generator
+ (lambda (block definition-block)
+ (declare (integrate block definition-block))
+ (not (block-ancestor-or-self? definition-block block)))))
+
+(define value/available?
+ (value/test-generator
+ (lambda (block definition-block)
+ (declare (integrate block definition-block))
+ (block-ancestor-or-self? block definition-block))))
+
+(define-integrable (r/lvalue->rvalue block r/lvalue)
+ (if (lvalue/variable? r/lvalue)
+ (make-reference block r/lvalue false)
+ r/lvalue))
+\f
+(define (combination/trivial! comb r/lvalue)
+ (let ((push (combination/continuation-push comb)))
+ (if (and push (rvalue-known-value (combination/continuation comb)))
+ (set-virtual-continuation/type!
+ (virtual-return-operator push)
+ continuation-type/effect)))
+ (combination/constant! comb
+ (r/lvalue->rvalue (combination/block comb) r/lvalue)))
+
+(define (procedure/trivial! procedure kind)
+ (let ((place (assq 'TRIVIAL (procedure-properties procedure))))
+ (cond ((not place)
+ (set-procedure-properties!
+ procedure
+ (cons `(TRIVIAL ,kind) (procedure-properties procedure))))
+ ((not (memq kind (cdr place)))
+ (set-cdr! place (cons kind (cdr place)))))))
+
+(define (simplify-procedure! procedure r/lvalue)
+ (let ((place (assq 'SIMPLIFIED (procedure-properties procedure))))
+ (if place
+ (error "procedure/trivial!: Already simplified" procedure))
+ (set-procedure-properties! procedure
+ (cons `(SIMPLIFIED ,r/lvalue)
+ (procedure-properties procedure))))
+ (set-procedure-entry-node!
+ procedure
+ (let ((block (procedure-block procedure)))
+ (cfg-entry-node
+ (make-return block
+ (make-reference block
+ (procedure-continuation-lvalue procedure)
+ true)
+ (r/lvalue->rvalue block r/lvalue))))))
+
+(define (procedure/simplified-value procedure block)
+ (let ((node (procedure-entry-node procedure)))
+ (and (application? node)
+ (application/return? node)
+ (let ((value
+ (let ((operand (return/operand node)))
+ (if (rvalue/reference? operand)
+ (reference-lvalue operand)
+ (rvalue-known-value operand)))))
+ (and value
+ (value/available? value block)
+ value)))))
+
+) ;; package
\ No newline at end of file
projects / mit-scheme.git / commitdiff