diff options
Diffstat (limited to 'module/language/tree-il/effects.scm')
-rw-r--r-- | module/language/tree-il/effects.scm | 591 |
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)) |