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

DFG: Add code to compute live variable sets.

Browse source 
* module/language/cps/dfg.scm (compute-live-variables)
  (compute-maximum-fixed-point, print-dfa): New code to compute live
  variable sets.
This commit is contained in:
Andy Wingo 2013-10-21 11:51:51 +02:00
parent fc95a944d3
commit db11440d38
1 changed files with 174 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

175
module/language/cps/dfg.scm
View file

@ -64,7 +64,13 @@
branch?
find-other-branches
dead-after-branch?
lookup-bound-syms))
lookup-bound-syms
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
dfa-var-idx dfa-var-name dfa-var-sym dfa-var-count
print-dfa))
(define (build-cont-table fun)
(fold-conts (lambda (k src cont table)
@ -408,6 +414,173 @@
(set-block-pdom-level! b pdom-level)
(lp (1+ n)))))))
;; Compute the maximum fixed point of the data-flow constraint problem.
;;
;; This always completes, as the graph is finite and the in and out sets
;; are complete semi-lattices. If the graph is reducible and the blocks
;; are sorted in reverse post-order, this completes in a maximum of LC +
;; 2 iterations, where LC is the loop connectedness number. See Hecht
;; and Ullman, "Analysis of a simple algorithm for global flow
;; problems", POPL 1973, or the recent summary in "Notes on graph
;; algorithms used in optimizing compilers", Offner 2013.
(define (compute-maximum-fixed-point preds inv outv killv genv union?)
(define (bitvector-copy! dst src)
(bitvector-fill! dst #f)
(bit-set*! dst src #t))
(define (bitvector-meet! accum src)
(bit-set*! accum src union?))
(let lp ((n 0) (changed? #f))
(cond
((< n (vector-length preds))
(let ((in (vector-ref inv n))
(out (vector-ref outv n))
(kill (vector-ref killv n))
(gen (vector-ref genv n)))
(let ((out-count (or changed? (bit-count #t out))))
(for-each
(lambda (pred)
(bitvector-meet! in (vector-ref outv pred)))
(vector-ref preds n))
(bitvector-copy! out in)
(for-each (cut bitvector-set! out <> #f) kill)
(for-each (cut bitvector-set! out <> #t) gen)
(lp (1+ n)
(or changed? (not (eqv? out-count (bit-count #t out))))))))
(changed?
(lp 0 #f)))))
;; Data-flow analysis.
(define-record-type $dfa
(make-dfa k->idx order var->idx names syms in out)
dfa?
;; Function mapping k-sym -> k-idx
(k->idx dfa-k->idx)
;; Vector of k-idx -> k-sym
(order dfa-order)
;; Function mapping var-sym -> var-idx
(var->idx dfa-var->idx)
;; Vector of var-idx -> name
(names dfa-names)
;; Vector of var-idx -> var-sym
(syms dfa-syms)
;; Vector of k-idx -> bitvector
(in dfa-in)
;; Vector of k-idx -> bitvector
(out dfa-out))
(define (dfa-k-idx dfa k)
((dfa-k->idx dfa) k))
(define (dfa-k-sym dfa idx)
(vector-ref (dfa-order dfa) idx))
(define (dfa-k-count dfa)
(vector-length (dfa-order dfa)))
(define (dfa-var-idx dfa var)
((dfa-var->idx dfa) var))
(define (dfa-var-name dfa idx)
(vector-ref (dfa-names dfa) idx))
(define (dfa-var-sym dfa idx)
(vector-ref (dfa-syms dfa) idx))
(define (dfa-var-count dfa)
(vector-length (dfa-syms dfa)))
(define (dfa-k-in dfa idx)
(vector-ref (dfa-in dfa) idx))
(define (dfa-k-out dfa idx)
(vector-ref (dfa-out dfa) idx))
(define (compute-live-variables ktail dfg)
(define (make-variable-mapper use-maps)
(let ((mapping (make-hash-table))
(n 0))
(hash-for-each (lambda (sym use-map)
(hashq-set! mapping sym n)
(set! n (1+ n)))
use-maps)
(values (lambda (sym)
(or (hashq-ref mapping sym)
(error "unknown sym" sym)))
n)))
(define (make-block-mapper order)
(let ((mapping (make-hash-table)))
(let lp ((n 0))
(when (< n (vector-length order))
(hashq-set! mapping (vector-ref order n) n)
(lp (1+ n))))
(lambda (k)
(or (hashq-ref mapping k)
(error "unknown k" k)))))
(call-with-values (lambda () (make-variable-mapper (dfg-use-maps dfg)))
(lambda (var->idx nvars)
(let* ((blocks (dfg-blocks dfg))
(order (reverse-post-order ktail blocks block-preds))
(succs (convert-predecessors order blocks block-succs))
(k->idx (make-block-mapper order))
(syms (make-vector nvars #f))
(names (make-vector nvars #f))
(usev (make-vector (vector-length order) '()))
(defv (make-vector (vector-length order) '()))
(live-in (make-vector (vector-length order) #f))
(live-out (make-vector (vector-length order) #f)))
;; Initialize syms, names, defv, and usev.
(hash-for-each
(lambda (sym use-map)
(match use-map
(($ $use-map name sym def uses)
(let ((v (var->idx sym)))
(vector-set! syms v sym)
(vector-set! names v name)
(for-each (lambda (def)
(vector-push! defv (k->idx def) v))
(block-preds (lookup-block def blocks)))
(for-each (lambda (use)
(vector-push! usev (k->idx use) v))
uses)))))
(dfg-use-maps dfg))
;; Initialize live-in and live-out sets.
(let lp ((n 0))
(when (< n (vector-length live-out))
(vector-set! live-in n (make-bitvector nvars #f))
(vector-set! live-out n (make-bitvector nvars #f))
(lp (1+ n))))
;; Liveness is a reverse data-flow problem, so we give
;; compute-maximum-fixed-point a reversed graph, swapping in and
;; out, usev and defv, using successors instead of predecessors,
;; and starting with ktail instead of the entry.
(compute-maximum-fixed-point succs live-out live-in defv usev #t)
(make-dfa k->idx order var->idx names syms live-in live-out)))))
(define (print-dfa dfa)
(match dfa
(($ $dfa k->idx order var->idx names syms in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
(when n
(format #t " ~A" (vector-ref syms n))
(lp (1+ n))))))
(let lp ((n 0))
(when (< n (vector-length order))
(format #t "~A:\n" (vector-ref order n))
(format #t " in:")
(print-var-set (vector-ref in n))
(newline)
(format #t " out:")
(print-var-set (vector-ref out n))
(newline)
(lp (1+ n)))))))
(define (visit-fun fun conts blocks use-maps global?)
(define (add-def! name sym def-k)
(unless def-k