diff options
author | Andy Wingo <wingo@pobox.com> | 2020-05-28 15:59:20 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-05-29 16:33:48 +0200 |
commit | 6fb063535835358a61047adc0f1d9514e3c60c4a (patch) | |
tree | 9e74977fd84d4038ab376039c434dfc7726d60b2 /module/language | |
parent | 2318e7238f44d38f479c14d7d588636958c9d67f (diff) | |
download | guile-6fb063535835358a61047adc0f1d9514e3c60c4a.tar.gz |
CSE eliminates expressions at continuations
* module/language/cps/cse.scm (compute-available-expressions): Take a
clobber map instead of an effects map.
(compute-singly-referenced): Remove unused function.
(eliminate-common-subexpressions-in-fun): Keep a preds map. Use it
add entries to the equiv-set and var-substs at expression
continuations instead of at the expression terms themselves.
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/cps/cse.scm | 160 |
1 files changed, 72 insertions, 88 deletions
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index d6b38af91..46c5a0354 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -34,11 +34,11 @@ #:use-module (language cps renumber) #:export (eliminate-common-subexpressions)) -(define (compute-available-expressions succs kfun effects) +(define (compute-available-expressions succs kfun clobbers) "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is an intset containing ancestor labels whose value is available at LABEL." (let ((init (intmap-map (lambda (label succs) #f) succs)) - (kill (compute-clobber-map effects)) + (kill clobbers) (gen (intmap-map (lambda (label succs) (intset label)) succs)) (subtract (lambda (in-1 kill-1) (if in-1 @@ -137,24 +137,12 @@ false. It could be that both true and false proofs are available." (intset kfun) (intmap-add empty-intmap kfun empty-intset))) -(define (compute-singly-referenced succs) - (define (visit label succs single multiple) - (intset-fold (lambda (label single multiple) - (if (intset-ref single label) - (values single (intset-add! multiple label)) - (values (intset-add! single label) multiple))) - succs single multiple)) - (call-with-values (lambda () - (intmap-fold visit succs empty-intset empty-intset)) - (lambda (single multiple) - (intset-subtract (persistent-intset single) - (persistent-intset multiple))))) - (define (eliminate-common-subexpressions-in-fun kfun conts out) (let* ((effects (synthesize-definition-effects (compute-effects conts))) + (clobbers (compute-clobber-map effects)) (succs (compute-successors conts kfun)) - (singly-referenced (compute-singly-referenced succs)) - (avail (compute-available-expressions succs kfun effects)) + (preds (invert-graph succs)) + (avail (compute-available-expressions succs kfun clobbers)) (truthy-labels (compute-truthy-expressions conts kfun)) (equiv-set (make-hash-table))) (define (true-idx idx) (ash idx 1)) @@ -185,6 +173,39 @@ false. It could be that both true and false proofs are available." (($ $prompt) #f) (($ $throw) #f))) + (define (add-var-substs label defs out var-substs) + (match (trivial-intset (intmap-ref preds label)) + (#f var-substs) + (pred + (match (intmap-ref out pred) + (($ $kargs _ _ ($ $continue _ _ ($ $values vals))) + ;; FIXME: Eliminate predecessor entirely, retargetting its + ;; predecessors. + (fold (lambda (def var var-substs) + (intmap-add var-substs def var)) + 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 var-substs term-key))) + var-substs) + (_ + var-substs))))) + (define (add-auxiliary-definitions! label defs var-substs term-key) (let ((defs (and defs (subst-vars var-substs defs)))) (define (add-def! aux-key var) @@ -270,87 +291,50 @@ false. It could be that both true and false proofs are available." ($throw src op param ,(map subst-var args))))) (define (visit-label label cont out var-substs) - (define (term-defs term) - (match term - (($ $continue k) - (and (intset-ref singly-referenced k) - (match (intmap-ref conts k) - (($ $kargs names vars) vars) - (_ #f)))) - (($ $branch) '()))) (define (add cont) (intmap-add! out label cont)) (match cont (($ $kargs names vars term) - (let ((term (rename-uses term var-substs))) + (let* ((var-substs (add-var-substs label vars out var-substs)) + (term (rename-uses term var-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)))))) - (match (compute-term-key term) - (#f - (values (residualize) var-substs)) - (term-key - (let* ((equiv (hash-ref equiv-set term-key '())) - (fx (intmap-ref effects label)) - (avail (intmap-ref avail label))) - (define (finish out var-substs defs) - ;; If this expression defines auxiliary definitions, - ;; as `cons' does for the results of `car' and `cdr', - ;; define those. Do so after finding equivalent - ;; expressions, so that we can take advantage of - ;; subst'd output vars. - (add-auxiliary-definitions! label defs var-substs term-key) - (values out var-substs)) - (let lp ((candidates equiv)) - (match candidates - (() - ;; No matching expressions. Add our expression - ;; to the equivalence set, if appropriate. 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). - (let ((defs (term-defs term))) - (when (and defs - (not (causes-effect? fx &allocation)) - (not (effect-clobbers? fx (&read-object &fluid)))) - (hash-set! equiv-set term-key (acons label defs equiv))) - (finish (residualize) var-substs defs))) - (((candidate . vars) . candidates) - (cond - ((not (intset-ref avail candidate)) - ;; This expression isn't available here; try - ;; the next one. - (lp candidates)) - (else - ;; Yay, a match. Mark expression as equivalent. - ;; For expressions that define values, mark the - ;; vars for substitution. For branches, maybe - ;; fold the branch. - (match term - (($ $continue k src) - (let ((defs (term-defs term))) - (finish (eliminate k src vars) - (if defs - (fold (lambda (def var var-substs) - (intmap-add var-substs def var)) - var-substs defs vars) - var-substs) - defs))) - (($ $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) - (values (eliminate (if t kt kf) src '()) - var-substs))))))))))))))) + (values + (match (compute-term-key term) + (#f (residualize)) + (term-key + (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 '()))))))))))))) + var-substs))) (_ (values (add cont) var-substs)))) ;; Because of the renumber pass, the labels are numbered in reverse |