--- /dev/null
- (($ <dynwind> _ winder body unwinder)
+ ;;; 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)))
- (($ <application> _ ($ <primitive-ref> _ 'values) ())
++ (($ <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.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect+exception-free-primitive?)))
- args)
++ (($ <primcall> _ 'values ())
+ (cause &zero-values))
+
+ ;; Effect-free primitives.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect-free-primitive?)))
- args)
++ (($ <primcall> _ (and name (? effect+exception-free-primitive?)) args)
+ (logior (accumulate-effects args)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ &no-effects)))
- (($ <application> _ ($ <lambda> _ _ body) args)
++ (($ <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.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
++ (($ <call> _ ($ <lambda> _ _ body) args)
+ (logior (compute-effects body)
+ (accumulate-effects args)
+ (cause &type-check)))
+
+ ;; Bailout primitives.
- (($ <application> _ proc args)
++ (($ <primcall> _ (? bailout-primitive? name) args)
+ (logior (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+
+ ;; A call to an unknown procedure can do anything.
- (($ <sequence> _ exps)
- (let lp ((exps exps) (effects &no-effects))
- (match exps
- ((tail)
- (logior (compute-effects tail)
- ;; Returning zero values to a for-effect continuation is
- ;; not observable.
- (exclude-effects effects (cause &zero-values))))
- ((head . tail)
- (lp tail (logior (compute-effects head) effects))))))
++ (($ <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)
HCoop / bpt / guile.git / commitdiff