compiler.tree.propagation: fix broken corner cases in bitand and shift transforms, exposed by Hugh Aguilar's LC53 benchmark

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -140,8 +140,19 @@ IN: compiler.tree.propagation.known-words
     '[ _ _ 2bi ] "outputs" set-word-prop
 ] each
 
-\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
+: shift-op-class ( info1 info2 -- newclass )
-\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
+    [ class>> ] bi@
+    2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ;
+
+: shift-op ( word interval-quot post-proc-quot -- )
+    '[
+        [ shift-op-class ] [ _ binary-op-interval ] 2bi
+        @
+        <class/interval-info>
+    ] "outputs" set-word-prop ;
+
+\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op
 
 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op

basis/compiler/tree/propagation/propagation-tests.factor

@@ -407,10 +407,18 @@ IN: compiler.tree.propagation.tests
     [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
 ] unit-test
 
+[ V{ fixnum } ] [
+    [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
+] unit-test
+
 [ V{ fixnum } ] [
     [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
 ] unit-test
 
+[ V{ fixnum } ] [
+    [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
+] unit-test
+
 cell-bits 32 = [
     [ V{ integer } ] [
         [ { fixnum } declare 1 swap 31 bitand shift ]
@@ -900,9 +908,20 @@ M: tuple-with-read-only-slot clone
 [ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
 [ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
 
+! bitand identities
 [ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
 [ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
 
 [ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
 [ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
 [ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
+
+[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test
+[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test
+
+! Could be bignum not integer but who cares
+[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -42,30 +42,27 @@ IN: compiler.tree.propagation.transforms
 : positive-fixnum? ( obj -- ? )
     { [ fixnum? ] [ 0 >= ] } 1&& ;
 
-: simplify-bitand? ( value -- ? )
+: simplify-bitand? ( value1 value2 -- ? )
-    value-info literal>> positive-fixnum? ;
+    [ literal>> positive-fixnum? ]
+    [ class>> fixnum swap class<= ]
+    bi* and ;
 
-: all-ones? ( int -- ? )
+: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
-    dup 1 + bitand zero? ; inline
 
-: redundant-bitand? ( var 111... -- ? )
+: redundant-bitand? ( value1 value2 -- ? )
-    [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* {
+    [ interval>> ] [ literal>> ] bi* {
         [ nip integer? ]
         [ nip all-ones? ]
         [ 0 swap [a,b] interval-subset? ]
     } 2&& ;
 
-: (zero-bitand?) ( value-info value-info' -- ? )
+: zero-bitand? ( value1 value2 -- ? )
     [ interval>> ] [ literal>> ] bi* {
         [ nip integer? ]
         [ nip bitnot all-ones? ]
         [ 0 swap bitnot [a,b] interval-subset? ]
     } 2&& ;
 
-: zero-bitand? ( var1 var2 -- ? )
-    [ value-info ] bi@
-    { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
-
 {
     bitand-integer-integer
     bitand-integer-fixnum
@@ -73,36 +70,42 @@ IN: compiler.tree.propagation.transforms
     bitand
 } [
     [
+        in-d>> first2 [ value-info ] bi@ {
             {
-            {
+                [ 2dup zero-bitand? ]
-                [ dup in-d>> first2 zero-bitand? ]
+                [ 2drop [ 2drop 0 ] ]
-                [ drop [ 2drop 0 ] ]
             }
             {
-                [ dup in-d>> first2 redundant-bitand? ]
+                [ 2dup swap zero-bitand? ]
-                [ drop [ drop ] ]
+                [ 2drop [ 2drop 0 ] ]
             }
             {
-                [ dup in-d>> first2 swap redundant-bitand? ]
+                [ 2dup redundant-bitand? ]
-                [ drop [ nip ] ]
+                [ 2drop [ drop ] ]
             }
             {
-                [ dup in-d>> first simplify-bitand? ]
+                [ 2dup swap redundant-bitand? ]
-                [ drop [ >fixnum fixnum-bitand ] ]
+                [ 2drop [ nip ] ]
             }
             {
-                [ dup in-d>> second simplify-bitand? ]
+                [ 2dup simplify-bitand? ]
-                [ drop [ [ >fixnum ] dip fixnum-bitand ] ]
+                [ 2drop [ >fixnum fixnum-bitand ] ]
             }
-            [ drop f ]
+            {
+                [ 2dup swap simplify-bitand? ]
+                [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
+            }
+            [ 2drop f ]
         } cond
     ] "custom-inlining" set-word-prop
 ] each
 
 ! Speeds up 2^
 : 2^? ( #call -- ? )
-    in-d>> first value-info
+    in-d>> first2 [ value-info ] bi@
-    { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ;
+    [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
+    [ class>> fixnum class<= ]
+    bi* and ;
 
 \ shift [
      2^? [