mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-12 06:41:13 +02:00
cse: expressions evaluated for effect do not provide predicates
* module/language/tree-il/cse.scm (cse): When trying to fold conditionals, only look at entries in the database that were added in test context. * test-suite/tests/cse.test ("cse"): Add a test case.
This commit is contained in:
parent
378daa5fa5
commit
4d1ae11279
2 changed files with 18 additions and 3 deletions
|
@ -276,11 +276,11 @@
|
||||||
#f)))
|
#f)))
|
||||||
(_
|
(_
|
||||||
(cond
|
(cond
|
||||||
((find-dominating-expression exp effects #f db)
|
((find-dominating-expression exp effects 'test db)
|
||||||
;; We have an EXP fact, so we infer #t.
|
;; We have an EXP fact, so we infer #t.
|
||||||
(log 'inferring exp #t)
|
(log 'inferring exp #t)
|
||||||
(make-const (tree-il-src exp) #t))
|
(make-const (tree-il-src exp) #t))
|
||||||
((find-dominating-expression (negate exp 'test) effects #f db)
|
((find-dominating-expression (negate exp 'test) effects 'test db)
|
||||||
;; We have a (not EXP) fact, so we infer #f.
|
;; We have a (not EXP) fact, so we infer #f.
|
||||||
(log 'inferring exp #f)
|
(log 'inferring exp #f)
|
||||||
(make-const (tree-il-src exp) #f))
|
(make-const (tree-il-src exp) #f))
|
||||||
|
|
|
@ -271,4 +271,19 @@
|
||||||
(let ((x (car y)))
|
(let ((x (car y)))
|
||||||
(cons x (car y)))
|
(cons x (car y)))
|
||||||
(let (x) (_) ((apply (primitive car) (toplevel y)))
|
(let (x) (_) ((apply (primitive car) (toplevel y)))
|
||||||
(apply (primitive cons) (lexical x _) (lexical x _)))))
|
(apply (primitive cons) (lexical x _) (lexical x _))))
|
||||||
|
|
||||||
|
;; Dominating expressions only provide predicates when evaluated in
|
||||||
|
;; test context.
|
||||||
|
(pass-if-cse
|
||||||
|
(let ((t (car x)))
|
||||||
|
(if (car x)
|
||||||
|
'one
|
||||||
|
'two))
|
||||||
|
;; Actually this one should reduce in other ways, but this is the
|
||||||
|
;; current reduction:
|
||||||
|
(begin
|
||||||
|
(apply (primitive car) (toplevel x))
|
||||||
|
(if (apply (primitive car) (toplevel x))
|
||||||
|
(const one)
|
||||||
|
(const two)))))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue