Merge branch 'master' of factorcode.org:/git/factor

db4
Eduardo Cavazos 2008-07-22 11:32:39 -05:00
commit e799acd1c3
30 changed files with 1124 additions and 410 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -11,7 +11,7 @@ IN: stack-checker.transforms
dup zero? [
drop '[ recursive-state get @ ]
] [
'[
swap '[
, consume-d
[ first literal recursion>> ]
[ [ literal value>> ] each ] bi @