From f1268db79a540ba35c2ab1e9427e0c68012ec257 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 21 Jul 2008 20:48:30 -0500
Subject: [PATCH 1/7] Fix test
---
core/math/parser/parser-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor
index c16a031690..cee2314d07 100755
--- a/core/math/parser/parser-tests.factor
+++ b/core/math/parser/parser-tests.factor
@@ -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
From af09eae727be83071222f7231c44c52b579295aa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Jul 2008 01:27:39 -0500
Subject: [PATCH 2/7] Add some more interval operations
---
core/math/intervals/intervals-docs.factor | 13 ++++-
core/math/intervals/intervals-tests.factor | 51 +++++++++++++-----
core/math/intervals/intervals.factor | 62 ++++++++++++++++++----
core/math/math-docs.factor | 28 ++++------
core/math/math.factor | 2 +-
5 files changed, 112 insertions(+), 44 deletions(-)
diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor
index 59fb0df18e..d6b3935b17 100644
--- a/core/math/intervals/intervals-docs.factor
+++ b/core/math/intervals/intervals-docs.factor
@@ -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? }
diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index faf04d305e..f8dce14a06 100755
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -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
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 9b994b4bbf..66d829e0ae 100755
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -36,6 +36,8 @@ C: <interval> interval
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
+: [-inf,inf] ( -- interval ) -1./0. 1./0. [a,b] ; foldable
+
: compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [
2drop t
@@ -154,7 +156,7 @@ C: <interval> interval
: interval-shift-safe ( i1 i2 -- i3 )
dup to>> first 100 > [
- 2drop f
+ 2drop [-inf,inf]
] [
interval-shift
] if ;
@@ -172,7 +174,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 +189,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 +215,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 +256,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 ;
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index f75a63eefc..237438e69a 100755
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -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 } ;
diff --git a/core/math/math.factor b/core/math/math.factor
index 457dddceeb..4efca0ef2f 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -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
From 0582f45fcb0464590ebe8621786be90f7d834927 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Jul 2008 01:27:52 -0500
Subject: [PATCH 3/7] Add more class algebra opeations
---
core/classes/algebra/algebra-tests.factor | 2 --
core/classes/algebra/algebra.factor | 3 +++
core/generic/math/math.factor | 10 ++++++++--
3 files changed, 11 insertions(+), 4 deletions(-)
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 665fc86ebb..350c2fd66f 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -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= ;
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 00657f48c4..23695c06f8 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -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* ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 1c1368a6c2..834e19d9d9 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -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 ;
From b42c845d480e4e9e6f8c3ea221c08286e8b319e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Jul 2008 04:44:21 -0500
Subject: [PATCH 4/7] Update intervals docs
---
core/math/intervals/intervals-docs.factor | 46 ++++++++++++++++++++---
core/math/intervals/intervals.factor | 3 +-
2 files changed, 43 insertions(+), 6 deletions(-)
diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor
index d6b3935b17..077ffd6d28 100644
--- a/core/math/intervals/intervals-docs.factor
+++ b/core/math/intervals/intervals-docs.factor
@@ -62,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" }
@@ -153,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" } "." } ;
@@ -169,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 } "." } ;
@@ -190,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 } }
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 66d829e0ae..2d7596d126 100755
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -36,7 +36,8 @@ C: <interval> interval
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
-: [-inf,inf] ( -- interval ) -1./0. 1./0. [a,b] ; foldable
+: [-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 [
From 47376d86f8d7b6a65f727e95d2b268bee9ef92dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Jul 2008 04:44:33 -0500
Subject: [PATCH 5/7] Add 2map-into, 2change-each
---
core/sequences/sequences.factor | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 349d68adc5..c3126abf0d 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -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
From 49d34ab8a7ea865108a16d8b54bb9d7316e5ac49 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Jul 2008 04:44:44 -0500
Subject: [PATCH 6/7] Cleanup
---
extra/math/ratios/ratios.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor
index b71a34022a..6569ee9540 100755
--- a/extra/math/ratios/ratios.factor
+++ b/extra/math/ratios/ratios.factor
@@ -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 ;
From 1f27b9252ee5de9f59fa0b401c22837a0fb2c488 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Jul 2008 04:45:03 -0500
Subject: [PATCH 7/7] Working on propagation pass
---
.../compiler/tree/dead-code/dead-code.factor | 12 +-
.../compiler/tree/def-use/def-use.factor | 10 +-
.../tree/propagation/branches/branches.factor | 59 ++--
.../constraints/constraints.factor | 180 +++++-------
.../tree/propagation/info/info-tests.factor | 50 ++++
.../tree/propagation/info/info.factor | 128 +++++++++
.../known-words/known-words.factor | 271 ++++++++++++++++++
.../tree/propagation/nodes/nodes.factor | 24 ++
.../tree/propagation/propagation-tests.factor | 89 ++++++
.../tree/propagation/propagation.factor | 31 +-
.../propagation/recursive/recursive.factor | 94 ++----
.../tree/propagation/simple/simple.factor | 124 ++++----
unfinished/compiler/tree/tree.factor | 32 +--
.../partial-dispatch-tests.factor | 12 +
.../partial-dispatch/partial-dispatch.factor | 174 +++++++++++
.../stack-checker/branches/branches.factor | 6 +-
.../stack-checker/inlining/inlining.factor | 2 +-
.../known-words/known-words.factor | 2 +-
.../transforms/transforms.factor | 2 +-
19 files changed, 949 insertions(+), 353 deletions(-)
create mode 100644 unfinished/compiler/tree/propagation/info/info-tests.factor
create mode 100644 unfinished/compiler/tree/propagation/info/info.factor
create mode 100644 unfinished/compiler/tree/propagation/known-words/known-words.factor
create mode 100644 unfinished/compiler/tree/propagation/nodes/nodes.factor
create mode 100644 unfinished/compiler/tree/propagation/propagation-tests.factor
create mode 100644 unfinished/math/partial-dispatch/partial-dispatch-tests.factor
create mode 100644 unfinished/math/partial-dispatch/partial-dispatch.factor
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 89e2397045..4ad61afd19 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -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
diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor
index 7a1485826b..cc5b1aaf57 100755
--- a/unfinished/compiler/tree/def-use/def-use.factor
+++ b/unfinished/compiler/tree/def-use/def-use.factor
@@ -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 [
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index 98ca00df9e..b95b7f0750 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -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 ;
diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor
index 628de3e039..0d4216a649 100644
--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor
@@ -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> ;
diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor
new file mode 100644
index 0000000000..18b9977f7f
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@@ -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
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
new file mode 100644
index 0000000000..25872173d0
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -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< ;
diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
new file mode 100644
index 0000000000..900060feb5
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@@ -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...
diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor
new file mode 100644
index 0000000000..a996e32959
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor
@@ -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* ;
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
new file mode 100644
index 0000000000..06374e7783
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -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
diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor
index f8e760ea0c..ff822f6f92 100755
--- a/unfinished/compiler/tree/propagation/propagation.factor
+++ b/unfinished/compiler/tree/propagation/propagation.factor
@@ -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 ;
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index b19dbd9052..2223e1dd13 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -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 ;
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 21aa9c9522..1c77fe1fc6 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -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 ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 6f87869a66..e528a48db9 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -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 ;
diff --git a/unfinished/math/partial-dispatch/partial-dispatch-tests.factor b/unfinished/math/partial-dispatch/partial-dispatch-tests.factor
new file mode 100644
index 0000000000..92a5b849a4
--- /dev/null
+++ b/unfinished/math/partial-dispatch/partial-dispatch-tests.factor
@@ -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
diff --git a/unfinished/math/partial-dispatch/partial-dispatch.factor b/unfinished/math/partial-dispatch/partial-dispatch.factor
new file mode 100644
index 0000000000..625770e09f
--- /dev/null
+++ b/unfinished/math/partial-dispatch/partial-dispatch.factor
@@ -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
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index 1c4e5ddfe4..55aa452c10 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@@ -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 ]
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 560fd89496..45252f117f 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -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 ;
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index d3ca657c14..362c4f1394 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -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
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index 4572d9532c..c379bced75 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -11,7 +11,7 @@ IN: stack-checker.transforms
dup zero? [
drop '[ recursive-state get @ ]
] [
- '[
+ swap '[
, consume-d
[ first literal recursion>> ]
[ [ literal value>> ] each ] bi @