From 7e35723db00ea3fc4584fd4bff71694899ed0417 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 Aug 2009 01:16:49 -0500 Subject: [PATCH] compiler.tree.propagation: be more careful with intervals, ensuring that the inferred interval of a value is a subset of the value class's interval. This improves accuracy, for example [ >fixnum 1 + >fixnum most-positive-fixnum <= ] constant-folds to true --- basis/compiler/tree/debugger/debugger.factor | 2 + .../modular-arithmetic-tests.factor | 7 +++- .../tree/propagation/info/info.factor | 33 ++++++++++----- .../known-words/known-words.factor | 25 +++--------- .../tree/propagation/propagation-tests.factor | 14 +++++++ .../recursive/recursive-tests.factor | 40 +++++++++++++++++-- .../propagation/recursive/recursive.factor | 28 ++++++++----- basis/math/intervals/intervals.factor | 19 +++++++-- 8 files changed, 118 insertions(+), 50 deletions(-) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index d6906d6348..6f313320d0 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -16,6 +16,7 @@ compiler.tree.builder compiler.tree.optimizer compiler.tree.combinators compiler.tree.checker +compiler.tree.identities compiler.tree.dead-code compiler.tree.modular-arithmetic ; FROM: fry => _ ; @@ -208,6 +209,7 @@ SYMBOL: node-count normalize propagate cleanup + apply-identities compute-def-use remove-dead-code compute-def-use diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 13555d45f7..a9415adbd7 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: compiler.tree.modular-arithmetic.tests USING: kernel kernel.private tools.test math math.partial-dispatch -math.private accessors slots.private sequences strings sbufs +math.private accessors slots.private sequences sequences.private strings sbufs compiler.tree.builder compiler.tree.normalization compiler.tree.debugger @@ -171,3 +171,8 @@ cell { [ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test [ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test + +[ t ] [ + [ 0 10 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ] + { >fixnum } inlined? +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 98baba3e97..cae8d6cde6 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals namespaces -sequences words combinators combinators.short-circuit byte-arrays -strings arrays layouts cpu.architecture compiler.tree.propagation.copy - ; +sequences sequences.private words combinators +combinators.short-circuit byte-arrays strings arrays layouts +cpu.architecture compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info : false-class? ( class -- ? ) \ f class<= ; @@ -37,10 +37,6 @@ CONSTANT: null-info T{ value-info f null empty-interval } CONSTANT: object-info T{ value-info f object full-interval } -: class-interval ( class -- interval ) - dup real class<= - [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ; - : interval>literal ( class interval -- literal literal? ) #! If interval has zero length and the class is sufficiently #! precise, we can turn it into a literal @@ -85,6 +81,23 @@ UNION: fixed-length array byte-array string ; [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ] } 1|| ; +: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ; + +: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ; + +: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ; + +: wrap-interval ( interval class -- interval' ) + { + { fixnum [ interval->fixnum ] } + { array-capacity [ max-array-capacity [a,a] interval-rem ] } + [ drop ] + } case ; + +: init-interval ( info -- info ) + dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval + dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline + : init-value-info ( info -- info ) dup literal?>> [ init-literal-info @@ -93,8 +106,7 @@ UNION: fixed-length array byte-array string ; null >>class empty-interval >>interval ] [ - [ [-inf,inf] or ] change-interval - dup class>> integer class<= [ [ integral-closure ] change-interval ] when + init-interval dup [ class>> ] [ interval>> ] bi interval>literal [ >>literal ] [ >>literal? ] bi* ] if @@ -107,8 +119,7 @@ UNION: fixed-length array byte-array string ; init-value-info ; foldable : ( class -- info ) - dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or - ; foldable + f ; foldable : ( interval -- info ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index a2955ca699..8c4e81f41d 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -18,14 +18,6 @@ compiler.tree.propagation.call-effect compiler.tree.propagation.transforms ; 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 @@ -53,8 +45,8 @@ most-negative-fixnum most-positive-fixnum [a,b] { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; -: fits? ( interval class -- ? ) - "interval" word-prop interval-subset? ; +: fits-in-fixnum? ( interval -- ? ) + fixnum-interval interval-subset? ; : binary-op-class ( info1 info2 -- newclass ) [ class>> ] bi@ @@ -66,7 +58,7 @@ most-negative-fixnum most-positive-fixnum [a,b] [ [ interval>> ] bi@ ] dip call ; inline : won't-overflow? ( class interval -- ? ) - [ fixnum class<= ] [ fixnum fits? ] bi* and ; + [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ; : may-overflow ( class interval -- class' interval' ) over null-class? [ @@ -219,14 +211,7 @@ generic-comparison-ops [ { >integer integer } } [ - '[ - _ - [ nip ] [ - [ interval>> ] [ class-interval ] bi* - interval-intersect - ] 2bi - - ] "outputs" set-word-prop + '[ _ swap interval>> ] "outputs" set-word-prop ] assoc-each { numerator denominator } @@ -262,7 +247,7 @@ generic-comparison-ops [ [ string>number 8 * 2^ 1- 0 swap [a,b] ] } } cond - [ fixnum fits? fixnum integer ? ] keep + [ fits-in-fixnum? fixnum integer ? ] keep '[ 2drop _ ] "outputs" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 46d98c28b6..59631d04c6 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -713,6 +713,20 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test +! generalize-counter is not tight enough +[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test + +[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test + +! Coercions need to update intervals +[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test + +[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test + +[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test + +[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test + ! Mutable tuples with circularity should not cause problems TUPLE: circle me ; diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor index cf72a2a135..db427d34af 100644 --- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor +++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor @@ -1,19 +1,51 @@ IN: compiler.tree.propagation.recursive.tests USING: tools.test compiler.tree.propagation.recursive -math.intervals kernel ; +math.intervals kernel math literals layouts ; [ T{ interval f { 0 t } { 1/0. t } } ] [ T{ interval f { 1 t } { 1 t } } - T{ interval f { 0 t } { 0 t } } generalize-counter-interval + T{ interval f { 0 t } { 0 t } } + integer generalize-counter-interval +] unit-test + +[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [ + T{ interval f { 1 t } { 1 t } } + T{ interval f { 0 t } { 0 t } } + fixnum generalize-counter-interval ] unit-test [ T{ interval f { -1/0. t } { 10 t } } ] [ T{ interval f { -1 t } { -1 t } } - T{ interval f { 10 t } { 10 t } } generalize-counter-interval + T{ interval f { 10 t } { 10 t } } + integer generalize-counter-interval +] unit-test + +[ T{ interval f { $[ most-negative-fixnum ] t } { 10 t } } ] [ + T{ interval f { -1 t } { -1 t } } + T{ interval f { 10 t } { 10 t } } + fixnum generalize-counter-interval ] unit-test [ t ] [ T{ interval f { 1 t } { 268435455 t } } T{ interval f { -268435456 t } { 268435455 t } } tuck - generalize-counter-interval = + integer generalize-counter-interval = +] unit-test + +[ t ] [ + T{ interval f { 1 t } { 268435455 t } } + T{ interval f { -268435456 t } { 268435455 t } } tuck + fixnum generalize-counter-interval = +] unit-test + +[ full-interval ] [ + T{ interval f { -5 t } { 3 t } } + T{ interval f { 2 t } { 11 t } } + integer generalize-counter-interval +] unit-test + +[ $[ fixnum-interval ] ] [ + T{ interval f { -5 t } { 3 t } } + T{ interval f { 2 t } { 11 t } } + fixnum generalize-counter-interval ] unit-test diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 64b7ba4609..eb4158e756 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors arrays fry math.intervals -combinators namespaces +USING: kernel sequences accessors arrays fry math math.intervals +layouts combinators namespaces locals stack-checker.inlining compiler.tree compiler.tree.combinators @@ -24,20 +24,26 @@ IN: compiler.tree.propagation.recursive [ label>> calls>> [ node>> node-input-infos ] map flip ] [ latest-input-infos ] bi ; -: generalize-counter-interval ( interval initial-interval -- interval' ) +:: generalize-counter-interval ( interval initial-interval class -- interval' ) { - { [ 2dup interval-subset? ] [ empty-interval ] } - { [ over empty-interval eq? ] [ empty-interval ] } - { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] } - { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] } - [ [-inf,inf] ] - } cond interval-union nip ; + { [ interval initial-interval interval-subset? ] [ initial-interval ] } + { [ interval empty-interval eq? ] [ initial-interval ] } + { + [ interval initial-interval interval>= t eq? ] + [ class max-value [a,a] initial-interval interval-union ] + } + { + [ interval initial-interval interval<= t eq? ] + [ class min-value [a,a] initial-interval interval-union ] + } + [ class class-interval ] + } cond ; : generalize-counter ( info' initial -- info ) 2dup [ not ] either? [ drop ] [ 2dup [ class>> null-class? ] either? [ drop ] [ [ clone ] dip - [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ] + [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ] [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ] [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ] tri diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 39582eafa4..8b07394596 100755 --- 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 layouts ; +combinators generic layouts memoize ; IN: math.intervals SYMBOL: empty-interval @@ -48,7 +48,10 @@ TUPLE: interval { from read-only } { to read-only } ; : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline -: [0,inf] ( -- interval ) 0 [a,inf] ; foldable +MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable + +MEMO: fixnum-interval ( -- interval ) + most-negative-fixnum most-positive-fixnum [a,b] ; inline : [-inf,inf] ( -- interval ) full-interval ; inline @@ -331,12 +334,22 @@ SYMBOL: incomparable } cond swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ; +: (rem-range) ( i -- i' ) interval-abs to>> first 0 swap [a,b) ; + : interval-rem ( i1 i2 -- i3 ) { { [ over empty-interval eq? ] [ drop ] } { [ dup empty-interval eq? ] [ nip ] } { [ dup full-interval eq? ] [ nip ] } - [ nip interval-abs to>> first 0 swap [a,b) ] + [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ] + } cond ; + +: interval->fixnum ( i1 -- i2 ) + { + { [ dup empty-interval eq? ] [ ] } + { [ dup full-interval eq? ] [ drop fixnum-interval ] } + { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] } + [ ] } cond ; : interval-bitand-pos ( i1 i2 -- ? )