wingo pushed a commit to branch master in repository guile. commit a92c623a66e65e0223a488b75343e8c7075f735f Author: Andy Wingo <wi...@pobox.com> AuthorDate: Fri May 29 11:20:50 2020 +0200
Eager graph pruning in CSE * module/language/cps/cse.scm (elide-predecessor, prune-branch) (prune-successors, term-successors): New helpers. (eliminate-common-subexpressions-in-fun): When we modify the CFG, update the analysis. Also, thread the substs map through CSE so that closures in high-level CPS can take advantage of eliminated variables. (fold-renumbered-functions): Take multiple seeds. (eliminate-common-subexpressions): Thread var substs map through CSE. --- module/language/cps/cse.scm | 287 ++++++++++++++++++++++++++++++-------------- 1 file changed, 197 insertions(+), 90 deletions(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index d3c42fb..4d35a14 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -147,7 +147,87 @@ false. It could be that both true and false proofs are available." (avail analysis-avail) (truthy-labels analysis-truthy-labels)) -(define (eliminate-common-subexpressions-in-fun kfun conts out) +;; When we determine that we can replace an expression with +;; already-bound variables, we change the expression to a $values. At +;; its continuation, if it turns out that the $values expression is the +;; only predecessor, we elide the predecessor, to make redundant branch +;; folding easier. Ideally, elision results in redundant branches +;; having multiple predecessors which already have values for the +;; branch. +;; +;; We could avoid elision, and instead search backwards when we get to a +;; branch that we'd like to elide. However it's gnarly: branch elisions +;; reconfigure the control-flow graph, and thus affect the avail / +;; truthy maps. If we forwarded such a distant predecessor, if there +;; were no intermediate definitions, we'd have to replay the flow +;; analysis from far away. Maybe it's possible but it's not obvious. +;; +;; The elision mechanism is to rewrite predecessors to continue to the +;; successor. We could have instead replaced the predecessor with the +;; body of the successor, but that would invalidate the values of the +;; avail / truthy maps, as well as the clobber sets. +;; +;; We can't always elide the predecessor though. If any of the +;; predecessor's predecessors is a back-edge, it hasn't been +;; residualized yet and so we can't rewrite it. This is an +;; implementation limitation. +;; +(define (elide-predecessor label pred out analysis) + (match analysis + (($ <analysis> effects clobbers preds avail truthy-labels) + (let ((pred-preds (intmap-ref preds pred))) + (and + ;; Don't elide predecessors that are the targets of back-edges. + (< (intset-prev pred-preds) pred) + (cons + (intset-fold + (lambda (pred-pred out) + (define (rename k) (if (eqv? k pred) label k)) + (intmap-replace! + out pred-pred + (rewrite-cont (intmap-ref out pred-pred) + (($ $kargs names vals ($ $continue k src exp)) + ($kargs names vals ($continue (rename k) src ,exp))) + (($ $kargs names vals ($ $branch kf kt src op param args)) + ($kargs names vals ($branch (rename kf) (rename kt) src op param args))) + (($ $kargs names vals ($ $prompt k kh src escape? tag)) + ($kargs names vals ($prompt (rename k) (rename kh) src escape? tag))) + (($ $kreceive ($ $arity req () rest () #f) kbody) + ($kreceive req rest (rename kbody))) + (($ $kclause arity kbody kalternate) + ;; Can only be a body continuation. + ($kclause ,arity (rename kbody) kalternate))))) + pred-preds + (intmap-remove out pred)) + (make-analysis effects + clobbers + (intmap-add (intmap-add preds label pred intset-remove) + label pred-preds intset-union) + avail + truthy-labels))))))) + +(define (prune-branch analysis pred succ) + (match analysis + (($ <analysis> effects clobbers preds avail truthy-labels) + (make-analysis effects + clobbers + (intmap-add preds succ pred intset-remove) + avail + truthy-labels)))) + +(define (prune-successors analysis pred succs) + (intset-fold (lambda (succ analysis) + (prune-branch analysis pred succ)) + succs analysis)) + +(define (term-successors term) + (match term + (($ $continue k) (intset k)) + (($ $branch kf kt) (intset kf kt)) + (($ $prompt k kh) (intset k kh)) + (($ $throw) empty-intset))) + +(define (eliminate-common-subexpressions-in-fun kfun conts out substs) (define equiv-set (make-hash-table)) (define (true-idx idx) (ash idx 1)) (define (false-idx idx) (1+ (ash idx 1))) @@ -177,41 +257,6 @@ false. It could be that both true and false proofs are available." (($ $prompt) #f) (($ $throw) #f))) - (define (add-substs label defs out substs analysis) - (match analysis - (($ <analysis> effects clobbers preds avail truthy-labels) - (match (trivial-intset (intmap-ref preds label)) - (#f substs) - (pred - (match (intmap-ref out pred) - (($ $kargs _ _ ($ $continue _ _ ($ $values vals))) - ;; FIXME: Eliminate predecessor entirely, retargetting its - ;; predecessors. - (fold (lambda (def var substs) - (intmap-add substs def var)) - substs defs vals)) - (($ $kargs _ _ term) - (match (compute-term-key term) - (#f #f) - (term-key - (let ((fx (intmap-ref effects pred))) - ;; Add residualized definition to the equivalence set. - ;; Note that expressions that allocate a fresh object - ;; or change the current fluid environment can't be - ;; eliminated by CSE (though DCE might do it if the - ;; value proves to be unused, in the allocation case). - (when (and (not (causes-effect? fx &allocation)) - (not (effect-clobbers? fx (&read-object &fluid)))) - (let ((equiv (hash-ref equiv-set term-key '()))) - (hash-set! equiv-set term-key (acons pred defs equiv))))) - ;; If the predecessor defines auxiliary definitions, as - ;; `cons' does for the results of `car' and `cdr', define - ;; those as well. - (add-auxiliary-definitions! pred defs substs term-key))) - substs) - (_ - substs))))))) - (define (add-auxiliary-definitions! label defs substs term-key) (define (add-def! aux-key var) (let ((equiv (hash-ref equiv-set aux-key '()))) @@ -295,69 +340,129 @@ 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-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) + (let ((avail (intmap-ref avail label))) + (let lp ((candidates (hash-ref equiv-set term-key '()))) + (match candidates + (() + ;; No available expression; residualize. + (residualize)) + (((candidate . vars) . candidates) + (cond + ((not (intset-ref avail candidate)) + ;; This expression isn't available here; try + ;; the next one. + (lp candidates)) + (else + (match term + (($ $continue k src) + ;; Yay, a match; eliminate the expression. + (eliminate k src vars)) + (($ $branch kf kt src) + (let* ((bool (intmap-ref truthy-labels label)) + (t (intset-ref bool (true-idx candidate))) + (f (intset-ref bool (false-idx candidate)))) + (if (eqv? t f) + ;; Can't fold the branch; keep on + ;; looking for another candidate. + (lp candidates) + ;; Nice, the branch folded. + (fold-branch t kf kt src))))))))))))))))) + (define (visit-label label cont out substs analysis) - (define (add cont) - (intmap-add! out label cont)) (match cont (($ $kargs names vars term) - (let* ((substs (add-substs label vars out substs analysis)) - (term (rename-uses term substs))) - (define (residualize) - (add (build-cont ($kargs names vars ,term)))) - (define (eliminate k src vals) - (add (build-cont ($kargs names vars - ($continue k src ($values vals)))))) - - (values - (match (compute-term-key term) - (#f (residualize)) - (term-key - (match analysis - (($ <analysis> effects clobbers preds avail truthy-labels) - (let ((avail (intmap-ref avail label))) - (let lp ((candidates (hash-ref equiv-set term-key '()))) - (match candidates - (() - ;; No available expression; residualize. - (residualize)) - (((candidate . vars) . candidates) - (cond - ((not (intset-ref avail candidate)) - ;; This expression isn't available here; try - ;; the next one. - (lp candidates)) - (else - (match term - (($ $continue k src) - ;; Yay, a match; eliminate the expression. - (eliminate k src vars)) - (($ $branch kf kt src) - (let* ((bool (intmap-ref truthy-labels label)) - (t (intset-ref bool (true-idx candidate))) - (f (intset-ref bool (false-idx candidate)))) - (if (eqv? t f) - ;; Can't fold the branch; keep on - ;; looking for another candidate. - (lp candidates) - ;; Nice, the branch folded. - (eliminate (if t kt kf) src '()))))))))))))))) - substs analysis))) - (_ (values (add cont) substs analysis)))) + (define (visit-term* names vars out substs analysis) + (call-with-values (lambda () + (visit-term label term substs analysis)) + (lambda (term analysis) + (values (intmap-add! out label + (build-cont ($kargs names vars ,term))) + substs + analysis)))) + (define (visit-term-normally) + (visit-term* names vars out substs analysis)) + (match analysis + (($ <analysis> effects clobbers preds avail truthy-labels) + (let ((preds (intmap-ref preds label))) + (cond + ((eq? preds empty-intset) + ;; Branch folding made this term unreachable. Prune from + ;; preds set. + (values out substs + (prune-successors analysis label (term-successors term)))) + ((trivial-intset preds) + => (lambda (pred) + (match (intmap-ref out pred) + (($ $kargs names' vars' ($ $continue _ _ ($ $values vals))) + ;; Substitute dominating definitions, and try to elide the + ;; predecessor entirely. + (let ((substs (fold (lambda (var val substs) + (intmap-add substs var val)) + substs vars vals))) + (match (elide-predecessor label pred out analysis) + (#f + ;; Can't elide; predecessor must be target of + ;; backwards branch. + (visit-term* names vars out substs analysis)) + ((out . analysis) + (visit-term* names' vars' out substs analysis))))) + (($ $kargs _ _ term) + (match (compute-term-key term) + (#f #f) + (term-key + (let ((fx (intmap-ref effects pred))) + ;; Add residualized definition to the equivalence set. + ;; Note that expressions that allocate a fresh object + ;; or change the current fluid environment can't be + ;; eliminated by CSE (though DCE might do it if the + ;; value proves to be unused, in the allocation case). + (when (and (not (causes-effect? fx &allocation)) + (not (effect-clobbers? fx (&read-object &fluid)))) + (let ((equiv (hash-ref equiv-set term-key '()))) + (hash-set! equiv-set term-key (acons pred vars equiv))))) + ;; If the predecessor defines auxiliary definitions, as + ;; `cons' does for the results of `car' and `cdr', define + ;; those as well. + (add-auxiliary-definitions! pred vars substs term-key))) + (visit-term-normally)) + (_ + (visit-term-normally))))) + (else + (visit-term-normally))))))) + (_ (values (intmap-add! out label cont) substs analysis)))) ;; Because of the renumber pass, the labels are numbered in reverse ;; post-order, so the intmap-fold will visit definitions before ;; uses. - (let* ((substs empty-intmap) - (effects (synthesize-definition-effects (compute-effects conts))) + (let* ((effects (synthesize-definition-effects (compute-effects conts))) (clobbers (compute-clobber-map effects)) (succs (compute-successors conts kfun)) (preds (invert-graph succs)) (avail (compute-available-expressions succs kfun clobbers)) (truthy-labels (compute-truthy-expressions conts kfun))) - (intmap-fold visit-label conts out substs - (make-analysis effects clobbers preds avail truthy-labels)))) + (call-with-values + (lambda () + (intmap-fold visit-label conts out substs + (make-analysis effects clobbers preds avail truthy-labels))) + (lambda (out substs analysis) + (values out substs))))) -(define (fold-renumbered-functions f conts seed) +(define (fold-renumbered-functions f conts . seeds) ;; Precondition: CONTS has been renumbered, and therefore functions ;; contained within it are topologically sorted, and the conts of each ;; function's body are numbered sequentially after the function's @@ -373,14 +478,16 @@ false. It could be that both true and false proofs are available." (cont (lp (1+ k) (intmap-add! body k cont)))))))) - (let fold ((kfun 0) (seed seed)) + (let fold ((kfun 0) (seeds seeds)) (match (next-function-body kfun) - (#f seed) + (#f (apply values seeds)) (conts - (fold (1+ (intmap-prev conts)) (f kfun conts seed)))))) + (call-with-values (lambda () (apply f kfun conts seeds)) + (lambda seeds + (fold (1+ (intmap-prev conts)) seeds))))))) (define (eliminate-common-subexpressions conts) (let ((conts (renumber conts 0))) (persistent-intmap (fold-renumbered-functions eliminate-common-subexpressions-in-fun - conts empty-intmap)))) + conts empty-intmap empty-intmap))))