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

Thread flow analysis through CSE pass

Browse source 
* module/language/cps/cse.scm (<analysis>): New data type, grouping
  available expression analysis, predecessor map, etc.
  (eliminate-common-subexpressions-in-fun): Instead of having a static
  analysis, thread it through the CSE pass so that we can update the CFG
  as we go.
This commit is contained in:
Andy Wingo 2020-05-28 16:47:17 +02:00
parent 6fb0635358
commit 3c4d4acbd4
1 changed files with 214 additions and 199 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -25,6 +25,7 @@
(define-module (language cps cse)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
@ -137,23 +138,26 @@ false. It could be that both true and false proofs are available."
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define-record-type <analysis>
(make-analysis effects clobbers preds avail truthy-labels)
analysis?
(effects analysis-effects)
(clobbers analysis-clobbers)
(preds analysis-preds)
(avail analysis-avail)
(truthy-labels analysis-truthy-labels))
(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))
(preds (invert-graph succs))
(avail (compute-available-expressions succs kfun clobbers))
(truthy-labels (compute-truthy-expressions conts kfun))
(equiv-set (make-hash-table)))
(define equiv-set (make-hash-table))
(define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (ash idx 1)))
(define (subst-var var-substs var)
(intmap-ref var-substs var (lambda (var) var)))
(define (subst-vars var-substs vars)
(define (subst-var substs var)
(intmap-ref substs var (lambda (var) var)))
(define (subst-vars substs vars)
(let lp ((vars vars))
(match vars
(() '())
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
((var . vars) (cons (subst-var substs var) (lp vars))))))
(define (compute-term-key term)
(match term
@ -173,17 +177,19 @@ 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)
(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 var-substs)
(#f 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))
(fold (lambda (def var substs)
(intmap-add substs def var))
substs defs vals))
(($ $kargs _ _ term)
(match (compute-term-key term)
(#f #f)
@ -201,13 +207,12 @@ false. It could be that both true and false proofs are available."
;; 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)
(add-auxiliary-definitions! pred defs substs term-key)))
substs)
(_
var-substs)))))
substs)))))))
(define (add-auxiliary-definitions! label defs var-substs term-key)
(let ((defs (and defs (subst-vars var-substs defs))))
(define (add-auxiliary-definitions! label defs substs term-key)
(define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! equiv-set aux-key
@ -263,11 +268,11 @@ false. It could be that both true and false proofs are available."
((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)))))
((s <- tag-char #f u) (u <- untag-char #f s))))
(define (rename-uses term var-substs)
(define (rename-uses term substs)
(define (subst-var var)
(intmap-ref var-substs var (lambda (var) var)))
(intmap-ref substs var (lambda (var) var)))
(define (rename-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $const-fun) ($ $code))
@ -290,13 +295,13 @@ false. It could be that both true and false proofs are available."
(($ $throw src op param args)
($throw src op param ,(map subst-var args)))))
(define (visit-label label cont out var-substs)
(define (visit-label label cont out substs analysis)
(define (add cont)
(intmap-add! out label cont))
(match cont
(($ $kargs names vars term)
(let* ((var-substs (add-var-substs label vars out var-substs))
(term (rename-uses term var-substs)))
(let* ((substs (add-substs label vars out substs analysis))
(term (rename-uses term substs)))
(define (residualize)
(add (build-cont ($kargs names vars ,term))))
(define (eliminate k src vals)
@ -307,6 +312,8 @@ false. It could be that both true and false proofs are available."
(match (compute-term-key term)
(#f (residualize))
(term-key
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(let ((avail (intmap-ref avail label)))
(let lp ((candidates (hash-ref equiv-set term-key '())))
(match candidates
@ -333,14 +340,22 @@ false. It could be that both true and false proofs are available."
;; looking for another candidate.
(lp candidates)
;; Nice, the branch folded.
(eliminate (if t kt kf) src '())))))))))))))
var-substs)))
(_ (values (add cont) var-substs))))
(eliminate (if t kt kf) src '())))))))))))))))
substs analysis)))
(_ (values (add cont) substs analysis))))
;; Because of the renumber pass, the labels are numbered in reverse
;; post-order, so the intmap-fold will visit definitions before
;; uses.
(intmap-fold visit-label conts out empty-intmap)))
(let* ((substs empty-intmap)
(effects (synthesize-definition-effects (compute-effects conts)))
(clobbers (compute-clobber-map effects))
(succs (compute-successors conts kfun))
(preds (invert-graph succs))
(avail (compute-available-expressions succs kfun clobbers))
(truthy-labels (compute-truthy-expressions conts kfun)))
(intmap-fold visit-label conts out substs
(make-analysis effects clobbers preds avail truthy-labels))))
(define (fold-renumbered-functions f conts seed)
;; Precondition: CONTS has been renumbered, and therefore functions