Cleaner loop detection pass

unfinished/compiler/tree/loop/detection/detection.factor

@@ -1,22 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences namespaces assocs accessors fry
-compiler.tree ;
+compiler.tree dequeues search-dequeues ;
 IN: compiler.tree.loop.detection
 
 ! A loop is a #recursive which only tail calls itself, and those
-! calls are nested inside other loops only.
-
-TUPLE: recursive-call tail? nesting ;
-
-! calls is a sequence of recursive-call instances
-TUPLE: loop-info calls height ;
-
-! Mapping inline-recursive instances to loop-info instances
-SYMBOL: loop-infos
-
-! A sequence of inline-recursive instances
-SYMBOL: label-stack
+! 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 ;
@@ -29,6 +20,11 @@ SYMBOL: label-stack
         tri or or
     ] map (tail-calls) ;
 
+SYMBOL: loop-heights
+SYMBOL: loop-calls
+SYMBOL: label-stack
+SYMBOL: work-list
+
 GENERIC: collect-loop-info* ( tail? node -- )
 
 : non-tail-label-info ( nodes -- )
@@ -37,24 +33,32 @@ GENERIC: collect-loop-info* ( tail? node -- )
 : (collect-loop-info) ( tail? nodes -- )
     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
 
-: remember-loop-info ( #recursive -- )
-    V{ } clone label-stack get length loop-info boa
-    swap label>> loop-infos get set-at ;
+: remember-loop-info ( label -- )
+    label-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
     nip
     [
-        [ label-stack [ swap label>> suffix ] change ]
-        [ remember-loop-info ]
-        [ t swap child>> (collect-loop-info) ]
-        tri
+        [
+            label>>
+            [ label-stack [ swap suffix ] change ]
+            [ remember-loop-info ]
+            [ t >>loop? drop ]
+            tri
+        ]
+        [ t swap child>> (collect-loop-info) ] bi
     ] with-scope ;
 
+: current-loop-nesting ( label -- labels )
+    label-stack get swap loop-heights get at tail ;
+
+: disqualify-loop ( label -- )
+    work-list get push-front ;
+
 M: #call-recursive collect-loop-info*
-    label>> loop-infos get at
-    [ label-stack get swap height>> tail recursive-call boa ]
-    [ calls>> ]
-    bi push ;
+    label>>
+    swap [ dup disqualify-loop ] unless
+    dup current-loop-nesting [ loop-calls get push-at ] with each ;
 
 M: #if collect-loop-info*
     children>> [ (collect-loop-info) ] with each ;
@@ -66,38 +70,19 @@ M: node collect-loop-info* 2drop ;
 
 : collect-loop-info ( node -- )
     { } label-stack set
-    H{ } clone loop-infos set
+    H{ } clone loop-calls set
+    H{ } clone loop-heights set
+    <hashed-dlist> work-list set
     t swap (collect-loop-info) ;
 
-! Sub-assoc of loop-infos
-SYMBOL: potential-loops
-
-: remove-non-tail-calls ( -- )
-    loop-infos get
-    [ nip calls>> [ tail?>> ] all? ] assoc-filter
-    potential-loops set ;
-
-: (remove-non-loop-calls) ( loop-infos -- )
-    f over [
-        ! If label X is called from within a label Y that is
-        ! no longer a potential loop, then X is no longer a
-        ! potential loop either.
-        over potential-loops get key? [
-            potential-loops get '[ , key? ] all?
-            [ drop ] [ potential-loops get delete-at t or ] if
-        ] [ 2drop ] if
-    ] assoc-each
-    [ (remove-non-loop-calls) ] [ drop ] if ;
-
-: remove-non-loop-calls ( -- )
-    ! Boolean is set to t if something changed.
-    !  We recurse until a fixed point is reached.
-    loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
-    (remove-non-loop-calls) ;
+: disqualify-loops ( -- )
+    work-list get [
+        dup loop?>> [
+            [ f >>loop? drop ]
+            [ loop-calls get at [ disqualify-loop ] each ]
+            bi
+        ] [ drop ] if
+    ] slurp-dequeue ;
 
 : detect-loops ( nodes -- nodes )
-    dup
-    collect-loop-info
-    remove-non-tail-calls
-    remove-non-loop-calls
-    potential-loops get [ drop t >>loop? drop ] assoc-each ;
+    dup collect-loop-info disqualify-loops ;