From e4f8448eb140f2ab8e399675e74fb53e897cd152 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 19:44:49 -0600 Subject: [PATCH] Fix some problems with arithmetic type inference, exposed by recent changes to log2 word - declared input type for bignum-shift was stricter than the runtime behavior, leading to bad propagation of type info if shift count was a bignum - types inferred for type functions which used number-valued/integer-valued/real-valued were not always precise, eg bignum bignum bitxor => integer - add interval-log2, type function for (log2) - remove math-class-min, it was useless --- basis/compiler/tests/optimizer.factor | 6 ++ .../known-words/known-words.factor | 33 ++++--- .../tree/propagation/propagation-tests.factor | 90 +++++++++++++------ basis/math/intervals/intervals-docs.factor | 7 +- basis/math/intervals/intervals.factor | 16 +++- core/generic/math/math.factor | 3 - core/math/integers/integers.factor | 5 +- core/math/math.factor | 5 +- vm/math.c | 2 +- 9 files changed, 116 insertions(+), 51 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 41df6e7ae5..fa6a3c7b21 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -375,3 +375,9 @@ DEFER: loop-bbb : loop-ccc ( -- ) loop-bbb ; [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test + +! Type inference issue +[ 4 3 ] [ + 1 >bignum 2 >bignum + [ { bignum integer } declare [ shift ] keep 1+ ] compile-call +] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 8242311287..4d8d935477 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -1,11 +1,12 @@ ! 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 math.parser math.order -layouts words sequences sequences.private arrays assocs classes -classes.algebra combinators generic.math splitting fry locals -classes.tuple alien.accessors classes.tuple.private slots.private -definitions strings.private vectors hashtables +USING: kernel effects accessors math math.private +math.integers.private math.partial-dispatch math.intervals +math.parser math.order layouts words sequences sequences.private +arrays assocs classes classes.algebra combinators generic.math +splitting fry locals classes.tuple alien.accessors +classes.tuple.private slots.private definitions strings.private +vectors hashtables stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b] [ rational math-class-max ] dip ] unless ; +: ensure-math-class ( class must-be -- class' ) + [ class<= ] 2keep ? ; + : number-valued ( class interval -- class' interval' ) - [ number math-class-min ] dip ; + [ number ensure-math-class ] dip ; : integer-valued ( class interval -- class' interval' ) - [ integer math-class-min ] dip ; + [ integer ensure-math-class ] dip ; : real-valued ( class interval -- class' interval' ) - [ real math-class-min ] dip ; + [ real ensure-math-class ] dip ; : float-valued ( class interval -- class' interval' ) over null-class? [ @@ -230,7 +234,7 @@ generic-comparison-ops [ } [ [ in-d>> second value-info >literal< - [ power-of-2? [ 1- bitand ] f ? ] when + [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when ] "custom-inlining" set-word-prop ] each @@ -247,6 +251,15 @@ generic-comparison-ops [ ] "custom-inlining" set-word-prop ] each +{ numerator denominator } +[ [ drop integer ] "outputs" set-word-prop ] each + +{ (log2) fixnum-log2 bignum-log2 } [ + [ + [ class>> ] [ interval>> interval-log2 ] bi + ] "outputs" set-word-prop +] each + \ string-nth [ 2drop fixnum 0 23 2^ [a,b] ] "outputs" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index aa04b58de7..d95245fe83 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -34,17 +34,57 @@ IN: compiler.tree.propagation.tests [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test -[ V{ number } ] [ [ + ] final-classes ] unit-test +! Test type propagation for math ops +: cleanup-math-class ( obj -- class ) + { null fixnum bignum integer ratio rational float real complex number } + [ class= ] with find nip ; -[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test +: final-math-class ( quot -- class ) + final-classes first cleanup-math-class ; -[ V{ float } ] [ [ /f ] final-classes ] unit-test +[ number ] [ [ + ] final-math-class ] unit-test -[ V{ integer } ] [ [ /i ] final-classes ] unit-test +[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test -[ V{ integer } ] [ - [ { integer } declare bitnot ] final-classes -] unit-test +[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test + +[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test + +[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test + +[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test + +[ float ] [ [ { real float } declare + ] final-math-class ] unit-test + +[ float ] [ [ { float real } declare + ] final-math-class ] unit-test + +[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test + +[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test + +[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test + +[ float ] [ [ /f ] final-math-class ] unit-test + +[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test + +[ integer ] [ [ /i ] final-math-class ] unit-test + +[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test + +[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test + +[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test + +[ null ] [ [ { null null } declare + ] final-math-class ] unit-test + +[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test + +[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test + +[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test + +[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test [ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test @@ -66,18 +106,6 @@ IN: compiler.tree.propagation.tests [ { fixnum } declare 615949 * ] final-classes ] unit-test -[ V{ null } ] [ - [ { null null } declare + ] final-classes -] unit-test - -[ V{ null } ] [ - [ { 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 @@ -279,14 +307,6 @@ IN: compiler.tree.propagation.tests ] final-classes ] unit-test -[ V{ float } ] [ - [ { real float } declare + ] final-classes -] unit-test - -[ V{ float } ] [ - [ { float real } declare + ] final-classes -] unit-test - [ V{ fixnum } ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes ] unit-test @@ -604,6 +624,22 @@ MIXIN: empty-mixin [ { integer } declare 127 bitand ] final-info first interval>> ] unit-test +[ V{ bignum } ] [ + [ { bignum } declare dup 1- bitxor ] final-classes +] unit-test + +[ V{ bignum integer } ] [ + [ { bignum integer } declare [ shift ] keep ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum } declare log2 ] final-classes +] unit-test + +[ V{ word } ] [ + [ { fixnum } declare log2 0 >= ] final-classes +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index 5a96c7aceb..d8a80340ba 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic" { $subsection interval-bitnot } { $subsection interval-recip } { $subsection interval-2/ } -{ $subsection interval-abs } ; +{ $subsection interval-abs } +{ $subsection interval-log2 } ; ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals" { $subsection interval-contains? } @@ -203,6 +204,10 @@ HELP: interval-abs { $values { "i1" interval } { "i2" interval } } { $description "Absolute value of an interval." } ; +HELP: interval-log2 +{ $values { "i1" interval } { "i2" interval } } +{ $description "Integer-valued Base-2 logarithm 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 } "." } ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4182d25524..ed76ccaedd 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. USING: accessors kernel sequences arrays math math.order -combinators generic ; +combinators generic layouts ; IN: math.intervals SYMBOL: empty-interval @@ -365,7 +365,7 @@ SYMBOL: incomparable 2dup [ interval-nonnegative? ] both? [ [ interval>points [ first ] bi@ ] bi@ - 4array supremum 0 swap next-power-of-2 [a,b] + 4array supremum 0 swap >integer next-power-of-2 [a,b] ] [ 2drop [-inf,inf] ] if ] do-empty-interval ; @@ -373,6 +373,18 @@ SYMBOL: incomparable #! Inaccurate. interval-bitor ; +: interval-log2 ( i1 -- i2 ) + { + { empty-interval [ empty-interval ] } + { full-interval [ 0 [a,inf] ] } + [ + to>> first 1 max dup most-positive-fixnum > + [ drop full-interval interval-log2 ] + [ 1+ >integer log2 0 swap [a,b] ] + if + ] + } case ; + : assume< ( i1 i2 -- i3 ) dup special-interval? [ drop ] [ to>> first [-inf,a) interval-intersect diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 63043b50b9..66f2da7191 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -28,9 +28,6 @@ PREDICATE: math-class < class : 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 ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 910d394c55..30903e3269 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -45,9 +45,6 @@ M: fixnum bit? neg shift 1 bitand 0 > ; M: fixnum (log2) fixnum-log2 ; -M: integer next-power-of-2 - dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; - M: bignum >fixnum bignum>fixnum ; M: bignum >bignum ; @@ -76,7 +73,7 @@ M: bignum /mod bignum/mod ; M: bignum bitand bignum-bitand ; M: bignum bitor bignum-bitor ; M: bignum bitxor bignum-bitxor ; -M: bignum shift bignum-shift ; +M: bignum shift >fixnum bignum-shift ; M: bignum bitnot bignum-bitnot ; M: bignum bit? bignum-bit? ; diff --git a/core/math/math.factor b/core/math/math.factor index 8b064725d3..2434bf8ec6 100644 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -103,9 +103,8 @@ M: float fp-infinity? ( float -- ? ) drop f ] if ; -GENERIC: next-power-of-2 ( m -- n ) foldable - -M: real next-power-of-2 1+ >integer next-power-of-2 ; +: next-power-of-2 ( m -- n ) + dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline : power-of-2? ( n -- ? ) dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable diff --git a/vm/math.c b/vm/math.c index dd01e852ad..f0aa874886 100644 --- a/vm/math.c +++ b/vm/math.c @@ -197,7 +197,7 @@ void primitive_bignum_xor(void) void primitive_bignum_shift(void) { - F_FIXNUM y = to_fixnum(dpop()); + F_FIXNUM y = untag_fixnum_fast(dpop()); F_ARRAY* x = untag_object(dpop()); dpush(tag_bignum(bignum_arithmetic_shift(x,y))); }