diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d4780b335b..e21ab74cc2 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/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 [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op +: shift-op-class ( info1 info2 -- newclass ) + [ 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 + @ + + ] "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 diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0a8cb61a9f..5d12c14f5f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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* ] { } inlined? ] unit-test [ V{ void*-array } ] [ [ void* ] 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 diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 3a75ee37e1..d1f5386450 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/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 -- ? ) - value-info literal>> positive-fixnum? ; +: simplify-bitand? ( value1 value2 -- ? ) + [ literal>> positive-fixnum? ] + [ class>> fixnum swap class<= ] + bi* and ; -: all-ones? ( int -- ? ) - dup 1 + bitand zero? ; inline +: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline -: redundant-bitand? ( var 111... -- ? ) - [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* { +: redundant-bitand? ( value1 value2 -- ? ) + [ 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@ { { - [ dup in-d>> first2 zero-bitand? ] - [ drop [ 2drop 0 ] ] + [ 2dup zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 redundant-bitand? ] - [ drop [ drop ] ] + [ 2dup swap zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 swap redundant-bitand? ] - [ drop [ nip ] ] + [ 2dup redundant-bitand? ] + [ 2drop [ drop ] ] } { - [ dup in-d>> first simplify-bitand? ] - [ drop [ >fixnum fixnum-bitand ] ] + [ 2dup swap redundant-bitand? ] + [ 2drop [ nip ] ] } { - [ dup in-d>> second simplify-bitand? ] - [ drop [ [ >fixnum ] dip fixnum-bitand ] ] + [ 2dup simplify-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 - { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ; + in-d>> first2 [ value-info ] bi@ + [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ] + [ class>> fixnum class<= ] + bi* and ; \ shift [ 2^? [