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

stronger conditional optimization

Browse source 
* 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
Download patch file Download diff file Expand all files Collapse all files

8
module/language/tree-il/peval.scm
View file

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

27
test-suite/tests/peval.test
View file

@ -1028,4 +1028,31 @@
(toplevel C)) (toplevel C))
(apply (toplevel baz) (toplevel x)) (apply (toplevel baz) (toplevel x))
(apply (lexical failure _))))) (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 _)))))) (apply (lexical failure _))))))