diff options
author | Andy Wingo <wingo@pobox.com> | 2016-01-03 18:15:20 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-01-03 18:15:20 +0100 |
commit | 166703c5ce9549a9e4e010d657b9415e4275fff6 (patch) | |
tree | d66a8b05b887d78f1e3de7ce9f0213b1691b382e | |
parent | 52965e03ec47b92e5bd34c9dc9d9bbcaf100f26a (diff) | |
download | guile-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.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 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 |