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.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 1641b5b..15c7164 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -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)

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index c24fa8b..aefb2e0 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -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 _))))))