compiler.tree.propagation: be more careful with intervals, ensuring that the inferred interval of a value is a subset of the value class's interval. This improves accuracy, for example [ >fixnum 1 + >fixnum most-positive-fixnum <= ] constant-folds to true

basis/compiler/tree/debugger/debugger.factor

@@ -16,6 +16,7 @@ compiler.tree.builder
 compiler.tree.optimizer
 compiler.tree.combinators
 compiler.tree.checker
+compiler.tree.identities
 compiler.tree.dead-code
 compiler.tree.modular-arithmetic ;
 FROM: fry => _ ;
@@ -208,6 +209,7 @@ SYMBOL: node-count
         normalize
         propagate
         cleanup
+        apply-identities
         compute-def-use
         remove-dead-code
         compute-def-use

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler.tree.modular-arithmetic.tests
 USING: kernel kernel.private tools.test math math.partial-dispatch
-math.private accessors slots.private sequences strings sbufs
+math.private accessors slots.private sequences sequences.private strings sbufs
 compiler.tree.builder
 compiler.tree.normalization
 compiler.tree.debugger
@@ -171,3 +171,8 @@ cell {
 [ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test
 
 [ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test
+
+[ t ] [
+    [ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
+    { >fixnum } inlined?
+] unit-test

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

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra classes.tuple
 classes.tuple.private kernel accessors math math.intervals namespaces
-sequences words combinators combinators.short-circuit byte-arrays
+sequences sequences.private words combinators
-strings arrays layouts cpu.architecture compiler.tree.propagation.copy
+combinators.short-circuit byte-arrays strings arrays layouts
- ;
+cpu.architecture compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -37,10 +37,6 @@ CONSTANT: null-info T{ value-info f null empty-interval }
 
 CONSTANT: object-info T{ value-info f object full-interval }
 
-: class-interval ( class -- interval )
-    dup real class<=
-    [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
-
 : interval>literal ( class interval -- literal literal? )
     #! If interval has zero length and the class is sufficiently
     #! precise, we can turn it into a literal
@@ -85,6 +81,23 @@ UNION: fixed-length array byte-array string ;
         [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
     } 1|| ;
 
+: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+
+: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+
+: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+
+: wrap-interval ( interval class -- interval' )
+    {
+        { fixnum [ interval->fixnum ] }
+        { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+        [ drop ]
+    } case ;
+
+: init-interval ( info -- info )
+    dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
+    dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
+
 : init-value-info ( info -- info )
     dup literal?>> [
         init-literal-info
@@ -93,8 +106,7 @@ UNION: fixed-length array byte-array string ;
             null >>class
             empty-interval >>interval
         ] [
-            [ [-inf,inf] or ] change-interval
+            init-interval
-            dup class>> integer class<= [ [ integral-closure ] change-interval ] when
             dup [ class>> ] [ interval>> ] bi interval>literal
             [ >>literal ] [ >>literal? ] bi*
         ] if
@@ -107,8 +119,7 @@ UNION: fixed-length array byte-array string ;
     init-value-info ; foldable
 
 : <class-info> ( class -- info )
-    dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
+    f <class/interval-info> ; foldable
-    <class/interval-info> ; foldable
 
 : <interval-info> ( interval -- info )
     <value-info>

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

@@ -18,14 +18,6 @@ compiler.tree.propagation.call-effect
 compiler.tree.propagation.transforms ;
 IN: compiler.tree.propagation.known-words
 
-\ fixnum
-most-negative-fixnum most-positive-fixnum [a,b]
-"interval" set-word-prop
-
-\ array-capacity
-0 max-array-capacity [a,b]
-"interval" set-word-prop
-
 { + - * / }
 [ { number number } "input-classes" set-word-prop ] each
 
@@ -53,8 +45,8 @@ most-negative-fixnum most-positive-fixnum [a,b]
     { fixnum bignum integer rational float real number object }
     [ class<= ] with find nip ;
 
-: fits? ( interval class -- ? )
+: fits-in-fixnum? ( interval -- ? )
-    "interval" word-prop interval-subset? ;
+    fixnum-interval interval-subset? ;
 
 : binary-op-class ( info1 info2 -- newclass )
     [ class>> ] bi@
@@ -66,7 +58,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     [ [ interval>> ] bi@ ] dip call ; inline
 
 : won't-overflow? ( class interval -- ? )
-    [ fixnum class<= ] [ fixnum fits? ] bi* and ;
+    [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
 
 : may-overflow ( class interval -- class' interval' )
     over null-class? [
@@ -219,14 +211,7 @@ generic-comparison-ops [
 
     { >integer integer }
 } [
-    '[
+    '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
-        _
-        [ nip ] [
-            [ interval>> ] [ class-interval ] bi*
-            interval-intersect
-        ] 2bi
-        <class/interval-info>
-    ] "outputs" set-word-prop
 ] assoc-each
 
 { numerator denominator }
@@ -262,7 +247,7 @@ generic-comparison-ops [
             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
         }
     } cond
-    [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
+    [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
     '[ 2drop _ ] "outputs" set-word-prop
 ] each
 

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

@@ -713,6 +713,20 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 
 [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
 
+! generalize-counter is not tight enough
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
+
+! Coercions need to update intervals
+[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
+
+[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
+
 ! Mutable tuples with circularity should not cause problems
 TUPLE: circle me ;
 

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

@@ -1,19 +1,51 @@
 IN: compiler.tree.propagation.recursive.tests
 USING: tools.test compiler.tree.propagation.recursive
-math.intervals kernel ;
+math.intervals kernel math literals layouts ;
 
 [ T{ interval f { 0 t } { 1/0. t } } ] [
     T{ interval f { 1 t } { 1 t } }
-    T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+    T{ interval f { 0 t } { 0 t } }
+    integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+    T{ interval f { 1 t } { 1 t } }
+    T{ interval f { 0 t } { 0 t } }
+    fixnum generalize-counter-interval
 ] unit-test
 
 [ T{ interval f { -1/0. t } { 10 t } } ] [
     T{ interval f { -1 t } { -1 t } }
-    T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+    T{ interval f { 10 t } { 10 t } }
+    integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { $[ most-negative-fixnum ] t } { 10 t } } ] [
+    T{ interval f { -1 t } { -1 t } }
+    T{ interval f { 10 t } { 10 t } }
+    fixnum generalize-counter-interval
 ] unit-test
 
 [ t ] [
     T{ interval f { 1 t } { 268435455 t } }
     T{ interval f { -268435456 t } { 268435455 t } } tuck
-    generalize-counter-interval =
+    integer generalize-counter-interval =
+] unit-test
+
+[ t ] [
+    T{ interval f { 1 t } { 268435455 t } }
+    T{ interval f { -268435456 t } { 268435455 t } } tuck
+    fixnum generalize-counter-interval =
+] unit-test
+
+[ full-interval ] [
+    T{ interval f { -5 t } { 3 t } }
+    T{ interval f { 2 t } { 11 t } }
+    integer generalize-counter-interval
+] unit-test
+
+[ $[ fixnum-interval ] ] [
+    T{ interval f { -5 t } { 3 t } }
+    T{ interval f { 2 t } { 11 t } }
+    fixnum generalize-counter-interval
 ] unit-test

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors arrays fry math.intervals
+USING: kernel sequences accessors arrays fry math math.intervals
-combinators namespaces
+layouts combinators namespaces locals
 stack-checker.inlining
 compiler.tree
 compiler.tree.combinators
@@ -24,20 +24,26 @@ IN: compiler.tree.propagation.recursive
     [ label>> calls>> [ node>> node-input-infos ] map flip ]
     [ latest-input-infos ] bi ;
 
-: generalize-counter-interval ( interval initial-interval -- interval' )
+:: generalize-counter-interval ( interval initial-interval class -- interval' )
     {
-        { [ 2dup interval-subset? ] [ empty-interval ] }
+        { [ interval initial-interval interval-subset? ] [ initial-interval ] }
-        { [ over empty-interval eq? ] [ empty-interval ] }
+        { [ interval empty-interval eq? ] [ initial-interval ] }
-        { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
+        {
-        { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
+            [ interval initial-interval interval>= t eq? ]
-        [ [-inf,inf] ]
+            [ class max-value [a,a] initial-interval interval-union ]
-    } cond interval-union nip ;
+        }
+        {
+            [ interval initial-interval interval<= t eq? ]
+            [ class min-value [a,a] initial-interval interval-union ]
+        }
+        [ class class-interval ]
+    } cond ;
 
 : generalize-counter ( info' initial -- info )
     2dup [ not ] either? [ drop ] [
         2dup [ class>> null-class? ] either? [ drop ] [
             [ clone ] dip
-            [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+            [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
             [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
             [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
             tri

basis/math/intervals/intervals.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
 USING: accessors kernel sequences arrays math math.order
-combinators generic layouts ;
+combinators generic layouts memoize ;
 IN: math.intervals
 
 SYMBOL: empty-interval
@@ -48,7 +48,10 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
 
-: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
+MEMO: fixnum-interval ( -- interval )
+    most-negative-fixnum most-positive-fixnum [a,b] ; inline
 
 : [-inf,inf] ( -- interval ) full-interval ; inline
 
@@ -331,12 +334,22 @@ SYMBOL: incomparable
     } cond
     swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ;
 
+: (rem-range) ( i -- i' ) interval-abs to>> first 0 swap [a,b) ;
+
 : 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) ]
+        [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ]
+    } cond ;
+
+: interval->fixnum ( i1 -- i2 )
+    {
+        { [ dup empty-interval eq? ] [ ] }
+        { [ dup full-interval eq? ] [ drop fixnum-interval ] }
+        { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] }
+        [ ]
     } cond ;
 
 : interval-bitand-pos ( i1 i2 -- ? )