summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/Makefile.am1
-rw-r--r--module/language/tree-il/effects.scm329
-rw-r--r--module/language/tree-il/peval.scm79
-rw-r--r--test-suite/tests/peval.test12
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))