mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

Eager graph pruning in CSE

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-05-29 11:20:50 +02:00
parent 6b1835a169
commit a92c623a66
1 changed files with 197 additions and 90 deletions
Download patch file Download diff file Expand all files Collapse all files

223
module/language/cps/cse.scm
View file

@ -147,7 +147,87 @@ false. It could be that both true and false proofs are available."
(avail analysis-avail) (avail analysis-avail)
(truthy-labels analysis-truthy-labels)) (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 equiv-set (make-hash-table))
(define (true-idx idx) (ash idx 1)) (define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (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) (($ $prompt) #f)
(($ $throw) #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-auxiliary-definitions! label defs substs term-key)
(define (add-def! aux-key var) (define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '()))) (let ((equiv (hash-ref equiv-set aux-key '())))
@ -295,20 +340,16 @@ false. It could be that both true and false proofs are available."
(($ $throw src op param args) (($ $throw src op param args)
($throw src op param ,(map subst-var args))))) ($throw src op param ,(map subst-var args)))))
(define (visit-label label cont out substs analysis) (define (visit-term label term substs analysis)
(define (add cont) (let* ((term (rename-uses term substs)))
(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) (define (residualize)
(add (build-cont ($kargs names vars ,term)))) (values term analysis))
(define (eliminate k src vals) (define (eliminate k src vals)
(add (build-cont ($kargs names vars (values (build-term ($continue k src ($values vals))) analysis))
($continue k src ($values vals)))))) (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))))
(values
(match (compute-term-key term) (match (compute-term-key term)
(#f (residualize)) (#f (residualize))
(term-key (term-key
@ -340,24 +381,88 @@ false. It could be that both true and false proofs are available."
;; looking for another candidate. ;; looking for another candidate.
(lp candidates) (lp candidates)
;; Nice, the branch folded. ;; Nice, the branch folded.
(eliminate (if t kt kf) src '()))))))))))))))) (fold-branch t kf kt src)))))))))))))))))
substs analysis)))
(_ (values (add cont) substs analysis)))) (define (visit-label label cont out substs analysis)
(match cont
(($ $kargs names vars term)
(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 ;; Because of the renumber pass, the labels are numbered in reverse
;; post-order, so the intmap-fold will visit definitions before ;; post-order, so the intmap-fold will visit definitions before
;; uses. ;; uses.
(let* ((substs empty-intmap) (let* ((effects (synthesize-definition-effects (compute-effects conts)))
(effects (synthesize-definition-effects (compute-effects conts)))
(clobbers (compute-clobber-map effects)) (clobbers (compute-clobber-map effects))
(succs (compute-successors conts kfun)) (succs (compute-successors conts kfun))
(preds (invert-graph succs)) (preds (invert-graph succs))
(avail (compute-available-expressions succs kfun clobbers)) (avail (compute-available-expressions succs kfun clobbers))
(truthy-labels (compute-truthy-expressions conts kfun))) (truthy-labels (compute-truthy-expressions conts kfun)))
(call-with-values
(lambda ()
(intmap-fold visit-label conts out substs (intmap-fold visit-label conts out substs
(make-analysis effects clobbers preds avail truthy-labels)))) (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 ;; Precondition: CONTS has been renumbered, and therefore functions
;; contained within it are topologically sorted, and the conts of each ;; contained within it are topologically sorted, and the conts of each
;; function's body are numbered sequentially after the function's ;; 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 (cont
(lp (1+ k) (intmap-add! body k 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) (match (next-function-body kfun)
(#f seed) (#f (apply values seeds))
(conts (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) (define (eliminate-common-subexpressions conts)
(let ((conts (renumber conts 0))) (let ((conts (renumber conts 0)))
(persistent-intmap (persistent-intmap
(fold-renumbered-functions eliminate-common-subexpressions-in-fun (fold-renumbered-functions eliminate-common-subexpressions-in-fun
conts empty-intmap)))) conts empty-intmap empty-intmap))))