mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

CSE eliminates expressions at continuations

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-05-28 15:59:20 +02:00
parent 2318e7238f
commit 6fb0635358
1 changed files with 72 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -34,11 +34,11 @@
#:use-module (language cps renumber) #:use-module (language cps renumber)
#:export (eliminate-common-subexpressions)) #: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 "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
an intset containing ancestor labels whose value is available at LABEL." an intset containing ancestor labels whose value is available at LABEL."
(let ((init (intmap-map (lambda (label succs) #f) succs)) (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)) (gen (intmap-map (lambda (label succs) (intset label)) succs))
(subtract (lambda (in-1 kill-1) (subtract (lambda (in-1 kill-1)
(if in-1 (if in-1
@ -137,24 +137,12 @@ false. It could be that both true and false proofs are available."
(intset kfun) (intset kfun)
(intmap-add empty-intmap kfun empty-intset))) (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) (define (eliminate-common-subexpressions-in-fun kfun conts out)
(let* ((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)) (succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs)) (preds (invert-graph succs))
(avail (compute-available-expressions succs kfun effects)) (avail (compute-available-expressions succs kfun clobbers))
(truthy-labels (compute-truthy-expressions conts kfun)) (truthy-labels (compute-truthy-expressions conts kfun))
(equiv-set (make-hash-table))) (equiv-set (make-hash-table)))
(define (true-idx idx) (ash idx 1)) (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) (($ $prompt) #f)
(($ $throw) #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) (define (add-auxiliary-definitions! label defs var-substs term-key)
(let ((defs (and defs (subst-vars var-substs defs)))) (let ((defs (and defs (subst-vars var-substs defs))))
(define (add-def! aux-key var) (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))))) ($throw src op param ,(map subst-var args)))))
(define (visit-label label cont out var-substs) (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) (define (add cont)
(intmap-add! out label cont)) (intmap-add! out label cont))
(match cont (match cont
(($ $kargs names vars term) (($ $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) (define (residualize)
(add (build-cont ($kargs names vars ,term)))) (add (build-cont ($kargs names vars ,term))))
(define (eliminate k src vals) (define (eliminate k src vals)
(add (build-cont ($kargs names vars (add (build-cont ($kargs names vars
($continue k src ($values vals)))))) ($continue k src ($values vals))))))
(match (compute-term-key term) (values
(#f (match (compute-term-key term)
(values (residualize) var-substs)) (#f (residualize))
(term-key (term-key
(let* ((equiv (hash-ref equiv-set term-key '())) (let ((avail (intmap-ref avail label)))
(fx (intmap-ref effects label)) (let lp ((candidates (hash-ref equiv-set term-key '())))
(avail (intmap-ref avail label))) (match candidates
(define (finish out var-substs defs) (()
;; If this expression defines auxiliary definitions, ;; No available expression; residualize.
;; as `cons' does for the results of `car' and `cdr', (residualize))
;; define those. Do so after finding equivalent (((candidate . vars) . candidates)
;; expressions, so that we can take advantage of (cond
;; subst'd output vars. ((not (intset-ref avail candidate))
(add-auxiliary-definitions! label defs var-substs term-key) ;; This expression isn't available here; try
(values out var-substs)) ;; the next one.
(let lp ((candidates equiv)) (lp candidates))
(match candidates (else
(() (match term
;; No matching expressions. Add our expression (($ $continue k src)
;; to the equivalence set, if appropriate. Note ;; Yay, a match; eliminate the expression.
;; that expressions that allocate a fresh object (eliminate k src vars))
;; or change the current fluid environment can't (($ $branch kf kt src)
;; be eliminated by CSE (though DCE might do it (let* ((bool (intmap-ref truthy-labels label))
;; if the value proves to be unused, in the (t (intset-ref bool (true-idx candidate)))
;; allocation case). (f (intset-ref bool (false-idx candidate))))
(let ((defs (term-defs term))) (if (eqv? t f)
(when (and defs ;; Can't fold the branch; keep on
(not (causes-effect? fx &allocation)) ;; looking for another candidate.
(not (effect-clobbers? fx (&read-object &fluid)))) (lp candidates)
(hash-set! equiv-set term-key (acons label defs equiv))) ;; Nice, the branch folded.
(finish (residualize) var-substs defs))) (eliminate (if t kt kf) src '())))))))))))))
(((candidate . vars) . candidates) var-substs)))
(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 (add cont) var-substs)))) (_ (values (add cont) var-substs))))
;; Because of the renumber pass, the labels are numbered in reverse ;; Because of the renumber pass, the labels are numbered in reverse