From 8e847749ce232ccc21315a99bf235a5599be627b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 24 Jul 2008 00:14:13 -0500
Subject: [PATCH] Improve branch folding

---
 .../tree/propagation/branches/branches.factor | 20 +++++++++-----
 .../tree/propagation/info/info-tests.factor   |  5 ++++
 .../tree/propagation/info/info.factor         | 18 +++++++++++--
 .../tree/propagation/propagation-tests.factor | 27 +++++++++++++++++--
 4 files changed, 60 insertions(+), 10 deletions(-)

diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index 63cb05de0a..22f0978e22 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/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 [
         [
-            value-infos [ clone ] change
-            constraints [ clone ] change
-            assume
-            [ first>> (propagate) ] when*
+            over [
+                value-infos [ clone ] change
+                constraints [ clone ] change
+                assume
+                first>> (propagate)
+            ] [
+                2drop
+                value-infos off
+                constraints off
+            ] if
         ] H{ } make-assoc
     ] 2map ;
 
diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor
index 8503b8d98d..41da9e6014 100644
--- a/unfinished/compiler/tree/propagation/info/info-tests.factor
+++ b/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
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index dea5808fa6..90ef41754a 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/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 ;
 
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 64ab3df807..5533cd1407 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/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