Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
e799acd1c3
|
|
@ -13,8 +13,6 @@ IN: classes.algebra.tests
|
|||
\ flatten-class must-infer
|
||||
\ flatten-builtin-class must-infer
|
||||
|
||||
: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;
|
||||
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
|
||||
|
||||
: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;
|
||||
|
|
|
|||
|
|
@ -186,6 +186,9 @@ M: anonymous-complement (classes-intersect?)
|
|||
[ [ rank-class ] bi@ < ]
|
||||
} cond ;
|
||||
|
||||
: class= ( first second -- ? )
|
||||
[ class<= ] [ swap class<= ] 2bi and ;
|
||||
|
||||
: largest-class ( seq -- n elt )
|
||||
dup [ [ class< ] with contains? not ] curry find-last
|
||||
[ "Topological sort failed" throw ] unless* ;
|
||||
|
|
|
|||
|
|
@ -22,8 +22,14 @@ PREDICATE: math-class < class
|
|||
[ drop { 100 100 } ]
|
||||
} cond ;
|
||||
|
||||
: math-class-max ( class class -- class )
|
||||
[ [ math-precedence ] compare +gt+ eq? ] most ;
|
||||
: math-class<=> ( class1 class2 -- class )
|
||||
[ math-precedence ] compare +gt+ eq? ;
|
||||
|
||||
: math-class-max ( class1 class2 -- class )
|
||||
[ math-class<=> ] most ;
|
||||
|
||||
: math-class-min ( class1 class2 -- class )
|
||||
[ swap math-class<=> ] most ;
|
||||
|
||||
: (math-upgrade) ( max class -- quot )
|
||||
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
|
||||
|
|
|
|||
|
|
@ -14,6 +14,8 @@ ARTICLE: "math-intervals-new" "Creating intervals"
|
|||
{ $subsection [-inf,a) }
|
||||
{ $subsection [a,inf] }
|
||||
{ $subsection (a,inf] }
|
||||
"The set of all real numbers with infinities:"
|
||||
{ $subsection [-inf,inf] }
|
||||
"Another constructor:"
|
||||
{ $subsection points>interval } ;
|
||||
|
||||
|
|
@ -24,16 +26,23 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
|
|||
{ $subsection interval* }
|
||||
{ $subsection interval/ }
|
||||
{ $subsection interval/i }
|
||||
{ $subsection interval-shift }
|
||||
{ $subsection interval-mod }
|
||||
{ $subsection interval-rem }
|
||||
{ $subsection interval-min }
|
||||
{ $subsection interval-max }
|
||||
"Bitwise operations on intervals:"
|
||||
{ $subsection interval-shift }
|
||||
{ $subsection interval-bitand }
|
||||
{ $subsection interval-bitor }
|
||||
{ $subsection interval-bitxor }
|
||||
"Unary operations on intervals:"
|
||||
{ $subsection interval-1+ }
|
||||
{ $subsection interval-1- }
|
||||
{ $subsection interval-neg }
|
||||
{ $subsection interval-bitnot }
|
||||
{ $subsection interval-recip }
|
||||
{ $subsection interval-2/ } ;
|
||||
{ $subsection interval-2/ }
|
||||
{ $subsection interval-abs } ;
|
||||
|
||||
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
|
||||
{ $subsection interval-contains? }
|
||||
|
|
@ -53,12 +62,20 @@ ARTICLE: "math-intervals-compare" "Comparing intervals"
|
|||
{ $subsection assume> }
|
||||
{ $subsection assume>= } ;
|
||||
|
||||
ARTICLE: "math-interval-properties" "Properties of interval arithmetic"
|
||||
"For some operations, interval arithmetic yields inaccurate results, either because the result of lifting some operations to intervals does not result in intervals (bitwise operations, for example) or for the sake of simplicity of implementation."
|
||||
$nl
|
||||
"However, one important property holds for all operations. Suppose " { $emphasis "I, J" } " are intervals and " { $emphasis "op" } " is an operation. If " { $emphasis "x" } " is an element of " { $emphasis "I" } " and " { $emphasis "y" } " is an element of " { $emphasis "J" } ", then " { $emphasis "x op y" } " is an element of " { $emphasis "I op J" } "."
|
||||
$nl
|
||||
"In other words, the resulting interval might be an overestimate, but it is never an underestimate." ;
|
||||
|
||||
ARTICLE: "math-intervals" "Intervals"
|
||||
"Interval arithmetic is performed on ranges of real numbers, rather than exact values. It is used by the Factor compiler to convert arbitrary-precision arithmetic to machine arithmetic, by inferring bounds for integer calculations."
|
||||
$nl
|
||||
{ $subsection "math-interval-properties" }
|
||||
"The class of intervals:"
|
||||
{ $subsection interval }
|
||||
{ $subsection interval? }
|
||||
"Interval operations:"
|
||||
{ $subsection "math-intervals-new" }
|
||||
{ $subsection "math-intervals-arithmetic" }
|
||||
{ $subsection "math-intervals-sets" }
|
||||
|
|
@ -144,6 +161,26 @@ HELP: interval-max
|
|||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs the interval values obtained by lifting the " { $link max } " word to " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: interval-mod
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs an interval containing all possible values obtained by aplying " { $link mod } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: interval-rem
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs an interval containing all possible values obtained by aplying " { $link rem } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: interval-bitand
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs an interval containing all possible values obtained by aplying " { $link bitand } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: interval-bitor
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs an interval containing all possible values obtained by aplying " { $link bitor } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: interval-bitxor
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs an interval containing all possible values obtained by aplying " { $link bitxor } " to elements of " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: interval-min
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs the interval values obtained by lifting the " { $link min } " word to " { $snippet "i1" } " and " { $snippet "i2" } "." } ;
|
||||
|
|
@ -160,6 +197,10 @@ HELP: interval-neg
|
|||
{ $values { "i1" interval } { "i2" interval } }
|
||||
{ $description "Negates an interval." } ;
|
||||
|
||||
HELP: interval-abs
|
||||
{ $values { "i1" interval } { "i2" interval } }
|
||||
{ $description "Absolute value of an interval." } ;
|
||||
|
||||
HELP: interval-intersect
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
|
||||
|
|
@ -181,12 +222,16 @@ HELP: interval-closure
|
|||
{ $description "Outputs the smallest closed interval containing the endpoints of " { $snippet "i1" } "." } ;
|
||||
|
||||
HELP: interval/
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link / } " to perform the division. Outputs " { $link f } " if " { $snippet "i2" } " contains points arbitrarily close to zero." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link / } " to perform the division." } ;
|
||||
|
||||
HELP: interval/i
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link /i } " to perform the division. Outputs " { $link f } " if " { $snippet "i2" } " contains points arbitrarily close to zero." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link /i } " to perform the division." } ;
|
||||
|
||||
HELP: interval/f
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Divides " { $snippet "i1" } " by " { $snippet "i2" } ", using " { $link /f } " to perform the division." } ;
|
||||
|
||||
HELP: interval-recip
|
||||
{ $values { "i1" interval } { "i2" interval } }
|
||||
|
|
|
|||
|
|
@ -84,9 +84,9 @@ IN: math.intervals.tests
|
|||
1 0 1 (a,b) interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ -1 1 (a,b) -1 1 (a,b) interval/ ] unit-test
|
||||
[ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test
|
||||
|
||||
[ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test
|
||||
[ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test
|
||||
|
||||
"math.ratios.private" vocab [
|
||||
[ t ] [
|
||||
|
|
@ -156,7 +156,7 @@ IN: math.intervals.tests
|
|||
interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
|
||||
[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
|
||||
|
||||
! Interval random tester
|
||||
: random-element ( interval -- n )
|
||||
|
|
@ -177,12 +177,43 @@ IN: math.intervals.tests
|
|||
{ 3 [ (a,b] ] }
|
||||
} case ;
|
||||
|
||||
: random-op ( -- pair )
|
||||
: random-unary-op ( -- pair )
|
||||
{
|
||||
{ bitnot interval-bitnot }
|
||||
{ abs interval-abs }
|
||||
{ 2/ interval-2/ }
|
||||
{ 1+ interval-1+ }
|
||||
{ 1- interval-1- }
|
||||
{ neg interval-neg }
|
||||
}
|
||||
"math.ratios.private" vocab [
|
||||
{ recip interval-recip } suffix
|
||||
] when
|
||||
random ;
|
||||
|
||||
: unary-test ( -- ? )
|
||||
random-interval random-unary-op ! 2dup . .
|
||||
0 pick interval-contains? over first \ recip eq? and [
|
||||
2drop t
|
||||
] [
|
||||
[ >r random-element ! dup .
|
||||
r> first execute ] 2keep
|
||||
second execute interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
|
||||
|
||||
: random-binary-op ( -- pair )
|
||||
{
|
||||
{ + interval+ }
|
||||
{ - interval- }
|
||||
{ * interval* }
|
||||
{ /i interval/i }
|
||||
{ mod interval-mod }
|
||||
{ rem interval-rem }
|
||||
{ bitand interval-bitand }
|
||||
{ bitor interval-bitor }
|
||||
{ bitxor interval-bitxor }
|
||||
{ shift interval-shift }
|
||||
{ min interval-min }
|
||||
{ max interval-max }
|
||||
|
|
@ -192,8 +223,8 @@ IN: math.intervals.tests
|
|||
] when
|
||||
random ;
|
||||
|
||||
: interval-test ( -- ? )
|
||||
random-interval random-interval random-op ! 3dup . . .
|
||||
: binary-test ( -- ? )
|
||||
random-interval random-interval random-binary-op ! 3dup . . .
|
||||
0 pick interval-contains? over first { / /i } member? and [
|
||||
3drop t
|
||||
] [
|
||||
|
|
@ -202,7 +233,7 @@ IN: math.intervals.tests
|
|||
second execute interval-contains?
|
||||
] if ;
|
||||
|
||||
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
|
||||
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
|
||||
|
||||
: random-comparison ( -- pair )
|
||||
{
|
||||
|
|
@ -215,11 +246,7 @@ IN: math.intervals.tests
|
|||
: comparison-test ( -- ? )
|
||||
random-interval random-interval random-comparison
|
||||
[ >r [ random-element ] bi@ r> first execute ] 3keep
|
||||
second execute dup incomparable eq? [
|
||||
2drop t
|
||||
] [
|
||||
=
|
||||
] if ;
|
||||
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
|
||||
|
||||
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -36,6 +36,9 @@ C: <interval> interval
|
|||
|
||||
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
|
||||
|
||||
: [-inf,inf] ( -- interval )
|
||||
T{ interval f { -1./0. t } { 1./0. t } } ; inline
|
||||
|
||||
: compare-endpoints ( p1 p2 quot -- ? )
|
||||
>r over first over first r> call [
|
||||
2drop t
|
||||
|
|
@ -154,7 +157,7 @@ C: <interval> interval
|
|||
|
||||
: interval-shift-safe ( i1 i2 -- i3 )
|
||||
dup to>> first 100 > [
|
||||
2drop f
|
||||
2drop [-inf,inf]
|
||||
] [
|
||||
interval-shift
|
||||
] if ;
|
||||
|
|
@ -172,7 +175,7 @@ C: <interval> interval
|
|||
|
||||
: interval-division-op ( i1 i2 quot -- i3 )
|
||||
>r 0 over interval-closure interval-contains?
|
||||
[ 2drop f ] r> if ; inline
|
||||
[ 2drop [-inf,inf] ] r> if ; inline
|
||||
|
||||
: interval/ ( i1 i2 -- i3 )
|
||||
[ [ / ] interval-op ] interval-division-op ;
|
||||
|
|
@ -187,6 +190,25 @@ C: <interval> interval
|
|||
[ [ /i ] interval-op ] interval-integer-op
|
||||
] interval-division-op interval-closure ;
|
||||
|
||||
: interval/f ( i1 i2 -- i3 )
|
||||
[ [ /f ] interval-op ] interval-division-op ;
|
||||
|
||||
: interval-abs ( i1 -- i2 )
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
|
||||
points>interval ;
|
||||
|
||||
: interval-mod ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
nip interval-abs to>> first [ neg ] keep (a,b)
|
||||
] interval-division-op ;
|
||||
|
||||
: interval-rem ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
nip interval-abs to>> first 0 swap [a,b)
|
||||
] interval-division-op ;
|
||||
|
||||
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
|
||||
|
||||
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
|
||||
|
|
@ -194,16 +216,16 @@ C: <interval> interval
|
|||
SYMBOL: incomparable
|
||||
|
||||
: left-endpoint-< ( i1 i2 -- ? )
|
||||
[ swap interval-subset? ] 2keep
|
||||
[ nip interval-singleton? ] 2keep
|
||||
[ from>> ] bi@ =
|
||||
and and ;
|
||||
[ swap interval-subset? ]
|
||||
[ nip interval-singleton? ]
|
||||
[ [ from>> ] bi@ = ]
|
||||
2tri and and ;
|
||||
|
||||
: right-endpoint-< ( i1 i2 -- ? )
|
||||
[ interval-subset? ] 2keep
|
||||
[ drop interval-singleton? ] 2keep
|
||||
[ to>> ] bi@ =
|
||||
and and ;
|
||||
[ interval-subset? ]
|
||||
[ drop interval-singleton? ]
|
||||
[ [ to>> ] bi@ = ]
|
||||
2tri and and ;
|
||||
|
||||
: (interval<) ( i1 i2 -- i1 i2 ? )
|
||||
over from>> over from>> endpoint< ;
|
||||
|
|
@ -235,6 +257,27 @@ SYMBOL: incomparable
|
|||
: interval>= ( i1 i2 -- ? )
|
||||
swap interval<= ;
|
||||
|
||||
: interval-bitand ( i1 i2 -- i3 )
|
||||
dup 1 [a,a] interval>= [
|
||||
1 [a,a] interval- interval-rem
|
||||
] [
|
||||
2drop [-inf,inf]
|
||||
] if ;
|
||||
|
||||
: interval-bitor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ to>> first 0 swap [a,b] interval-intersect ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if ;
|
||||
|
||||
: interval-bitxor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ nip to>> first 0 swap [a,b] ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
to>> first [-inf,a) interval-intersect ;
|
||||
|
||||
|
|
|
|||
|
|
@ -130,38 +130,27 @@ HELP: /
|
|||
{ $see-also "division-by-zero" } ;
|
||||
|
||||
HELP: /i
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $values { "x" real } { "y" real } { "z" integer } }
|
||||
{ $description
|
||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer."
|
||||
{ $list
|
||||
"Integer division of fixnums may overflow and yield a bignum."
|
||||
"Integer division of bignums always yields a bignum."
|
||||
"Integer division of floats always yields a float."
|
||||
"Integer division of ratios and complex numbers proceeds using the relevant mathematical rules."
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" } ;
|
||||
|
||||
HELP: /f
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $values { "x" real } { "y" real } { "z" float } }
|
||||
{ $description
|
||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number."
|
||||
{ $list
|
||||
"Integer division of fixnums may overflow and yield a bignum."
|
||||
"Integer division of bignums always yields a bignum."
|
||||
"Integer division of floats always yields a float."
|
||||
"Integer division of ratios and complex numbers proceeds using the relevant mathematical rules."
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" } ;
|
||||
|
||||
HELP: mod
|
||||
{ $values { "x" integer } { "y" integer } { "z" integer } }
|
||||
{ $values { "x" rational } { "y" rational } { "z" rational } }
|
||||
{ $description
|
||||
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
|
||||
{ $list
|
||||
"Modulus of fixnums always yields a fixnum."
|
||||
"Modulus of bignums always yields a bignum."
|
||||
"Modulus of bignums always yields a bignum."
|
||||
{ "Modulus of rationals always yields a rational. In this case, the remainder is computed using the formula " { $snippet "x - (x mod y) * y" } "." }
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" rem } ;
|
||||
|
|
@ -254,12 +243,13 @@ HELP: recip
|
|||
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
|
||||
|
||||
HELP: rem
|
||||
{ $values { "x" integer } { "y" integer } { "z" integer } }
|
||||
{ $values { "x" rational } { "y" rational } { "z" rational } }
|
||||
{ $description
|
||||
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
|
||||
{ $list
|
||||
"Modulus of fixnums always yields a fixnum."
|
||||
"Modulus of bignums always yields a bignum."
|
||||
"Given fixnums, always yields a fixnum."
|
||||
"Given bignums, always yields a bignum."
|
||||
"Given rationals, always yields a rational."
|
||||
}
|
||||
}
|
||||
{ $see-also "division-by-zero" mod } ;
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ PRIVATE>
|
|||
|
||||
: ?1+ [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
|
||||
: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable
|
||||
|
||||
: 2^ ( n -- 2^n ) 1 swap shift ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ unit-test
|
|||
|
||||
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
|
||||
|
||||
[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
|
||||
[ t ] [ "0/0." string>number fp-nan? ] unit-test
|
||||
|
||||
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -326,6 +326,9 @@ M: immutable-sequence clone-like like ;
|
|||
>r [ min-length ] 2keep r>
|
||||
[ >r 2nth-unsafe r> call ] 3curry ; inline
|
||||
|
||||
: 2map-into ( seq1 seq2 quot into -- newseq )
|
||||
>r (2each) r> collect ; inline
|
||||
|
||||
: finish-find ( i seq -- i elt )
|
||||
over [ dupd nth-unsafe ] [ drop f ] if ; inline
|
||||
|
||||
|
|
@ -382,12 +385,15 @@ PRIVATE>
|
|||
>r -rot r> 2each ; inline
|
||||
|
||||
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
|
||||
>r (2each) over r>
|
||||
[ [ collect ] keep ] new-like ; inline
|
||||
>r 2over min-length r>
|
||||
[ [ 2map-into ] keep ] new-like ; inline
|
||||
|
||||
: 2map ( seq1 seq2 quot -- newseq )
|
||||
pick 2map-as ; inline
|
||||
|
||||
: 2change-each ( seq1 seq2 quot -- newseq )
|
||||
pick 2map-into ; inline
|
||||
|
||||
: 2all? ( seq1 seq2 quot -- ? )
|
||||
(2each) all-integers? ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -51,5 +51,5 @@ M: ratio * 2>fraction * >r * r> / ;
|
|||
M: ratio / scale / ;
|
||||
M: ratio /i scale /i ;
|
||||
M: ratio /f scale /f ;
|
||||
M: ratio mod 2dup >r >r /i r> r> rot * - ;
|
||||
M: ratio mod [ /i ] 2keep rot * - ;
|
||||
M: ratio /mod [ /i ] 2keep mod ;
|
||||
|
|
|
|||
|
|
@ -77,8 +77,8 @@ M: #shuffle propagate* mapping>> at look-at-value ;
|
|||
M: #phi propagate*
|
||||
#! If any of the outputs of a #phi are live, then the
|
||||
#! corresponding inputs are live too.
|
||||
[ [ out-d>> ] [ phi-in-d>> flip ] bi look-at-corresponding ]
|
||||
[ [ out-r>> ] [ phi-in-r>> flip ] bi look-at-corresponding ]
|
||||
[ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
|
||||
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
|
||||
2bi ;
|
||||
|
||||
M: node propagate* 2drop ;
|
||||
|
|
@ -139,15 +139,15 @@ M: #copy remove-dead-values* remove-dead-copies ;
|
|||
|
||||
: remove-dead-phi-d ( #phi -- #phi )
|
||||
dup
|
||||
[ phi-in-d>> flip ] [ out-d>> ] bi
|
||||
[ phi-in-d>> ] [ out-d>> ] bi
|
||||
filter-corresponding-values
|
||||
[ flip >>phi-in-d ] [ >>out-d ] bi* ;
|
||||
[ >>phi-in-d ] [ >>out-d ] bi* ;
|
||||
|
||||
: remove-dead-phi-r ( #phi -- #phi )
|
||||
dup
|
||||
[ phi-in-r>> flip ] [ out-r>> ] bi
|
||||
[ phi-in-r>> ] [ out-r>> ] bi
|
||||
filter-corresponding-values
|
||||
[ flip >>phi-in-r ] [ >>out-r ] bi* ;
|
||||
[ >>phi-in-r ] [ >>out-r ] bi* ;
|
||||
|
||||
M: #phi remove-dead-values*
|
||||
remove-dead-phi-d
|
||||
|
|
|
|||
|
|
@ -29,7 +29,8 @@ TUPLE: definition value node uses ;
|
|||
GENERIC: node-uses-values ( node -- values )
|
||||
|
||||
M: #phi node-uses-values
|
||||
[ phi-in-d>> concat ] [ phi-in-r>> concat ] bi append ;
|
||||
[ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
|
||||
append sift prune ;
|
||||
|
||||
M: #r> node-uses-values in-r>> ;
|
||||
|
||||
|
|
@ -43,12 +44,9 @@ M: #>r node-defs-values out-r>> ;
|
|||
|
||||
M: node node-defs-values out-d>> ;
|
||||
|
||||
: each-value ( node values quot -- )
|
||||
[ sift ] dip with each ; inline
|
||||
|
||||
: node-def-use ( node -- )
|
||||
[ dup node-uses-values [ use-value ] each-value ]
|
||||
[ dup node-defs-values [ def-value ] each-value ] bi ;
|
||||
[ dup node-uses-values [ use-value ] with each ]
|
||||
[ dup node-defs-values [ def-value ] with each ] bi ;
|
||||
|
||||
: check-def-use ( -- )
|
||||
def-use get [
|
||||
|
|
|
|||
|
|
@ -3,6 +3,9 @@
|
|||
USING: fry kernel sequences assocs accessors namespaces
|
||||
math.intervals arrays classes.algebra
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.constraints ;
|
||||
IN: compiler.tree.propagation.branches
|
||||
|
|
@ -11,60 +14,36 @@ IN: compiler.tree.propagation.branches
|
|||
GENERIC: child-constraints ( node -- seq )
|
||||
|
||||
M: #if child-constraints
|
||||
[
|
||||
\ f class-not 0 `input class,
|
||||
f 0 `input literal,
|
||||
] make-constraints ;
|
||||
in-d>> first
|
||||
[ <true-constraint> ] [ <false-constraint> ] bi
|
||||
2array ;
|
||||
|
||||
M: #dispatch child-constraints
|
||||
dup [
|
||||
children>> length [ 0 `input literal, ] each
|
||||
] make-constraints ;
|
||||
|
||||
DEFER: (propagate)
|
||||
M: #dispatch child-constraints drop f ;
|
||||
|
||||
: infer-children ( node -- assocs )
|
||||
[ children>> ] [ child-constraints ] bi [
|
||||
[
|
||||
value-classes [ clone ] change
|
||||
value-literals [ clone ] change
|
||||
value-intervals [ clone ] change
|
||||
value-infos [ clone ] change
|
||||
constraints [ clone ] change
|
||||
apply-constraint
|
||||
assume
|
||||
(propagate)
|
||||
] H{ } make-assoc
|
||||
] 2map ;
|
||||
|
||||
: merge-classes ( inputs outputs results -- )
|
||||
'[
|
||||
, null
|
||||
[ [ value-class ] bind class-or ] 2reduce
|
||||
_ set-value-class
|
||||
] 2each ;
|
||||
: (merge-value-infos) ( inputs results -- infos )
|
||||
'[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
|
||||
|
||||
: merge-intervals ( inputs outputs results -- )
|
||||
'[
|
||||
, [ [ value-interval ] bind ] 2map
|
||||
dup first [ interval-union ] reduce
|
||||
_ set-value-interval
|
||||
] 2each ;
|
||||
: merge-value-infos ( results inputs outputs -- )
|
||||
[ swap (merge-value-infos) ] dip set-value-infos ;
|
||||
|
||||
: merge-literals ( inputs outputs results -- )
|
||||
'[
|
||||
, [ [ value-literal 2array ] bind ] 2map
|
||||
dup all-eq? [ first first2 ] [ drop f f ] if
|
||||
_ swap [ set-value-literal ] [ 2drop ] if
|
||||
] 2each ;
|
||||
|
||||
: merge-stuff ( inputs outputs results -- )
|
||||
[ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
|
||||
: propagate-branch-phi ( results #phi -- )
|
||||
[ nip node-defs-values [ introduce-value ] each ]
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
2tri ;
|
||||
|
||||
: merge-children ( results node -- )
|
||||
successor>> dup #phi? [
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
|
||||
2bi
|
||||
] [ 2drop ] if ;
|
||||
successor>> propagate-branch-phi ;
|
||||
|
||||
M: #branch propagate-around
|
||||
[ infer-children ] [ merge-children ] [ annotate-node ] tri ;
|
||||
|
|
|
|||
|
|
@ -2,145 +2,97 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs math math.intervals kernel accessors
|
||||
sequences namespaces disjoint-sets classes classes.algebra
|
||||
combinators words compiler.tree ;
|
||||
combinators words compiler.tree compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.constraints
|
||||
|
||||
! A constraint is a statement about a value.
|
||||
|
||||
! We need a notion of equality which doesn't recurse so cannot
|
||||
! infinite loop on circular data
|
||||
GENERIC: eql? ( obj1 obj2 -- ? )
|
||||
M: object eql? eq? ;
|
||||
M: number eql? number= ;
|
||||
|
||||
! Maps constraints to constraints
|
||||
! Maps constraints to constraints ("A implies B")
|
||||
SYMBOL: constraints
|
||||
|
||||
TUPLE: literal-constraint literal value ;
|
||||
GENERIC: assume ( constraint -- )
|
||||
GENERIC: satisfied? ( constraint -- ? )
|
||||
|
||||
C: <literal-constraint> literal-constraint
|
||||
! Boolean constraints
|
||||
TUPLE: true-constraint value ;
|
||||
|
||||
M: literal-constraint equal?
|
||||
over literal-constraint? [
|
||||
[ [ literal>> ] bi@ eql? ]
|
||||
[ [ value>> ] bi@ = ]
|
||||
2bi and
|
||||
] [ 2drop f ] if ;
|
||||
: <true-constraint> ( value -- constriant )
|
||||
resolve-copy true-constraint boa ;
|
||||
|
||||
TUPLE: class-constraint class value ;
|
||||
M: true-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
||||
bi ;
|
||||
|
||||
C: <class-constraint> class-constraint
|
||||
M: true-constraint satisfied?
|
||||
value>> value-info class>> \ f class-not class<= ;
|
||||
|
||||
TUPLE: interval-constraint interval value ;
|
||||
TUPLE: false-constraint value ;
|
||||
|
||||
C: <interval-constraint> interval-constraint
|
||||
: <false-constraint> ( value -- constriant )
|
||||
resolve-copy false-constraint boa ;
|
||||
|
||||
GENERIC: apply-constraint ( constraint -- )
|
||||
GENERIC: constraint-satisfied? ( constraint -- ? )
|
||||
M: false-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ \ f <class-info> swap value>> refine-value-info ]
|
||||
bi ;
|
||||
|
||||
: `input ( n -- value ) node get in-d>> nth ;
|
||||
: `output ( n -- value ) node get out-d>> nth ;
|
||||
: class, ( class value -- ) <class-constraint> , ;
|
||||
: literal, ( literal value -- ) <literal-constraint> , ;
|
||||
: interval, ( interval value -- ) <interval-constraint> , ;
|
||||
M: false-constraint satisfied?
|
||||
value>> value-info class>> \ f class-not class<= ;
|
||||
|
||||
M: f apply-constraint drop ;
|
||||
! Class constraints
|
||||
TUPLE: class-constraint value class ;
|
||||
|
||||
: make-constraints ( node quot -- constraint )
|
||||
[ swap node set call ] { } make ; inline
|
||||
: <class-constraint> ( value class -- constraint )
|
||||
[ resolve-copy ] dip class-constraint boa ;
|
||||
|
||||
: set-constraints ( node quot -- )
|
||||
make-constraints
|
||||
unclip [ 2array ] reduce
|
||||
apply-constraint ; inline
|
||||
M: class-constraint assume
|
||||
[ class>> <class-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
: assume ( constraint -- )
|
||||
constraints get at [ apply-constraint ] when* ;
|
||||
! Interval constraints
|
||||
TUPLE: interval-constraint value interval ;
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
SYMBOL: copies
|
||||
: <interval-constraint> ( value interval -- constraint )
|
||||
[ resolve-copy ] dip interval-constraint boa ;
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get equate ;
|
||||
M: interval-constraint assume
|
||||
[ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
|
||||
! Literal constraints
|
||||
TUPLE: literal-constraint value literal ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get representative ;
|
||||
: <literal-constraint> ( value literal -- constraint )
|
||||
[ resolve-copy ] dip literal-constraint boa ;
|
||||
|
||||
: introduce-value ( val -- ) copies get add-atom ;
|
||||
M: literal-constraint assume
|
||||
[ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
! Current value --> literal mapping
|
||||
SYMBOL: value-literals
|
||||
! Implication constraints
|
||||
TUPLE: implication p q ;
|
||||
|
||||
! Current value --> interval mapping
|
||||
SYMBOL: value-intervals
|
||||
C: <implication> implication
|
||||
|
||||
! Current value --> class mapping
|
||||
SYMBOL: value-classes
|
||||
|
||||
: value-interval ( value -- interval/f )
|
||||
resolve-copy value-intervals get at ;
|
||||
|
||||
: set-value-interval ( interval value -- )
|
||||
resolve-copy value-intervals get set-at ;
|
||||
|
||||
: intersect-value-interval ( interval value -- )
|
||||
resolve-copy value-intervals get [ interval-intersect ] change-at ;
|
||||
|
||||
M: interval-constraint apply-constraint
|
||||
[ interval>> ] [ value>> ] bi intersect-value-interval ;
|
||||
|
||||
: set-class-interval ( class value -- )
|
||||
over class? [
|
||||
[ "interval" word-prop ] dip over
|
||||
[ resolve-copy set-value-interval ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: value-class ( value -- class )
|
||||
resolve-copy value-classes get at null or ;
|
||||
|
||||
: set-value-class ( class value -- )
|
||||
resolve-copy over [
|
||||
dup value-intervals get at [
|
||||
2dup set-class-interval
|
||||
] unless
|
||||
2dup <class-constraint> assume
|
||||
] when
|
||||
value-classes get set-at ;
|
||||
|
||||
: intersect-value-class ( class value -- )
|
||||
resolve-copy value-classes get [ class-and ] change-at ;
|
||||
|
||||
M: class-constraint apply-constraint
|
||||
[ class>> ] [ value>> ] bi intersect-value-class ;
|
||||
|
||||
: literal-interval ( value -- interval/f )
|
||||
dup real? [ [a,a] ] [ drop f ] if ;
|
||||
|
||||
: value-literal ( value -- obj ? )
|
||||
resolve-copy value-literals get at* ;
|
||||
|
||||
: set-value-literal ( literal value -- )
|
||||
resolve-copy {
|
||||
[ [ class ] dip set-value-class ]
|
||||
[ [ literal-interval ] dip set-value-interval ]
|
||||
[ <literal-constraint> assume ]
|
||||
[ value-literals get set-at ]
|
||||
} 2cleave ;
|
||||
|
||||
M: literal-constraint apply-constraint
|
||||
[ literal>> ] [ value>> ] bi set-value-literal ;
|
||||
|
||||
M: literal-constraint constraint-satisfied?
|
||||
dup value>> value-literal
|
||||
[ swap literal>> eql? ] [ 2drop f ] if ;
|
||||
|
||||
M: class-constraint constraint-satisfied?
|
||||
[ value>> value-class ] [ class>> ] bi class<= ;
|
||||
|
||||
M: pair apply-constraint
|
||||
first2
|
||||
M: implication assume
|
||||
[ q>> ] [ p>> ] bi
|
||||
[ constraints get set-at ]
|
||||
[ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
|
||||
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||
|
||||
M: pair constraint-satisfied?
|
||||
first constraint-satisfied? ;
|
||||
! Conjunction constraints
|
||||
TUPLE: conjunction p q ;
|
||||
|
||||
C: <conjunction> conjunction
|
||||
|
||||
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
|
||||
|
||||
! No-op
|
||||
M: f assume drop ;
|
||||
|
||||
! Utilities
|
||||
: if-true ( constraint boolean-value -- constraint' )
|
||||
<true-constraint> swap <implication> ;
|
||||
|
||||
: if-false ( constraint boolean-value -- constraint' )
|
||||
<false-constraint> swap <implication> ;
|
||||
|
||||
: <conditional> ( true-constr false-constr boolean-value -- constraint )
|
||||
tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
USING: accessors math math.intervals sequences classes.algebra
|
||||
math kernel tools.test compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.info.tests
|
||||
|
||||
[ t ] [
|
||||
number <class-info>
|
||||
sequence <class-info>
|
||||
value-info-intersect
|
||||
class>> integer class=
|
||||
] unit-test
|
||||
|
||||
[ t t ] [
|
||||
0 10 [a,b] <interval-info>
|
||||
5 20 [a,b] <interval-info>
|
||||
value-info-intersect
|
||||
[ class>> real class= ]
|
||||
[ interval>> 5 10 [a,b] = ]
|
||||
bi
|
||||
] unit-test
|
||||
|
||||
[ float 10.0 t ] [
|
||||
10.0 <literal-info>
|
||||
10.0 <literal-info>
|
||||
value-info-intersect
|
||||
[ class>> ] [ >literal< ] bi
|
||||
] unit-test
|
||||
|
||||
[ null ] [
|
||||
10 <literal-info>
|
||||
10.0 <literal-info>
|
||||
value-info-intersect
|
||||
class>>
|
||||
] unit-test
|
||||
|
||||
[ fixnum 10 t ] [
|
||||
10 <literal-info>
|
||||
10 <literal-info>
|
||||
value-info-union
|
||||
[ class>> ] [ >literal< ] bi
|
||||
] unit-test
|
||||
|
||||
[ 3.0 t ] [
|
||||
3 3 [a,b] <interval-info> float <class-info>
|
||||
value-info-intersect >literal<
|
||||
] unit-test
|
||||
|
||||
[ 3 t ] [
|
||||
2 3 (a,b] <interval-info> fixnum <class-info>
|
||||
value-info-intersect >literal<
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra kernel accessors math
|
||||
math.intervals namespaces disjoint-sets sequences words
|
||||
combinators ;
|
||||
IN: compiler.tree.propagation.info
|
||||
|
||||
SYMBOL: +interval+
|
||||
|
||||
GENERIC: eql? ( obj1 obj2 -- ? )
|
||||
M: object eql? eq? ;
|
||||
M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ;
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
SYMBOL: copies
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get equate ;
|
||||
|
||||
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get representative ;
|
||||
|
||||
: introduce-value ( val -- ) copies get add-atom ;
|
||||
|
||||
! Value info represents a set of objects. Don't mutate value infos
|
||||
! you receive, always construct new ones. We don't declare the
|
||||
! slots read-only to allow cloning followed by writing.
|
||||
TUPLE: value-info
|
||||
{ class initial: null }
|
||||
interval
|
||||
literal
|
||||
literal? ;
|
||||
|
||||
: class-interval ( class -- interval )
|
||||
dup real class<=
|
||||
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
|
||||
|
||||
: interval>literal ( class interval -- literal literal? )
|
||||
dup from>> first {
|
||||
{ [ over interval-length 0 > ] [ 3drop f f ] }
|
||||
{ [ over from>> second not ] [ 3drop f f ] }
|
||||
{ [ over to>> second not ] [ 3drop f f ] }
|
||||
{ [ pick fixnum class<= ] [ 2nip >fixnum t ] }
|
||||
{ [ pick bignum class<= ] [ 2nip >bignum t ] }
|
||||
{ [ pick float class<= ] [ 2nip >float t ] }
|
||||
[ 3drop f f ]
|
||||
} cond ;
|
||||
|
||||
: <value-info> ( class interval literal literal? -- info )
|
||||
[
|
||||
2nip
|
||||
[ class ]
|
||||
[ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ]
|
||||
[ ]
|
||||
tri t
|
||||
] [
|
||||
drop
|
||||
over null class<= [ drop f f f ] [
|
||||
over integer class<= [ integral-closure ] when
|
||||
2dup interval>literal
|
||||
] if
|
||||
] if
|
||||
\ value-info boa ; foldable
|
||||
|
||||
: <class-info> ( class -- info )
|
||||
[-inf,inf] f f <value-info> ; foldable
|
||||
|
||||
: <interval-info> ( interval -- info )
|
||||
real swap f f <value-info> ; foldable
|
||||
|
||||
: <literal-info> ( literal -- info )
|
||||
f [-inf,inf] rot t <value-info> ; foldable
|
||||
|
||||
: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
|
||||
|
||||
: intersect-literals ( info1 info2 -- literal literal? )
|
||||
{
|
||||
{ [ dup literal?>> not ] [ drop >literal< ] }
|
||||
{ [ over literal?>> not ] [ nip >literal< ] }
|
||||
{ [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
|
||||
[ drop >literal< ]
|
||||
} cond ;
|
||||
|
||||
: interval-intersect' ( i1 i2 -- i3 )
|
||||
#! Change core later.
|
||||
2dup and [ interval-intersect ] [ 2drop f ] if ;
|
||||
|
||||
: value-info-intersect ( info1 info2 -- info )
|
||||
[ [ class>> ] bi@ class-and ]
|
||||
[ [ interval>> ] bi@ interval-intersect' ]
|
||||
[ intersect-literals ]
|
||||
2tri <value-info> ;
|
||||
|
||||
: interval-union' ( i1 i2 -- i3 )
|
||||
{
|
||||
{ [ dup not ] [ drop ] }
|
||||
{ [ over not ] [ nip ] }
|
||||
[ interval-union ]
|
||||
} cond ;
|
||||
|
||||
: union-literals ( info1 info2 -- literal literal? )
|
||||
2dup [ literal?>> ] both? [
|
||||
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if ;
|
||||
|
||||
: value-info-union ( info1 info2 -- info )
|
||||
[ [ class>> ] bi@ class-or ]
|
||||
[ [ interval>> ] bi@ interval-union' ]
|
||||
[ union-literals ]
|
||||
2tri <value-info> ;
|
||||
|
||||
: value-infos-union ( infos -- info )
|
||||
dup first [ value-info-union ] reduce ;
|
||||
|
||||
! Current value --> info mapping
|
||||
SYMBOL: value-infos
|
||||
|
||||
: value-info ( value -- info )
|
||||
resolve-copy value-infos get at T{ value-info } or ;
|
||||
|
||||
: set-value-info ( info value -- )
|
||||
resolve-copy value-infos get set-at ;
|
||||
|
||||
: refine-value-info ( info value -- )
|
||||
resolve-copy value-infos get [ value-info-intersect ] change-at ;
|
||||
|
||||
: value-literal ( value -- obj ? )
|
||||
value-info >literal< ;
|
||||
|
|
@ -0,0 +1,271 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel effects accessors math math.private math.libm
|
||||
math.partial-dispatch math.intervals layouts words sequences
|
||||
sequences.private arrays assocs classes classes.algebra
|
||||
combinators generic.math fry locals
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.constraints ;
|
||||
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
|
||||
|
||||
{ /f < > <= >= }
|
||||
[ { real real } "input-classes" set-word-prop ] each
|
||||
|
||||
{ /i mod /mod }
|
||||
[ { rational rational } "input-classes" set-word-prop ] each
|
||||
|
||||
{ bitand bitor bitxor bitnot shift }
|
||||
[ { integer integer } "input-classes" set-word-prop ] each
|
||||
|
||||
\ bitnot { integer } "input-classes" set-word-prop
|
||||
|
||||
{
|
||||
fcosh
|
||||
flog
|
||||
fsinh
|
||||
fexp
|
||||
fasin
|
||||
facosh
|
||||
fasinh
|
||||
ftanh
|
||||
fatanh
|
||||
facos
|
||||
fpow
|
||||
fatan
|
||||
fatan2
|
||||
fcos
|
||||
ftan
|
||||
fsin
|
||||
fsqrt
|
||||
} [
|
||||
dup stack-effect
|
||||
[ in>> length real <repetition> "input-classes" set-word-prop ]
|
||||
[ out>> length float <repetition> "default-output-classes" set-word-prop ]
|
||||
2bi
|
||||
] each
|
||||
|
||||
: ?change-interval ( info quot -- quot' )
|
||||
over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
|
||||
|
||||
{ bitnot fixnum-bitnot bignum-bitnot } [
|
||||
[ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop
|
||||
] each
|
||||
|
||||
\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
|
||||
|
||||
: math-closure ( class -- newclass )
|
||||
{ null fixnum bignum integer rational float real number }
|
||||
[ class<= ] with find nip number or ;
|
||||
|
||||
: interval-subset?' ( i1 i2 -- ? )
|
||||
{
|
||||
{ [ over not ] [ 2drop t ] }
|
||||
{ [ dup not ] [ 2drop f ] }
|
||||
[ interval-subset? ]
|
||||
} cond ;
|
||||
|
||||
: fits? ( interval class -- ? )
|
||||
+interval+ word-prop interval-subset?' ;
|
||||
|
||||
: binary-op-class ( info1 info2 -- newclass )
|
||||
[ class>> math-closure ] bi@ math-class-max ;
|
||||
|
||||
: binary-op-interval ( info1 info2 quot -- newinterval )
|
||||
[ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline
|
||||
|
||||
: <class/interval-info> ( class interval -- info )
|
||||
[ f f <value-info> ] [ <class-info> ] if* ;
|
||||
|
||||
: won't-overflow? ( class interval -- ? )
|
||||
[ fixnum class<= ] [ fixnum fits? ] bi* and ;
|
||||
|
||||
: may-overflow ( class interval -- class' interval' )
|
||||
2dup won't-overflow?
|
||||
[ [ integer math-class-max ] dip ] unless ;
|
||||
|
||||
: may-be-rational ( class interval -- class' interval' )
|
||||
over null class<= [
|
||||
[ rational math-class-max ] dip
|
||||
] unless ;
|
||||
|
||||
: integer-valued ( class interval -- class' interval' )
|
||||
[ integer math-class-min ] dip ;
|
||||
|
||||
: real-valued ( class interval -- class' interval' )
|
||||
[ real math-class-min ] dip ;
|
||||
|
||||
: float-valued ( class interval -- class' interval' )
|
||||
over null class<= [
|
||||
[ drop float ] dip
|
||||
] unless ;
|
||||
|
||||
: binary-op ( word interval-quot post-proc-quot -- )
|
||||
'[
|
||||
[ binary-op-class ] [ , binary-op-interval ] 2bi
|
||||
@
|
||||
<class/interval-info>
|
||||
] +outputs+ set-word-prop ;
|
||||
|
||||
\ + [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
|
||||
\ + [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
|
||||
|
||||
\ - [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
|
||||
\ - [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
|
||||
|
||||
\ * [ [ interval* ] [ may-overflow ] binary-op ] each-derived-op
|
||||
\ * [ [ interval* ] [ ] binary-op ] each-fast-derived-op
|
||||
|
||||
\ shift [ [ interval-shift-safe ] [ may-overflow ] binary-op ] each-derived-op
|
||||
\ shift [ [ interval-shift-safe ] [ ] binary-op ] each-fast-derived-op
|
||||
|
||||
\ / [ [ interval/-safe ] [ may-be-rational ] binary-op ] each-derived-op
|
||||
\ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
|
||||
\ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
|
||||
|
||||
\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
|
||||
\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
|
||||
|
||||
\ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
|
||||
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
|
||||
\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
|
||||
|
||||
: assume-interval ( i1 i2 op -- i3 )
|
||||
{
|
||||
{ \ < [ assume< ] }
|
||||
{ \ > [ assume> ] }
|
||||
{ \ <= [ assume<= ] }
|
||||
{ \ >= [ assume>= ] }
|
||||
} case ;
|
||||
|
||||
: swap-comparison ( op -- op' )
|
||||
{
|
||||
{ < > }
|
||||
{ > < }
|
||||
{ <= >= }
|
||||
{ >= <= }
|
||||
} at ;
|
||||
|
||||
: negate-comparison ( op -- op' )
|
||||
{
|
||||
{ < >= }
|
||||
{ > <= }
|
||||
{ <= > }
|
||||
{ >= < }
|
||||
} at ;
|
||||
|
||||
:: (comparison-constraints) ( in1 in2 op -- constraint )
|
||||
[let | i1 [ in1 value-info interval>> ]
|
||||
i2 [ in2 value-info interval>> ] |
|
||||
i1 i2 and [
|
||||
in1 i1 i2 op assume-interval <interval-constraint>
|
||||
in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
|
||||
<conjunction>
|
||||
] [
|
||||
f
|
||||
] if
|
||||
] ;
|
||||
|
||||
: comparison-constraints ( in1 in2 out op -- constraint )
|
||||
swap [
|
||||
[ (comparison-constraints) ]
|
||||
[ negate-comparison (comparison-constraints) ]
|
||||
3bi
|
||||
] dip <conditional> ;
|
||||
|
||||
: comparison-op ( word op -- )
|
||||
'[
|
||||
[ in-d>> first2 ] [ out-d>> first ] bi
|
||||
, comparison-constraints
|
||||
] +constraints+ set-word-prop ;
|
||||
|
||||
{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
{ >bignum bignum }
|
||||
{ >float float }
|
||||
} [
|
||||
'[
|
||||
,
|
||||
[ nip ] [
|
||||
[ interval>> ] [ class-interval ] bi*
|
||||
interval-intersect'
|
||||
] 2bi
|
||||
<class/interval-info>
|
||||
] +outputs+ set-word-prop
|
||||
] assoc-each
|
||||
|
||||
!
|
||||
! {
|
||||
! alien-signed-1
|
||||
! alien-unsigned-1
|
||||
! alien-signed-2
|
||||
! alien-unsigned-2
|
||||
! alien-signed-4
|
||||
! alien-unsigned-4
|
||||
! alien-signed-8
|
||||
! alien-unsigned-8
|
||||
! } [
|
||||
! dup name>> {
|
||||
! {
|
||||
! [ "alien-signed-" ?head ]
|
||||
! [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
|
||||
! }
|
||||
! {
|
||||
! [ "alien-unsigned-" ?head ]
|
||||
! [ string>number 8 * 2^ 1- 0 swap [a,b] ]
|
||||
! }
|
||||
! } cond 1array
|
||||
! [ nip f swap ] curry "output-classes" set-word-prop
|
||||
! ] each
|
||||
!
|
||||
!
|
||||
! { <tuple> <tuple-boa> (tuple) } [
|
||||
! [
|
||||
! dup node-in-d peek node-literal
|
||||
! dup tuple-layout? [ class>> ] [ drop tuple ] if
|
||||
! 1array f
|
||||
! ] "output-classes" set-word-prop
|
||||
! ] each
|
||||
!
|
||||
! \ new [
|
||||
! dup node-in-d peek node-literal
|
||||
! dup class? [ drop tuple ] unless 1array f
|
||||
! ] "output-classes" set-word-prop
|
||||
!
|
||||
! ! the output of clone has the same type as the input
|
||||
! { clone (clone) } [
|
||||
! [
|
||||
! node-in-d [ value-class* ] map f
|
||||
! ] "output-classes" set-word-prop
|
||||
! ] each
|
||||
!
|
||||
! ! if the result of eq? is t and the second input is a literal,
|
||||
! ! the first input is equal to the second
|
||||
! \ eq? [
|
||||
! dup node-in-d second dup value? [
|
||||
! swap [
|
||||
! value-literal 0 `input literal,
|
||||
! \ f class-not 0 `output class,
|
||||
! ] set-constraints
|
||||
! ] [
|
||||
! 2drop
|
||||
! ] if
|
||||
! ] "constraints" set-word-prop
|
||||
|
||||
: and-constraints ( in1 in2 out -- constraint )
|
||||
[ [ <true-constraint> ] bi@ ] dip <conditional> ;
|
||||
|
||||
! XXX...
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors kernel
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.nodes
|
||||
|
||||
SYMBOL: +constraints+
|
||||
SYMBOL: +outputs+
|
||||
|
||||
GENERIC: propagate-before ( node -- )
|
||||
|
||||
GENERIC: propagate-after ( node -- )
|
||||
|
||||
GENERIC: propagate-around ( node -- )
|
||||
|
||||
: (propagate) ( node -- )
|
||||
[
|
||||
[ node-defs-values [ introduce-value ] each ]
|
||||
[ propagate-around ]
|
||||
[ successor>> ]
|
||||
tri
|
||||
(propagate)
|
||||
] when* ;
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
USING: kernel compiler.frontend compiler.tree
|
||||
compiler.tree.propagation tools.test math accessors
|
||||
sequences arrays kernel.private ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
: final-info ( quot -- seq )
|
||||
dataflow propagate last-node node-input-infos ;
|
||||
|
||||
: final-classes ( quot -- seq )
|
||||
final-info [ class>> ] map ;
|
||||
|
||||
: final-literals ( quot -- seq )
|
||||
final-info [ literal>> ] map ;
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
|
||||
|
||||
[ V{ array } ] [ [ 10 f <array> ] final-classes ] unit-test
|
||||
|
||||
[ V{ array } ] [ [ { array } declare ] final-classes ] unit-test
|
||||
|
||||
[ V{ array } ] [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
|
||||
|
||||
[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
|
||||
|
||||
[ V{ number } ] [ [ + ] final-classes ] unit-test
|
||||
|
||||
[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
|
||||
|
||||
[ V{ float } ] [ [ /f ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ /i ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[
|
||||
{ fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ { fixnum } declare [ 255 bitand ] keep + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ { fixnum } declare 615949 * ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ null } ] [
|
||||
[ { null null } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { null fixnum } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { float fixnum } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ 255 bitand >fixnum 3 bitor ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ 0 } ] [
|
||||
[ >fixnum 1 mod ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ 69 } ] [
|
||||
[ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ >fixnum dup 10 > [ 1 - ] when ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -1,37 +1,28 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences namespaces hashtables
|
||||
disjoint-sets
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.constraints
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.branches
|
||||
compiler.tree.propagation.recursive ;
|
||||
compiler.tree.propagation.recursive
|
||||
compiler.tree.propagation.constraints
|
||||
compiler.tree.propagation.known-words ;
|
||||
IN: compiler.tree.propagation
|
||||
|
||||
: (propagate) ( node -- )
|
||||
[
|
||||
[ node-defs-values [ introduce-value ] each ]
|
||||
[ propagate-around ]
|
||||
[ successor>> ]
|
||||
tri
|
||||
(propagate)
|
||||
] when* ;
|
||||
|
||||
: propagate-with ( node classes literals intervals -- )
|
||||
: propagate-with ( node infos -- )
|
||||
[
|
||||
H{ } clone constraints set
|
||||
>hashtable value-intervals set
|
||||
>hashtable value-literals set
|
||||
>hashtable value-classes set
|
||||
>hashtable value-infos set
|
||||
<disjoint-set> copies set
|
||||
(propagate)
|
||||
] with-scope ;
|
||||
|
||||
: propagate ( node -- node )
|
||||
dup f f f propagate-with ;
|
||||
dup f propagate-with ;
|
||||
|
||||
: propagate/node ( node existing -- )
|
||||
#! Infer classes, using the existing node's class info as a
|
||||
#! starting point.
|
||||
[ classes>> ] [ literals>> ] [ intervals>> ] tri
|
||||
propagate-with ;
|
||||
info>> propagate-with ;
|
||||
|
|
|
|||
|
|
@ -1,72 +1,32 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.tree compiler.tree.propagation.simple
|
||||
USING: kernel sequences accessors
|
||||
compiler.tree
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.branches ;
|
||||
IN: compiler.tree.propagation.recursive
|
||||
|
||||
! M: #recursive child-constraints
|
||||
! drop { f } ;
|
||||
!
|
||||
! M: #recursive propagate-around
|
||||
! [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
|
||||
!
|
||||
! : classes= ( inferred current -- ? )
|
||||
! 2dup min-length '[ , tail* ] bi@ sequence= ;
|
||||
!
|
||||
! SYMBOL: fixed-point?
|
||||
!
|
||||
! SYMBOL: nested-labels
|
||||
!
|
||||
! : annotate-entry ( nodes #label -- )
|
||||
! [ (merge-classes) ] dip node-child
|
||||
! 2dup node-output-classes classes=
|
||||
! [ 2drop ] [ set-classes fixed-point? off ] if ;
|
||||
!
|
||||
! : init-recursive-calls ( #label -- )
|
||||
! #! We set recursive calls to output the empty type, then
|
||||
! #! repeat inference until a fixed point is reached.
|
||||
! #! Hopefully, our type functions are monotonic so this
|
||||
! #! will always converge.
|
||||
! returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
|
||||
!
|
||||
! M: #label propagate-before ( #label -- )
|
||||
! [ init-recursive-calls ]
|
||||
! [ [ 1array ] keep annotate-entry ] bi ;
|
||||
!
|
||||
! : infer-label-loop ( #label -- )
|
||||
! fixed-point? on
|
||||
! dup node-child (propagate)
|
||||
! dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
|
||||
! fixed-point? get [ drop ] [ infer-label-loop ] if ;
|
||||
!
|
||||
! M: #label propagate-around ( #label -- )
|
||||
! #! Now merge the types at every recursion point with the
|
||||
! #! entry types.
|
||||
! [
|
||||
! {
|
||||
! [ nested-labels get push ]
|
||||
! [ annotate-node ]
|
||||
! [ propagate-before ]
|
||||
! [ infer-label-loop ]
|
||||
! [ drop nested-labels get pop* ]
|
||||
! } cleave
|
||||
! ] with-scope ;
|
||||
!
|
||||
! : find-label ( param -- #label )
|
||||
! word>> nested-labels get [ word>> eq? ] with find nip ;
|
||||
!
|
||||
! M: #call-recursive propagate-before ( #call-label -- )
|
||||
! [ label>> returns>> (merge-classes) ] [ out-d>> ] bi
|
||||
! [ set-value-class ] 2each ;
|
||||
!
|
||||
! M: #return propagate-around
|
||||
! nested-labels get length 0 > [
|
||||
! dup word>> nested-labels get peek word>> eq? [
|
||||
! [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
|
||||
! classes= not [
|
||||
! fixed-point? off
|
||||
! [ in-d>> value-classes get valid-keys ] keep
|
||||
! set-node-classes
|
||||
! ] [ drop ] if
|
||||
! ] [ call-next-method ] if
|
||||
! ] [ call-next-method ] if ;
|
||||
: (merge-value-infos) ( inputs -- infos )
|
||||
[ [ value-info ] map value-infos-union ] map ;
|
||||
|
||||
: merge-value-infos ( inputs outputs -- fixed-point? )
|
||||
[ (merge-value-infos) ] dip
|
||||
[ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
|
||||
|
||||
: propagate-recursive-phi ( #phi -- fixed-point? )
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
bi and ;
|
||||
|
||||
M: #recursive propagate-around ( #recursive -- )
|
||||
dup
|
||||
[ children>> (propagate) ]
|
||||
[ node-child propagate-recursive-phi ] bi
|
||||
[ drop ] [ propagate-around ] if ;
|
||||
|
||||
M: #call-recursive propagate-before ( #call-label -- )
|
||||
#! What if we reach a fixed point for the phi but not for the
|
||||
#! #call-label output?
|
||||
[ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
|
||||
|
|
|
|||
|
|
@ -1,25 +1,39 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors kernel sequences assocs words namespaces
|
||||
combinators classes.algebra compiler.tree
|
||||
classes.algebra combinators classes
|
||||
compiler.tree
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.constraints ;
|
||||
IN: compiler.tree.propagation.simple
|
||||
|
||||
GENERIC: propagate-before ( node -- )
|
||||
|
||||
M: #introduce propagate-before
|
||||
values>> [ object swap set-value-class ] each ;
|
||||
object <class-info> swap values>> [ set-value-info ] with each ;
|
||||
|
||||
M: #push propagate-before
|
||||
[ literal>> ] [ out-d>> first ] bi set-value-literal ;
|
||||
[ literal>> value>> <literal-info> ] [ out-d>> first ] bi
|
||||
set-value-info ;
|
||||
|
||||
: refine-value-infos ( classes values -- )
|
||||
[ refine-value-info ] 2each ;
|
||||
|
||||
: class-infos ( classes -- infos )
|
||||
[ <class-info> ] map ;
|
||||
|
||||
: set-value-infos ( infos values -- )
|
||||
[ set-value-info ] 2each ;
|
||||
|
||||
M: #declare propagate-before
|
||||
[ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
|
||||
[ [ declaration>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
|
||||
bi ;
|
||||
[
|
||||
[ declaration>> class-infos ] [ out-d>> ] bi
|
||||
refine-value-infos
|
||||
] bi ;
|
||||
|
||||
M: #shuffle propagate-before
|
||||
[ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
|
||||
[ out-d>> dup ] [ mapping>> ] bi
|
||||
'[ , at ] map swap are-copies-of ;
|
||||
|
||||
M: #>r propagate-before
|
||||
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
|
||||
|
|
@ -30,83 +44,53 @@ M: #r> propagate-before
|
|||
M: #copy propagate-before
|
||||
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
||||
|
||||
: intersect-classes ( classes values -- )
|
||||
[ intersect-value-class ] 2each ;
|
||||
: predicate-constraints ( value class boolean-value -- constraint )
|
||||
[ [ <class-constraint> ] dip if-true ]
|
||||
[ [ class-not <class-constraint> ] dip if-false ]
|
||||
3bi <conjunction> ;
|
||||
|
||||
: intersect-intervals ( intervals values -- )
|
||||
[ intersect-value-interval ] 2each ;
|
||||
|
||||
: predicate-constraints ( class #call -- )
|
||||
[
|
||||
! If word outputs true, input is an instance of class
|
||||
: compute-constraints ( #call -- constraint )
|
||||
dup word>> +constraints+ word-prop [ call assume ] [
|
||||
dup word>> predicate?
|
||||
[
|
||||
0 `input class,
|
||||
\ f class-not 0 `output class,
|
||||
] set-constraints
|
||||
] [
|
||||
! If word outputs false, input is not an instance of class
|
||||
[
|
||||
class-not 0 `input class,
|
||||
\ f 0 `output class,
|
||||
] set-constraints
|
||||
] 2bi ;
|
||||
|
||||
: compute-constraints ( #call -- )
|
||||
dup word>> "constraints" word-prop [
|
||||
call
|
||||
] [
|
||||
dup word>> "predicating" word-prop dup
|
||||
[ swap predicate-constraints ] [ 2drop ] if
|
||||
[ in-d>> first ]
|
||||
[ word>> "predicating" word-prop ]
|
||||
[ out-d>> first ]
|
||||
tri predicate-constraints assume
|
||||
] [ drop ] if
|
||||
] if* ;
|
||||
|
||||
: compute-output-classes ( node word -- classes intervals )
|
||||
dup word>> "output-classes" word-prop
|
||||
dup [ call ] [ 2drop f f ] if ;
|
||||
: default-output-value-infos ( node -- infos )
|
||||
dup word>> "default-output-classes" word-prop [
|
||||
class-infos
|
||||
] [
|
||||
out-d>> length object <class-info> <repetition>
|
||||
] ?if ;
|
||||
|
||||
: output-classes ( node -- classes intervals )
|
||||
dup compute-output-classes [
|
||||
[ ] [ word>> "default-output-classes" word-prop ] ?if
|
||||
] dip ;
|
||||
: call-outputs-quot ( node quot -- infos )
|
||||
[ in-d>> [ value-info ] map ] dip with-datastack ;
|
||||
|
||||
: intersect-values ( classes intervals values -- )
|
||||
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
|
||||
: output-value-infos ( node word -- infos )
|
||||
dup word>> +outputs+ word-prop
|
||||
[ call-outputs-quot ] [ default-output-value-infos ] if* ;
|
||||
|
||||
M: #call propagate-before
|
||||
[ compute-constraints ]
|
||||
[ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
|
||||
[ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] bi ;
|
||||
|
||||
M: node propagate-before drop ;
|
||||
|
||||
GENERIC: propagate-after ( node -- )
|
||||
|
||||
: input-classes ( #call -- classes )
|
||||
word>> "input-classes" word-prop ;
|
||||
|
||||
M: #call propagate-after
|
||||
[ input-classes ] [ in-d>> ] bi intersect-classes ;
|
||||
dup word>> "input-classes" word-prop dup [
|
||||
class-infos swap in-d>> refine-value-infos
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: node propagate-after drop ;
|
||||
|
||||
GENERIC: propagate-around ( node -- )
|
||||
|
||||
: valid-keys ( seq assoc -- newassoc )
|
||||
'[ dup resolve-copy , at ] H{ } map>assoc
|
||||
[ nip ] assoc-filter
|
||||
f assoc-like ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
#! Annotate the node with the currently-inferred set of
|
||||
#! value classes.
|
||||
dup node-values {
|
||||
[ value-intervals get valid-keys >>intervals ]
|
||||
[ value-classes get valid-keys >>classes ]
|
||||
[ value-literals get valid-keys >>literals ]
|
||||
[ 2drop ]
|
||||
} cleave ;
|
||||
dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
|
||||
|
||||
M: object propagate-around
|
||||
{
|
||||
[ propagate-before ]
|
||||
[ annotate-node ]
|
||||
[ propagate-after ]
|
||||
} cleave ;
|
||||
M: node propagate-around
|
||||
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
|
||||
|
|
|
|||
|
|
@ -18,8 +18,7 @@ IN: compiler.tree
|
|||
! 3) A value is never used in the same node where it is defined.
|
||||
|
||||
TUPLE: node < identity-tuple
|
||||
in-d out-d in-r out-r
|
||||
classes literals intervals
|
||||
in-d out-d in-r out-r info
|
||||
history successor children ;
|
||||
|
||||
M: node hashcode* drop node hashcode* ;
|
||||
|
|
@ -31,7 +30,7 @@ M: node hashcode* drop node hashcode* ;
|
|||
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
|
||||
4array concat ;
|
||||
|
||||
: node-child ( node -- child ) node-children first ;
|
||||
: node-child ( node -- child ) children>> first ;
|
||||
|
||||
: last-node ( node -- last )
|
||||
dup successor>> [ last-node ] [ ] ?if ;
|
||||
|
|
@ -44,29 +43,14 @@ M: node hashcode* drop node hashcode* ;
|
|||
2drop f
|
||||
] if ;
|
||||
|
||||
: node-literal? ( node value -- ? )
|
||||
swap literals>> key? ;
|
||||
: node-value-info ( node value -- info )
|
||||
swap info>> at ;
|
||||
|
||||
: node-literal ( node value -- obj )
|
||||
swap literals>> at ;
|
||||
: node-input-infos ( node -- seq )
|
||||
dup in-d>> [ node-value-info ] with map ;
|
||||
|
||||
: node-interval ( node value -- interval )
|
||||
swap intervals>> at ;
|
||||
|
||||
: node-class ( node value -- class )
|
||||
swap classes>> at ;
|
||||
|
||||
: node-input-classes ( node -- seq )
|
||||
dup in-d>> [ node-class ] with map ;
|
||||
|
||||
: node-output-classes ( node -- seq )
|
||||
dup out-d>> [ node-class ] with map ;
|
||||
|
||||
: node-input-intervals ( node -- seq )
|
||||
dup in-d>> [ node-interval ] with map ;
|
||||
|
||||
: node-class-first ( node -- class )
|
||||
dup in-d>> first node-class ;
|
||||
: node-output-infos ( node -- seq )
|
||||
dup out-d>> [ node-value-info ] with map ;
|
||||
|
||||
TUPLE: #introduce < node values ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
IN: optimizer.math.partial.tests
|
||||
USING: math.partial-dispatch tools.test math kernel sequences ;
|
||||
|
||||
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
|
||||
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
|
||||
[ t ] [ \ + integer bignum math-both-known? ] unit-test
|
||||
[ t ] [ \ + float fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ + real fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ + object number math-both-known? ] unit-test
|
||||
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
|
||||
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
|
||||
|
|
@ -0,0 +1,174 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel kernel.private math math.private words
|
||||
sequences parser namespaces assocs quotations arrays
|
||||
generic generic.math hashtables effects compiler.units ;
|
||||
IN: math.partial-dispatch
|
||||
|
||||
! Partial dispatch.
|
||||
|
||||
! This code will be overhauled and generalized when
|
||||
! multi-methods go into the core.
|
||||
PREDICATE: math-partial < word
|
||||
"derived-from" word-prop >boolean ;
|
||||
|
||||
: fixnum-integer-op ( a b fix-word big-word -- c )
|
||||
pick tag 0 eq? [
|
||||
drop execute
|
||||
] [
|
||||
>r drop >r fixnum>bignum r> r> execute
|
||||
] if ; inline
|
||||
|
||||
: integer-fixnum-op ( a b fix-word big-word -- c )
|
||||
>r pick tag 0 eq? [
|
||||
r> drop execute
|
||||
] [
|
||||
drop fixnum>bignum r> execute
|
||||
] if ; inline
|
||||
|
||||
: integer-integer-op ( a b fix-word big-word -- c )
|
||||
pick tag 0 eq? [
|
||||
integer-fixnum-op
|
||||
] [
|
||||
>r drop over tag 0 eq? [
|
||||
>r fixnum>bignum r> r> execute
|
||||
] [
|
||||
r> execute
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: integer-op-combinator ( triple -- word )
|
||||
[
|
||||
[ second name>> % "-" % ]
|
||||
[ third name>> % "-op" % ]
|
||||
bi
|
||||
] "" make "math.partial-dispatch" lookup ;
|
||||
|
||||
: integer-op-word ( triple fix-word big-word -- word )
|
||||
[
|
||||
drop
|
||||
name>> "fast" tail? >r
|
||||
[ "-" % ] [ name>> % ] interleave
|
||||
r> [ "-fast" % ] when
|
||||
] "" make "math.partial-dispatch" create ;
|
||||
|
||||
: integer-op-quot ( word fix-word big-word -- quot )
|
||||
rot integer-op-combinator 1quotation 2curry ;
|
||||
|
||||
: define-integer-op-word ( word fix-word big-word -- )
|
||||
[
|
||||
[ integer-op-word ] [ integer-op-quot ] 3bi
|
||||
(( x y -- z )) define-declared
|
||||
]
|
||||
[
|
||||
[ integer-op-word ] [ 2drop ] 3bi
|
||||
"derived-from" set-word-prop
|
||||
] 3bi ;
|
||||
|
||||
: define-integer-op-words ( words fix-word big-word -- )
|
||||
[ define-integer-op-word ] 2curry each ;
|
||||
|
||||
: integer-op-triples ( word -- triples )
|
||||
{
|
||||
{ fixnum integer }
|
||||
{ integer fixnum }
|
||||
{ integer integer }
|
||||
} swap [ prefix ] curry map ;
|
||||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
>r >r integer-op-triples r> r>
|
||||
[ define-integer-op-words ]
|
||||
[ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
|
||||
3bi ;
|
||||
|
||||
: define-math-ops ( op -- )
|
||||
{ fixnum bignum float }
|
||||
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
|
||||
[ nip ] assoc-filter
|
||||
[ def>> peek ] assoc-map % ;
|
||||
|
||||
SYMBOL: math-ops
|
||||
|
||||
SYMBOL: fast-math-ops
|
||||
|
||||
: math-op ( word left right -- word' ? )
|
||||
3array math-ops get at* ;
|
||||
|
||||
: math-method* ( word left right -- quot )
|
||||
3dup math-op
|
||||
[ >r 3drop r> 1quotation ] [ drop math-method ] if ;
|
||||
|
||||
: math-both-known? ( word left right -- ? )
|
||||
3dup math-op
|
||||
[ 2drop 2drop t ]
|
||||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap [ rot first eq? nip ] curry assoc-filter values ;
|
||||
|
||||
: derived-ops ( word -- words )
|
||||
[ 1array ]
|
||||
[ math-ops get (derived-ops) ]
|
||||
bi append ;
|
||||
|
||||
: fast-derived-ops ( word -- words )
|
||||
fast-math-ops get (derived-ops) ;
|
||||
|
||||
: all-derived-ops ( word -- words )
|
||||
[ derived-ops ] [ fast-derived-ops ] bi append ;
|
||||
|
||||
: each-derived-op ( word quot -- )
|
||||
>r derived-ops r> each ; inline
|
||||
|
||||
: each-fast-derived-op ( word quot -- )
|
||||
>r fast-derived-ops r> each ; inline
|
||||
|
||||
[
|
||||
[
|
||||
\ + define-math-ops
|
||||
\ - define-math-ops
|
||||
\ * define-math-ops
|
||||
\ shift define-math-ops
|
||||
\ mod define-math-ops
|
||||
\ /i define-math-ops
|
||||
|
||||
\ bitand define-math-ops
|
||||
\ bitor define-math-ops
|
||||
\ bitxor define-math-ops
|
||||
|
||||
\ < define-math-ops
|
||||
\ <= define-math-ops
|
||||
\ > define-math-ops
|
||||
\ >= define-math-ops
|
||||
\ number= define-math-ops
|
||||
|
||||
\ + \ fixnum+ \ bignum+ define-integer-ops
|
||||
\ - \ fixnum- \ bignum- define-integer-ops
|
||||
\ * \ fixnum* \ bignum* define-integer-ops
|
||||
\ shift \ fixnum-shift \ bignum-shift define-integer-ops
|
||||
\ mod \ fixnum-mod \ bignum-mod define-integer-ops
|
||||
\ /i \ fixnum/i \ bignum/i define-integer-ops
|
||||
|
||||
\ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
|
||||
\ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
|
||||
\ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
|
||||
|
||||
\ < \ fixnum< \ bignum< define-integer-ops
|
||||
\ <= \ fixnum<= \ bignum<= define-integer-ops
|
||||
\ > \ fixnum> \ bignum> define-integer-ops
|
||||
\ >= \ fixnum>= \ bignum>= define-integer-ops
|
||||
\ number= \ eq? \ bignum= define-integer-ops
|
||||
] { } make >hashtable math-ops set-global
|
||||
|
||||
[
|
||||
{ { + fixnum fixnum } fixnum+fast } ,
|
||||
{ { - fixnum fixnum } fixnum-fast } ,
|
||||
{ { * fixnum fixnum } fixnum*fast } ,
|
||||
{ { shift fixnum fixnum } fixnum-shift-fast } ,
|
||||
|
||||
\ + \ fixnum+fast \ bignum+ define-integer-ops
|
||||
\ - \ fixnum-fast \ bignum- define-integer-ops
|
||||
\ * \ fixnum*fast \ bignum* define-integer-ops
|
||||
\ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
|
||||
] { } make >hashtable fast-math-ops set-global
|
||||
] with-compilation-unit
|
||||
|
|
@ -12,7 +12,7 @@ IN: stack-checker.branches
|
|||
: phi-inputs ( seq -- newseq )
|
||||
dup empty? [
|
||||
dup [ length ] map supremum
|
||||
'[ , f pad-left ] map
|
||||
'[ , f pad-left ] map flip
|
||||
] unless ;
|
||||
|
||||
: unify-values ( values -- phi-out )
|
||||
|
|
@ -20,7 +20,7 @@ IN: stack-checker.branches
|
|||
[ nip first make-known ] [ 2drop <value> ] if ;
|
||||
|
||||
: phi-outputs ( phi-in -- stack )
|
||||
flip [ unify-values ] map ;
|
||||
[ unify-values ] map ;
|
||||
|
||||
SYMBOL: quotations
|
||||
|
||||
|
|
@ -47,7 +47,7 @@ SYMBOL: quotations
|
|||
: retainstack-phi ( seq -- phi-in phi-out )
|
||||
[ length 0 <repetition> ] [ meta-r active-variable ] bi
|
||||
unify-branches
|
||||
[ drop ] [ ] [ dup meta-r set ] tri* ;
|
||||
[ drop ] [ ] [ dup >vector meta-r set ] tri* ;
|
||||
|
||||
: compute-phi-function ( seq -- )
|
||||
[ quotation active-variable sift quotations set ]
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ SYMBOL: phi-out
|
|||
[
|
||||
[ call-site-stack ] dip
|
||||
[ check-call-site-stack ]
|
||||
[ phi-in>> push ]
|
||||
[ phi-in>> swap [ suffix ] 2change-each ]
|
||||
2bi
|
||||
] 2bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ IN: stack-checker.known-words
|
|||
|
||||
\ declare [
|
||||
pop-literal nip
|
||||
[ length consume-d dup copy-values ] keep
|
||||
[ length consume-d dup copy-values dup output-d ] keep
|
||||
#declare,
|
||||
] +infer+ set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: stack-checker.transforms
|
|||
dup zero? [
|
||||
drop '[ recursive-state get @ ]
|
||||
] [
|
||||
'[
|
||||
swap '[
|
||||
, consume-d
|
||||
[ first literal recursion>> ]
|
||||
[ [ literal value>> ] each ] bi @
|
||||
|
|
|
|||
Loading…
Reference in New Issue