compiler.tree.recursive: more accurate loop detection

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
 

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 ;

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 ;

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 ;

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' )

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

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 ;
+<PRIVATE
 
-M: #recursive collect-label-info
-    label>> 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 <reversed> [
+            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
-    <hashed-dlist> 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 ;

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 ;