mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

Predecessors and successors in DFG vectors

Browse source 
* module/language/cps/dfg.scm ($dfg, $block): Record predecessors and
  successors in vectors instead of in $block data structures.  Adapt
  users.
This commit is contained in:
Andy Wingo 2014-03-30 20:55:57 +02:00
parent f49e994b52
commit 21d6d183a9
1 changed files with 31 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -101,12 +101,14 @@
;; Data-flow graph for CPS: both for values and continuations. ;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg (define-record-type $dfg
(make-dfg conts blocks defs uses min-label nlabels min-var nvars) (make-dfg conts blocks preds succs defs uses min-label nlabels min-var nvars)
dfg? dfg?
;; vector of label -> $kif, $kargs, etc ;; vector of label -> $kif, $kargs, etc
(conts dfg-cont-table) (conts dfg-cont-table)
;; vector of label -> $block ;; vector of label -> $block
(blocks dfg-blocks) (blocks dfg-blocks)
(preds dfg-preds)
(succs dfg-succs)
;; vector of var -> def label ;; vector of var -> def label
(defs dfg-defs) (defs dfg-defs)
;; vector of var -> (use label ...) ;; vector of var -> (use label ...)
@ -118,15 +120,10 @@
(nvars dfg-nvars)) (nvars dfg-nvars))
(define-record-type $block (define-record-type $block
(%make-block scope scope-level preds succs) (make-block scope scope-level)
block? block?
(scope block-scope set-block-scope!) (scope block-scope)
(scope-level block-scope-level set-block-scope-level!) (scope-level block-scope-level))
(preds block-preds set-block-preds!)
(succs block-succs set-block-succs!))
(define (make-block scope scope-level)
(%make-block scope scope-level '() '()))
;; Some analyses assume that the only relevant set of nodes is the set ;; Some analyses assume that the only relevant set of nodes is the set
;; that is reachable from some start node. Others need to include nodes ;; that is reachable from some start node. Others need to include nodes
@ -224,7 +221,7 @@ for quickest convergence."
(when (< n k-count) (when (< n k-count)
(for-each (lambda (succ) (for-each (lambda (succ)
(vector-push! succs n (cfa-k-idx cfa succ))) (vector-push! succs n (cfa-k-idx cfa succ)))
(block-succs (lookup-block (cfa-k-sym cfa n) dfg))) (lookup-successors (cfa-k-sym cfa n) dfg))
(lp (1+ n)))) (lp (1+ n))))
;; Iterate cfa backwards, to converge quickly. ;; Iterate cfa backwards, to converge quickly.
@ -324,7 +321,7 @@ BODY for each body continuation in the prompt."
(let ((succ (cfa-k-idx cfa succ))) (let ((succ (cfa-k-idx cfa succ)))
(or (not (bitvector-ref body succ)) (or (not (bitvector-ref body succ))
(<= succ n)))) (<= succ n))))
(block-succs (lookup-block (cfa-k-sym cfa n) dfg)))) (lookup-successors (cfa-k-sym cfa n) dfg)))
(let lp ((n 0)) (let lp ((n 0))
(let ((n (bit-position #t body n))) (let ((n (bit-position #t body n)))
(when n (when n
@ -334,19 +331,15 @@ BODY for each body continuation in the prompt."
(find-prompt-bodies cfa dfg))) (find-prompt-bodies cfa dfg)))
(define* (analyze-control-flow fun dfg #:key reverse? add-handler-preds?) (define* (analyze-control-flow fun dfg #:key reverse? add-handler-preds?)
(define (build-cfa kentry block-succs block-preds forward-cfa) (define (build-cfa kentry lookup-succs lookup-preds forward-cfa)
(define (block-accessor accessor) (define (reachable-preds mapping)
(lambda (k)
(accessor (lookup-block k dfg))))
(define (reachable-preds mapping accessor)
;; It's possible for a predecessor to not be in the mapping, if ;; It's possible for a predecessor to not be in the mapping, if
;; the predecessor is not reachable from the entry node. ;; the predecessor is not reachable from the entry node.
(lambda (k) (lambda (k)
(filter-map (cut hashq-ref mapping <>) (filter-map (cut hashq-ref mapping <>) (lookup-preds k dfg))))
((block-accessor accessor) k))))
(let* ((order (reverse-post-order (let* ((order (reverse-post-order
kentry kentry
(block-accessor block-succs) (lambda (k) (lookup-succs k dfg))
(if forward-cfa (if forward-cfa
(lambda (f seed) (lambda (f seed)
(let lp ((n (cfa-k-count forward-cfa)) (seed seed)) (let lp ((n (cfa-k-count forward-cfa)) (seed seed))
@ -356,8 +349,7 @@ BODY for each body continuation in the prompt."
(f (cfa-k-sym forward-cfa (1- n)) seed))))) (f (cfa-k-sym forward-cfa (1- n)) seed)))))
(lambda (f seed) seed)))) (lambda (f seed) seed))))
(k-map (make-block-mapping order)) (k-map (make-block-mapping order))
(preds (convert-predecessors order (preds (convert-predecessors order (reachable-preds k-map)))
(reachable-preds k-map block-preds)))
(cfa (make-cfa k-map order preds))) (cfa (make-cfa k-map order preds)))
(when add-handler-preds? (when add-handler-preds?
;; Any expression in the prompt body could cause an abort to the ;; Any expression in the prompt body could cause an abort to the
@ -385,10 +377,10 @@ BODY for each body continuation in the prompt."
(and entry (and entry
($ $kentry self ($ $cont ktail tail) clauses)))) ($ $kentry self ($ $cont ktail tail) clauses))))
(if reverse? (if reverse?
(build-cfa ktail block-preds block-succs (build-cfa ktail lookup-predecessors lookup-successors
(analyze-control-flow fun dfg #:reverse? #f (analyze-control-flow fun dfg #:reverse? #f
#:add-handler-preds? #f)) #:add-handler-preds? #f))
(build-cfa kentry block-succs block-preds #f))))) (build-cfa kentry lookup-successors lookup-predecessors #f)))))
;; Dominator analysis. ;; Dominator analysis.
(define-record-type $dominator-analysis (define-record-type $dominator-analysis
@ -724,7 +716,7 @@ BODY for each body continuation in the prompt."
(vector-set! syms v (+ n min-var)) (vector-set! syms v (+ n min-var))
(for-each (lambda (def) (for-each (lambda (def)
(vector-push! defv (cfa-k-idx cfa def) v)) (vector-push! defv (cfa-k-idx cfa def) v))
(block-preds (lookup-block def dfg))) (lookup-predecessors def dfg))
(for-each (lambda (use) (for-each (lambda (use)
(vector-push! usev (cfa-k-idx cfa use) v)) (vector-push! usev (cfa-k-idx cfa use) v))
(vector-ref uses n))))) (vector-ref uses n)))))
@ -767,7 +759,7 @@ BODY for each body continuation in the prompt."
(newline) (newline)
(lp (1+ n))))))) (lp (1+ n)))))))
(define (visit-fun fun conts blocks defs uses min-label min-var global?) (define (visit-fun fun conts blocks preds succs defs uses min-label min-var global?)
(define (add-def! var def-k) (define (add-def! var def-k)
(vector-set! defs (- var min-var) def-k)) (vector-set! defs (- var min-var) def-k))
@ -784,12 +776,8 @@ BODY for each body continuation in the prompt."
(vector-set! blocks (- label min-label) (make-block parent level))) (vector-set! blocks (- label min-label) (make-block parent level)))
(define (link-blocks! pred succ) (define (link-blocks! pred succ)
(let ((pred-block (vector-ref blocks (- pred min-label))) (vector-push! succs (- pred min-label) succ)
(succ-block (vector-ref blocks (- succ min-label)))) (vector-push! preds (- succ min-label) pred))
(unless (and pred-block succ-block)
(error "internal error" pred-block succ-block))
(set-block-succs! pred-block (cons succ (block-succs pred-block)))
(set-block-preds! succ-block (cons pred (block-preds succ-block)))))
(define (visit exp exp-k) (define (visit exp exp-k)
(define (def! sym) (define (def! sym)
@ -825,7 +813,7 @@ BODY for each body continuation in the prompt."
(error "$letrec should not be present when building a local DFG")) (error "$letrec should not be present when building a local DFG"))
(for-each def! syms) (for-each def! syms)
(for-each (for-each
(cut visit-fun <> conts blocks defs uses min-label min-var global?) (cut visit-fun <> conts blocks preds succs defs uses min-label min-var global?)
funs) funs)
(visit body exp-k)) (visit body exp-k))
@ -852,7 +840,7 @@ BODY for each body continuation in the prompt."
(($ $fun) (($ $fun)
(when global? (when global?
(visit-fun exp conts blocks defs uses min-label min-var global?))) (visit-fun exp conts blocks preds succs defs uses min-label min-var global?)))
(_ #f))))) (_ #f)))))
@ -915,10 +903,12 @@ BODY for each body continuation in the prompt."
(nvars (- (1+ max-var) min-var)) (nvars (- (1+ max-var) min-var))
(conts (make-vector nlabels #f)) (conts (make-vector nlabels #f))
(blocks (make-vector nlabels #f)) (blocks (make-vector nlabels #f))
(preds (make-vector nlabels '()))
(succs (make-vector nlabels '()))
(defs (make-vector nvars #f)) (defs (make-vector nvars #f))
(uses (make-vector nvars '()))) (uses (make-vector nvars '())))
(visit-fun fun conts blocks defs uses min-label min-var global?) (visit-fun fun conts blocks preds succs defs uses min-label min-var global?)
(make-dfg conts blocks defs uses (make-dfg conts blocks preds succs defs uses
min-label label-count min-var var-count))))) min-label label-count min-var var-count)))))
(define (lookup-cont label dfg) (define (lookup-cont label dfg)
@ -933,26 +923,23 @@ BODY for each body continuation in the prompt."
(error "Unknown continuation!" k)) (error "Unknown continuation!" k))
res)) res))
(define (lookup-scope-level k dfg)
(match (lookup-block k dfg)
(($ $block _ scope-level) scope-level)))
(define (lookup-def var dfg) (define (lookup-def var dfg)
(vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg)))) (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
(define (lookup-uses var dfg) (define (lookup-uses var dfg)
(vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))) (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
(define (lookup-scope-level k dfg)
(block-scope-level (lookup-block k dfg)))
(define (lookup-block-scope k dfg) (define (lookup-block-scope k dfg)
(block-scope (lookup-block k dfg))) (block-scope (lookup-block k dfg)))
(define (lookup-predecessors k dfg) (define (lookup-predecessors k dfg)
(match (lookup-block k dfg) (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
(($ $block _ _ preds succs) preds)))
(define (lookup-successors k dfg) (define (lookup-successors k dfg)
(match (lookup-block k dfg) (vector-ref (dfg-succs dfg) (- k (dfg-min-label dfg))))
(($ $block _ _ preds succs) succs)))
(define (find-defining-term sym dfg) (define (find-defining-term sym dfg)
(match (lookup-predecessors (lookup-def sym dfg) dfg) (match (lookup-predecessors (lookup-def sym dfg) dfg)
@ -1045,9 +1032,7 @@ BODY for each body continuation in the prompt."
(lp scope)))))))) (lp scope))))))))
(define (continuation-bound-in? k use-k dfg) (define (continuation-bound-in? k use-k dfg)
(match (lookup-block k dfg) (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
(($ $block def-k)
(continuation-scope-contains? def-k use-k dfg))))
(define (variable-free-in? var k dfg) (define (variable-free-in? var k dfg)
(or-map (lambda (use) (or-map (lambda (use)