diff options
author | Andy Wingo <wingo@pobox.com> | 2014-07-06 12:38:26 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-07-22 12:18:07 +0200 |
commit | 44954194c936bee2f2faa4225480cb9dd2cbdcd8 (patch) | |
tree | d54500941c650c0cc8a21944495127d580f8cf36 | |
parent | 7700e67226e76eb53ceef12368992161243b59df (diff) | |
download | guile-44954194c936bee2f2faa4225480cb9dd2cbdcd8.tar.gz |
Simplify pass rewrite scope tree to reflect dominator tree
* module/language/cps/simplify.scm (redominate): Add micropass to
rewrite the scope tree to reflect the dominator tree. Will enable
better eta reduction.
-rw-r--r-- | module/language/cps/simplify.scm | 69 |
1 files changed, 68 insertions, 1 deletions
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 51858899a..07d65e913 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -234,7 +234,74 @@ ($fun (map subst free) ,(must-visit-cont body))))) (must-visit-cont fun))) +;; Rewrite the scope tree to reflect the dominator tree. Precondition: +;; the fun has been renumbered, its min-label is 0, and its labels are +;; packed. +(define (redominate fun) + (let* ((dfg (compute-dfg fun)) + (idoms (compute-idoms dfg 0 (dfg-label-count dfg))) + (doms (compute-dom-edges idoms 0))) + (define (visit-fun-cont cont) + (rewrite-cps-cont cont + (($ $cont label ($ $kfun src meta self tail clause)) + (label ($kfun src meta self ,tail + ,(and clause (visit-fun-cont clause))))) + (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) + (label ($kclause ,arity ,(visit-cont kbody body) + ,(and alternate (visit-fun-cont alternate))))))) + + (define (visit-cont label cont) + (rewrite-cps-cont cont + (($ $kargs names vars body) + (label ($kargs names vars ,(visit-term body label)))) + (_ (label ,cont)))) + + (define (visit-exp k src exp) + (rewrite-cps-term exp + (($ $fun free body) + ($continue k src ($fun free ,(visit-fun-cont body)))) + (_ + ($continue k src ,exp)))) + + (define (visit-term term label) + (define (visit-dom-conts label) + (let ((cont (lookup-cont label dfg))) + (match cont + (($ $ktail) '()) + (($ $kargs) (list (visit-cont label cont))) + (else + (cons (visit-cont label cont) + (visit-dom-conts* (vector-ref doms label))))))) + + (define (visit-dom-conts* labels) + (match labels + (() '()) + ((label . labels) + (append (visit-dom-conts label) + (visit-dom-conts* labels))))) + + (rewrite-cps-term term + (($ $letk conts body) + ,(visit-term body label)) + (($ $letrec names syms funs body) + ($letrec names syms (let lp ((funs funs)) + (match funs + (() '()) + ((($ $fun free body) . funs) + (cons (build-cps-exp + ($fun free ,(visit-fun-cont body))) + (lp funs))))) + ,(visit-term body label))) + (($ $continue k src exp) + ,(let ((conts (visit-dom-conts* (vector-ref doms label)))) + (if (null? conts) + (visit-exp k src exp) + (build-cps-term + ($letk ,conts ,(visit-exp k src exp)))))))) + + (visit-fun-cont fun))) + (define (simplify fun) ;; Renumbering prunes continuations that are made unreachable by ;; eta/beta reductions. - (renumber (eta-reduce (beta-reduce fun)))) + (redominate (renumber (eta-reduce (beta-reduce fun))))) |