summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-05-15 17:22:05 +0200
committerAndy Wingo <wingo@pobox.com>2012-05-15 17:22:05 +0200
commit83bd53abb697dd9597f3b78e13e74344b0b676e6 (patch)
treef81e4fa823839667859b94f560443778d29ee7c9
parent86e4479abb89d26840d6ba3afe9df611fbeb4b98 (diff)
downloadguile-83bd53abb697dd9597f3b78e13e74344b0b676e6.tar.gz
better effects analysis for calls to lexically bound procedures
* module/language/tree-il/effects.scm (make-effects-analyzer): The analyzer will take an optional second argument, a lookup procedure of type sym -> exp. This can let the analyzer dig into calls to lexically bound procedures.
-rw-r--r--module/language/tree-il/effects.scm352
1 files changed, 186 insertions, 166 deletions
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 67bb8b71e..656b262ae 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -162,174 +162,194 @@
"Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."
- (define compute-effects
- (let ((cache (make-hash-table)))
- (lambda (exp)
+ (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)))
- (($ <dynwind> _ winder body unwinder)
- (logior (compute-effects winder)
- (compute-effects body)
- (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> _ 'values) ())
- (cause &zero-values))
-
- ;; Effect-free primitives.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect+exception-free-primitive?)))
- args)
- (logior (accumulate-effects args)
- (if (constructor-primitive? name)
- (cause &allocation)
- &no-effects)))
- (($ <application> _
- ($ <primitive-ref> _ (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))))
+ 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 body unwinder)
+ (logior (compute-effects winder)
+ (compute-effects body)
+ (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> _ 'values) ())
+ (cause &zero-values))
+
+ ;; Effect-free primitives.
+ (($ <application> _
+ ($ <primitive-ref> _ (and name
+ (? effect+exception-free-primitive?)))
+ args)
+ (logior (accumulate-effects args)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ &no-effects)))
+ (($ <application> _
+ ($ <primitive-ref> _ (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> _ ($ <lambda> _ _ body) args)
- (logior (compute-effects body)
- (accumulate-effects args)
- (cause &type-check)))
+ ;; Lambda applications might throw wrong-number-of-args.
+ (($ <application> _ ($ <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))))))
- ;; Bailout primitives.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
- (logior (accumulate-effects args)
- (cause &definite-bailout)
- (cause &possible-bailout)))
-
- ;; A call to an unknown procedure can do anything.
- (($ <application> _ 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)))
-
- (($ <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))))))
-
- (($ <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)
+ ;; Bailout primitives.
+ (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
+ args)
+ (logior (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+
+ ;; A call to a lexically bound procedure, perhaps labels
+ ;; allocated.
+ (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (cond
+ ((lookup sym)
+ => (lambda (proc)
+ (compute-effects (make-application #f proc args))))
+ (else
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))))
+
+ ;; A call to an unknown procedure can do anything.
+ (($ <application> _ 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)))
+
+ (($ <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))))))
+
+ (($ <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 exp))
+
+ compute-effects))