diff options
author | Andy Wingo <wingo@pobox.com> | 2012-04-26 23:08:14 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-04-26 23:08:14 +0200 |
commit | 79d29f96c7c4631ec8096d88cbd86498f004162f (patch) | |
tree | 3cbe9c94b29c1cce72404ed23cdf640ed253f8d0 /module/language/tree-il/peval.scm | |
parent | c46e0a8a598a16b8f68b5492a13e4032b93f21f9 (diff) | |
parent | 1cd63115be7a25d0ea18aaa0e1eff5658d8db77a (diff) | |
download | guile-79d29f96c7c4631ec8096d88cbd86498f004162f.tar.gz |
Merge commit '1cd63115be7a25d0ea18aaa0e1eff5658d8db77a'
Conflicts:
module/language/tree-il/peval.scm
test-suite/tests/peval.test
Diffstat (limited to 'module/language/tree-il/peval.scm')
-rw-r--r-- | module/language/tree-il/peval.scm | 79 |
1 files changed, 25 insertions, 54 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 6b375919e..8866b0193 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -19,6 +19,7 @@ (define-module (language tree-il peval) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (language tree-il effects) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -298,12 +299,13 @@ (constant-value operand-constant-value set-operand-constant-value!)) (define* (make-operand var sym #:optional source visit) - ;; Bind SYM to VAR, with value SOURCE. Bound operands are considered - ;; copyable until we prove otherwise. If we have a source expression, - ;; truncate it to one value. Copy propagation does not work on - ;; multiply-valued expressions. + ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are + ;; considered copyable until we prove otherwise. If we have a source + ;; expression, truncate it to one value. Copy propagation does not + ;; work on multiply-valued expressions. (let ((source (and=> source truncate-values))) - (%make-operand var sym visit source 0 #f (and source #t) #f #f))) + (%make-operand var sym visit source 0 #f + (and source (not (var-set? var))) #f #f))) (define (make-bound-operands vars syms sources visit) (map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) @@ -555,52 +557,15 @@ top-level bindings from ENV and return the resulting expression." (let ((tail (loop tail))) (and tail (make-seq src head tail))))))) + (define compute-effects + (make-effects-analyzer assigned-lexical?)) + (define (constant-expression? x) ;; Return true if X is constant, for the purposes of copying or ;; elision---i.e., if it is known to have no effects, does not ;; allocate storage for a mutable object, and does not access ;; mutable data (like `car' or toplevel references). - (let loop ((x x)) - (match x - (($ <void>) #t) - (($ <const>) #t) - (($ <lambda>) #t) - (($ <lambda-case> _ req opt rest kw inits syms body alternate) - (and (not (any assigned-lexical? syms)) - (every loop inits) (loop body) - (or (not alternate) (loop alternate)))) - (($ <lexical-ref> _ _ gensym) - (not (assigned-lexical? gensym))) - (($ <primitive-ref>) #t) - (($ <conditional> _ condition subsequent alternate) - (and (loop condition) (loop subsequent) (loop alternate))) - (($ <primcall> _ 'values exps) - (and (not (null? exps)) - (every loop exps))) - (($ <primcall> _ name args) - (and (effect-free-primitive? name) - (not (constructor-primitive? name)) - (types-check? name args) - (if (accessor-primitive? name) - (every const? args) - (every loop args)))) - (($ <call> _ ($ <lambda> _ _ body) args) - (and (loop body) (every loop args))) - (($ <seq> _ head tail) - (and (loop head) (loop tail))) - (($ <let> _ _ syms vals body) - (and (not (any assigned-lexical? syms)) - (every loop vals) (loop body))) - (($ <letrec> _ _ _ syms vals body) - (and (not (any assigned-lexical? syms)) - (every loop vals) (loop body))) - (($ <fix> _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <let-values> _ exp body) - (and (loop exp) (loop body))) - (($ <prompt> _ tag body handler) - (and (loop tag) (loop body) (loop handler))) - (_ #f)))) + (constant? (compute-effects x))) (define (prune-bindings ops in-order? body counter ctx build-result) ;; This helper handles both `let' and `letrec'/`fix'. In the latter @@ -940,14 +905,20 @@ top-level bindings from ENV and return the resulting expression." ((test) (make-const #f #t)) (else exp))) (($ <conditional> src condition subsequent alternate) - (let ((condition (for-test condition))) - (if (const? condition) - (if (const-exp condition) - (for-tail subsequent) - (for-tail alternate)) - (make-conditional src condition - (for-tail subsequent) - (for-tail alternate))))) + (match (for-test condition) + (($ <const> _ val) + (if val + (for-tail subsequent) + (for-tail alternate))) + ;; Swap the arms of (if (not FOO) A B), to simplify. + (($ <primcall> _ 'not (c)) + (make-conditional src c + (for-tail alternate) + (for-tail subsequent))) + (c + (make-conditional src c + (for-tail subsequent) + (for-tail alternate))))) (($ <primcall> src '@call-with-values (producer ($ <lambda> _ _ |