More accurate interval inference for mod, rem, and propagation can now infer intervals in the case where a value might be f. so, [ [ 127 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] now constant-folds down to 't'!

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

@@ -74,3 +74,13 @@ TUPLE: test-tuple { x read-only } ;
 [ t ] [
     null-info 3 <literal-info> value-info<=
 ] unit-test
+
+[ t t ] [
+    f <literal-info>
+    fixnum 0 40 [a,b] <class/interval-info>
+    value-info-union
+    \ f class-not <class-info>
+    value-info-intersect
+    [ class>> fixnum class= ]
+    [ interval>> 0 40 [a,b] = ] bi
+] unit-test

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

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals
+classes.tuple.private kernel accessors math math.intervals namespaces
-namespaces sequences words combinators byte-arrays strings
+sequences words combinators combinators.short-circuit byte-arrays
-arrays layouts cpu.architecture compiler.tree.propagation.copy ;
+strings arrays layouts cpu.architecture compiler.tree.propagation.copy
+ ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -69,7 +70,7 @@ DEFER: <literal-info>
 UNION: fixed-length array byte-array string ;
 
 : init-literal-info ( info -- info )
-    [-inf,inf] >>interval
+    empty-interval >>interval
     dup literal>> class >>class
     dup literal>> {
         { [ dup real? ] [ [a,a] >>interval ] }
@@ -78,11 +79,17 @@ UNION: fixed-length array byte-array string ;
         [ drop ]
     } cond ; inline
 
+: empty-set? ( info -- ? )
+    {
+        [ class>> null-class? ]
+        [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
+    } 1|| ;
+
 : init-value-info ( info -- info )
     dup literal?>> [
         init-literal-info
     ] [
-        dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
+        dup empty-set? [
             null >>class
             empty-interval >>interval
         ] [

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -173,7 +173,8 @@ generic-comparison-ops [
     [ object-info ] [ f <literal-info> ] if ;
 
 : info-intervals-intersect? ( info1 info2 -- ? )
-    [ interval>> ] bi@ intervals-intersect? ;
+    2dup [ class>> real class<= ] both?
+    [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ;
 
 { number= bignum= float= } [
     [

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

@@ -155,6 +155,8 @@ IN: compiler.tree.propagation.tests
 
 [ V{ t } ] [ [ 40 rem 0 >= ] final-literals ] unit-test
 
+[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test
+
 [ V{ string } ] [
     [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
 ] unit-test
@@ -638,6 +640,10 @@ MIXIN: empty-mixin
     [ { integer } declare 127 bitand ] final-info first interval>>
 ] unit-test
 
+[ V{ t } ] [
+    [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals
+] unit-test
+  
 [ V{ bignum } ] [
     [ { bignum } declare dup 1- bitxor ] final-classes
 ] unit-test

basis/math/intervals/intervals.factor

@@ -269,22 +269,6 @@ TUPLE: interval { from read-only } { to read-only } ;
         [ (interval-abs) points>interval ]
     } cond ;
 
-: interval-mod ( i1 i2 -- i3 )
-    {
-        { [ over empty-interval eq? ] [ drop ] }
-        { [ dup empty-interval eq? ] [ nip ] }
-        { [ dup full-interval eq? ] [ nip ] }
-        [ nip interval-abs to>> first [ neg ] keep (a,b) ]
-    } cond ;
-
-: interval-rem ( i1 i2 -- i3 )
-    {
-        { [ over empty-interval eq? ] [ drop ] }
-        { [ dup empty-interval eq? ] [ nip ] }
-        { [ dup full-interval eq? ] [ nip ] }
-        [ nip interval-abs to>> first 0 swap [a,b) ]
-    } cond ;
-
 : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
 
 : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
@@ -335,6 +319,23 @@ SYMBOL: incomparable
 : interval>= ( i1 i2 -- ? )
     swap interval<= ;
 
+: interval-mod ( i1 i2 -- i3 )
+    {
+        { [ over empty-interval eq? ] [ swap ] }
+        { [ dup empty-interval eq? ] [ ] }
+        { [ dup full-interval eq? ] [ ] }
+        [ interval-abs to>> first [ neg ] keep (a,b) ]
+    } cond
+    swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ;
+
+: interval-rem ( i1 i2 -- i3 )
+    {
+        { [ over empty-interval eq? ] [ drop ] }
+        { [ dup empty-interval eq? ] [ nip ] }
+        { [ dup full-interval eq? ] [ nip ] }
+        [ nip interval-abs to>> first 0 swap [a,b) ]
+    } cond ;
+
 : interval-bitand-pos ( i1 i2 -- ? )
     [ to>> first ] bi@ min 0 swap [a,b] ;