compiler.tree.modular-arithmetic: eliminate >bignum calls where possible, convert fixnum-shift to fixnum-shift-fast if shift count is positive, don't run if there are no modular values

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -4,7 +4,7 @@ USING: kernel kernel.private tools.test math math.partial-dispatch
 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' )
@@ -134,7 +134,7 @@ TUPLE: declared-fixnum { x fixnum } ;
     ] { 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 ] [
@@ -201,6 +201,21 @@ cell {
     { >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?
@@ -257,4 +272,21 @@ cell {
 [ 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

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -1,8 +1,8 @@
 ! 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
+USING: math math.intervals math.private math.partial-dispatch
-sets accessors assocs words kernel memoize fry combinators
+namespaces sequences sets accessors assocs words kernel memoize fry
-combinators.short-circuit layouts alien.accessors
+combinators combinators.short-circuit layouts alien.accessors
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -30,7 +30,7 @@ IN: compiler.tree.modular-arithmetic
     ] 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
@@ -71,16 +71,28 @@ M: #push compute-modular-candidates*
     [ 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 modular-word? ] [ output-candidate ] }
-            [ dup word>> "modular-arithmetic" word-prop ]
+        { [ dup low-order-word? ] [ input-candidiate ] }
-            [ out-d>> first [ modular-value ] [ fixnum-value ] bi ]
-        }
-        {
-            [ dup word>> "low-order" word-prop ]
-            [ in-d>> first modular-value ]
-        }
         [ drop ]
     } cond ;
 
@@ -94,15 +106,13 @@ M: node compute-modular-candidates*
 
 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 ]
+        [ low-order-word? ]
-        [
+        [ { [ modular-word? ] [ output-modular? ] } 1&& ]
-            {
-                [ word>> "modular-arithmetic" word-prop ]
-                [ out-d>> first modular-values get key? ]
-            } 1&&
-        ]
     } 1|| ;
 
 M: node only-reads-low-order? drop f ;
@@ -167,17 +177,25 @@ MEMO: fixnum-coercion ( flags -- nodes )
         [ 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 like->fixnum? ] [ optimize->fixnum ] }
-        { [ dup \ >integer eq? ] [ drop optimize->integer ] }
+        { [ dup like->integer? ] [ optimize->integer ] }
-        { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
+        { [ dup modular-word? ] [ optimize-modular-op ] }
-        { [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
+        { [ dup low-order-word? ] [ optimize-low-order-op ] }
-        [ drop ]
+        [ ]
     } 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 ;