[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/05: Better partial evaluation of tests in tests
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/05: Better partial evaluation of tests in tests |
Date: |
Sun, 03 Jan 2016 17:32:56 +0000 |
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