summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-01-03 18:15:20 +0100
committerAndy Wingo <wingo@pobox.com>2016-01-03 18:15:20 +0100
commit166703c5ce9549a9e4e010d657b9415e4275fff6 (patch)
treed66a8b05b887d78f1e3de7ce9f0213b1691b382e
parent52965e03ec47b92e5bd34c9dc9d9bbcaf100f26a (diff)
downloadguile-166703c5ce9549a9e4e010d657b9415e4275fff6.tar.gz
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.
-rw-r--r--module/language/tree-il/peval.scm73
1 files changed, 53 insertions, 20 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 355d423dd..1cf2cb1a8 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