mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-13 23:20:32 +02:00
Code Activity

better effects analysis for calls to lexically bound procedures

Browse source 
* 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 2012-05-15 17:22:05 +02:00
parent 86e4479abb
commit 83bd53abb6
1 changed files with 176 additions and 156 deletions
Download patch file Download diff file Expand all files Collapse all files

32
module/language/tree-il/effects.scm
View file

@ -162,13 +162,13 @@
"Returns a procedure of type EXP -> EFFECTS that analyzes the effects "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression." of an expression."
(define compute-effects
(let ((cache (make-hash-table))) (let ((cache (make-hash-table)))
(lambda (exp) (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
(define (compute-effects exp)
(or (hashq-ref cache exp) (or (hashq-ref cache exp)
(let ((effects (visit exp))) (let ((effects (visit exp)))
(hashq-set! cache exp effects) (hashq-set! cache exp effects)
effects))))) effects)))
(define (accumulate-effects exps) (define (accumulate-effects exps)
(let lp ((exps exps) (out &no-effects)) (let lp ((exps exps) (out &no-effects))
@ -285,9 +285,16 @@ of an expression."
;; Lambda applications might throw wrong-number-of-args. ;; Lambda applications might throw wrong-number-of-args.
(($ <application> _ ($ <lambda> _ _ body) args) (($ <application> _ ($ <lambda> _ _ body) args)
(logior (accumulate-effects args)
(match body
(($ <lambda-case> _ req #f #f #f () syms body #f)
(logior (compute-effects body) (logior (compute-effects body)
(accumulate-effects args) (if (= (length req) (length args))
(cause &type-check))) 0
(cause &type-check))))
(($ <lambda-case>)
(logior (compute-effects body)
(cause &type-check))))))
;; Bailout primitives. ;; Bailout primitives.
(($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name)) (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
@ -296,6 +303,17 @@ of an expression."
(cause &definite-bailout) (cause &definite-bailout)
(cause &possible-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. ;; A call to an unknown procedure can do anything.
(($ <application> _ proc args) (($ <application> _ proc args)
(logior &all-effects-but-bailout (logior &all-effects-but-bailout
@ -332,4 +350,6 @@ of an expression."
(logior &all-effects-but-bailout (logior &all-effects-but-bailout
(cause &all-effects-but-bailout))))) (cause &all-effects-but-bailout)))))
compute-effects) (compute-effects exp))
compute-effects))