From c3d60e58993938c5f158dce3847ba376c949a1f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Aug 2009 19:18:40 -0500 Subject: [PATCH] compiler.tree.recursive: more accurate loop detection --- basis/compiler/tree/checker/checker.factor | 1 + basis/compiler/tree/cleanup/cleanup.factor | 2 +- .../tree/dead-code/recursive/recursive.factor | 1 + .../recursive/recursive.factor | 3 +- .../propagation/recursive/recursive.factor | 2 +- .../tree/recursive/recursive-tests.factor | 6 +- .../compiler/tree/recursive/recursive.factor | 178 ++++++++++-------- basis/compiler/tree/tree.factor | 3 - 8 files changed, 110 insertions(+), 86 deletions(-) diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index e25f152aef..0b3b46fe33 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -5,6 +5,7 @@ arrays combinators continuations columns math vectors grouping stack-checker.branches compiler.tree compiler.tree.def-use +compiler.tree.recursive compiler.tree.combinators ; IN: compiler.tree.checker diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 1b0343faa9..3232e965db 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -20,7 +20,7 @@ IN: compiler.tree.cleanup GENERIC: delete-node ( node -- ) M: #call-recursive delete-node - dup label>> [ [ eq? not ] with filter ] change-calls drop ; + dup label>> calls>> [ node>> eq? not ] with filter-here ; M: #return-recursive delete-node label>> f >>return drop ; diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 71830d07e7..b0ab864c80 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -3,6 +3,7 @@ USING: accessors arrays assocs sequences kernel locals fry combinators stack-checker.backend compiler.tree +compiler.tree.recursive compiler.tree.dead-code.branches compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ; diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor index 5aece23d17..ad6572a35c 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor @@ -3,6 +3,7 @@ USING: kernel sequences math combinators accessors namespaces fry disjoint-sets compiler.tree +compiler.tree.recursive compiler.tree.combinators compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.branches @@ -67,5 +68,5 @@ M: #return-recursive escape-analysis* ( #return-recursive -- ) [ call-next-method ] [ [ in-d>> ] [ label>> calls>> ] bi - [ out-d>> escaping-values get '[ _ equate ] 2each ] with each + [ node>> out-d>> escaping-values get '[ _ equate ] 2each ] with each ] bi ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index b8d1760a0b..64b7ba4609 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -21,7 +21,7 @@ IN: compiler.tree.propagation.recursive in-d>> [ value-info ] map ; : recursive-stacks ( #enter-recursive -- stacks initial ) - [ label>> calls>> [ node-input-infos ] map flip ] + [ label>> calls>> [ node>> node-input-infos ] map flip ] [ latest-input-infos ] bi ; : generalize-counter-interval ( interval initial-interval -- interval' ) diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 7cdb98bc58..f9ba5f75ea 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -146,7 +146,7 @@ DEFER: a'' [ t ] [ [ a'' ] build-tree analyze-recursive - \ a'' label-is-not-loop? + \ a'' label-is-loop? ] unit-test [ t ] [ @@ -156,10 +156,10 @@ DEFER: a'' [ t ] [ [ b'' ] build-tree analyze-recursive - \ a'' label-is-not-loop? + \ a'' label-is-loop? ] unit-test -[ f ] [ +[ t ] [ [ b'' ] build-tree analyze-recursive \ b'' label-is-not-loop? ] unit-test diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index 2e40693e69..f6235719ff 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -1,104 +1,128 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs arrays namespaces accessors sequences deques -search-deques dlists compiler.tree compiler.tree.combinators ; +USING: kernel assocs arrays namespaces accessors sequences deques fry +search-deques dlists combinators.short-circuit make sets compiler.tree ; IN: compiler.tree.recursive -! Collect label info -GENERIC: collect-label-info ( node -- ) +TUPLE: call-site tail? node label ; -M: #return-recursive collect-label-info - dup label>> (>>return) ; +: recursive-phi-in ( #enter-recursive -- seq ) + [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ; -M: #call-recursive collect-label-info - dup label>> calls>> push ; +> V{ } clone >>calls drop ; +TUPLE: call-tree-node label children calls ; -M: node collect-label-info drop ; - -! A loop is a #recursive which only tail calls itself, and those -! calls are nested inside other loops only. We optimistically -! assume all #recursive nodes are loops, disqualifying them as -! we see evidence to the contrary. : (tail-calls) ( tail? seq -- seq' ) reverse [ swap [ and ] keep ] map nip reverse ; : tail-calls ( tail? node -- seq ) [ - [ #phi? ] - [ #return? ] - [ #return-recursive? ] - tri or or + { + [ #phi? ] + [ #return? ] + [ #return-recursive? ] + } 1|| ] map (tail-calls) ; -SYMBOL: loop-heights -SYMBOL: loop-calls -SYMBOL: loop-stack -SYMBOL: work-list +SYMBOLS: children calls ; -GENERIC: collect-loop-info* ( tail? node -- ) +GENERIC: node-call-tree ( tail? node -- ) -: non-tail-label-info ( nodes -- ) - [ f swap collect-loop-info* ] each ; +: (build-call-tree) ( tail? nodes -- ) + [ tail-calls ] keep + [ node-call-tree ] 2each ; -: (collect-loop-info) ( tail? nodes -- ) - [ tail-calls ] keep [ collect-loop-info* ] 2each ; - -: remember-loop-info ( label -- ) - loop-stack get length swap loop-heights get set-at ; - -M: #recursive collect-loop-info* +: build-call-tree ( nodes -- labels calls ) [ - [ - label>> - [ swap 2array loop-stack [ swap suffix ] change ] - [ remember-loop-info ] - [ t >>loop? drop ] - tri - ] - [ t swap child>> (collect-loop-info) ] bi + V{ } clone children set + V{ } clone calls set + [ t ] dip (build-call-tree) + children get + calls get ] with-scope ; -: current-loop-nesting ( label -- alist ) - loop-stack get swap loop-heights get at tail ; +M: #return-recursive node-call-tree + nip dup label>> (>>return) ; -: disqualify-loop ( label -- ) - work-list get push-front ; +M: #call-recursive node-call-tree + [ dup label>> call-site boa ] keep + [ drop calls get push ] + [ label>> calls>> push ] 2bi ; -M: #call-recursive collect-loop-info* - label>> - swap [ dup disqualify-loop ] unless - dup current-loop-nesting - [ keys [ loop-calls get push-at ] with each ] - [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ] +M: #recursive node-call-tree + nip + [ label>> V{ } clone >>calls drop ] + [ + [ label>> ] [ child>> build-call-tree ] bi + call-tree-node boa children get push + ] bi ; + +M: #branch node-call-tree + children>> [ (build-call-tree) ] with each ; + +M: node node-call-tree 2drop ; + +SYMBOLS: not-loops recursive-nesting ; + +: not-a-loop ( label -- ) not-loops get conjoin ; + +: not-a-loop? ( label -- ? ) not-loops get key? ; + +: non-tail-calls ( call-tree-node -- seq ) + calls>> [ tail?>> not ] filter ; + +: visit-back-edges ( call-tree -- ) + [ + [ non-tail-calls [ label>> not-a-loop ] each ] + [ children>> visit-back-edges ] + bi + ] each ; + +SYMBOL: changed? + +: check-cross-frame-call ( call-site -- ) + label>> dup not-a-loop? [ drop ] [ + recursive-nesting get [ + 2dup eq? [ 2drop f ] [ + not-a-loop? [ not-a-loop changed? on ] [ drop ] if t + ] if + ] with all? drop + ] if ; + +: detect-cross-frame-calls ( call-tree -- ) + ! Suppose we have a nesting of recursives A --> B --> C + ! B tail-calls A, and C non-tail-calls B. Then A cannot be + ! a loop, it needs its own procedure, since the call from + ! C to A crosses a call-frame boundary. + [ + [ label>> recursive-nesting get push ] + [ calls>> [ check-cross-frame-call ] each ] + [ children>> detect-cross-frame-calls ] tri + recursive-nesting get pop* + ] each ; + +: while-changing ( quot: ( -- ) -- ) + changed? off + [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ; + inline recursive + +: detect-loops ( call-tree -- ) + H{ } clone not-loops set + V{ } clone recursive-nesting set + [ visit-back-edges ] + [ '[ _ detect-cross-frame-calls ] while-changing ] bi ; -M: #if collect-loop-info* - children>> [ (collect-loop-info) ] with each ; +: mark-loops ( call-tree -- ) + [ + [ label>> dup not-a-loop? [ t >>loop? ] unless drop ] + [ children>> mark-loops ] + bi + ] each ; -M: #dispatch collect-loop-info* - children>> [ (collect-loop-info) ] with each ; - -M: node collect-loop-info* 2drop ; - -: collect-loop-info ( node -- ) - { } loop-stack set - H{ } clone loop-calls set - H{ } clone loop-heights set - work-list set - t swap (collect-loop-info) ; - -: disqualify-loops ( -- ) - work-list get [ - dup loop?>> [ - [ f >>loop? drop ] - [ loop-calls get at [ disqualify-loop ] each ] - bi - ] [ drop ] if - ] slurp-deque ; +PRIVATE> : analyze-recursive ( nodes -- nodes ) - dup [ collect-label-info ] each-node - dup collect-loop-info disqualify-loops ; + dup build-call-tree drop + [ detect-loops ] [ mark-loops ] bi ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index c73f2211f0..7fa096b623 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -165,9 +165,6 @@ M: #shuffle inputs/outputs mapping>> unzip swap ; M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ; M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; -: recursive-phi-in ( #enter-recursive -- seq ) - [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; - : ends-with-terminate? ( nodes -- ? ) [ f ] [ last #terminate? ] if-empty ;