diff options
| author | Andy Wingo <wingo@pobox.com> | 2014-07-20 20:52:06 +0200 |
|---|---|---|
| committer | Andy Wingo <wingo@pobox.com> | 2014-07-22 12:18:07 +0200 |
| commit | b9a5bac69082114a75278c0d0fceedab787dbf7c (patch) | |
| tree | cd20ed493802f8f2a736dc4609f9edff5090af17 | |
| parent | ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31 (diff) | |
Better simplification of literal constants that continue to branches
* module/language/cps/simplify.scm (eta-reduce): Constants that continue
to branches eta-reduce to the true or false branch.
| -rw-r--r-- | module/language/cps/simplify.scm | 30 |
1 files changed, 29 insertions, 1 deletions
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 07d65e913..2c33edd82 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -85,6 +85,30 @@ (reduce* k scope #f)) (define (reduce-values k scope) (reduce* k scope #t)) + (define (reduce-const k src scope const) + (let lp ((k k) (seen '()) (const const)) + (match (lookup-cont k dfg) + (($ $kargs (_) (arg) term) + (match (find-call term) + (($ $continue k* src* ($ $values (arg*))) + (and (eqv? arg arg*) + (not (memq k* seen)) + (lp k* (cons k seen) const))) + (($ $continue k* src* ($ $primcall 'not (arg*))) + (and (eqv? arg arg*) + (not (memq k* seen)) + (lp k* (cons k seen) (not const)))) + (($ $continue k* src* ($ $branch kt ($ $values (arg*)))) + (and (eqv? arg arg*) + (let ((k* (if const kt k*))) + (and (continuation-bound-in? k* scope dfg) + (build-cps-term + ($continue k* src ($values ()))))))) + (_ + (and (continuation-bound-in? k scope dfg) + (build-cps-term + ($continue k src ($const const))))))) + (_ #f)))) (define (visit-cont cont scope) (rewrite-cps-cont cont (($ $cont sym ($ $kargs names syms body)) @@ -104,11 +128,15 @@ ,(visit-term body scope))) (($ $letrec names syms funs body) ($letrec names syms (map visit-fun funs) - ,(visit-term body scope))) + ,(visit-term body scope))) (($ $continue k src ($ $values args)) ($continue (reduce-values k scope) src ($values args))) (($ $continue k src (and fun ($ $fun))) ($continue (reduce k scope) src ,(visit-fun fun))) + (($ $continue k src ($ $const const)) + ,(let ((k (reduce k scope))) + (or (reduce-const k src scope const) + (build-cps-term ($continue k src ($const const)))))) (($ $continue k src exp) ($continue (reduce k scope) src ,exp)))) (define (visit-fun fun) |