1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00

stronger conditional optimization

* module/language/tree-il/peval.scm (peval): If we can lift one common
  test, see if we can lift others as well.

* test-suite/tests/peval.test: Add a test.
This commit is contained in:
Andy Wingo 2012-05-15 12:21:57 +02:00
parent f49fd9afd6
commit 9b1750ed42
2 changed files with 32 additions and 3 deletions

View file

@ -1036,8 +1036,9 @@ top-level bindings from ENV and return the resulting expression."
other-subsequent alternate)
(make-conditional
src outer-test
(make-conditional src* inner-test inner-subsequent
other-subsequent)
(simplify-conditional
(make-conditional src* inner-test inner-subsequent
other-subsequent))
alternate))
;; Likewise, but punching through any surrounding
;; failure continuations.
@ -1056,7 +1057,8 @@ top-level bindings from ENV and return the resulting expression."
(lambda (failure)
(make-conditional
src outer-test
(make-conditional src* inner-test inner-subsequent failure)
(simplify-conditional
(make-conditional src* inner-test inner-subsequent failure))
failure)))))))
(_ c)))
(match (for-test condition)

View file

@ -1028,4 +1028,31 @@
(toplevel C))
(apply (toplevel baz) (toplevel x))
(apply (lexical failure _)))))
(apply (lexical failure _)))))
;; Multiple common tests should get lifted as well.
(pass-if-peval resolve-primitives
(if (and (struct? x) (eq? (struct-vtable x) A) B)
(foo x)
(if (and (struct? x) (eq? (struct-vtable x) A) C)
(bar x)
(if (and (struct? x) (eq? (struct-vtable x) A) D)
(baz x)
(qux x))))
(let (failure) (_) ((lambda _
(lambda-case
((() #f #f #f () ())
(apply (toplevel qux) (toplevel x))))))
(if (apply (primitive struct?) (toplevel x))
(if (apply (primitive eq?)
(apply (primitive struct-vtable) (toplevel x))
(toplevel A))
(if (toplevel B)
(apply (toplevel foo) (toplevel x))
(if (toplevel C)
(apply (toplevel bar) (toplevel x))
(if (toplevel D)
(apply (toplevel baz) (toplevel x))
(apply (lexical failure _)))))
(apply (lexical failure _)))
(apply (lexical failure _))))))