From 8a94d945259e63f784825c0926cf0e317567af00 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Tue, 6 Dec 1988 18:57:56 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/fgopt/sideff.scm | 453 +++++++++++++++++++++++++++++++ 1 file changed, 453 insertions(+) create mode 100644 v7/src/compiler/fgopt/sideff.scm diff --git a/v7/src/compiler/fgopt/sideff.scm b/v7/src/compiler/fgopt/sideff.scm new file mode 100644 index 000000000..13829dc1c --- /dev/null +++ b/v7/src/compiler/fgopt/sideff.scm @@ -0,0 +1,453 @@ +#| -*-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)) + +;;;; 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))))))) + +(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 + +(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))))))) + +(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)))))) + +;;;; 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)) + +;;; 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)))))) + +;;; 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))))))) + +(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)) + +(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 -- 2.25.1