Fixing failing unit tests in compiler.tree.propagation due to constraints

basis/compiler/tree/propagation/branches/branches.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators columns
-stack-checker.branches
+stack-checker.branches locals
 compiler.utilities
 compiler.tree
 compiler.tree.combinators
@@ -82,6 +82,13 @@ M: #phi propagate-before ( #phi -- )
     [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
     bi ;
 
+:: update-constraints ( new old -- )
+    new [| key value | key old [ value append ] change-at ] assoc-each ;
+
+: include-child-constraints ( i -- )
+    infer-children-data get nth constraints swap at last
+    constraints get last update-constraints ;
+
 : branch-phi-constraints ( output values booleans -- )
      {
         {
@@ -116,22 +123,24 @@ M: #phi propagate-before ( #phi -- )
                 swap t-->
             ]
         }
-        ! {
+        {
-        !     { { t f } { } }
+            { { t f } { } }
-        !     [ B
+            [
-        !         first
+                first
-        !         [ [ =t ] bi@ <--> ]
+                [ [ =t ] bi@ <--> ]
-        !         [ [ =f ] bi@ <--> ] 2bi /\
+                [ [ =f ] bi@ <--> ] 2bi /\
-        !     ]
+                0 include-child-constraints
-        ! }
+            ]
-        ! {
+        }
-        !     { { } { t f } }
+        {
-        !     [
+            { { } { t f } }
-        !         second
+            [
-        !         [ [ =t ] bi@ <--> ]
+                second
-        !         [ [ =f ] bi@ <--> ] 2bi /\
+                [ [ =t ] bi@ <--> ]
-        !     ]
+                [ [ =f ] bi@ <--> ] 2bi /\
-        ! }
+                1 include-child-constraints
+            ]
+        }
         [ 3drop f ]
     } case assume ;
 
@@ -147,6 +156,7 @@ M: #phi propagate-after ( #phi -- )
     ] [ drop ] if ;
 
 M: #phi propagate-around ( #phi -- )
+    ! Is this necessary?
     [ propagate-before ] [ propagate-after ] bi ;
 
 M: #branch propagate-around

basis/compiler/tree/propagation/constraints/constraints.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces classes classes.algebra
-combinators words
+combinators words combinators.short-circuit
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.copy ;
@@ -28,15 +28,19 @@ M: object satisfied? drop f ;
 ! Boolean constraints
 TUPLE: true-constraint value ;
 
-: =t ( value -- constriant ) resolve-copy true-constraint boa ;
+: =t ( value -- constraint ) resolve-copy true-constraint boa ;
+
+: follow-implications ( constraint -- )
+    constraints get assoc-stack [ assume ] when* ;
 
 M: true-constraint assume*
     [ \ f class-not <class-info> swap value>> refine-value-info ]
-    [ constraints get assoc-stack [ assume ] when* ]
+    [ follow-implications ]
     bi ;
 
 M: true-constraint satisfied?
-    value>> value-info class>> true-class? ;
+    value>> value-info class>>
+    { [ true-class? ] [ null-class? not ] } 1&& ;
 
 TUPLE: false-constraint value ;
 
@@ -44,11 +48,12 @@ TUPLE: false-constraint value ;
 
 M: false-constraint assume*
     [ \ f <class-info> swap value>> refine-value-info ]
-    [ constraints get assoc-stack [ assume ] when* ]
+    [ follow-implications ]
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>> false-class? ;
+    value>> value-info class>>
+    { [ false-class? ] [ null-class? not ] } 1&& ;
 
 ! Class constraints
 TUPLE: class-constraint value class ;
@@ -82,7 +87,7 @@ TUPLE: implication p q ;
 
 C: --> implication
 
-: assume-implication ( p q -- )
+: assume-implication ( q p -- )
     [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 

basis/compiler/tree/propagation/info/info.factor

@@ -302,7 +302,7 @@ SYMBOL: value-infos
 
 : refine-value-info ( info value -- )
     resolve-copy value-infos get
-    [ assoc-stack value-info-intersect ] 2keep
+    [ assoc-stack [ value-info-intersect ] when* ] 2keep
     last set-at ;
 
 : value-literal ( value -- obj ? )

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

@@ -694,17 +694,17 @@ MIXIN: empty-mixin
     [ { word object } declare equal? ] final-classes
 ] unit-test
 
-! [ V{ string } ] [
+[ V{ string } ] [
-!     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+    [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-! ] unit-test
+] unit-test
 
-! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
 
-! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
 
-! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
 
-! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
 
 ! generalize-counter-interval wasn't being called in all the right places.
 ! bug found by littledan