prettyprint math.private accessors slots.private sequences
sequences.private strings sbufs compiler.tree.builder
compiler.tree.normalization compiler.tree.debugger alien.accessors
-layouts combinators byte-arrays ;
+layouts combinators byte-arrays arrays ;
IN: compiler.tree.modular-arithmetic.tests
: test-modular-arithmetic ( quot -- quot' )
] { mod fixnum-mod rem } inlined?
] unit-test
-[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >fixnum 255 >R R> fixnum-bitand ] ]
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
[ t ] [
{ >fixnum } inlined?
] unit-test
+[ t ] [
+ [ >integer [ >fixnum ] [ >fixnum ] bi ]
+ { >integer } inlined?
+] unit-test
+
+[ f ] [
+ [ >bignum [ >fixnum ] [ >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ >bignum [ >fixnum ] [ >fixnum ] bi ]
+ { >bignum } inlined?
+] unit-test
+
[ f ] [
[ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
{ fixnum+ } inlined?
[ f ] [
[ [ >fixnum ] 2dip set-alien-unsigned-1 ]
{ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare 123 >bignum bitand >fixnum ]
+ { >bignum fixnum>bignum bignum-bitand } inlined?
+] unit-test
+
+! Shifts
+[ t ] [
+ [
+ [ 0 ] 2dip { array } declare [
+ hashcode* >fixnum swap [
+ [ -2 shift ] [ 5 shift ] bi
+ + +
+ ] keep bitxor >fixnum
+ ] with each
+ ] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.private math.partial-dispatch namespaces sequences
-sets accessors assocs words kernel memoize fry combinators
-combinators.short-circuit layouts alien.accessors
+USING: math math.intervals math.private math.partial-dispatch
+namespaces sequences sets accessors assocs words kernel memoize fry
+combinators combinators.short-circuit layouts alien.accessors
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
] each-integer-derived-op
] each
-{ bitand bitor bitxor bitnot >integer }
+{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
[ t "modular-arithmetic" set-word-prop ] each
! Words that only use the low-order bits of their input. If the input
[ out-d>> first ] [ literal>> ] bi
real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
+: small-shift? ( interval -- ? )
+ 0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
+
+: modular-word? ( #call -- ? )
+ dup word>> { shift fixnum-shift bignum-shift } memq?
+ [ node-input-infos second interval>> small-shift? ]
+ [ word>> "modular-arithmetic" word-prop ]
+ if ;
+
+: output-candidate ( #call -- )
+ out-d>> first [ modular-value ] [ fixnum-value ] bi ;
+
+: low-order-word? ( #call -- ? )
+ word>> "low-order" word-prop ;
+
+: input-candidiate ( #call -- )
+ in-d>> first modular-value ;
+
M: #call compute-modular-candidates*
{
- {
- [ dup word>> "modular-arithmetic" word-prop ]
- [ out-d>> first [ modular-value ] [ fixnum-value ] bi ]
- }
- {
- [ dup word>> "low-order" word-prop ]
- [ in-d>> first modular-value ]
- }
+ { [ dup modular-word? ] [ output-candidate ] }
+ { [ dup low-order-word? ] [ input-candidiate ] }
[ drop ]
} cond ;
GENERIC: only-reads-low-order? ( node -- ? )
+: output-modular? ( #call -- ? )
+ out-d>> first modular-values get key? ;
+
M: #call only-reads-low-order?
{
- [ word>> "low-order" word-prop ]
- [
- {
- [ word>> "modular-arithmetic" word-prop ]
- [ out-d>> first modular-values get key? ]
- } 1&&
- ]
+ [ low-order-word? ]
+ [ { [ modular-word? ] [ output-modular? ] } 1&& ]
} 1|| ;
M: node only-reads-low-order? drop f ;
[ drop fixnum <class-info> ] change-at
] when ;
+: like->fixnum? ( #call -- ? )
+ word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
+
+: like->integer? ( #call -- ? )
+ word>> { >integer >bignum fixnum>bignum } memq? ;
+
M: #call optimize-modular-arithmetic*
- dup word>> {
- { [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] }
- { [ dup \ >integer eq? ] [ drop optimize->integer ] }
- { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
- { [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
- [ drop ]
+ {
+ { [ dup like->fixnum? ] [ optimize->fixnum ] }
+ { [ dup like->integer? ] [ optimize->integer ] }
+ { [ dup modular-word? ] [ optimize-modular-op ] }
+ { [ dup low-order-word? ] [ optimize-low-order-op ] }
+ [ ]
} cond ;
M: node optimize-modular-arithmetic* ;
: optimize-modular-arithmetic ( nodes -- nodes' )
dup compute-modular-candidates compute-modular-values
- [ optimize-modular-arithmetic* ] map-nodes ;
+ modular-values get assoc-empty? [
+ [ optimize-modular-arithmetic* ] map-nodes
+ ] unless ;