mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
Refactor CSE to take advantage of RPO numbering
* module/language/cps/cse.scm (fold-renumbered-functions): New helper. (compute-equivalent-expressions): Use new helper. (compute-equivalent-expressions-in-fun): Lift to top-level. (eliminate-common-subexpressions): Adapt.
This commit is contained in:
Andy Wingo
parent
cf948e0f6f
commit
6e91173334
1 changed files with 182 additions and 163 deletions
|
|
@ -187,174 +187,193 @@ false. It could be that both true and false proofs are available."
|
||||||
(intset-subtract (persistent-intset single)
|
(intset-subtract (persistent-intset single)
|
||||||
(persistent-intset multiple)))))
|
(persistent-intset multiple)))))
|
||||||
|
|
||||||
(define (intmap-select map set)
|
(define (compute-equivalent-expressions-in-fun kfun conts
|
||||||
(intset->intmap (lambda (label) (intmap-ref map label)) set))
|
equiv-labels var-substs)
|
||||||
|
(let* ((effects (synthesize-definition-effects (compute-effects conts)))
|
||||||
|
(succs (compute-successors conts kfun))
|
||||||
|
(singly-referenced (compute-singly-referenced succs))
|
||||||
|
(avail (compute-available-expressions succs kfun effects))
|
||||||
|
(defs (compute-defs conts kfun))
|
||||||
|
(equiv-set (make-hash-table)))
|
||||||
|
(define (subst-var var-substs var)
|
||||||
|
(intmap-ref var-substs var (lambda (var) var)))
|
||||||
|
(define (subst-vars var-substs vars)
|
||||||
|
(let lp ((vars vars))
|
||||||
|
(match vars
|
||||||
|
(() '())
|
||||||
|
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
|
||||||
|
|
||||||
(define (compute-equivalent-subexpressions conts kfun)
|
(define (compute-term-key var-substs term)
|
||||||
(define (visit-fun kfun body equiv-labels var-substs)
|
(match term
|
||||||
(let* ((conts (intmap-select conts body))
|
(($ $continue k src exp)
|
||||||
(effects (synthesize-definition-effects (compute-effects conts)))
|
(match exp
|
||||||
(succs (compute-successors conts kfun))
|
(($ $const val) (cons 'const val))
|
||||||
(singly-referenced (compute-singly-referenced succs))
|
(($ $prim name) (cons 'prim name))
|
||||||
(avail (compute-available-expressions succs kfun effects))
|
(($ $fun body) #f)
|
||||||
(defs (compute-defs conts kfun))
|
(($ $rec names syms funs) #f)
|
||||||
(equiv-set (make-hash-table)))
|
(($ $const-fun label) #f)
|
||||||
(define (subst-var var-substs var)
|
(($ $code label) (cons 'code label))
|
||||||
(intmap-ref var-substs var (lambda (var) var)))
|
(($ $call proc args) #f)
|
||||||
(define (subst-vars var-substs vars)
|
(($ $callk k proc args) #f)
|
||||||
(let lp ((vars vars))
|
(($ $primcall name param args)
|
||||||
(match vars
|
(cons* name param (subst-vars var-substs args)))
|
||||||
(() '())
|
(($ $values args) #f)))
|
||||||
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
|
(($ $branch kf kt src op param args)
|
||||||
|
(cons* op param (subst-vars var-substs args)))
|
||||||
|
((or ($ $prompt) ($ $throw)) #f)))
|
||||||
|
|
||||||
(define (compute-term-key var-substs term)
|
(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)
|
||||||
|
(let ((equiv (hash-ref equiv-set aux-key '())))
|
||||||
|
(hash-set! equiv-set aux-key
|
||||||
|
(acons label (list var) equiv))))
|
||||||
|
(define-syntax add-definitions
|
||||||
|
(syntax-rules (<-)
|
||||||
|
((add-definitions)
|
||||||
|
#f)
|
||||||
|
((add-definitions
|
||||||
|
((def <- op arg ...) (aux <- op* arg* ...) ...)
|
||||||
|
. clauses)
|
||||||
|
(match term-key
|
||||||
|
(('op arg ...)
|
||||||
|
(match defs
|
||||||
|
(#f
|
||||||
|
;; If the successor is a control-flow join, don't
|
||||||
|
;; pretend to know the values of its defs.
|
||||||
|
#f)
|
||||||
|
((def) (add-def! (list 'op* arg* ...) aux) ...)))
|
||||||
|
(_ (add-definitions . clauses))))
|
||||||
|
((add-definitions
|
||||||
|
((op arg ...) (aux <- op* arg* ...) ...)
|
||||||
|
. clauses)
|
||||||
|
(match term-key
|
||||||
|
(('op arg ...)
|
||||||
|
(add-def! (list 'op* arg* ...) aux) ...)
|
||||||
|
(_ (add-definitions . clauses))))))
|
||||||
|
(add-definitions
|
||||||
|
((scm-set! p s i x) (x <- scm-ref p s i))
|
||||||
|
((scm-set!/tag p s x) (x <- scm-ref/tag p s))
|
||||||
|
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
|
||||||
|
((word-set! p s i x) (x <- word-ref p s i))
|
||||||
|
((word-set!/immediate p s x) (x <- word-ref/immediate p s))
|
||||||
|
((pointer-set!/immediate p s x) (x <- pointer-ref/immediate p s))
|
||||||
|
|
||||||
|
((u <- scm->f64 #f s) (s <- f64->scm #f u))
|
||||||
|
((s <- f64->scm #f u) (u <- scm->f64 #f s))
|
||||||
|
((u <- scm->u64 #f s) (s <- u64->scm #f u))
|
||||||
|
((s <- u64->scm #f u) (u <- scm->u64 #f s)
|
||||||
|
(u <- scm->u64/truncate #f s))
|
||||||
|
((s <- u64->scm/unlikely #f u) (u <- scm->u64 #f s)
|
||||||
|
(u <- scm->u64/truncate #f s))
|
||||||
|
((u <- scm->s64 #f s) (s <- s64->scm #f u))
|
||||||
|
((s <- s64->scm #f u) (u <- scm->s64 #f s))
|
||||||
|
((s <- s64->scm/unlikely #f u) (u <- scm->s64 #f s))
|
||||||
|
((u <- untag-fixnum #f s) (s <- s64->scm #f u)
|
||||||
|
(s <- tag-fixnum #f u))
|
||||||
|
;; NB: These definitions rely on U having top 2 bits equal to
|
||||||
|
;; 3rd (sign) bit.
|
||||||
|
((s <- tag-fixnum #f u) (u <- scm->s64 #f s)
|
||||||
|
(u <- untag-fixnum #f s))
|
||||||
|
((s <- u64->s64 #f u) (u <- s64->u64 #f s))
|
||||||
|
((u <- s64->u64 #f s) (s <- u64->s64 #f u))
|
||||||
|
|
||||||
|
((u <- untag-char #f s) (s <- tag-char #f u))
|
||||||
|
((s <- tag-char #f u) (u <- untag-char #f s)))))
|
||||||
|
|
||||||
|
(define (visit-label label cont equiv-labels var-substs)
|
||||||
|
(define (term-defs term)
|
||||||
(match term
|
(match term
|
||||||
(($ $continue k src exp)
|
(($ $continue k)
|
||||||
(match exp
|
(and (intset-ref singly-referenced k)
|
||||||
(($ $const val) (cons 'const val))
|
(intmap-ref defs label)))
|
||||||
(($ $prim name) (cons 'prim name))
|
(($ $branch) '())))
|
||||||
(($ $fun body) #f)
|
(match cont
|
||||||
(($ $rec names syms funs) #f)
|
(($ $kargs names vars term)
|
||||||
(($ $const-fun label) #f)
|
(match (compute-term-key var-substs term)
|
||||||
(($ $code label) (cons 'code label))
|
(#f (values equiv-labels var-substs))
|
||||||
(($ $call proc args) #f)
|
(term-key
|
||||||
(($ $callk k proc args) #f)
|
(let* ((equiv (hash-ref equiv-set term-key '()))
|
||||||
(($ $primcall name param args)
|
(fx (intmap-ref effects label))
|
||||||
(cons* name param (subst-vars var-substs args)))
|
(avail (intmap-ref avail label)))
|
||||||
(($ $values args) #f)))
|
(define (finish equiv-labels var-substs defs)
|
||||||
(($ $branch kf kt src op param args)
|
;; If this expression defines auxiliary definitions,
|
||||||
(cons* op param (subst-vars var-substs args)))
|
;; as `cons' does for the results of `car' and `cdr',
|
||||||
((or ($ $prompt) ($ $throw)) #f)))
|
;; define those. Do so after finding equivalent
|
||||||
|
;; expressions, so that we can take advantage of
|
||||||
(define (add-auxiliary-definitions! label defs var-substs term-key)
|
;; subst'd output vars.
|
||||||
(let ((defs (and defs (subst-vars var-substs defs))))
|
(add-auxiliary-definitions! label defs var-substs term-key)
|
||||||
(define (add-def! aux-key var)
|
(values equiv-labels var-substs))
|
||||||
(let ((equiv (hash-ref equiv-set aux-key '())))
|
(let lp ((candidates equiv))
|
||||||
(hash-set! equiv-set aux-key
|
(match candidates
|
||||||
(acons label (list var) equiv))))
|
(()
|
||||||
(define-syntax add-definitions
|
;; No matching expressions. Add our expression
|
||||||
(syntax-rules (<-)
|
;; to the equivalence set, if appropriate. Note
|
||||||
((add-definitions)
|
;; that expressions that allocate a fresh object
|
||||||
#f)
|
;; or change the current fluid environment can't
|
||||||
((add-definitions
|
;; be eliminated by CSE (though DCE might do it
|
||||||
((def <- op arg ...) (aux <- op* arg* ...) ...)
|
;; if the value proves to be unused, in the
|
||||||
. clauses)
|
;; allocation case).
|
||||||
(match term-key
|
(let ((defs (term-defs term)))
|
||||||
(('op arg ...)
|
(when (and defs
|
||||||
(match defs
|
(not (causes-effect? fx &allocation))
|
||||||
(#f
|
(not (effect-clobbers? fx (&read-object &fluid))))
|
||||||
;; If the successor is a control-flow join, don't
|
(hash-set! equiv-set term-key (acons label defs equiv)))
|
||||||
;; pretend to know the values of its defs.
|
(finish equiv-labels var-substs defs)))
|
||||||
#f)
|
(((and head (candidate . vars)) . candidates)
|
||||||
((def) (add-def! (list 'op* arg* ...) aux) ...)))
|
(cond
|
||||||
(_ (add-definitions . clauses))))
|
((not (intset-ref avail candidate))
|
||||||
((add-definitions
|
;; This expression isn't available here; try
|
||||||
((op arg ...) (aux <- op* arg* ...) ...)
|
;; the next one.
|
||||||
. clauses)
|
(lp candidates))
|
||||||
(match term-key
|
(else
|
||||||
(('op arg ...)
|
;; Yay, a match. Mark expression as equivalent. If
|
||||||
(add-def! (list 'op* arg* ...) aux) ...)
|
;; we provide the definitions for the successor, mark
|
||||||
(_ (add-definitions . clauses))))))
|
;; the vars for substitution.
|
||||||
(add-definitions
|
|
||||||
((scm-set! p s i x) (x <- scm-ref p s i))
|
|
||||||
((scm-set!/tag p s x) (x <- scm-ref/tag p s))
|
|
||||||
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
|
|
||||||
((word-set! p s i x) (x <- word-ref p s i))
|
|
||||||
((word-set!/immediate p s x) (x <- word-ref/immediate p s))
|
|
||||||
((pointer-set!/immediate p s x) (x <- pointer-ref/immediate p s))
|
|
||||||
|
|
||||||
((u <- scm->f64 #f s) (s <- f64->scm #f u))
|
|
||||||
((s <- f64->scm #f u) (u <- scm->f64 #f s))
|
|
||||||
((u <- scm->u64 #f s) (s <- u64->scm #f u))
|
|
||||||
((s <- u64->scm #f u) (u <- scm->u64 #f s)
|
|
||||||
(u <- scm->u64/truncate #f s))
|
|
||||||
((s <- u64->scm/unlikely #f u) (u <- scm->u64 #f s)
|
|
||||||
(u <- scm->u64/truncate #f s))
|
|
||||||
((u <- scm->s64 #f s) (s <- s64->scm #f u))
|
|
||||||
((s <- s64->scm #f u) (u <- scm->s64 #f s))
|
|
||||||
((s <- s64->scm/unlikely #f u) (u <- scm->s64 #f s))
|
|
||||||
((u <- untag-fixnum #f s) (s <- s64->scm #f u)
|
|
||||||
(s <- tag-fixnum #f u))
|
|
||||||
;; NB: These definitions rely on U having top 2 bits equal to
|
|
||||||
;; 3rd (sign) bit.
|
|
||||||
((s <- tag-fixnum #f u) (u <- scm->s64 #f s)
|
|
||||||
(u <- untag-fixnum #f s))
|
|
||||||
((s <- u64->s64 #f u) (u <- s64->u64 #f s))
|
|
||||||
((u <- s64->u64 #f s) (s <- u64->s64 #f u))
|
|
||||||
|
|
||||||
((u <- untag-char #f s) (s <- tag-char #f u))
|
|
||||||
((s <- tag-char #f u) (u <- untag-char #f s)))))
|
|
||||||
|
|
||||||
(define (visit-label label cont equiv-labels var-substs)
|
|
||||||
(define (term-defs term)
|
|
||||||
(match term
|
|
||||||
(($ $continue k)
|
|
||||||
(and (intset-ref singly-referenced k)
|
|
||||||
(intmap-ref defs label)))
|
|
||||||
(($ $branch) '())))
|
|
||||||
(match cont
|
|
||||||
(($ $kargs names vars term)
|
|
||||||
(match (compute-term-key var-substs term)
|
|
||||||
(#f (values equiv-labels var-substs))
|
|
||||||
(term-key
|
|
||||||
(let* ((equiv (hash-ref equiv-set term-key '()))
|
|
||||||
(fx (intmap-ref effects label))
|
|
||||||
(avail (intmap-ref avail label)))
|
|
||||||
(define (finish equiv-labels 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 equiv-labels 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)))
|
(let ((defs (term-defs term)))
|
||||||
(when (and defs
|
(finish (intmap-add equiv-labels label head)
|
||||||
(not (causes-effect? fx &allocation))
|
(if defs
|
||||||
(not (effect-clobbers? fx (&read-object &fluid))))
|
(fold (lambda (def var var-substs)
|
||||||
(hash-set! equiv-set term-key (acons label defs equiv)))
|
(intmap-add var-substs def var))
|
||||||
(finish equiv-labels var-substs defs)))
|
var-substs defs vars)
|
||||||
(((and head (candidate . vars)) . candidates)
|
var-substs)
|
||||||
(cond
|
defs)))))))))))
|
||||||
((not (intset-ref avail candidate))
|
(_ (values equiv-labels var-substs))))
|
||||||
;; This expression isn't available here; try
|
|
||||||
;; the next one.
|
|
||||||
(lp candidates))
|
|
||||||
(else
|
|
||||||
;; Yay, a match. Mark expression as equivalent. If
|
|
||||||
;; we provide the definitions for the successor, mark
|
|
||||||
;; the vars for substitution.
|
|
||||||
(let ((defs (term-defs term)))
|
|
||||||
(finish (intmap-add equiv-labels label head)
|
|
||||||
(if defs
|
|
||||||
(fold (lambda (def var var-substs)
|
|
||||||
(intmap-add var-substs def var))
|
|
||||||
var-substs defs vars)
|
|
||||||
var-substs)
|
|
||||||
defs)))))))))))
|
|
||||||
(_ (values equiv-labels var-substs))))
|
|
||||||
|
|
||||||
;; Because of the renumber pass, the labels are numbered in
|
;; Because of the renumber pass, the labels are numbered in
|
||||||
;; reverse post-order, which will visit definitions before uses.
|
;; reverse post-order, which will visit definitions before uses.
|
||||||
(intmap-fold visit-label
|
(intmap-fold visit-label
|
||||||
conts
|
conts
|
||||||
equiv-labels
|
equiv-labels
|
||||||
var-substs)))
|
var-substs)))
|
||||||
|
|
||||||
(intmap-fold visit-fun
|
(define (fold-renumbered-functions f conts . seeds)
|
||||||
(compute-reachable-functions conts kfun)
|
;; Precondition: CONTS has been renumbered, and therefore functions
|
||||||
empty-intmap
|
;; contained within it are topologically sorted, and the conts of each
|
||||||
empty-intmap))
|
;; function's body are numbered sequentially after the function's
|
||||||
|
;; $kfun.
|
||||||
|
(define (next-function-body kfun)
|
||||||
|
(match (intmap-ref conts kfun (lambda (_) #f))
|
||||||
|
(#f #f)
|
||||||
|
((and cont ($ $kfun))
|
||||||
|
(let lp ((k (1+ kfun)) (body (intmap-add! empty-intmap kfun cont)))
|
||||||
|
(match (intmap-ref conts k (lambda (_) #f))
|
||||||
|
((or #f ($ $kfun))
|
||||||
|
(persistent-intmap body))
|
||||||
|
(cont
|
||||||
|
(lp (1+ k) (intmap-add! body k cont))))))))
|
||||||
|
|
||||||
|
(let fold ((kfun 0) (seeds seeds))
|
||||||
|
(match (next-function-body kfun)
|
||||||
|
(#f (apply values seeds))
|
||||||
|
(conts
|
||||||
|
(call-with-values (lambda () (apply f kfun conts seeds))
|
||||||
|
(lambda seeds
|
||||||
|
(fold (1+ (intmap-prev conts)) seeds)))))))
|
||||||
|
|
||||||
|
(define (compute-equivalent-expressions conts)
|
||||||
|
(fold-renumbered-functions compute-equivalent-expressions-in-fun
|
||||||
|
conts empty-intmap empty-intmap))
|
||||||
|
|
||||||
(define (apply-cse conts equiv-labels var-substs truthy-labels)
|
(define (apply-cse conts equiv-labels var-substs truthy-labels)
|
||||||
(define (true-idx idx) (ash idx 1))
|
(define (true-idx idx) (ash idx 1))
|
||||||
|
|
@ -415,7 +434,7 @@ false. It could be that both true and false proofs are available."
|
||||||
|
|
||||||
(define (eliminate-common-subexpressions conts)
|
(define (eliminate-common-subexpressions conts)
|
||||||
(let ((conts (renumber conts 0)))
|
(let ((conts (renumber conts 0)))
|
||||||
(call-with-values (lambda () (compute-equivalent-subexpressions conts 0))
|
(call-with-values (lambda () (compute-equivalent-expressions conts))
|
||||||
(lambda (equiv-labels var-substs)
|
(lambda (equiv-labels var-substs)
|
||||||
(let ((truthy-labels (compute-truthy-expressions conts 0)))
|
(let ((truthy-labels (compute-truthy-expressions conts 0)))
|
||||||
(apply-cse conts equiv-labels var-substs truthy-labels))))))
|
(apply-cse conts equiv-labels var-substs truthy-labels))))))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue