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

CSE can run on first-order CPS

Browse source 
* module/language/cps/cse.scm (compute-truthy-expressions):
  (compute-equivalent-subexpressions):
  (eliminate-common-subexpressions): Refactor to be able to work on
  first-order CPS.
This commit is contained in:
Andy Wingo 2015-10-28 09:13:20 +00:00
parent 8d79dfddb6
commit 04356dabb9
1 changed files with 148 additions and 164 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -123,7 +123,7 @@ an intset containing ancestor labels whose value is available at LABEL."
(intset kfun) (intset kfun)
(intmap-add empty-intmap kfun empty-intset))) (intmap-add empty-intmap kfun empty-intset)))
(define (compute-truthy-expressions conts kfun boolv) (define (compute-truthy-expressions conts kfun)
"Compute a \"truth map\", indicating which expressions can be shown to "Compute a \"truth map\", indicating which expressions can be shown to
be true and/or false at each label in the function starting at KFUN.. be true and/or false at each label in the function starting at KFUN..
Returns an intmap of intsets. The even elements of the intset indicate Returns an intmap of intsets. The even elements of the intset indicate
@ -177,24 +177,13 @@ false. It could be that both true and false proofs are available."
(propagate1 kbody))) (propagate1 kbody)))
(($ $ktail) (propagate0))))) (($ $ktail) (propagate0)))))
(let ((boolv (worklist-fold* visit-cont
(intset kfun)
(intmap-add boolv kfun empty-intset))))
;; Now visit nested functions. We don't do this in the worklist
;; folder because that would be exponential.
(define (recurse kfun boolv)
(compute-truthy-expressions conts kfun boolv))
(intset-fold (intset-fold
(lambda (label boolv) (lambda (kfun boolv)
(match (intmap-ref conts label) (worklist-fold* visit-cont
(($ $kargs _ _ ($ $continue _ _ exp)) (intset kfun)
(match exp (intmap-add boolv kfun empty-intset)))
(($ $fun kfun) (recurse kfun boolv)) (intmap-keys (compute-reachable-functions conts kfun))
(($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun)) empty-intmap))
(_ boolv)))
(_ boolv)))
(compute-function-body conts kfun)
boolv)))
(define (intset-map f set) (define (intset-map f set)
(persistent-intmap (persistent-intmap
@ -236,8 +225,8 @@ 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 (compute-equivalent-subexpressions conts kfun effects (define (compute-equivalent-subexpressions conts kfun effects)
equiv-labels var-substs) (define (visit-fun kfun equiv-labels var-substs)
(let* ((succs (compute-successors conts kfun)) (let* ((succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs)) (singly-referenced (compute-singly-referenced succs))
(avail (compute-available-expressions conts kfun effects)) (avail (compute-available-expressions conts kfun effects))
@ -257,6 +246,7 @@ false. It could be that both true and false proofs are available."
(($ $prim name) (cons 'prim name)) (($ $prim name) (cons 'prim name))
(($ $fun body) #f) (($ $fun body) #f)
(($ $rec names syms funs) #f) (($ $rec names syms funs) #f)
(($ $closure label nfree) #f)
(($ $call proc args) #f) (($ $call proc args) #f)
(($ $callk k proc args) #f) (($ $callk k proc args) #f)
(($ $primcall name args) (($ $primcall name args)
@ -319,23 +309,13 @@ false. It could be that both true and false proofs are available."
(fx (intmap-ref effects label)) (fx (intmap-ref effects label))
(avail (intmap-ref avail label))) (avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs) (define (finish equiv-labels var-substs)
(define (recurse kfun equiv-labels var-substs)
(compute-equivalent-subexpressions conts kfun effects
equiv-labels var-substs))
;; If this expression defines auxiliary definitions, ;; If this expression defines auxiliary definitions,
;; as `cons' does for the results of `car' and `cdr', ;; as `cons' does for the results of `car' and `cdr',
;; define those. Do so after finding equivalent ;; define those. Do so after finding equivalent
;; expressions, so that we can take advantage of ;; expressions, so that we can take advantage of
;; subst'd output vars. ;; subst'd output vars.
(add-auxiliary-definitions! label var-substs exp-key) (add-auxiliary-definitions! label var-substs exp-key)
(match exp (values equiv-labels var-substs))
;; If we see a $fun, recurse to add to the result.
(($ $fun kfun)
(recurse kfun equiv-labels var-substs))
(($ $rec names vars (($ $fun kfun) ...))
(fold2 recurse kfun equiv-labels var-substs))
(_
(values equiv-labels var-substs))))
(let lp ((candidates equiv)) (let lp ((candidates equiv))
(match candidates (match candidates
(() (()
@ -382,6 +362,11 @@ false. It could be that both true and false proofs are available."
equiv-labels equiv-labels
var-substs))) var-substs)))
(intset-fold visit-fun
(intmap-keys (compute-reachable-functions conts kfun))
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))
(define (false-idx idx) (1+ (ash idx 1))) (define (false-idx idx) (1+ (ash idx 1)))
@ -391,7 +376,7 @@ false. It could be that both true and false proofs are available."
(define (visit-exp exp) (define (visit-exp exp)
(rewrite-exp exp (rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp) ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp)
(($ $call proc args) (($ $call proc args)
($call (subst-var proc) ,(map subst-var args))) ($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args) (($ $callk k proc args)
@ -442,8 +427,7 @@ false. It could be that both true and false proofs are available."
(call-with-values (call-with-values
(lambda () (lambda ()
(let ((effects (synthesize-definition-effects (compute-effects conts)))) (let ((effects (synthesize-definition-effects (compute-effects conts))))
(compute-equivalent-subexpressions conts 0 effects (compute-equivalent-subexpressions conts 0 effects)))
empty-intmap empty-intmap)))
(lambda (equiv-labels var-substs) (lambda (equiv-labels var-substs)
(let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap))) (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)))))