mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

fix bugs in effects analysis of "effect+exception-free-primitives"

Browse source 
* module/language/tree-il/effects.scm (make-effects-analyzer): Be more
  precise regarding the effects of the so-called
  effect+exception-free-primitives: now we check their arities.

* test-suite/tests/cse.test ("cse"): Add a test that we don't
  elide (cons 1 2 3) in effect context.
This commit is contained in:
Andy Wingo 2012-07-05 20:34:28 +02:00
parent 3d2bcd2c35
commit 37081d5d4b
2 changed files with 34 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -264,13 +264,34 @@ of an expression."
;; Effect-free primitives.
(($ <application> _
($ <primitive-ref> _ (and name
(? effect+exception-free-primitive?)))
($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
args)
(logior (accumulate-effects args)
(if (constructor-primitive? name)
(cause &allocation)
&no-effects)))
(accumulate-effects args))
(($ <application> _
($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
'vector? 'struct? 'string? 'number?
'char?))
(arg))
(compute-effects arg))
;; Primitives that allocate memory.
(($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
(logior (compute-effects x) (compute-effects y)
&allocation))
(($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
(logior (accumulate-effects args) &allocation))
(($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
&allocation)
(($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
(logior (compute-effects arg) &allocation))
;; Primitives that are normally effect-free, but which might
;; cause type checks, allocate memory, or access mutable
;; memory. FIXME: expand, to be more precise.
(($ <application> _
($ <primitive-ref> _ (and name
(? effect-free-primitive?)))

8
test-suite/tests/cse.test
View file

@ -286,4 +286,10 @@
(apply (primitive car) (toplevel x))
(if (apply (primitive car) (toplevel x))
(const one)
(const two)))))
(const two))))
(pass-if-cse
(begin (cons 1 2 3) 4)
(begin
(apply (primitive cons) (const 1) (const 2) (const 3))
(const 4))))