Control flow analysis work in progress

core/inference/dataflow/dataflow-docs.factor

@@ -1,4 +1,5 @@
-USING: inference.dataflow help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: inference.dataflow
 
 HELP: #return
 { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }

core/inference/dataflow/dataflow.factor

@@ -317,4 +317,8 @@ UNION: #tail
     POSTPONE: f #return #tail-values #tail-merge #terminate ;
 
 : tail-call? ( -- ? )
-    node-stack get [ node-successor #tail? ] all? ;
+    #! We don't consider calls which do non-local exits to be
+    #! tail calls, because this gives better error traces.
+    node-stack get [
+        node-successor dup #tail? swap #terminate? not and
+    ] all? ;

core/inference/known-words/known-words.factor

@@ -345,7 +345,7 @@ M: object infer-call
 \ <word> { object object } { word } <effect> set-primitive-effect
 \ <word> make-flushable
 
-\ word-xt { word } { integer } <effect> set-primitive-effect
+\ word-xt { word } { integer integer } <effect> set-primitive-effect
 \ word-xt make-flushable
 
 \ getenv { fixnum } { object } <effect> set-primitive-effect

core/optimizer/control/control-tests.factor

@@ -1,6 +1,7 @@
 IN: temporary
 USING: tools.test optimizer.control combinators kernel
-sequences inference.dataflow math inference ;
+sequences inference.dataflow math inference classes strings
+optimizer ;
 
 : label-is-loop? ( node word -- ? )
     [
@@ -60,3 +61,88 @@ sequences inference.dataflow math inference ;
     [ loop-test-3 ] dataflow dup detect-loops
     \ loop-test-3 label-is-not-loop?
 ] unit-test
+
+: loop-test-4 ( a -- )
+    dup [
+        loop-test-4
+    ] [
+        drop
+    ] if ; inline
+
+: find-label ( node -- label )
+    dup #label? [ node-successor find-label ] unless ;
+
+: test-loop-exits
+    dataflow dup detect-loops find-label
+    dup node-param swap
+    [ node-child find-tail find-loop-exits [ class ] map ] keep
+    #label-loop? ;
+
+[ { #values } t ] [
+    [ loop-test-4 ] test-loop-exits
+] unit-test
+
+: loop-test-5 ( a -- )
+    dup [
+        dup string? [
+            loop-test-5
+        ] [
+            drop
+        ] if
+    ] [
+        drop
+    ] if ; inline
+
+[ { #values #values } t ] [
+    [ loop-test-5 ] test-loop-exits
+] unit-test
+
+: loop-test-6 ( a -- )
+    dup [
+        dup string? [
+            loop-test-6
+        ] [
+            3 throw
+        ] if
+    ] [
+        drop
+    ] if ; inline
+
+[ { #values } t ] [
+    [ loop-test-6 ] test-loop-exits
+] unit-test
+
+[ f ] [
+    [ [ [ ] map ] map ] dataflow optimize
+    [ dup #label? swap #loop? not and ] node-exists?
+] unit-test
+
+: blah f ;
+
+DEFER: a
+
+: b ( -- )
+    blah [ b ] [ a ] if ; inline
+
+: a ( -- )
+    blah [ b ] [ a ] if ; inline
+
+[ t ] [
+    [ a ] dataflow dup detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] dataflow dup detect-loops
+    \ b label-is-loop?
+] unit-test
+
+[ t ] [
+    [ b ] dataflow dup detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] dataflow dup detect-loops
+    \ b label-is-loop?
+] unit-test

core/optimizer/control/control.factor

@@ -68,7 +68,7 @@ M: #label detect-loops* t swap set-#label-loop? ;
     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?
     {
@@ -234,9 +234,12 @@ M: #if optimize-node*
 !     |
 !  #return 1
 
-: find-tail
-    dup node-successor #tail?
-    [ node-successor find-tail ] unless ;
+: find-tail ( node -- tail )
+    dup #terminate? [
+        dup node-successor #tail? [
+            node-successor find-tail
+        ] unless
+    ] unless ;
 
 : child-tails ( node -- seq )
     node-children [ find-tail ] map ;
@@ -246,15 +249,18 @@ GENERIC: add-loop-exit* ( label node -- )
 M: #branch add-loop-exit*
     child-tails [ add-loop-exit* ] with each ;
 
-M: #call-label add-loop-exit* drop ;
+M: #call-label add-loop-exit*
+    tuck node-param eq? [ drop ] [ node-successor , ] if ;
 
-M: node add-loop-exit* node-successor add-loop-exit* , ;
+M: #terminate add-loop-exit*
+    2drop ;
+
+M: node add-loop-exit*
+    nip node-successor dup #terminate? [ drop ] [ , ] if ;
 
 : find-loop-exits ( label node -- seq )
     [ add-loop-exit* ] { } make ;
 
-! ! ! !
-
 : find-final-if ( node -- #if/f )
     dup [
         dup #if? [

core/optimizer/optimizer-tests.factor

@@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
 kernel.private math optimizer prettyprint sequences sbufs
 strings tools.test vectors words sequences.private quotations
 optimizer.backend classes inference.dataflow tuples.private
-continuations growable optimizer.inlining ;
+continuations growable optimizer.inlining namespaces ;
 IN: temporary
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [