compiler.tree.recursive: more accurate loop detection

diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor
index e25f152aefeda508316a10d7788b47416e898e64..0b3b46fe336da1463d13c1e0118fa6415a8c6a4e 100755 (executable)
--- 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 1b0343faa991400e09a0c2b5799b1438b31c1851..3232e965db10ac526d3f1400361efa689d86a934 100644 (file)
--- 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 71830d07e7e16b268fde37a767e5dc2ef10a03bc..b0ab864c80f2cb2bf3ac34c7e672c319ee7634a7 100644 (file)
--- 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 5aece23d1784a8933a8245b77ec86325ba50ae9a..ad6572a35c27e4beb248d8625a6afdf1bae13f4f 100644 (file)
--- 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 b8d1760a0b4edaf7aca4e780b8fe858a54e4f931..64b7ba4609309a58537296a4d7da7c7f78b82f0d 100644 (file)
--- 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 7cdb98bc58eb21fb9b07095bad8dbfcd28cc6585..f9ba5f75ea37df953633640171967d87bbace234 100644 (file)
--- 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 2e40693e6982df2fa5961eec6d964a87a940d5eb..f6235719ffe5b9700a31e17b5c984b7dbace1c5a 100644 (file)
--- 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 ;
+<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: node-call-tree ( tail? node -- )
 
-GENERIC: collect-loop-info* ( tail? node -- )
+: (build-call-tree) ( tail? nodes -- )
+    [ tail-calls ] keep
+    [ node-call-tree ] 2each ;
 
-: non-tail-label-info ( nodes -- )
-    [ f swap collect-loop-info* ] each ;
+: build-call-tree ( nodes -- labels calls )
+    [
+        V{ } clone children set
+        V{ } clone calls set
+        [ t ] dip (build-call-tree)
+        children get
+        calls get
+    ] with-scope ;
 
-: (collect-loop-info) ( tail? nodes -- )
-    [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+M: #return-recursive node-call-tree
+    nip dup label>> (>>return) ;
 
-: remember-loop-info ( label -- )
-    loop-stack get length swap loop-heights get set-at ;
+M: #call-recursive node-call-tree
+    [ dup label>> call-site boa ] keep
+    [ drop calls get push ]
+    [ label>> calls>> push ] 2bi ;
 
-M: #recursive collect-loop-info*
+M: #recursive node-call-tree
+    nip
+    [ label>> V{ } clone >>calls drop ]
     [
-        [
-            label>>
-            [ swap 2array loop-stack [ swap suffix ] change ]
-            [ remember-loop-info ]
-            [ t >>loop? drop ]
-            tri
-        ]
-        [ t swap child>> (collect-loop-info) ] bi
-    ] with-scope ;
+        [ label>> ] [ child>> build-call-tree ] bi
+        call-tree-node boa children get push
+    ] bi ;
 
-: current-loop-nesting ( label -- alist )
-    loop-stack get swap loop-heights get at tail ;
+M: #branch node-call-tree
+    children>> [ (build-call-tree) ] with each ;
 
-: disqualify-loop ( label -- )
-    work-list get push-front ;
+M: node node-call-tree 2drop ;
 
-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 ]
-    bi ;
+SYMBOLS: not-loops recursive-nesting ;
 
-M: #if collect-loop-info*
-    children>> [ (collect-loop-info) ] with each ;
+: not-a-loop ( label -- ) not-loops get conjoin ;
 
-M: #dispatch collect-loop-info*
-    children>> [ (collect-loop-info) ] with each ;
+: not-a-loop? ( label -- ? ) not-loops get key? ;
 
-M: node collect-loop-info* 2drop ;
+: non-tail-calls ( call-tree-node -- seq )
+    calls>> [ tail?>> not ] filter ;
 
-: 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) ;
+: 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 ;
+
+: mark-loops ( call-tree -- )
+    [
+        [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
+        [ children>> mark-loops ]
+        bi
+    ] each ;
 
-: 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 c73f2211f04b378a33ee1ad5ebddbeaf42bf8f3e..7fa096b62392f828aef97bee34568b97cf5c93dd 100644 (file)
--- 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 ;