mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
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.
This commit is contained in:
Andy Wingo
parent
86e4479abb
commit
83bd53abb6
1 changed files with 176 additions and 156 deletions
|
|
@ -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)))))
|
||||
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 (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))))
|
||||
(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))
|
||||
;; 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))))
|
||||
;; 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)))
|
||||
;; 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)))
|
||||
;; 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)))))
|
||||
|
||||
(($ <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)))
|
||||
;; A call to an unknown procedure can do anything.
|
||||
(($ <application> _ proc args)
|
||||
(logior &all-effects-but-bailout
|
||||
(cause &all-effects-but-bailout)))
|
||||
|
||||
(($ <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))))))
|
||||
(($ <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)))
|
||||
|
||||
(($ <prompt> _ tag body handler)
|
||||
(logior (compute-effects tag)
|
||||
(compute-effects body)
|
||||
(compute-effects handler)))
|
||||
(($ <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))))))
|
||||
|
||||
(($ <abort> _ tag args tail)
|
||||
(logior &all-effects-but-bailout
|
||||
(cause &all-effects-but-bailout)))))
|
||||
(($ <prompt> _ tag body handler)
|
||||
(logior (compute-effects tag)
|
||||
(compute-effects body)
|
||||
(compute-effects handler)))
|
||||
|
||||
compute-effects)
|
||||
(($ <abort> _ tag args tail)
|
||||
(logior &all-effects-but-bailout
|
||||
(cause &all-effects-but-bailout)))))
|
||||
|
||||
(compute-effects exp))
|
||||
|
||||
compute-effects))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue