mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Flow-sensitive analysis of truth values

Browse source 
* module/language/cps/cse.scm (compute-truthy-expressions):
  (compute-equivalent-subexpressions, apply-cse): Arrange to infer
  truthiness of expressions, and use that information to elide redundant
  tests.
This commit is contained in:
Andy Wingo 2014-04-05 21:08:09 +02:00
parent e84cdfb6d4
commit d03c3c7795
1 changed files with 129 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -132,6 +132,75 @@ index corresponds to MIN-LABEL, and so on."
(lp 0 #f #f)
avail-in)))))))
(define (compute-truthy-expressions dfg min-label label-count)
"Compute a \"truth map\", indicating which expressions can be shown to
be true and/or false at each of LABEL-COUNT expressions in DFG, starting
from MIN-LABEL. Returns a vector of bitvectors, each bitvector twice as
long as LABEL-COUNT. The first half of the bitvector indicates labels
that may be true, and the second half those that may be false. It could
be that both true and false proofs are available."
(let ((boolv (make-vector label-count #f)))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(define (true-idx idx) idx)
(define (false-idx idx) (+ idx label-count))
(let lp ((n 0))
(when (< n label-count)
(let ((bool (make-bitvector (* label-count 2) #f)))
(vector-set! boolv n bool)
(lp (1+ n)))))
(let ((tmp (make-bitvector (* label-count 2) #f)))
(define (bitvector-copy! dst src)
(bitvector-fill! dst #f)
(bit-set*! dst src #t))
(define (intersect! dst src)
(bitvector-copy! tmp src)
(bit-invert! tmp)
(bit-set*! dst tmp #f))
(let lp ((n 0) (first? #t) (changed? #f))
(cond
((< n label-count)
(let* ((label (idx->label n))
(bool (vector-ref boolv n))
(prev-count (bit-count #t bool)))
;; Intersect truthiness from all predecessors.
(let lp ((preds (lookup-predecessors label dfg))
(initialized? #f))
(match preds
(() #t)
((pred . preds)
(let ((pidx (label->idx pred)))
(cond
((and first? (<= n pidx))
;; Avoid intersecting back-edges and cross-edges on
;; the first iteration.
(lp preds initialized?))
(else
(if initialized?
(intersect! bool (vector-ref boolv pidx))
(bitvector-copy! bool (vector-ref boolv pidx)))
(match (lookup-predecessors pred dfg)
((test)
(let ((tidx (label->idx test)))
(match (lookup-cont pred dfg)
(($ $kif kt kf)
(when (eqv? kt label)
(bitvector-set! bool (true-idx tidx) #t))
(when (eqv? kf label)
(bitvector-set! bool (false-idx tidx) #t)))
(_ #t))))
(_ #t))
(lp preds #t)))))))
(lp (1+ n) first?
(or changed?
(not (= prev-count (bit-count #t bool)))))))
(else
(if (or first? changed?)
(lp 0 #f #f)
boolv)))))))
(define (compute-defs dfg min-label label-count)
(define (cont-defs k)
(match (lookup-cont k dfg)
@ -252,7 +321,7 @@ index corresponds to MIN-LABEL, and so on."
(idoms (compute-idoms dfg min-label label-count))
(defs (compute-defs dfg min-label label-count))
(var-substs (make-vector var-count #f))
(label-substs (make-vector label-count #f))
(equiv-labels (make-vector label-count #f))
(equiv-set (make-hash-table)))
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
@ -313,36 +382,38 @@ index corresponds to MIN-LABEL, and so on."
(when exp-key
(hash-set! equiv-set exp-key (cons label equiv))))
((candidate . candidates)
(let ((subst (vector-ref defs (label->idx candidate))))
(cond
((not (bitvector-ref avail (label->idx candidate)))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
(else
;; Yay, a match. Mark expression for
;; replacement with $values.
(vector-set! label-substs (label->idx label) subst)
;; If we dominate the successor, mark vars
;; for substitution.
(when (= label (vector-ref idoms (label->idx k)))
(for-each/2
(lambda (var subst-var)
(vector-set! var-substs (var->idx var) subst-var))
(vector-ref defs (label->idx label))
subst))))))))))))
(cond
((not (bitvector-ref avail (label->idx candidate)))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
(else
;; Yay, a match. Mark expression as equivalent.
(vector-set! equiv-labels (label->idx label)
candidate)
;; If we dominate the successor, mark vars
;; for substitution.
(when (= label (vector-ref idoms (label->idx k)))
(for-each/2
(lambda (var subst-var)
(vector-set! var-substs (var->idx var) subst-var))
(vector-ref defs (label->idx label))
(vector-ref defs (label->idx candidate)))))))))))))
(_ #f))
(lp (1+ label))))
(values (compute-dom-edges idoms min-label)
label-substs min-label var-substs min-var)))
equiv-labels defs min-label var-substs min-var)))
(call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
(define (apply-cse fun dfg doms label-substs min-label var-substs min-var)
(define (apply-cse fun dfg
doms equiv-labels defs min-label var-substs min-var boolv)
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
(define (var->idx var) (- var min-var))
(define (true-idx idx) idx)
(define (false-idx idx) (+ idx (vector-length equiv-labels)))
(define (subst-var var)
;; It could be that the var is free in this function; if so,
@ -385,18 +456,36 @@ index corresponds to MIN-LABEL, and so on."
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
(define (visit-exp* k exp)
(define (visit-exp* k src exp)
(match exp
((and fun ($ $fun)) (cse fun dfg))
((and fun ($ $fun))
(build-cps-term ($continue k src ,(cse fun dfg))))
(_
(match (lookup-cont k dfg)
(($ $kargs names vars)
(cond
((vector-ref label-substs (label->idx label))
=> (lambda (vars)
(build-cps-exp ($values vars))))
(else (visit-exp exp))))
(_ (visit-exp exp))))))
(cond
((vector-ref equiv-labels (label->idx label))
=> (lambda (equiv)
(let* ((eidx (label->idx equiv))
(vars (vector-ref defs eidx)))
(rewrite-cps-term (lookup-cont k dfg)
(($ $kif kt kf)
,(let* ((bool (vector-ref boolv (label->idx label)))
(t (bitvector-ref bool (true-idx eidx)))
(f (bitvector-ref bool (false-idx eidx))))
(if (eqv? t f)
(build-cps-term
($continue k src ,(visit-exp exp)))
(build-cps-term
($continue (if t kt kf) src ($values ()))))))
(($ $kargs)
($continue k src ($values vars)))
;; There is no point in adding a case for $ktail, as
;; only $values, $call, or $callk can continue to
;; $ktail.
(_
($continue k src ,(visit-exp exp)))))))
(else
(build-cps-term
($continue k src ,(visit-exp exp))))))))
(define (visit-dom-conts label)
(let ((cont (lookup-cont label dfg)))
@ -415,22 +504,23 @@ index corresponds to MIN-LABEL, and so on."
($letrec names syms (map (lambda (fun) (cse fun dfg)) funs)
,(visit-term body label)))
(($ $continue k src exp)
,(let* ((exp (visit-exp* k exp))
(conts (append-map visit-dom-conts
(vector-ref doms (label->idx label)))))
,(let ((conts (append-map visit-dom-conts
(vector-ref doms (label->idx label)))))
(if (null? conts)
(build-cps-term ($continue k src ,exp))
(build-cps-term ($letk ,conts ($continue k src ,exp))))))))
(visit-exp* k src exp)
(build-cps-term
($letk ,conts ,(visit-exp* k src exp))))))))
(rewrite-cps-exp fun
(($ $fun src meta free body)
($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
;; TODO: Truth values, and interprocedural CSE.
(define (cse fun dfg)
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
(lambda (doms label-substs min-label var-substs min-var)
(apply-cse fun dfg doms label-substs min-label var-substs min-var))))
(lambda (doms equiv-labels defs min-label var-substs min-var)
(apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var
(compute-truthy-expressions dfg
min-label (vector-length doms))))))
(define (eliminate-common-subexpressions fun)
(call-with-values (lambda () (renumber fun))