summaryrefslogtreecommitdiff
path: root/module/language/tree-il/effects.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/effects.scm')
-rw-r--r--module/language/tree-il/effects.scm591
1 files changed, 591 insertions, 0 deletions
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
new file mode 100644
index 000000000..a133e3269
--- /dev/null
+++ b/module/language/tree-il/effects.scm
@@ -0,0 +1,591 @@
+;;; Effects analysis on Tree-IL
+
+;; Copyright (C) 2011, 2012, 2013 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
+ &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.
+;;;
+;;; Since we have more bits in a fixnum on 64-bit systems, we can be
+;;; more precise without losing efficiency. On a 32-bit system, some of
+;;; the more precise effects map to fewer bits.
+;;;
+
+(define-syntax define-effects
+ (lambda (x)
+ (syntax-case x ()
+ ((_ all name ...)
+ (with-syntax (((n ...) (iota (length #'(name ...)))))
+ #'(begin
+ (define-syntax name (identifier-syntax (ash 1 (* n 2))))
+ ...
+ (define-syntax all (identifier-syntax (logior name ...)))))))))
+
+(define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x (else)
+ ((_ (else body ...))
+ #'(begin body ...))
+ ((_ (exp body ...) clause ...)
+ (if (eval (syntax->datum #'exp) (current-module))
+ #'(begin body ...)
+ #'(compile-time-cond clause ...))))))
+
+;; 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.
+;;
+(compile-time-cond
+ ((>= (logcount most-positive-fixnum) 60)
+ (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 the car of a
+ ;; pair.
+ &car
+
+ ;; Indicates that an expression depends on the value of the cdr of a
+ ;; pair.
+ &cdr
+
+ ;; Indicates that an expression depends on the value of a vector
+ ;; field. We cannot be more precise, as vectors may alias other
+ ;; vectors.
+ &vector
+
+ ;; Indicates that an expression depends on the value of a variable
+ ;; cell.
+ &variable
+
+ ;; Indicates that an expression depends on the value of a particular
+ ;; struct field.
+ &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+
+
+ ;; Indicates that an expression depends on the contents of a string.
+ &string
+
+ ;; Indicates that an expression depends on the contents of a
+ ;; bytevector. We cannot be more precise, as bytevectors may alias
+ ;; other bytevectors.
+ &bytevector
+
+ ;; 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)
+
+ ;; Indicates that an expression depends on the contents of an unknown
+ ;; struct field.
+ (define-syntax &struct
+ (identifier-syntax
+ (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))
+
+ (else
+ ;; For systems with smaller fixnums, be less precise regarding struct
+ ;; fields.
+ (define-effects &all-effects
+ &mutable-lexical
+ &toplevel
+ &fluid
+ &definite-bailout
+ &possible-bailout
+ &zero-values
+ &allocation
+ &car
+ &cdr
+ &vector
+ &variable
+ &struct
+ &string
+ &bytevector
+ &type-check)
+ (define-syntax &struct-0 (identifier-syntax &struct))
+ (define-syntax &struct-1 (identifier-syntax &struct))
+ (define-syntax &struct-2 (identifier-syntax &struct))
+ (define-syntax &struct-3 (identifier-syntax &struct))
+ (define-syntax &struct-4 (identifier-syntax &struct))
+ (define-syntax &struct-5 (identifier-syntax &struct))
+ (define-syntax &struct-6+ (identifier-syntax &struct))))
+
+(define-syntax &no-effects (identifier-syntax 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-syntax &all-effects-but-bailout
+ (identifier-syntax
+ (logand &all-effects (lognot &definite-bailout))))
+
+(define-inlinable (cause effect)
+ (ash effect 1))
+
+(define-inlinable (&depends-on a)
+ (logand a &all-effects))
+(define-inlinable (&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-inlinable (depends-on-effects? x effects)
+ (not (zero? (logand (&depends-on x) effects))))
+(define-inlinable (causes-effects? x effects)
+ (not (zero? (logand (&causes x) (cause effects)))))
+
+(define-inlinable (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."
+
+ (let ((cache (make-hash-table)))
+ (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
+ (define (compute-effects 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)))
+ (($ <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> _ (or 'values 'eq? 'eqv? 'equal?) args)
+ (accumulate-effects args))
+
+ (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?)
+ (arg))
+ (compute-effects arg))
+
+ ;; Primitives that allocate memory.
+ (($ <primcall> _ 'cons (x y))
+ (logior (compute-effects x) (compute-effects y)
+ &allocation))
+
+ (($ <primcall> _ (or 'list 'vector) args)
+ (logior (accumulate-effects args) &allocation))
+
+ (($ <primcall> _ 'make-prompt-tag ())
+ &allocation)
+
+ (($ <primcall> _ 'make-prompt-tag (arg))
+ (logior (compute-effects arg) &allocation))
+
+ (($ <primcall> _ 'fluid-ref (fluid))
+ (logior (compute-effects fluid)
+ (cause &type-check)
+ &fluid))
+
+ (($ <primcall> _ 'fluid-set! (fluid exp))
+ (logior (compute-effects fluid)
+ (compute-effects exp)
+ (cause &type-check)
+ (cause &fluid)))
+
+ (($ <primcall> _ 'push-fluid (fluid val))
+ (logior (compute-effects fluid)
+ (compute-effects val)
+ (cause &type-check)
+ (cause &fluid)))
+
+ (($ <primcall> _ 'pop-fluid ())
+ (logior (cause &fluid)))
+
+ (($ <primcall> _ 'push-dynamic-state (state))
+ (logior (compute-effects state)
+ (cause &type-check)
+ (cause &fluid)))
+
+ (($ <primcall> _ 'pop-dynamic-state ())
+ (logior (cause &fluid)))
+
+ (($ <primcall> _ 'car (x))
+ (logior (compute-effects x)
+ (cause &type-check)
+ &car))
+ (($ <primcall> _ 'set-car! (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ (cause &car)))
+
+ (($ <primcall> _ 'cdr (x))
+ (logior (compute-effects x)
+ (cause &type-check)
+ &cdr))
+ (($ <primcall> _ 'set-cdr! (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ (cause &cdr)))
+
+ (($ <primcall> _ (or 'memq 'memv) (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ &car &cdr))
+
+ (($ <primcall> _ 'vector-ref (v n))
+ (logior (compute-effects v)
+ (compute-effects n)
+ (cause &type-check)
+ &vector))
+ (($ <primcall> _ 'vector-set! (v n x))
+ (logior (compute-effects v)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &vector)))
+
+ (($ <primcall> _ 'variable-ref (v))
+ (logior (compute-effects v)
+ (cause &type-check)
+ &variable))
+ (($ <primcall> _ 'variable-set! (v x))
+ (logior (compute-effects v)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &variable)))
+
+ (($ <primcall> _ 'struct-ref (s n))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (cause &type-check)
+ (match n
+ (($ <const> _ 0) &struct-0)
+ (($ <const> _ 1) &struct-1)
+ (($ <const> _ 2) &struct-2)
+ (($ <const> _ 3) &struct-3)
+ (($ <const> _ 4) &struct-4)
+ (($ <const> _ 5) &struct-5)
+ (($ <const> _ _) &struct-6+)
+ (_ &struct))))
+ (($ <primcall> _ 'struct-set! (s n x))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (match n
+ (($ <const> _ 0) (cause &struct-0))
+ (($ <const> _ 1) (cause &struct-1))
+ (($ <const> _ 2) (cause &struct-2))
+ (($ <const> _ 3) (cause &struct-3))
+ (($ <const> _ 4) (cause &struct-4))
+ (($ <const> _ 5) (cause &struct-5))
+ (($ <const> _ _) (cause &struct-6+))
+ (_ (cause &struct)))))
+
+ (($ <primcall> _ 'string-ref (s n))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (cause &type-check)
+ &string))
+ (($ <primcall> _ 'string-set! (s n c))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (compute-effects c)
+ (cause &type-check)
+ (cause &string)))
+
+ (($ <primcall> _
+ (or 'bytevector-u8-ref 'bytevector-s8-ref
+ 'bytevector-u16-ref 'bytevector-u16-native-ref
+ 'bytevector-s16-ref 'bytevector-s16-native-ref
+ 'bytevector-u32-ref 'bytevector-u32-native-ref
+ 'bytevector-s32-ref 'bytevector-s32-native-ref
+ 'bytevector-u64-ref 'bytevector-u64-native-ref
+ 'bytevector-s64-ref 'bytevector-s64-native-ref
+ 'bytevector-ieee-single-ref 'bytevector-ieee-single-native-ref
+ 'bytevector-ieee-double-ref 'bytevector-ieee-double-native-ref)
+ (bv n))
+ (logior (compute-effects bv)
+ (compute-effects n)
+ (cause &type-check)
+ &bytevector))
+ (($ <primcall> _
+ (or 'bytevector-u8-set! 'bytevector-s8-set!
+ 'bytevector-u16-set! 'bytevector-u16-native-set!
+ 'bytevector-s16-set! 'bytevector-s16-native-set!
+ 'bytevector-u32-set! 'bytevector-u32-native-set!
+ 'bytevector-s32-set! 'bytevector-s32-native-set!
+ 'bytevector-u64-set! 'bytevector-u64-native-set!
+ 'bytevector-s64-set! 'bytevector-s64-native-set!
+ 'bytevector-ieee-single-set! 'bytevector-ieee-single-native-set!
+ 'bytevector-ieee-double-set! 'bytevector-ieee-double-native-set!)
+ (bv n x))
+ (logior (compute-effects bv)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &bytevector)))
+
+ ;; Primitives that are normally effect-free, but which might
+ ;; cause type checks or allocate memory. Nota bene,
+ ;; primitives that access mutable memory should be given their
+ ;; own inline cases above!
+ (($ <primcall> _ (and name (? effect-free-primitive?)) args)
+ (logior (accumulate-effects args)
+ (cause &type-check)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ &no-effects)))
+
+ ;; Lambda applications might throw wrong-number-of-args.
+ (($ <call> _ ($ <lambda> _ _ body) args)
+ (logior (accumulate-effects args)
+ (match body
+ (($ <lambda-case> _ req #f #f #f () syms body #f)
+ (logior (compute-effects body)
+ (if (= (length req) (length args))
+ 0
+ (cause &type-check))))
+ (($ <lambda-case>)
+ (logior (compute-effects body)
+ (cause &type-check)))
+ (#f
+ ;; Calling a case-lambda with no clauses
+ ;; definitely causes bailout.
+ (logior (cause &definite-bailout)
+ (cause &possible-bailout))))))
+
+ ;; Bailout primitives.
+ (($ <primcall> _ (? bailout-primitive? name) args)
+ (logior (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+ (($ <call> _
+ (and proc
+ ($ <module-ref> _ mod name public?)
+ (? (lambda (_)
+ (false-if-exception
+ (procedure-property
+ (module-ref (if public?
+ (resolve-interface mod)
+ (resolve-module mod))
+ name)
+ 'definite-bailout?)))))
+ args)
+ (logior (compute-effects proc)
+ (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+
+ ;; A call to a lexically bound procedure, perhaps labels
+ ;; allocated.
+ (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (cond
+ ((lookup sym)
+ => (lambda (proc)
+ (compute-effects (make-call #f proc args))))
+ (else
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-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> _ escape-only? 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 exp))
+
+ compute-effects))