mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +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

312
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-fold
(intset kfun) (lambda (kfun boolv)
(intmap-add boolv kfun empty-intset)))) (worklist-fold* visit-cont
;; Now visit nested functions. We don't do this in the worklist (intset kfun)
;; folder because that would be exponential. (intmap-add boolv kfun empty-intset)))
(define (recurse kfun boolv) (intmap-keys (compute-reachable-functions conts kfun))
(compute-truthy-expressions conts kfun boolv)) empty-intmap))
(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)))
(define (intset-map f set) (define (intset-map f set)
(persistent-intmap (persistent-intmap
@ -236,151 +225,147 @@ 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))
(defs (compute-defs conts kfun)) (defs (compute-defs conts kfun))
(equiv-set (make-hash-table))) (equiv-set (make-hash-table)))
(define (subst-var var-substs var) (define (subst-var var-substs var)
(intmap-ref var-substs var (lambda (var) var))) (intmap-ref var-substs var (lambda (var) var)))
(define (subst-vars var-substs vars) (define (subst-vars var-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 var-substs var) (lp vars))))))
(define (compute-exp-key var-substs exp) (define (compute-exp-key var-substs exp)
(match exp (match exp
(($ $const val) (cons 'const val)) (($ $const val) (cons 'const val))
(($ $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)
(($ $call proc args) #f) (($ $closure label nfree) #f)
(($ $callk k proc args) #f) (($ $call proc args) #f)
(($ $primcall name args) (($ $callk k proc args) #f)
(cons* 'primcall name (subst-vars var-substs args))) (($ $primcall name args)
(($ $branch _ ($ $primcall name args)) (cons* 'primcall name (subst-vars var-substs args)))
(cons* 'primcall name (subst-vars var-substs args))) (($ $branch _ ($ $primcall name args))
(($ $branch) #f) (cons* 'primcall name (subst-vars var-substs args)))
(($ $values args) #f) (($ $branch) #f)
(($ $prompt escape? tag handler) #f))) (($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
(define (add-auxiliary-definitions! label var-substs exp-key) (define (add-auxiliary-definitions! label var-substs exp-key)
(define (subst var) (define (subst var)
(subst-var var-substs var)) (subst-var var-substs var))
(let ((defs (intmap-ref defs label))) (let ((defs (intmap-ref defs label)))
(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
(acons label (list var) equiv)))) (acons label (list var) equiv))))
(match exp-key (match exp-key
(('primcall 'box val) (('primcall 'box val)
(match defs (match defs
((box) ((box)
(add-def! `(primcall box-ref ,(subst box)) val)))) (add-def! `(primcall box-ref ,(subst box)) val))))
(('primcall 'box-set! box val) (('primcall 'box-set! box val)
(add-def! `(primcall box-ref ,box) val)) (add-def! `(primcall box-ref ,box) val))
(('primcall 'cons car cdr) (('primcall 'cons car cdr)
(match defs (match defs
((pair) ((pair)
(add-def! `(primcall car ,(subst pair)) car) (add-def! `(primcall car ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr)))) (add-def! `(primcall cdr ,(subst pair)) cdr))))
(('primcall 'set-car! pair car) (('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car)) (add-def! `(primcall car ,pair) car))
(('primcall 'set-cdr! pair cdr) (('primcall 'set-cdr! pair cdr)
(add-def! `(primcall cdr ,pair) cdr)) (add-def! `(primcall cdr ,pair) cdr))
(('primcall (or 'make-vector 'make-vector/immediate) len fill) (('primcall (or 'make-vector 'make-vector/immediate) len fill)
(match defs (match defs
((vec) ((vec)
(add-def! `(primcall vector-length ,(subst vec)) len)))) (add-def! `(primcall vector-length ,(subst vec)) len))))
(('primcall 'vector-set! vec idx val) (('primcall 'vector-set! vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val)) (add-def! `(primcall vector-ref ,vec ,idx) val))
(('primcall 'vector-set!/immediate vec idx val) (('primcall 'vector-set!/immediate vec idx val)
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
(('primcall (or 'allocate-struct 'allocate-struct/immediate) (('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size) vtable size)
(match defs (match defs
((struct) ((struct)
(add-def! `(primcall struct-vtable ,(subst struct)) (add-def! `(primcall struct-vtable ,(subst struct))
vtable)))) vtable))))
(('primcall 'struct-set! struct n val) (('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val)) (add-def! `(primcall struct-ref ,struct ,n) val))
(('primcall 'struct-set!/immediate struct n val) (('primcall 'struct-set!/immediate struct n val)
(add-def! `(primcall struct-ref/immediate ,struct ,n) val)) (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
(_ #t)))) (_ #t))))
(define (visit-label label equiv-labels var-substs) (define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src exp))
(let* ((exp-key (compute-exp-key var-substs exp)) (let* ((exp-key (compute-exp-key var-substs exp))
(equiv (hash-ref equiv-set exp-key '())) (equiv (hash-ref equiv-set exp-key '()))
(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) ;; If this expression defines auxiliary definitions,
(compute-equivalent-subexpressions conts kfun effects ;; as `cons' does for the results of `car' and `cdr',
equiv-labels var-substs)) ;; define those. Do so after finding equivalent
;; If this expression defines auxiliary definitions, ;; expressions, so that we can take advantage of
;; as `cons' does for the results of `car' and `cdr', ;; subst'd output vars.
;; define those. Do so after finding equivalent (add-auxiliary-definitions! label var-substs exp-key)
;; expressions, so that we can take advantage of (values equiv-labels var-substs))
;; subst'd output vars. (let lp ((candidates equiv))
(add-auxiliary-definitions! label var-substs exp-key) (match candidates
(match exp (()
;; If we see a $fun, recurse to add to the result. ;; No matching expressions. Add our expression
(($ $fun kfun) ;; to the equivalence set, if appropriate. Note
(recurse kfun equiv-labels var-substs)) ;; that expressions that allocate a fresh object
(($ $rec names vars (($ $fun kfun) ...)) ;; or change the current fluid environment can't
(fold2 recurse kfun equiv-labels var-substs)) ;; be eliminated by CSE (though DCE might do it
(_ ;; if the value proves to be unused, in the
(values equiv-labels var-substs)))) ;; allocation case).
(let lp ((candidates equiv)) (when (and exp-key
(match candidates (not (causes-effect? fx &allocation))
(() (not (effect-clobbers? fx (&read-object &fluid))))
;; No matching expressions. Add our expression (let ((defs (and (intset-ref singly-referenced k)
;; to the equivalence set, if appropriate. Note (intmap-ref defs label))))
;; that expressions that allocate a fresh object (when defs
;; or change the current fluid environment can't (hash-set! equiv-set exp-key
;; be eliminated by CSE (though DCE might do it (acons label defs equiv)))))
;; if the value proves to be unused, in the (finish equiv-labels var-substs))
;; allocation case). (((and head (candidate . vars)) . candidates)
(when (and exp-key (cond
(not (causes-effect? fx &allocation)) ((not (intset-ref avail candidate))
(not (effect-clobbers? fx (&read-object &fluid)))) ;; This expression isn't available here; try
(let ((defs (and (intset-ref singly-referenced k) ;; the next one.
(intmap-ref defs label)))) (lp candidates))
(when defs (else
(hash-set! equiv-set exp-key ;; Yay, a match. Mark expression as equivalent. If
(acons label defs equiv))))) ;; we provide the definitions for the successor, mark
(finish equiv-labels var-substs)) ;; the vars for substitution.
(((and head (candidate . vars)) . candidates) (finish (intmap-add equiv-labels label head)
(cond (let ((defs (and (intset-ref singly-referenced k)
((not (intset-ref avail candidate)) (intmap-ref defs label))))
;; This expression isn't available here; try (if defs
;; the next one. (fold (lambda (def var var-substs)
(lp candidates)) (intmap-add var-substs def var))
(else var-substs defs vars)
;; Yay, a match. Mark expression as equivalent. If var-substs))))))))))
;; we provide the definitions for the successor, mark (_ (values equiv-labels var-substs))))
;; the vars for substitution.
(finish (intmap-add equiv-labels label head)
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
var-substs defs vars)
var-substs))))))))))
(_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in reverse post-order, which will ;; Traverse the labels in fun in reverse post-order, which will
;; visit definitions before uses first. ;; visit definitions before uses first.
(fold2 visit-label (fold2 visit-label
(compute-reverse-post-order succs kfun) (compute-reverse-post-order succs kfun)
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))
@ -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)))))