From 366eb4d764cc575eb48015b4e68fefc88b22706b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 12 Oct 2013 12:48:08 +0200 Subject: [PATCH] DFG refactorings * module/language/cps/dfg.scm ($block): Add "irreducible" field, format TBD. (reverse-post-order): Return a vector directly. (convert-predecessors, compute-dom-levels, compute-idoms): (analyze-control-flow!): Factor out control flow analsysis a bit better. (identify-loops): New helper. Currently a NOP. (visit-fun): Adapt to compute-dominator-tree rename to analyze-control-flow!. --- module/language/cps/dfg.scm | 109 ++++++++++++++++++++++-------------- 1 file changed, 67 insertions(+), 42 deletions(-) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index fe5c245b7..da569b056 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -105,7 +105,7 @@ (uses use-map-uses set-use-map-uses!)) (define-record-type $block - (%make-block scope scope-level preds succs idom dom-level loop-header) + (%make-block scope scope-level preds succs idom dom-level loop-header irreducible) block? (scope block-scope set-block-scope!) (scope-level block-scope-level set-block-scope-level!) @@ -113,10 +113,17 @@ (succs block-succs set-block-succs!) (idom block-idom set-block-idom!) (dom-level block-dom-level set-block-dom-level!) - (loop-header block-loop-header set-block-loop-header!)) + + ;; The loop header of this block, if this block is part of a reducible + ;; loop. Otherwise #f. + (loop-header block-loop-header set-block-loop-header!) + + ;; Some sort of marker that this block is part of an irreducible + ;; (multi-entry) loop. Otherwise #f. + (irreducible block-irreducible set-block-irreducible!)) (define (make-block scope scope-level) - (%make-block scope scope-level '() '() #f #f #f)) + (%make-block scope scope-level '() '() #f #f #f #f)) (define (reverse-post-order k0 blocks) (let ((order '()) @@ -130,33 +137,29 @@ (visit k))) succs) (set! order (cons k order))))) - order)) - -(define-inlinable (for-each/enumerate f l) - (fold (lambda (x n) (f x n) (1+ n)) 0 l)) + (list->vector order))) (define (convert-predecessors order blocks) - (let* ((len (length order)) - (mapping (make-hash-table)) - (preds-vec (make-vector len #f))) - (for-each/enumerate - (cut hashq-set! mapping <> <>) - order) - (for-each/enumerate - (lambda (k n) - (match (lookup-block k blocks) - (($ $block _ _ preds) - (vector-set! preds-vec n - ;; It's possible for a predecessor to not be in - ;; the mapping, if the predecessor is not - ;; reachable from the entry node. - (filter-map (cut hashq-ref mapping <>) preds))))) - order) + (let* ((mapping (make-hash-table)) + (preds-vec (make-vector (vector-length order) #f))) + (let lp ((n 0)) + (when (< n (vector-length order)) + (hashq-set! mapping (vector-ref order n) n) + (lp (1+ n)))) + (let lp ((n 0)) + (when (< n (vector-length order)) + (match (lookup-block (vector-ref order n) blocks) + (($ $block _ _ preds) + (vector-set! preds-vec n + ;; It's possible for a predecessor to not be in + ;; the mapping, if the predecessor is not + ;; reachable from the entry node. + (filter-map (cut hashq-ref mapping <>) preds)) + (lp (1+ n)))))) preds-vec)) -(define (finish-idoms order idoms blocks) - (let ((order (list->vector order)) - (dom-levels (make-vector (vector-length idoms) #f))) +(define (compute-dom-levels idoms) + (let ((dom-levels (make-vector (vector-length idoms) #f))) (define (compute-dom-level n) (or (vector-ref dom-levels n) (let ((dom-level (1+ (compute-dom-level (vector-ref idoms n))))) @@ -164,18 +167,13 @@ dom-level))) (vector-set! dom-levels 0 0) (let lp ((n 0)) - (when (< n (vector-length order)) - (let* ((k (vector-ref order n)) - (idom (vector-ref idoms n)) - (b (lookup-block k blocks))) - (set-block-idom! b (vector-ref order idom)) - (set-block-dom-level! b (compute-dom-level n)) - (lp (1+ n))))))) + (when (< n (vector-length idoms)) + (compute-dom-level n) + (lp (1+ n)))) + dom-levels)) -(define (compute-dominator-tree k blocks) - (let* ((order (reverse-post-order k blocks)) - (preds (convert-predecessors order blocks)) - (idoms (make-vector (vector-length preds) 0))) +(define (compute-idoms preds) + (let ((idoms (make-vector (vector-length preds) 0))) (define (common-idom d0 d1) ;; We exploit the fact that a reverse post-order is a topological ;; sort, and so the idom of a node is always numerically less than @@ -210,8 +208,35 @@ (iterate (1+ n) #t))))) (changed? (iterate 0 #f)) - (else - (finish-idoms order idoms blocks)))))) + (else idoms))))) + +;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS +;; Technical Memo 98, 1995. +(define (identify-loops preds idoms dom-levels) + (define (dominates? n1 n2) + (or (= n1 n2) + (and (< n1 n2) + (dominates? n1 (vector-ref idoms n2))))) + (make-vector (vector-length preds) '())) + +(define (analyze-control-flow! k blocks) + (let* ((order (reverse-post-order k blocks)) + (preds (convert-predecessors order blocks)) + (idoms (compute-idoms preds)) + (dom-levels (compute-dom-levels idoms)) + (loop-headers (identify-loops preds idoms dom-levels))) + (let lp ((n 0)) + (when (< n (vector-length order)) + (let* ((k (vector-ref order n)) + (idom (vector-ref idoms n)) + (dom-level (vector-ref idoms n)) + (loop-header (vector-ref loop-headers n)) + (b (lookup-block k blocks))) + (set-block-idom! b (vector-ref order idom)) + (set-block-dom-level! b dom-level) + (set-block-loop-header! b (and loop-header + (vector-ref order loop-header))) + (lp (1+ n))))))) (define (visit-fun fun conts blocks use-maps global?) (define (add-def! sym def-k) @@ -324,7 +349,7 @@ (visit body kbody))) clauses) - (compute-dominator-tree kentry blocks)))) + (analyze-control-flow! kentry blocks)))) (define* (compute-dfg fun #:key (global? #t)) (let* ((conts (make-hash-table)) @@ -510,8 +535,8 @@ (($ $use-map sym def uses) ;; If all other uses dominate this use, it is now dead. There ;; are other ways for it to be dead, but this is an - ;; approximation. A better check would be if the successor - ;; post-dominates all uses. + ;; approximation. A better check would be if all successors + ;; post-dominate all uses. (and-map (cut dominates? <> use-k blocks) uses))))))