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) (define-module (language cps cse)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps utils) #:use-module (language cps utils)
@ -137,23 +138,26 @@ 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-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) (define (eliminate-common-subexpressions-in-fun kfun conts out)
(let* ((effects (synthesize-definition-effects (compute-effects conts))) (define equiv-set (make-hash-table))
(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 (true-idx idx) (ash idx 1)) (define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (ash idx 1))) (define (false-idx idx) (1+ (ash idx 1)))
(define (subst-var var-substs var) (define (subst-var substs var)
(intmap-ref var-substs var (lambda (var) var))) (intmap-ref substs var (lambda (var) var)))
(define (subst-vars var-substs vars) (define (subst-vars substs vars)
(let lp ((vars vars)) (let lp ((vars vars))
(match 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) (define (compute-term-key term)
(match term (match term
@ -173,17 +177,19 @@ 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) (define (add-substs label defs out substs analysis)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(match (trivial-intset (intmap-ref preds label)) (match (trivial-intset (intmap-ref preds label))
(#f var-substs) (#f substs)
(pred (pred
(match (intmap-ref out pred) (match (intmap-ref out pred)
(($ $kargs _ _ ($ $continue _ _ ($ $values vals))) (($ $kargs _ _ ($ $continue _ _ ($ $values vals)))
;; FIXME: Eliminate predecessor entirely, retargetting its ;; FIXME: Eliminate predecessor entirely, retargetting its
;; predecessors. ;; predecessors.
(fold (lambda (def var var-substs) (fold (lambda (def var substs)
(intmap-add var-substs def var)) (intmap-add substs def var))
var-substs defs vals)) substs defs vals))
(($ $kargs _ _ term) (($ $kargs _ _ term)
(match (compute-term-key term) (match (compute-term-key term)
(#f #f) (#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 ;; If the predecessor defines auxiliary definitions, as
;; `cons' does for the results of `car' and `cdr', define ;; `cons' does for the results of `car' and `cdr', define
;; those as well. ;; those as well.
(add-auxiliary-definitions! pred defs var-substs term-key))) (add-auxiliary-definitions! pred defs substs term-key)))
var-substs) substs)
(_ (_
var-substs))))) substs)))))))
(define (add-auxiliary-definitions! label defs var-substs term-key) (define (add-auxiliary-definitions! label defs substs term-key)
(let ((defs (and defs (subst-vars var-substs defs))))
(define (add-def! aux-key var) (define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '()))) (let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! 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 <- s64->u64 #f s) (s <- u64->s64 #f u))
((u <- untag-char #f s) (s <- tag-char #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) (define (subst-var var)
(intmap-ref var-substs var (lambda (var) var))) (intmap-ref substs var (lambda (var) var)))
(define (rename-exp exp) (define (rename-exp exp)
(rewrite-exp exp (rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $const-fun) ($ $code)) ((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 args)
($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 substs analysis)
(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* ((var-substs (add-var-substs label vars out var-substs)) (let* ((substs (add-substs label vars out substs analysis))
(term (rename-uses term var-substs))) (term (rename-uses term 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)
@ -307,6 +312,8 @@ false. It could be that both true and false proofs are available."
(match (compute-term-key term) (match (compute-term-key term)
(#f (residualize)) (#f (residualize))
(term-key (term-key
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(let ((avail (intmap-ref avail label))) (let ((avail (intmap-ref avail label)))
(let lp ((candidates (hash-ref equiv-set term-key '()))) (let lp ((candidates (hash-ref equiv-set term-key '())))
(match candidates (match candidates
@ -333,14 +340,22 @@ false. It could be that both true and false proofs are available."
;; looking for another candidate. ;; looking for another candidate.
(lp candidates) (lp candidates)
;; Nice, the branch folded. ;; Nice, the branch folded.
(eliminate (if t kt kf) src '()))))))))))))) (eliminate (if t kt kf) src '())))))))))))))))
var-substs))) substs analysis)))
(_ (values (add cont) var-substs)))) (_ (values (add cont) substs analysis))))
;; Because of the renumber pass, the labels are numbered in reverse ;; Because of the renumber pass, the labels are numbered in reverse
;; post-order, so the intmap-fold will visit definitions before ;; post-order, so the intmap-fold will visit definitions before
;; uses. ;; 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) (define (fold-renumbered-functions f conts seed)
;; Precondition: CONTS has been renumbered, and therefore functions ;; Precondition: CONTS has been renumbered, and therefore functions