Loop conversion work in progress

core/generator/generator.factor

@@ -107,6 +107,20 @@ M: #label generate-node
     dup #label-word over node-param rot node-child generate
     r> ;
 
+! #loop
+SYMBOL: compiling-loop?
+
+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
+    ] with-scope
+    end-basic-block ;
+
 ! #if
 : end-false-branch ( label -- )
     tail-call? [ %return drop ] [ %jump-label ] if ;
@@ -256,4 +270,6 @@ M: #r> generate-node
     iterate-next ;
 
 ! #return
-M: #return generate-node drop end-basic-block %return f ;
+M: #return generate-node
+    node-param compiling-label get eq? compiling-loop? get and
+    [ end-basic-block %return ] unless f ;

core/inference/dataflow/dataflow.factor

@@ -97,11 +97,13 @@ M: object flatten-curry , ;
 
 : node-child node-children first ;
 
-TUPLE: #label word ;
+TUPLE: #label word loop? ;
 
 : #label ( word label -- node )
     \ #label param-node [ set-#label-word ] keep ;
 
+PREDICATE: #label #loop #label-loop? ;
+
 TUPLE: #entry ;
 
 : #entry ( -- node ) \ #entry all-out-node ;

core/optimizer/backend/backend.factor

@@ -367,6 +367,10 @@ DEFER: (flat-length)
     dup node-param dup +inlined+ depends-on
     word-def splice-quot ;
 
+: method-body-inline? ( #call -- ? )
+    node-param dup method-body?
+    [ flat-length 8 <= ] [ drop f ] if ;
+
 M: #call optimize-node*
     {
         { [ dup flush-eval? ] [ flush-eval ] }
@@ -375,5 +379,6 @@ M: #call optimize-node*
         { [ dup optimizer-hook ] [ optimize-hook ] }
         { [ dup optimize-predicate? ] [ optimize-predicate ] }
         { [ dup optimistic-inline? ] [ optimistic-inline ] }
+        { [ dup method-body-inline? ] [ optimistic-inline ] }
         { [ t ] [ inline-method ] }
     } cond dup not ;

core/optimizer/control/control-tests.factor

@@ -0,0 +1,62 @@
+IN: temporary
+USING: tools.test optimizer.control combinators kernel
+sequences inference.dataflow math inference ;
+
+: label-is-loop? ( node word -- ? )
+    [
+        {
+            { [ over #label? not ] [ 2drop f ] }
+            { [ over #label-word over eq? not ] [ 2drop f ] }
+            { [ over #label-loop? not ] [ 2drop f ] }
+            { [ t ] [ 2drop t ] }
+        } cond
+    ] curry node-exists? ;
+
+: label-is-not-loop? ( node word -- ? )
+    [
+        {
+            { [ over #label? not ] [ 2drop f ] }
+            { [ over #label-word over eq? not ] [ 2drop f ] }
+            { [ over #label-loop? ] [ 2drop f ] }
+            { [ t ] [ 2drop t ] }
+        } cond
+    ] curry node-exists? ;
+
+: loop-test-1 ( a -- )
+    dup [ 1+ loop-test-1 ] [ drop ] if ; inline
+
+[ t ] [
+    [ loop-test-1 ] dataflow dup detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ loop-test-1 1 2 3 ] dataflow dup detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] dataflow dup detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] dataflow dup detect-loops
+    \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+    dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
+
+[ t ] [
+    [ loop-test-2 ] dataflow dup detect-loops
+    \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+    dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
+
+[ t ] [
+    [ loop-test-3 ] dataflow dup detect-loops
+    \ loop-test-3 label-is-not-loop?
+] unit-test

core/optimizer/control/control.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel inference.dataflow combinators sequences
+namespaces math ;
+IN: optimizer.control
+
+GENERIC: detect-loops* ( node -- )
+
+M: node detect-loops* drop ;
+
+M: #label detect-loops* t swap set-#label-loop? ;
+
+: not-a-loop ( #label -- )
+    f swap set-#label-loop? ;
+
+: tail-call? ( -- ? )
+    node-stack get
+    dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
+    [ node-successor #tail? ] all? ;
+
+: 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 detect-loops*
+    f swap node-param node-stack get <reversed>
+    [ detect-loop ] with all? 2drop ;
+
+: detect-loops ( node -- )
+    [ detect-loops* ] each-node ;

core/optimizer/optimizer.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces optimizer.backend optimizer.def-use
-optimizer.known-words optimizer.math inference.class ;
+optimizer.known-words optimizer.math optimizer.control
+inference.class ;
 IN: optimizer
 
 : optimize-1 ( node -- newnode ? )
@@ -11,6 +12,7 @@ IN: optimizer
         H{ } clone value-substitutions set
         dup compute-def-use
         kill-values
+        "detect-loops" get [ dup detect-loops ] when
         dup infer-classes
         optimizer-changed off
         optimize-nodes