[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guilecommits] 08/12: Eager graph pruning in CSE
From: 
Andy Wingo 
Subject: 
[Guilecommits] 08/12: Eager graph pruning in CSE 
Date: 
Fri, 29 May 2020 10:34:09 0400 (EDT) 
wingo pushed a commit to branch master
in repository guile.
commit a92c623a66e65e0223a488b75343e8c7075f735f
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri May 29 11:20:50 2020 +0200
Eager graph pruning in CSE
* module/language/cps/cse.scm (elidepredecessor, prunebranch)
(prunesuccessors, termsuccessors): New helpers.
(eliminatecommonsubexpressionsinfun): When we modify the CFG,
update the analysis. Also, thread the substs map through CSE so that
closures in highlevel CPS can take advantage of eliminated variables.
(foldrenumberedfunctions): Take multiple seeds.
(eliminatecommonsubexpressions): 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 analysisavail)
(truthylabels analysistruthylabels))
(define (eliminatecommonsubexpressionsinfun kfun conts out)
+;; When we determine that we can replace an expression with
+;; alreadybound 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 controlflow 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 backedge, it hasn't been
+;; residualized yet and so we can't rewrite it. This is an
+;; implementation limitation.
+;;
+(define (elidepredecessor label pred out analysis)
+ (match analysis
+ (($ <analysis> effects clobbers preds avail truthylabels)
+ (let ((predpreds (intmapref preds pred)))
+ (and
+ ;; Don't elide predecessors that are the targets of backedges.
+ (< (intsetprev predpreds) pred)
+ (cons
+ (intsetfold
+ (lambda (predpred out)
+ (define (rename k) (if (eqv? k pred) label k))
+ (intmapreplace!
+ out predpred
+ (rewritecont (intmapref out predpred)
+ (($ $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)))))
+ predpreds
+ (intmapremove out pred))
+ (makeanalysis effects
+ clobbers
+ (intmapadd (intmapadd preds label pred intsetremove)
+ label predpreds intsetunion)
+ avail
+ truthylabels)))))))
+
+(define (prunebranch analysis pred succ)
+ (match analysis
+ (($ <analysis> effects clobbers preds avail truthylabels)
+ (makeanalysis effects
+ clobbers
+ (intmapadd preds succ pred intsetremove)
+ avail
+ truthylabels))))
+
+(define (prunesuccessors analysis pred succs)
+ (intsetfold (lambda (succ analysis)
+ (prunebranch analysis pred succ))
+ succs analysis))
+
+(define (termsuccessors term)
+ (match term
+ (($ $continue k) (intset k))
+ (($ $branch kf kt) (intset kf kt))
+ (($ $prompt k kh) (intset k kh))
+ (($ $throw) emptyintset)))
+
+(define (eliminatecommonsubexpressionsinfun kfun conts out substs)
(define equivset (makehashtable))
(define (trueidx idx) (ash idx 1))
(define (falseidx 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 (addsubsts label defs out substs analysis)
 (match analysis
 (($ <analysis> effects clobbers preds avail truthylabels)
 (match (trivialintset (intmapref preds label))
 (#f substs)
 (pred
 (match (intmapref out pred)
 (($ $kargs _ _ ($ $continue _ _ ($ $values vals)))
 ;; FIXME: Eliminate predecessor entirely, retargetting its
 ;; predecessors.
 (fold (lambda (def var substs)
 (intmapadd substs def var))
 substs defs vals))
 (($ $kargs _ _ term)
 (match (computetermkey term)
 (#f #f)
 (termkey
 (let ((fx (intmapref 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 (causeseffect? fx &allocation))
 (not (effectclobbers? fx (&readobject &fluid))))
 (let ((equiv (hashref equivset termkey '())))
 (hashset! equivset termkey (acons pred defs equiv)))))
 ;; If the predecessor defines auxiliary definitions, as
 ;; `cons' does for the results of `car' and `cdr', define
 ;; those as well.
 (addauxiliarydefinitions! pred defs substs termkey)))
 substs)
 (_
 substs)))))))

(define (addauxiliarydefinitions! label defs substs termkey)
(define (adddef! auxkey var)
(let ((equiv (hashref equivset auxkey '())))
@@ 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 substvar args)))))
+ (define (visitterm label term substs analysis)
+ (let* ((term (renameuses term substs)))
+ (define (residualize)
+ (values term analysis))
+ (define (eliminate k src vals)
+ (values (buildterm ($continue k src ($values vals))) analysis))
+ (define (foldbranch true? kf kt src)
+ (values (buildterm ($continue (if true? kt kf) src ($values ())))
+ (prunebranch analysis label (if true? kf kt))))
+
+ (match (computetermkey term)
+ (#f (residualize))
+ (termkey
+ (match analysis
+ (($ <analysis> effects clobbers preds avail truthylabels)
+ (let ((avail (intmapref avail label)))
+ (let lp ((candidates (hashref equivset termkey '())))
+ (match candidates
+ (()
+ ;; No available expression; residualize.
+ (residualize))
+ (((candidate . vars) . candidates)
+ (cond
+ ((not (intsetref 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 (intmapref truthylabels label))
+ (t (intsetref bool (trueidx candidate)))
+ (f (intsetref bool (falseidx candidate))))
+ (if (eqv? t f)
+ ;; Can't fold the branch; keep on
+ ;; looking for another candidate.
+ (lp candidates)
+ ;; Nice, the branch folded.
+ (foldbranch t kf kt src)))))))))))))))))
+
(define (visitlabel label cont out substs analysis)
 (define (add cont)
 (intmapadd! out label cont))
(match cont
(($ $kargs names vars term)
 (let* ((substs (addsubsts label vars out substs analysis))
 (term (renameuses term substs)))
 (define (residualize)
 (add (buildcont ($kargs names vars ,term))))
 (define (eliminate k src vals)
 (add (buildcont ($kargs names vars
 ($continue k src ($values vals))))))

 (values
 (match (computetermkey term)
 (#f (residualize))
 (termkey
 (match analysis
 (($ <analysis> effects clobbers preds avail truthylabels)
 (let ((avail (intmapref avail label)))
 (let lp ((candidates (hashref equivset termkey '())))
 (match candidates
 (()
 ;; No available expression; residualize.
 (residualize))
 (((candidate . vars) . candidates)
 (cond
 ((not (intsetref 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 (intmapref truthylabels label))
 (t (intsetref bool (trueidx candidate)))
 (f (intsetref bool (falseidx 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 (visitterm* names vars out substs analysis)
+ (callwithvalues (lambda ()
+ (visitterm label term substs analysis))
+ (lambda (term analysis)
+ (values (intmapadd! out label
+ (buildcont ($kargs names vars ,term)))
+ substs
+ analysis))))
+ (define (visittermnormally)
+ (visitterm* names vars out substs analysis))
+ (match analysis
+ (($ <analysis> effects clobbers preds avail truthylabels)
+ (let ((preds (intmapref preds label)))
+ (cond
+ ((eq? preds emptyintset)
+ ;; Branch folding made this term unreachable. Prune from
+ ;; preds set.
+ (values out substs
+ (prunesuccessors analysis label (termsuccessors
term))))
+ ((trivialintset preds)
+ => (lambda (pred)
+ (match (intmapref 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)
+ (intmapadd substs var val))
+ substs vars vals)))
+ (match (elidepredecessor label pred out analysis)
+ (#f
+ ;; Can't elide; predecessor must be target of
+ ;; backwards branch.
+ (visitterm* names vars out substs analysis))
+ ((out . analysis)
+ (visitterm* names' vars' out substs analysis)))))
+ (($ $kargs _ _ term)
+ (match (computetermkey term)
+ (#f #f)
+ (termkey
+ (let ((fx (intmapref 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 (causeseffect? fx &allocation))
+ (not (effectclobbers? fx (&readobject
&fluid))))
+ (let ((equiv (hashref equivset termkey '())))
+ (hashset! equivset termkey (acons pred vars
equiv)))))
+ ;; If the predecessor defines auxiliary definitions,
as
+ ;; `cons' does for the results of `car' and `cdr',
define
+ ;; those as well.
+ (addauxiliarydefinitions! pred vars substs
termkey)))
+ (visittermnormally))
+ (_
+ (visittermnormally)))))
+ (else
+ (visittermnormally)))))))
+ (_ (values (intmapadd! out label cont) substs analysis))))
;; Because of the renumber pass, the labels are numbered in reverse
;; postorder, so the intmapfold will visit definitions before
;; uses.
 (let* ((substs emptyintmap)
 (effects (synthesizedefinitioneffects (computeeffects conts)))
+ (let* ((effects (synthesizedefinitioneffects (computeeffects conts)))
(clobbers (computeclobbermap effects))
(succs (computesuccessors conts kfun))
(preds (invertgraph succs))
(avail (computeavailableexpressions succs kfun clobbers))
(truthylabels (computetruthyexpressions conts kfun)))
 (intmapfold visitlabel conts out substs
 (makeanalysis effects clobbers preds avail truthylabels))))
+ (callwithvalues
+ (lambda ()
+ (intmapfold visitlabel conts out substs
+ (makeanalysis effects clobbers preds avail
truthylabels)))
+ (lambda (out substs analysis)
+ (values out substs)))))
(define (foldrenumberedfunctions f conts seed)
+(define (foldrenumberedfunctions 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) (intmapadd! body k cont))))))))
 (let fold ((kfun 0) (seed seed))
+ (let fold ((kfun 0) (seeds seeds))
(match (nextfunctionbody kfun)
 (#f seed)
+ (#f (apply values seeds))
(conts
 (fold (1+ (intmapprev conts)) (f kfun conts seed))))))
+ (callwithvalues (lambda () (apply f kfun conts seeds))
+ (lambda seeds
+ (fold (1+ (intmapprev conts)) seeds)))))))
(define (eliminatecommonsubexpressions conts)
(let ((conts (renumber conts 0)))
(persistentintmap
(foldrenumberedfunctions eliminatecommonsubexpressionsinfun
 conts emptyintmap))))
+ conts emptyintmap emptyintmap))))
 [Guilecommits] 01/12: Renumber before CSE, (continued)
 [Guilecommits] 01/12: Renumber before CSE, Andy Wingo, 2020/05/29
 [Guilecommits] 03/12: Refactor CSE to analyze and transform in a single pass, Andy Wingo, 2020/05/29
 [Guilecommits] 04/12: CSE eliminates expressions at continuations, Andy Wingo, 2020/05/29
 [Guilecommits] 02/12: Refactor CSE to take advantage of RPO numbering, Andy Wingo, 2020/05/29
 [Guilecommits] 06/12: Macro fix to CPS buildterm, Andy Wingo, 2020/05/29
 [Guilecommits] 05/12: Thread flow analysis through CSE pass, Andy Wingo, 2020/05/29
 [Guilecommits] 07/12: Add indentation rule for let/ec, Andy Wingo, 2020/05/29
 [Guilecommits] 09/12: Use intmaps in CSE equivalent expression table, Andy Wingo, 2020/05/29
 [Guilecommits] 11/12: CSE forwards branch predecessors where the branch folds, Andy Wingo, 2020/05/29
 [Guilecommits] 12/12: CSE forwardpropagates changes to CFG, Andy Wingo, 2020/05/29
 [Guilecommits] 08/12: Eager graph pruning in CSE,
Andy Wingo <=
 [Guilecommits] 10/12: CSE refactor, Andy Wingo, 2020/05/29