[Guile-commits] 03/05: Better partial evaluation of tests in tests

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 166703c5ce9549a9e4e010d657b9415e4275fff6
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 3 18:15:20 2016 +0100

    Better partial evaluation of tests in tests
    
    * module/language/tree-il/peval.scm (peval): In test context,
      fold (let ((x EXP)) (if x x ALT)) to (if EXP #t ALT).  This reduces
      the number of boolean literals that the compiler has to reify, by
      causing EXP to evaluate in test context instead of value context.
      Also, rotate `let' out of the test part of conditionals, for the same
      reason.
---
 module/language/tree-il/peval.scm |   73 +++++++++++++++++++++++++++----------
 1 files changed, 53 insertions(+), 20 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 355d423..1cf2cb1 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -944,26 +944,35 @@ top-level bindings from ENV and return the resulting 
expression."
                                         (map lookup-alias vals)))
               (env (fold extend-env env gensyms ops))
               (body (loop body env counter ctx)))
-         (cond
-          ((const? body)
-           (for-tail (list->seq src (append vals (list body)))))
-          ((and (lexical-ref? body)
-                (memq (lexical-ref-gensym body) new))
-           (let ((sym (lexical-ref-gensym body))
-                 (pairs (map cons new vals)))
-             ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
-             (for-tail
-              (list->seq
-               src
-               (append (map cdr (alist-delete sym pairs eq?))
-                       (list (assq-ref pairs sym)))))))
-          (else
-           ;; Only include bindings for which lexical references
-           ;; have been residualized.
-           (prune-bindings ops #f body counter ctx
-                           (lambda (names gensyms vals body)
-                             (if (null? names) (error "what!" names))
-                             (make-let src names gensyms vals body)))))))
+         (match body
+           (($ <const>)
+            (for-tail (list->seq src (append vals (list body)))))
+           (($ <lexical-ref> _ _ (? (lambda (sym) (memq sym new)) sym))
+            (let ((pairs (map cons new vals)))
+              ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
+              (for-tail
+               (list->seq
+                src
+                (append (map cdr (alist-delete sym pairs eq?))
+                        (list (assq-ref pairs sym)))))))
+           ((and ($ <conditional> src*
+                    ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym) alt)
+                 (? (lambda (_)
+                      (case ctx
+                        ((test effect)
+                         (and (equal? (list sym) new)
+                              (= (lexical-refcount sym) 2)))
+                        (else #f)))))
+            ;; (let ((x EXP)) (if x x ALT)) -> (if EXP #t ALT) in test context
+            (make-conditional src* (visit-operand (car ops) counter 'test)
+                              (make-const src* #t) alt))
+           (_
+            ;; Only include bindings for which lexical references
+            ;; have been residualized.
+            (prune-bindings ops #f body counter ctx
+                            (lambda (names gensyms vals body)
+                              (if (null? names) (error "what!" names))
+                              (make-let src names gensyms vals body)))))))
       (($ <letrec> src in-order? names gensyms vals body)
        ;; Note the difference from the `let' case: here we use letrec*
        ;; so that the `visit' procedure for the new operands closes over
@@ -1084,6 +1093,30 @@ top-level bindings from ENV and return the resulting 
expression."
                subsequent alternate)
             (simplify-conditional
              (make-conditional src pred alternate subsequent)))
+           ;; In the following four cases, we try to expose the test to
+           ;; the conditional.  This will let the CPS conversion avoid
+           ;; reifying boolean literals in some cases.
+           (($ <conditional> src ($ <let> src* names vars vals body)
+               subsequent alternate)
+            (make-let src* names vars vals
+                      (simplify-conditional
+                       (make-conditional src body subsequent alternate))))
+           (($ <conditional> src
+               ($ <letrec> src* in-order? names vars vals body)
+               subsequent alternate)
+            (make-letrec src* in-order? names vars vals
+                         (simplify-conditional
+                          (make-conditional src body subsequent alternate))))
+           (($ <conditional> src ($ <fix> src* names vars vals body)
+               subsequent alternate)
+            (make-fix src* names vars vals
+                      (simplify-conditional
+                       (make-conditional src body subsequent alternate))))
+           (($ <conditional> src ($ <seq> src* head tail)
+               subsequent alternate)
+            (make-seq src* head
+                      (simplify-conditional
+                       (make-conditional src tail subsequent alternate))))
            ;; Special cases for common tests in the predicates of chains
            ;; of if expressions.
            (($ <conditional> src