summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-27 23:21:53 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-28 00:13:56 +0200
commit40be30c97459e1baf8a9997c1c116a67f153cfef (patch)
tree37f5980b03efe36704673f25e6c5c26488a07066 /module/language/tree-il/optimize.scm
parentfc283c92cbdb31942f033541b52376fd1bade3f2 (diff)
downloadguile-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.scm66
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