diff options
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/language/tree-il/effects.scm | 329 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 79 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 12 |
4 files changed, 361 insertions, 60 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index e161b9c5e..1b58495ac 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -96,6 +96,7 @@ SCHEME_LANG_SOURCES = \ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ language/tree-il/peval.scm \ + language/tree-il/effects.scm \ language/tree-il/fix-letrec.scm \ language/tree-il/optimize.scm \ language/tree-il/canonicalize.scm \ diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm new file mode 100644 index 000000000..b2e218e3b --- /dev/null +++ b/module/language/tree-il/effects.scm @@ -0,0 +1,329 @@ +;;; Effects analysis on Tree-IL + +;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (language tree-il effects) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (ice-9 match) + #:export (make-effects-analyzer + &mutable-lexical + &toplevel + &fluid + &definite-bailout + &possible-bailout + &zero-values + &allocation + &mutable-data + &type-check + &all-effects + effects-commute? + exclude-effects + effect-free? + constant? + depends-on-effects? + causes-effects?)) + +;;; +;;; Hey, it's some effects analysis! If you invoke +;;; `make-effects-analyzer', you get a procedure that computes the set +;;; of effects that an expression depends on and causes. This +;;; information is useful when writing algorithms that move code around, +;;; while preserving the semantics of an input program. +;;; +;;; The effects set is represented by a bitfield, as a fixnum. The set +;;; of possible effects is modelled rather coarsely. For example, a +;;; toplevel reference to FOO is modelled as depending on the &toplevel +;;; effect, and causing a &type-check effect. If any intervening code +;;; sets any toplevel variable, that will block motion of FOO. +;;; +;;; For each effect, two bits are reserved: one to indicate that an +;;; expression depends on the effect, and the other to indicate that an +;;; expression causes the effect. +;;; + +(define-syntax define-effects + (lambda (x) + (syntax-case x () + ((_ all name ...) + (with-syntax (((n ...) (iota (length #'(name ...))))) + #'(begin + (define name (ash 1 (* n 2))) + ... + (define all (logior name ...)))))))) + +;; Here we define the effects, indicating the meaning of the effect. +;; +;; Effects that are described in a "depends on" sense can also be used +;; in the "causes" sense. +;; +;; Effects that are described as causing an effect are not usually used +;; in a "depends-on" sense. Although the "depends-on" sense is used +;; when checking for the existence of the "causes" effect, the effects +;; analyzer will not associate the "depends-on" sense of these effects +;; with any expression. +;; +(define-effects &all-effects + ;; Indicates that an expression depends on the value of a mutable + ;; lexical variable. + &mutable-lexical + + ;; Indicates that an expression depends on the value of a toplevel + ;; variable. + &toplevel + + ;; Indicates that an expression depends on the value of a fluid + ;; variable. + &fluid + + ;; Indicates that an expression definitely causes a non-local, + ;; non-resumable exit -- a bailout. Only used in the "changes" sense. + &definite-bailout + + ;; Indicates that an expression may cause a bailout. + &possible-bailout + + ;; Indicates than an expression may return zero values -- a "causes" + ;; effect. + &zero-values + + ;; Indicates that an expression may return a fresh object -- a + ;; "causes" effect. + &allocation + + ;; Indicates that an expression depends on the value of a mutable data + ;; structure. + &mutable-data + + ;; Indicates that an expression may cause a type check. A type check, + ;; for the purposes of this analysis, is the possibility of throwing + ;; an exception the first time an expression is evaluated. If the + ;; expression did not cause an exception to be thrown, users can + ;; assume that evaluating the expression again will not cause an + ;; exception to be thrown. + ;; + ;; For example, (+ x y) might throw if X or Y are not numbers. But if + ;; it doesn't throw, it should be safe to elide a dominated, common + ;; subexpression (+ x y). + &type-check) + +(define &no-effects 0) + +;; Definite bailout is an oddball effect. Since it indicates that an +;; expression definitely causes bailout, it's not in the set of effects +;; of a call to an unknown procedure. At the same time, it's also +;; special in that a definite bailout in a subexpression doesn't always +;; cause an outer expression to include &definite-bailout in its +;; effects. For that reason we have to treat it specially. +;; +(define &all-effects-but-bailout + (logand &all-effects (lognot &definite-bailout))) + +(define (cause effect) + (ash effect 1)) + +(define (&depends-on a) + (logand a &all-effects)) +(define (&causes a) + (logand a (cause &all-effects))) + +(define (exclude-effects effects exclude) + (logand effects (lognot (cause exclude)))) +(define (effect-free? effects) + (zero? (&causes effects))) +(define (constant? effects) + (zero? effects)) + +(define (depends-on-effects? x effects) + (not (zero? (logand (&depends-on x) effects)))) +(define (causes-effects? x effects) + (not (zero? (logand (&causes x) (cause effects))))) + +(define (effects-commute? a b) + (and (not (causes-effects? a (&depends-on b))) + (not (causes-effects? b (&depends-on a))))) + +(define (make-effects-analyzer assigned-lexical?) + "Returns a procedure of type EXP -> EFFECTS that analyzes the effects +of an expression." + + (define compute-effects + (let ((cache (make-hash-table))) + (lambda (exp) + (or (hashq-ref cache exp) + (let ((effects (visit exp))) + (hashq-set! cache exp effects) + effects))))) + + (define (accumulate-effects exps) + (let lp ((exps exps) (out &no-effects)) + (if (null? exps) + out + (lp (cdr exps) (logior out (compute-effects (car exps))))))) + + (define (visit exp) + (match exp + (($ <const>) + &no-effects) + (($ <void>) + &no-effects) + (($ <lexical-ref> _ _ gensym) + (if (assigned-lexical? gensym) + &mutable-lexical + &no-effects)) + (($ <lexical-set> _ name gensym exp) + (logior (cause &mutable-lexical) + (compute-effects exp))) + (($ <let> _ names gensyms vals body) + (logior (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (accumulate-effects vals) + (compute-effects body))) + (($ <letrec> _ in-order? names gensyms vals body) + (logior (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (accumulate-effects vals) + (compute-effects body))) + (($ <fix> _ names gensyms vals body) + (logior (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (accumulate-effects vals) + (compute-effects body))) + (($ <let-values> _ producer consumer) + (logior (compute-effects producer) + (compute-effects consumer) + (cause &type-check))) + (($ <dynwind> _ winder pre body post unwinder) + (logior (compute-effects winder) + (compute-effects pre) + (compute-effects body) + (compute-effects post) + (compute-effects unwinder))) + (($ <dynlet> _ fluids vals body) + (logior (accumulate-effects fluids) + (accumulate-effects vals) + (cause &type-check) + (cause &fluid) + (compute-effects body))) + (($ <dynref> _ fluid) + (logior (compute-effects fluid) + (cause &type-check) + &fluid)) + (($ <dynset> _ fluid exp) + (logior (compute-effects fluid) + (compute-effects exp) + (cause &type-check) + (cause &fluid))) + (($ <toplevel-ref>) + (logior &toplevel + (cause &type-check))) + (($ <module-ref>) + (logior &toplevel + (cause &type-check))) + (($ <module-set> _ mod name public? exp) + (logior (cause &toplevel) + (cause &type-check) + (compute-effects exp))) + (($ <toplevel-define> _ name exp) + (logior (cause &toplevel) + (compute-effects exp))) + (($ <toplevel-set> _ name exp) + (logior (cause &toplevel) + (compute-effects exp))) + (($ <primitive-ref>) + &no-effects) + (($ <conditional> _ test consequent alternate) + (let ((tfx (compute-effects test)) + (cfx (compute-effects consequent)) + (afx (compute-effects alternate))) + (if (causes-effects? (logior tfx (logand afx cfx)) + &definite-bailout) + (logior tfx cfx afx) + (exclude-effects (logior tfx cfx afx) + &definite-bailout)))) + + ;; Zero values. + (($ <primcall> _ 'values ()) + (cause &zero-values)) + + ;; Effect-free primitives. + (($ <primcall> _ (and name (? effect+exception-free-primitive?)) args) + (logior (accumulate-effects args) + (if (constructor-primitive? name) + (cause &allocation) + &no-effects))) + (($ <primcall> _ (and name (? effect-free-primitive?)) args) + (logior (accumulate-effects args) + (cause &type-check) + (if (constructor-primitive? name) + (cause &allocation) + (if (accessor-primitive? name) + &mutable-data + &no-effects)))) + + ;; Lambda applications might throw wrong-number-of-args. + (($ <call> _ ($ <lambda> _ _ body) args) + (logior (compute-effects body) + (accumulate-effects args) + (cause &type-check))) + + ;; Bailout primitives. + (($ <primcall> _ (? bailout-primitive? name) args) + (logior (accumulate-effects args) + (cause &definite-bailout) + (cause &possible-bailout))) + + ;; A call to an unknown procedure can do anything. + (($ <primcall> _ name args) + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))) + (($ <call> _ proc args) + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))) + + (($ <lambda> _ meta body) + &no-effects) + (($ <lambda-case> _ req opt rest kw inits gensyms body alt) + (logior (exclude-effects (accumulate-effects inits) + &definite-bailout) + (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (compute-effects body) + (if alt (compute-effects alt) &no-effects))) + + (($ <seq> _ head tail) + (logior + ;; Returning zero values to a for-effect continuation is + ;; not observable. + (exclude-effects (compute-effects head) + (cause &zero-values)) + (compute-effects tail))) + + (($ <prompt> _ tag body handler) + (logior (compute-effects tag) + (compute-effects body) + (compute-effects handler))) + + (($ <abort> _ tag args tail) + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))))) + + compute-effects) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 6b375919e..8866b0193 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -19,6 +19,7 @@ (define-module (language tree-il peval) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (language tree-il effects) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -298,12 +299,13 @@ (constant-value operand-constant-value set-operand-constant-value!)) (define* (make-operand var sym #:optional source visit) - ;; Bind SYM to VAR, with value SOURCE. Bound operands are considered - ;; copyable until we prove otherwise. If we have a source expression, - ;; truncate it to one value. Copy propagation does not work on - ;; multiply-valued expressions. + ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are + ;; considered copyable until we prove otherwise. If we have a source + ;; expression, truncate it to one value. Copy propagation does not + ;; work on multiply-valued expressions. (let ((source (and=> source truncate-values))) - (%make-operand var sym visit source 0 #f (and source #t) #f #f))) + (%make-operand var sym visit source 0 #f + (and source (not (var-set? var))) #f #f))) (define (make-bound-operands vars syms sources visit) (map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) @@ -555,52 +557,15 @@ top-level bindings from ENV and return the resulting expression." (let ((tail (loop tail))) (and tail (make-seq src head tail))))))) + (define compute-effects + (make-effects-analyzer assigned-lexical?)) + (define (constant-expression? x) ;; Return true if X is constant, for the purposes of copying or ;; elision---i.e., if it is known to have no effects, does not ;; allocate storage for a mutable object, and does not access ;; mutable data (like `car' or toplevel references). - (let loop ((x x)) - (match x - (($ <void>) #t) - (($ <const>) #t) - (($ <lambda>) #t) - (($ <lambda-case> _ req opt rest kw inits syms body alternate) - (and (not (any assigned-lexical? syms)) - (every loop inits) (loop body) - (or (not alternate) (loop alternate)))) - (($ <lexical-ref> _ _ gensym) - (not (assigned-lexical? gensym))) - (($ <primitive-ref>) #t) - (($ <conditional> _ condition subsequent alternate) - (and (loop condition) (loop subsequent) (loop alternate))) - (($ <primcall> _ 'values exps) - (and (not (null? exps)) - (every loop exps))) - (($ <primcall> _ name args) - (and (effect-free-primitive? name) - (not (constructor-primitive? name)) - (types-check? name args) - (if (accessor-primitive? name) - (every const? args) - (every loop args)))) - (($ <call> _ ($ <lambda> _ _ body) args) - (and (loop body) (every loop args))) - (($ <seq> _ head tail) - (and (loop head) (loop tail))) - (($ <let> _ _ syms vals body) - (and (not (any assigned-lexical? syms)) - (every loop vals) (loop body))) - (($ <letrec> _ _ _ syms vals body) - (and (not (any assigned-lexical? syms)) - (every loop vals) (loop body))) - (($ <fix> _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <let-values> _ exp body) - (and (loop exp) (loop body))) - (($ <prompt> _ tag body handler) - (and (loop tag) (loop body) (loop handler))) - (_ #f)))) + (constant? (compute-effects x))) (define (prune-bindings ops in-order? body counter ctx build-result) ;; This helper handles both `let' and `letrec'/`fix'. In the latter @@ -940,14 +905,20 @@ top-level bindings from ENV and return the resulting expression." ((test) (make-const #f #t)) (else exp))) (($ <conditional> src condition subsequent alternate) - (let ((condition (for-test condition))) - (if (const? condition) - (if (const-exp condition) - (for-tail subsequent) - (for-tail alternate)) - (make-conditional src condition - (for-tail subsequent) - (for-tail alternate))))) + (match (for-test condition) + (($ <const> _ val) + (if val + (for-tail subsequent) + (for-tail alternate))) + ;; Swap the arms of (if (not FOO) A B), to simplify. + (($ <primcall> _ 'not (c)) + (make-conditional src c + (for-tail alternate) + (for-tail subsequent))) + (c + (make-conditional src c + (for-tail subsequent) + (for-tail alternate))))) (($ <primcall> src '@call-with-values (producer ($ <lambda> _ _ diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 310cd974e..b10bedf1f 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -760,15 +760,15 @@ ;; This test checks that the `start' binding is indeed residualized. ;; See the `referenced?' procedure in peval's `prune-bindings'. (let ((pos 0)) - (set! pos 1) ;; Cause references to `pos' to residualize. (let ((here (let ((start pos)) (lambda () start)))) + (set! pos 1) ;; Cause references to `pos' to residualize. (here))) (let (pos) (_) ((const 0)) - (seq - (set! (lexical pos _) (const 1)) - (let (here) (_) (_) - (call (lexical here _)))))) - + (let (here) (_) (_) + (seq + (set! (lexical pos _) (const 1)) + (call (lexical here _)))))) + (pass-if-peval ;; FIXME: should this one residualize the binding? (letrec ((a a)) |