compiler.tree.propagation: fix bug in constraints that caused retain stack overflow

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

@@ -39,8 +39,8 @@ M: true-constraint assume*
     bi ;
 
 M: true-constraint satisfied?
-    value>> value-info class>>
+    value>> value-info*
-    { [ true-class? ] [ null-class? not ] } 1&& ;
+    [ class>> true-class? ] [ drop f ] if ;
 
 TUPLE: false-constraint value ;
 
@@ -52,8 +52,8 @@ M: false-constraint assume*
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>>
+    value>> value-info*
-    { [ false-class? ] [ null-class? not ] } 1&& ;
+    [ class>> false-class? ] [ drop f ] if ;
 
 ! Class constraints
 TUPLE: class-constraint value class ;

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

@@ -294,8 +294,11 @@ DEFER: (value-info-union)
 ! Assoc stack of current value --> info mapping
 SYMBOL: value-infos
 
+: value-info* ( value -- info ? )
+    resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
+
 : value-info ( value -- info )
-    resolve-copy value-infos get assoc-stack null-info or ;
+    value-info* drop ;
 
 : set-value-info ( info value -- )
     resolve-copy value-infos get last set-at ;

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

@@ -239,6 +239,14 @@ IN: compiler.tree.propagation.tests
     ] final-classes
 ] unit-test
 
+[ ] [
+    [
+        dup dup dup [ 100 < ] [ drop f ] if dup
+        [ 2drop f ] [ 2drop f ] if
+        [ ] [ dup [ ] [ ] if ] if
+    ] final-info drop
+] unit-test
+
 [ V{ fixnum } ] [
     [ { fixnum } declare (clone) ] final-classes
 ] unit-test