From f9c76689d6c3e4b48360de0b24bdacced749e2b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 15 Feb 2008 18:07:56 -0600
Subject: [PATCH] #loop optimization fixes

---
 core/generator/generator.factor             |  29 ++--
 core/optimizer/control/control-tests.factor |  35 ++++-
 core/optimizer/control/control.factor       | 143 +++++++++++++-------
 3 files changed, 139 insertions(+), 68 deletions(-)
 mode change 100644 => 100755 core/optimizer/control/control-tests.factor

diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index e6a6226afa..3514947e3d 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -26,7 +26,7 @@ SYMBOL: compiling-word
 
 SYMBOL: compiling-label
 
-SYMBOL: compiling-loop?
+SYMBOL: compiling-loops
 
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
@@ -34,7 +34,7 @@ SYMBOL: current-label-start
 : compiled-stack-traces? ( -- ? ) 36 getenv ;
 
 : begin-compiling ( word label -- )
-    compiling-loop? off
+    H{ } clone compiling-loops set
     compiling-label set
     compiling-word set
     compiled-stack-traces?
@@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
 : generate-call ( label -- next )
     dup maybe-compile
     end-basic-block
-    dup compiling-label get eq? compiling-loop? get and [
-        drop current-label-start get %jump-label f
+    dup compiling-loops get at [
+        %jump-label f
     ] [
         tail-call? [
             %jump f
@@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
             %call
             iterate-next
         ] if
-    ] if ;
+    ] ?if ;
 
 ! #label
 M: #label generate-node
@@ -113,17 +113,13 @@ M: #label generate-node
     r> ;
 
 ! #loop
+: compiling-loop ( word -- )
+    <label> dup resolve-label swap compiling-loops get set-at ;
+
 M: #loop generate-node
     end-basic-block
-    [
-        dup node-param compiling-label set
-        current-label-start define-label
-        current-label-start resolve-label
-        compiling-loop? on
-        node-child generate-nodes
-        end-basic-block
-    ] with-scope
-    init-templates
+    dup node-param compiling-loop
+    node-child generate-nodes
     iterate-next ;
 
 ! #if
@@ -269,5 +265,6 @@ M: #r> generate-node
 
 ! #return
 M: #return generate-node
