[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/12: Refactor CSE to take advantage of RPO numbering
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/12: Refactor CSE to take advantage of RPO numbering |
|
Date: |
Fri, 29 May 2020 10:34:06 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 6e91173334c0121c929d3cfbd20ea25b6ff4e6dc
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu May 28 11:52:28 2020 +0200
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.
---
module/language/cps/cse.scm | 353 +++++++++++++++++++++++---------------------
1 file changed, 186 insertions(+), 167 deletions(-)
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index ec1685c..bb33868 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -187,174 +187,193 @@ false. It could be that both true and false proofs are
available."
(intset-subtract (persistent-intset single)
(persistent-intset multiple)))))
-(define (intmap-select map set)
- (intset->intmap (lambda (label) (intmap-ref map label)) set))
-
-(define (compute-equivalent-subexpressions conts kfun)
- (define (visit-fun kfun body equiv-labels var-substs)
- (let* ((conts (intmap-select conts body))
- (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-term-key var-substs term)
+(define (compute-equivalent-expressions-in-fun kfun conts
+ 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-term-key var-substs term)
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ (($ $const val) (cons 'const val))
+ (($ $prim name) (cons 'prim name))
+ (($ $fun body) #f)
+ (($ $rec names syms funs) #f)
+ (($ $const-fun label) #f)
+ (($ $code label) (cons 'code label))
+ (($ $call proc args) #f)
+ (($ $callk k proc args) #f)
+ (($ $primcall name param args)
+ (cons* name param (subst-vars var-substs args)))
+ (($ $values args) #f)))
+ (($ $branch kf kt src op param args)
+ (cons* op param (subst-vars var-substs args)))
+ ((or ($ $prompt) ($ $throw)) #f)))
+
+ (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
- (($ $continue k src exp)
- (match exp
- (($ $const val) (cons 'const val))
- (($ $prim name) (cons 'prim name))
- (($ $fun body) #f)
- (($ $rec names syms funs) #f)
- (($ $const-fun label) #f)
- (($ $code label) (cons 'code label))
- (($ $call proc args) #f)
- (($ $callk k proc args) #f)
- (($ $primcall name param args)
- (cons* name param (subst-vars var-substs args)))
- (($ $values args) #f)))
- (($ $branch kf kt src op param args)
- (cons* op param (subst-vars var-substs args)))
- ((or ($ $prompt) ($ $throw)) #f)))
-
- (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
- (($ $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).
+ (($ $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)))
+ (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 equiv-labels var-substs defs)))
+ (((and head (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. If
+ ;; we provide the definitions for the successor, mark
+ ;; the vars for substitution.
(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 equiv-labels var-substs defs)))
- (((and head (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. 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
- ;; reverse post-order, which will visit definitions before uses.
- (intmap-fold visit-label
- conts
- equiv-labels
- var-substs)))
-
- (intmap-fold visit-fun
- (compute-reachable-functions conts kfun)
- empty-intmap
- empty-intmap))
+ (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
+ ;; reverse post-order, which will visit definitions before uses.
+ (intmap-fold visit-label
+ conts
+ equiv-labels
+ var-substs)))
+
+(define (fold-renumbered-functions 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
+ ;; $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 (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)
(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)
(let ((truthy-labels (compute-truthy-expressions conts 0)))
(apply-cse conts equiv-labels var-substs truthy-labels))))))
- [Guile-commits] branch master updated (4677c12 -> 4c59ff7), Andy Wingo, 2020/05/29
- [Guile-commits] 01/12: Renumber before CSE, Andy Wingo, 2020/05/29
- [Guile-commits] 03/12: Refactor CSE to analyze and transform in a single pass, Andy Wingo, 2020/05/29
- [Guile-commits] 04/12: CSE eliminates expressions at continuations, Andy Wingo, 2020/05/29
- [Guile-commits] 02/12: Refactor CSE to take advantage of RPO numbering,
Andy Wingo <=
- [Guile-commits] 06/12: Macro fix to CPS build-term, Andy Wingo, 2020/05/29
- [Guile-commits] 05/12: Thread flow analysis through CSE pass, Andy Wingo, 2020/05/29
- [Guile-commits] 07/12: Add indentation rule for let/ec, Andy Wingo, 2020/05/29
- [Guile-commits] 09/12: Use intmaps in CSE equivalent expression table, Andy Wingo, 2020/05/29
- [Guile-commits] 11/12: CSE forwards branch predecessors where the branch folds, Andy Wingo, 2020/05/29
- [Guile-commits] 12/12: CSE forward-propagates changes to CFG, Andy Wingo, 2020/05/29
- [Guile-commits] 08/12: Eager graph pruning in CSE, Andy Wingo, 2020/05/29
- [Guile-commits] 10/12: CSE refactor, Andy Wingo, 2020/05/29