mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +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)
(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
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
@ -177,24 +177,13 @@ false. It could be that both true and false proofs are available."
(propagate1 kbody)))
(($ $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
(lambda (label boolv)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun kfun) (recurse kfun boolv))
(($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun))
(_ boolv)))
(_ boolv)))
(compute-function-body conts kfun)
boolv)))
(lambda (kfun boolv)
(worklist-fold* visit-cont
(intset kfun)
(intmap-add boolv kfun empty-intset)))
(intmap-keys (compute-reachable-functions conts kfun))
empty-intmap))
(define (intset-map f set)
(persistent-intmap
@ -236,8 +225,8 @@ false. It could be that both true and false proofs are available."
(intset-subtract (persistent-intset single)
(persistent-intset multiple)))))
(define (compute-equivalent-subexpressions conts kfun effects
equiv-labels var-substs)
(define (compute-equivalent-subexpressions conts kfun effects)
(define (visit-fun kfun equiv-labels var-substs)
(let* ((succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs))
(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))
(($ $fun body) #f)
(($ $rec names syms funs) #f)
(($ $closure label nfree) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
@ -319,23 +309,13 @@ false. It could be that both true and false proofs are available."
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
(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,
;; 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 var-substs exp-key)
(match exp
;; 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))))
(values equiv-labels var-substs))
(let lp ((candidates equiv))
(match candidates
(()
@ -382,6 +362,11 @@ false. It could be that both true and false proofs are available."
equiv-labels
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 (true-idx idx) (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)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp)
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
@ -442,8 +427,7 @@ false. It could be that both true and false proofs are available."
(call-with-values
(lambda ()
(let ((effects (synthesize-definition-effects (compute-effects conts))))
(compute-equivalent-subexpressions conts 0 effects
empty-intmap empty-intmap)))
(compute-equivalent-subexpressions conts 0 effects)))
(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)))))