steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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'!

db4
Slava Pestov 2009-08-08 23:03:45 -05:00
parent 61ea749bb6
commit e400d80d8b
5 changed files with 47 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/compiler/tree/propagation/info/info-tests.factor
View File

@ -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

17
basis/compiler/tree/propagation/info/info.factor
View File

@ -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
namespaces sequences words combinators byte-arrays strings
arrays layouts cpu.architecture compiler.tree.propagation.copy ;
classes.tuple.private kernel accessors math math.intervals namespaces
sequences words combinators combinators.short-circuit byte-arrays
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
] [

3
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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= } [
[

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

33
basis/math/intervals/intervals.factor
View File

@ -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] ;