-    node-param compiling-label get eq? compiling-loop? get and
-    [ end-basic-block %return ] unless f ;
+    end-basic-block
+    node-param compiling-loops get key?
+    [ %return ] unless f ;
diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor
old mode 100644
new mode 100755
index ab5c055fbd..b5b52e0e0e
--- a/core/optimizer/control/control-tests.factor
+++ b/core/optimizer/control/control-tests.factor
@@ -113,7 +113,7 @@ optimizer ;
 ] unit-test
 
 [ f ] [
-    [ [ [ ] map ] map ] dataflow optimize
+    [ [ [ ] map ] map ] dataflow dup detect-loops
     [ dup #label? swap #loop? not and ] node-exists?
 ] unit-test
 
@@ -146,3 +146,36 @@ DEFER: a
     [ a ] dataflow dup detect-loops
     \ b label-is-loop?
 ] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+    blah [ b' b' ] [ a' ] if ; inline
+
+: a' ( -- )
+    blah [ b' ] [ a' ] if ; inline
+
+[ f ] [
+    [ a' ] dataflow dup detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ b' ] dataflow dup detect-loops
+    \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound. The loop analysis algorithm looks pretty solid -- its
+! a standard iterative dataflow problem after all -- so I'm
+! tempted to believe the computer here
+[ t ] [
+    [ b' ] dataflow dup detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ a' ] dataflow dup detect-loops
+    \ b' label-is-loop?
+] unit-test
diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor
index c9b3458d2a..b04d4677ce 100755
--- a/core/optimizer/control/control.factor
+++ b/core/optimizer/control/control.factor
@@ -7,7 +7,7 @@ combinators classes generic.math continuations optimizer.def-use
 optimizer.backend generic.standard ;
 IN: optimizer.control
 
-! ! ! Loop detection
+! ! ! Rudimentary CFA
 
 ! A LOOP
 !
@@ -36,7 +36,8 @@ IN: optimizer.control
 !       |
 !    #values
 !
-! NOT A LOOP (call to A nested inside another label/loop):
+! NOT A LOOP (call to A nested inside another label which is
+! not a loop):
 !
 !
 !          #label A
@@ -53,38 +54,70 @@ IN: optimizer.control
 !               |       |
 !         #call-label A |
 !               |       |
-!              ...     ...
+!           #values     |
+!                 #call-label B
+!                       |
+!                      ...
 
-GENERIC: detect-loops* ( node -- )
+! Mapping word => { node { nesting tail? }+ height }
+! We record all calls to a label, their control nesting and
+! whether it is a tail call or not
+SYMBOL: label-info
 
-M: node detect-loops* drop ;
+GENERIC: collect-label-info* ( node -- )
 
-M: #label detect-loops* t swap set-#label-loop? ;
+M: #label collect-label-info*
+    [ V{ } clone node-stack get length 3array ] keep
+    node-param label-info get set-at ;
 
-: not-a-loop ( #label -- )
-    f swap set-#label-loop? ;
+USE: prettyprint
 
-: tail-call? ( -- ? )
-    node-stack get
-    dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
-    [ node-successor #tail? ] all? ;
-USE: io
-: detect-loop ( seen-other? label node -- seen-other? continue? )
-    #! seen-other?: have we seen another label?
-    {
-        { [ dup #label? not ] [ 2drop t ] }
-        { [ 2dup node-param eq? not ] [ 3drop t t ] }
-        { [ tail-call? not ] [ not-a-loop drop f ] }
-        { [ pick ] [ not-a-loop drop f ] }
-        { [ t ] [ 2drop f ] }
-    } cond ;
+M: #call-label collect-label-info*
+    node-param label-info get at
+    node-stack get over third tail
+    [ [ #label? ] subset [ node-param ] map ] keep
+    [ node-successor #tail? ] all? 2array
+    swap second push ;
 
-M: #call-label detect-loops*
-    f swap node-param node-stack get <reversed>
-    [ detect-loop ] with all? 2drop ;
+M: node collect-label-info*
+    drop ;
 
-: detect-loops ( node -- )
-    [ detect-loops* ] each-node ;
+: collect-label-info ( node -- )
+    H{ } clone label-info set
+    [ collect-label-info* ] each-node ;
+
+! Mapping word => label
+SYMBOL: potential-loops
+
+: remove-non-tail-calls ( -- )
+    label-info get
+    [ nip second [ second ] all? ] assoc-subset
+    [ first ] assoc-map
+    potential-loops set ;
+
+: remove-non-loop-calls ( -- )
+    ! Boolean is set to t if something changed.
+    !  We recurse until a fixed point is reached.
+    f label-info get [
+        ! 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? [
+            second [ first ] map concat
+            potential-loops get [ key? ] curry all?
+            [ drop ] [ potential-loops get delete-at t or ] if
+        ] [ 2drop ] if
+    ] assoc-each [ remove-non-loop-calls ] when ;
+
+: detect-loops ( nodes -- )
+    [
+        collect-label-info
+        remove-non-tail-calls
+        remove-non-loop-calls
+        potential-loops get [
+            nip t swap set-#label-loop?
+        ] assoc-each
+    ] with-scope ;
 
 ! ! ! Constant branch folding
 !
@@ -204,7 +237,7 @@ M: #if optimize-node*
 
 !   #label -> C -> #return 1
 !     |
-!     -> #if -> #merge -> #return 2
+!     -> #if -> #merge (*) -> #return 2
 !         |
 !     --------
 !     |      |
@@ -218,19 +251,19 @@ M: #if optimize-node*
 
 ! AFTER:
 
-!    #label -> #terminate
-!     |
-!     -> #if -> #terminate
+!        #label -> #return 1
 !         |
-!     --------
-!     |      |
-!     A      B
-!     |      |
-!  #values   |
-!     |  #call-label
-!  #merge    |
-!     |      |
-!     C   #values
+!         -> #if -------> #merge (*) -> #return 2
+!             |           \-------------------/
+!     ----------------              |
+!     |              |              |
+!     A              B     unreacachable code needed to
+!     |              |         preserve invariants
+!  #values           |
+!     |          #call-label
+!  #merge (*)        |
+!     |              |
+!     C           #values
 !     |
 !  #return 1
 
@@ -282,14 +315,22 @@ M: node add-loop-exit*
         ] [ 2drop f ] if
     ] [ drop f ] if ;
 
-! M: #loop optimize-node*
-!     dup lift-loop-tail? dup [
-!         last-node >r
-!         dup detach-node-successor
-!         over node-child find-final-if detach-node-successor
-!         [ set-node-successor ] keep
-!         r> set-node-successor
-!         t
-!     ] [
-!         2drop t f
-!     ] if ;
+M: #loop optimize-node*
+    dup lift-loop-tail? dup [
+        last-node "values" set
+
+        dup node-successor "tail" set
+        dup node-successor last-node "return" set
+        dup node-child find-final-if node-successor "merge" set
+
+        ! #label -> #return
+        "return" get clone-node over set-node-successor
+        ! #merge -> C
+        "merge" get clone-node "tail" get over set-node-successor
+        ! #values -> #merge ->C
+        "values" get set-node-successor
+
+        t
+    ] [
+        2drop t f
+    ] if ;