Improve branch folding

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -16,7 +16,8 @@ GENERIC: child-constraints ( node -- seq )
 M: #if child-constraints
     in-d>> first [ =t ] [ =f ] bi 2array ;
 
-M: #dispatch child-constraints drop f ;
+M: #dispatch child-constraints
+    children>> length f <repetition> ;
 
 GENERIC: live-children ( #branch -- children )
 
@@ -27,15 +28,22 @@ M: #if live-children
     2bi 2array ;
 
 M: #dispatch live-children
-    children>> ;
+    [ children>> ] [ in-d>> first value-info interval>> ] bi
+    '[ , interval-contains? [ drop f ] unless ] map-index ;
 
 : infer-children ( node -- assocs )
     [ live-children ] [ child-constraints ] bi [
         [
+            over [
                 value-infos [ clone ] change
                 constraints [ clone ] change
                 assume
-            [ first>> (propagate) ] when*
+                first>> (propagate)
+            ] [
+                2drop
+                value-infos off
+                constraints off
+            ] if
         ] H{ } make-assoc
     ] 2map ;
 

unfinished/compiler/tree/propagation/info/info-tests.factor

@@ -56,3 +56,8 @@ IN: compiler.tree.propagation.info.tests
     fixnum 19 29 [a,b] <class/interval-info>
     value-info-intersect
 ] unit-test
+
+[ 3 t ] [
+    3 <literal-info>
+    null <class-info> value-info-union >literal<
+] unit-test

unfinished/compiler/tree/propagation/info/info.factor

@@ -84,23 +84,37 @@ literal? ;
         [ drop >literal< ]
     } cond ;
 
-: value-info-intersect ( info1 info2 -- info )
+: (value-info-intersect) ( info1 info2 -- info )
     [ [ class>> ] bi@ class-and ]
     [ [ interval>> ] bi@ interval-intersect ]
     [ intersect-literals ]
     2tri <value-info> ;
 
+: value-info-intersect ( info1 info2 -- info )
+    {
+        { [ dup class>> null class<= ] [ nip ] }
+        { [ over class>> null class<= ] [ drop ] }
+        [ (value-info-intersect) ]
+    } cond ;
+
 : union-literals ( info1 info2 -- literal literal? )
     2dup [ literal?>> ] both? [
         [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
     ] [ 2drop f f ] if ;
 
-: value-info-union ( info1 info2 -- info )
+: (value-info-union) ( info1 info2 -- info )
     [ [ class>> ] bi@ class-or ]
     [ [ interval>> ] bi@ interval-union ]
     [ union-literals ]
     2tri <value-info> ;
 
+: value-info-union ( info1 info2 -- info )
+    {
+        { [ dup class>> null class<= ] [ drop ] }
+        { [ over class>> null class<= ] [ nip ] }
+        [ (value-info-union) ]
+    } cond ;
+
 : value-infos-union ( infos -- info )
     dup first [ value-info-union ] reduce ;
 

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -2,7 +2,7 @@ USING: kernel compiler.tree.builder compiler.tree
 compiler.tree.propagation compiler.tree.copy-equiv
 compiler.tree.def-use tools.test math math.order
 accessors sequences arrays kernel.private vectors
-alien.accessors alien.c-types ;
+alien.accessors alien.c-types sequences.private ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -178,7 +178,7 @@ IN: compiler.tree.propagation.tests
 [ V{ f } ] [
     [
         /f
-        dup 0.0 < [ dup 0.0 > [ drop 0.0 ] unless ] [ drop 0.0 ] if
+        dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
     ] final-literals
 ] unit-test
 
@@ -197,3 +197,26 @@ IN: compiler.tree.propagation.tests
 [ V{ t } ] [
     [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
 ] unit-test
+
+[ V{ "d" } ] [
+    [
+        3 {
+            [ "a" ]
+            [ "b" ]
+            [ "c" ]
+            [ "d" ]
+            [ "e" ]
+            [ "f" ]
+            [ "g" ]
+            [ "h" ]
+        } dispatch
+    ] final-literals
+] unit-test
+
+[ V{ "hi" } ] [
+    [ [ "hi" ] [ 123 3 throw ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
+] unit-test