wingo pushed a commit to branch master in repository guile. commit 4837e683155842959fec682462626404d8de90e7 Author: Andy Wingo <wi...@pobox.com> AuthorDate: Fri May 29 14:09:53 2020 +0200
CSE refactor * module/language/cps/cse.scm (eliminate-common-subexpressions-in-fun): Separate the paths for handling expressions and branches. --- module/language/cps/cse.scm | 116 ++++++++++++++++++++++++++------------------ 1 file changed, 68 insertions(+), 48 deletions(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 7cbaabc..d35c768 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -259,23 +259,27 @@ false. It could be that both true and false proofs are available." (() '()) ((var . vars) (cons (subst-var substs var) (lp vars)))))) + (define (compute-branch-key branch) + (match branch + (($ $branch kf kt src op param args) (cons* op param args)))) + (define (compute-expr-key expr) + (match expr + (($ $const val) (cons 'const val)) + (($ $prim name) (cons 'prim name)) + (($ $fun body) #f) + (($ $rec names syms funs) #f) + (($ $const-fun label) #f) + (($ $code label) (cons 'code label)) + (($ $call proc args) #f) + (($ $callk k proc args) #f) + (($ $primcall name param args) (cons* name param args)) + (($ $values args) #f))) (define (compute-term-key term) (match term - (($ $continue k src exp) - (match exp - (($ $const val) (cons 'const val)) - (($ $prim name) (cons 'prim name)) - (($ $fun body) #f) - (($ $rec names syms funs) #f) - (($ $const-fun label) #f) - (($ $code label) (cons 'code label)) - (($ $call proc args) #f) - (($ $callk k proc args) #f) - (($ $primcall name param args) (cons* name param args)) - (($ $values args) #f))) - (($ $branch kf kt src op param args) (cons* op param args)) - (($ $prompt) #f) - (($ $throw) #f))) + (($ $continue k src exp) (compute-expr-key exp)) + (($ $branch) (compute-branch-key term)) + (($ $prompt) #f) + (($ $throw) #f))) (define (add-auxiliary-definitions! label defs substs term-key) (define (add-def! aux-key var) @@ -359,40 +363,56 @@ false. It could be that both true and false proofs are available." (($ $throw src op param args) ($throw src op param ,(map subst-var args))))) + (define (visit-exp label exp analysis) + (define (residualize) exp) + (define (forward vals) (build-exp ($values vals))) + (match (compute-expr-key exp) + (#f (residualize)) + (key + (match analysis + (($ <analysis> effects clobbers preds avail truthy-labels) + (match (lookup-equivalent-expressions equivalent-expressions + key (intmap-ref avail label)) + ((? (lambda (x) (eq? x empty-intmap))) + (residualize)) + (equiv + (forward (intmap-ref equiv (intmap-next equiv)))))))))) + + (define (visit-branch label term analysis) + (define (residualize) + (values term analysis)) + (define (fold-branch true?) + (match term + (($ $branch kf kt src) + (values (build-term ($continue (if true? kt kf) src ($values ()))) + (prune-branch analysis label (if true? kf kt)))))) + + (match analysis + (($ <analysis> effects clobbers preds avail truthy-labels) + (let* ((equiv (lookup-equivalent-expressions equivalent-expressions + (compute-branch-key term) + (intmap-ref avail label))) + (bool (intmap-ref truthy-labels label))) + (let lp ((candidate (intmap-prev equiv))) + (match candidate + (#f (residualize)) + (_ (let ((t (intset-ref bool (true-idx candidate))) + (f (intset-ref bool (false-idx candidate)))) + (if (eqv? t f) + (lp (intmap-prev equiv (1- candidate))) + (fold-branch t)))))))))) + (define (visit-term label term substs analysis) - (let* ((term (rename-uses term substs))) - (define (residualize) - (values term analysis)) - (define (eliminate k src vals) - (values (build-term ($continue k src ($values vals))) analysis)) - (define (fold-branch true? kf kt src) - (values (build-term ($continue (if true? kt kf) src ($values ()))) - (prune-branch analysis label (if true? kf kt)))) - - (match (compute-term-key term) - (#f (residualize)) - (term-key - (match analysis - (($ <analysis> effects clobbers preds avail truthy-labels) - (match (lookup-equivalent-expressions equivalent-expressions - term-key - (intmap-ref avail label)) - ((? (lambda (x) (eq? x empty-intmap))) - (residualize)) - (equiv - (match term - (($ $continue k src) - (eliminate k src (intmap-ref equiv (intmap-next equiv)))) - (($ $branch kf kt src) - (let ((bool (intmap-ref truthy-labels label))) - (let lp ((candidate (intmap-prev equiv))) - (match candidate - (#f (residualize)) - (_ (let ((t (intset-ref bool (true-idx candidate))) - (f (intset-ref bool (false-idx candidate)))) - (if (eqv? t f) - (lp (intmap-prev equiv (1- candidate))) - (fold-branch t kf kt src))))))))))))))))) + (let ((term (rename-uses term substs))) + (match term + (($ $branch) + (visit-branch label term analysis)) + (($ $continue k src exp) + (values (build-term + ($continue k src ,(visit-exp label exp analysis))) + analysis)) + ((or ($ $prompt) ($ $throw)) + (values term analysis))))) (define (visit-label label cont out substs analysis) (match cont