diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-27 23:21:53 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-28 00:13:56 +0200 |
commit | 40be30c97459e1baf8a9997c1c116a67f153cfef (patch) | |
tree | 37f5980b03efe36704673f25e6c5c26488a07066 /module/language/tree-il/optimize.scm | |
parent | fc283c92cbdb31942f033541b52376fd1bade3f2 (diff) | |
download | guile-40be30c97459e1baf8a9997c1c116a67f153cfef.tar.gz |
peval: more effective binding pruning
* module/language/tree-il/optimize.scm (peval): Factor prune-bindings
out of `let' and company. Have it process unreferenced bindings in
effect context instead of always residualizing non-constant
expressions.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r-- | module/language/tree-il/optimize.scm | 66 |
1 files changed, 37 insertions, 29 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 369c2e44f..6de676a4d 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -500,6 +500,32 @@ it does not handle <fix> and <let-values>, it should be called before (and (loop tag) (loop body) (loop handler))) (_ #f)))) + (define (prune-bindings names syms vals body for-effect + build-result) + (let lp ((names names) (syms syms) (vals vals) + (names* '()) (syms* '()) (vals* '()) + (effects '())) + (match (list names syms vals) + ((() () ()) + (let ((body (if (null? effects) + body + (make-sequence #f (reverse (cons body effects)))))) + (if (null? names*) + body + (build-result (reverse names*) (reverse syms*) + (reverse vals*) body)))) + (((name . names) (sym . syms) (val . vals)) + (if (hashq-ref residual-lexical-references sym) + (lp names syms vals + (cons name names*) (cons sym syms*) (cons val vals*) + effects) + (let ((effect (for-effect val))) + (lp names syms vals + names* syms* vals* + (if (void? effect) + effects + (cons effect effects))))))))) + (define (small-expression? x limit) (let/ec k (tree-il-fold @@ -637,22 +663,10 @@ it does not handle <fix> and <let-values>, it should be called before (else ;; Only include bindings for which lexical references ;; have been residualized. - (let*-values - (((stripped) (remove - (lambda (x) - (and (not (hashq-ref - residual-lexical-references - (cadr x))) - ;; FIXME: Here we can probably - ;; strip pure expressions in - ;; addition to constant - ;; expressions. - (constant-expression? (car x)))) - (zip vals gensyms names))) - ((vals gensyms names) (unzip3 stripped))) - (if (null? stripped) - body - (make-let src names gensyms vals body))))))) + (prune-bindings names gensyms vals body for-effect + (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) ;; Things could be done more precisely when IN-ORDER? but ;; it's OK not to do it---at worst we lost an optimization @@ -665,18 +679,10 @@ it does not handle <fix> and <let-values>, it should be called before (if (and (const? body) (every constant-expression? vals)) body - (let*-values - (((stripped) (remove - (lambda (x) - (and (constant-expression? (car x)) - (not (hashq-ref - residual-lexical-references - (cadr x))))) - (zip vals gensyms names))) - ((vals gensyms names) (unzip3 stripped))) - (if (null? stripped) - body - (make-letrec src in-order? names gensyms vals body)))))) + (prune-bindings names gensyms vals body for-effect + (lambda (names gensyms vals body) + (make-letrec src in-order? + names gensyms vals body)))))) (($ <fix> src names gensyms vals body) (let* ((vals (map for-operand vals)) (body (loop body @@ -685,7 +691,9 @@ it does not handle <fix> and <let-values>, it should be called before ctx))) (if (const? body) body - (make-fix src names gensyms vals body)))) + (prune-bindings names gensyms vals body for-effect + (lambda (names gensyms vals body) + (make-fix src names gensyms vals body)))))) (($ <let-values> lv-src producer consumer) ;; Peval the producer, then try to inline the consumer into ;; the producer. If that succeeds, peval again. Otherwise |