Partial dispatch on integer operations
Slava Pestov
parent
9722b7a4ea
commit
2d2b3ec904
|
|
@ -29,6 +29,9 @@ PREDICATE: method-spec < pair
|
|||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
|
||||
: specific-method ( class word -- class )
|
||||
order min-class ;
|
||||
|
||||
GENERIC: effective-method ( ... generic -- method )
|
||||
|
||||
: next-method-class ( class generic -- class/f )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
|
|||
sequences words inference.class quotations alien
|
||||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system layouts vectors ;
|
||||
system layouts vectors optimizer.math.partial ;
|
||||
|
||||
! Make sure these compile even though this is invalid code
|
||||
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
|
||||
|
|
@ -18,6 +18,11 @@ system layouts vectors ;
|
|||
swap dataflow optimize
|
||||
[ node-param swap member? ] with node-exists? not ;
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare >fixnum ]
|
||||
\ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
GENERIC: mynot ( x -- y )
|
||||
|
||||
M: f mynot drop t ;
|
||||
|
|
@ -110,12 +115,17 @@ M: object xyz ;
|
|||
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ t ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
|
||||
[ f ] [
|
||||
[ { integer fixnum } declare dupd < [ 1 + ] when ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
|
|
@ -138,13 +148,13 @@ M: object xyz ;
|
|||
|
||||
DEFER: blah
|
||||
|
||||
[ t ] [
|
||||
[ ] [
|
||||
[
|
||||
\ blah
|
||||
[ dup V{ } eq? [ foo ] when ] dup second dup push define
|
||||
] with-compilation-unit
|
||||
|
||||
\ blah compiled?
|
||||
\ blah word-def dataflow optimize drop
|
||||
] unit-test
|
||||
|
||||
GENERIC: detect-fx ( n -- n )
|
||||
|
|
@ -159,14 +169,20 @@ M: fixnum detect-fx ;
|
|||
] \ detect-fx inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ + inlined?
|
||||
] unit-test
|
||||
[ f ] [
|
||||
[
|
||||
1000000000000000000000000000000000 [ ] times
|
||||
] \ 1+ inlined?
|
||||
] \ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] times ] \ 1+ inlined?
|
||||
[ { bignum } declare [ ] times ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
@ -359,15 +375,6 @@ cell-bits 32 = [
|
|||
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare
|
||||
dup 0 >= [
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] [ dup ] if
|
||||
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
: fib ( m -- n )
|
||||
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
|
||||
|
||||
|
|
@ -387,6 +394,106 @@ cell-bits 32 = [
|
|||
[ 27/2 fib ] { < - } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
|
||||
\ fixnum-bitand inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare 127 bitand 3 + ]
|
||||
{ + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { integer } declare 127 bitand 3 + ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ drop ] each-integer ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare length [ drop ] each-integer ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare [ drop ] each ]
|
||||
{ < <-integer-fixnum +-integer-fixnum + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
{ < <-integer-fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
\ +-integer-fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare
|
||||
dup 0 >= [
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] [ dup ] if
|
||||
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ fixnum } declare
|
||||
615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
] { >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare [ ] map
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare { } set-nth-unsafe
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ integer } declare 1 + { } set-nth-unsafe
|
||||
] \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ integer } declare 0 swap
|
||||
[
|
||||
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
] map
|
||||
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ fixnum } declare 0 swap
|
||||
[
|
||||
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
] map
|
||||
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
! Later
|
||||
|
||||
! [ t ] [
|
||||
|
|
|
|||
|
|
@ -96,6 +96,8 @@ C: <interval> interval
|
|||
|
||||
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
|
||||
|
||||
: interval-sq ( i1 -- i2 ) dup interval* ;
|
||||
|
||||
: make-interval ( from to -- int )
|
||||
over first over first {
|
||||
{ [ 2dup > ] [ 2drop 2drop f ] }
|
||||
|
|
|
|||
|
|
@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
|
|||
|
||||
M: object zero? drop f ;
|
||||
|
||||
: 1+ ( x -- y ) 1 + ; foldable
|
||||
: 1- ( x -- y ) 1 - ; foldable
|
||||
: 2/ ( x -- y ) -1 shift ; foldable
|
||||
: sq ( x -- y ) dup * ; foldable
|
||||
: neg ( x -- -x ) 0 swap - ; foldable
|
||||
: recip ( x -- y ) 1 swap / ; foldable
|
||||
: 1+ ( x -- y ) 1 + ; inline
|
||||
: 1- ( x -- y ) 1 - ; inline
|
||||
: 2/ ( x -- y ) -1 shift ; inline
|
||||
: sq ( x -- y ) dup * ; inline
|
||||
: neg ( x -- -x ) 0 swap - ; inline
|
||||
: recip ( x -- y ) 1 swap / ; inline
|
||||
|
||||
: ?1+ [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: /f ( x y -- z ) >r >float r> >float float/f ; inline
|
||||
|
||||
: max ( x y -- z ) [ > ] most ; foldable
|
||||
: min ( x y -- z ) [ < ] most ; foldable
|
||||
: max ( x y -- z ) [ > ] most ; inline
|
||||
: min ( x y -- z ) [ < ] most ; inline
|
||||
|
||||
: between? ( x y z -- ? )
|
||||
pick >= [ >= ] [ 2drop f ] if ; inline
|
||||
|
||||
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
|
||||
|
||||
: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
|
||||
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
|
||||
|
||||
: [-] ( x y -- z ) - 0 max ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
IN: optimizer.inlining.tests
|
||||
USING: tools.test optimizer.inlining ;
|
||||
|
||||
\ word-flat-length must-infer
|
||||
|
||||
\ inlining-math-method must-infer
|
||||
|
||||
\ optimistic-inline? must-infer
|
||||
|
||||
\ find-identity must-infer
|
||||
|
|
@ -3,10 +3,11 @@
|
|||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes classes.algebra generic.math continuations
|
||||
optimizer.def-use optimizer.backend generic.standard
|
||||
optimizer.specializers optimizer.def-use optimizer.pattern-match
|
||||
generic.standard optimizer.control kernel.private ;
|
||||
combinators classes classes.algebra generic.math
|
||||
optimizer.math.partial continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control kernel.private ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
|
|
@ -53,8 +54,6 @@ DEFER: (flat-length)
|
|||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
|
|
@ -79,21 +78,31 @@ DEFER: (flat-length)
|
|||
object
|
||||
} [ class< ] with find nip ;
|
||||
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes
|
||||
: inlining-math-method ( #call word -- quot/f )
|
||||
swap node-input-classes
|
||||
[ first normalize-math-class ]
|
||||
[ second normalize-math-class ] bi
|
||||
3dup math-both-known?
|
||||
[ math-method f splice-quot ]
|
||||
[ 2drop 2drop t ] if ;
|
||||
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
|
||||
|
||||
: inline-math-method ( #call word -- node/t )
|
||||
[ drop ] [ inlining-math-method ] 2bi
|
||||
dup [ f splice-quot ] [ 2drop t ] if ;
|
||||
|
||||
: inline-math-partial ( #call word -- node/t )
|
||||
[ drop ]
|
||||
[
|
||||
"derived-from" word-prop first
|
||||
inlining-math-method dup
|
||||
]
|
||||
[ nip 1quotation ] 2tri
|
||||
[ = not ] [ drop ] 2bi and
|
||||
[ f splice-quot ] [ 2drop t ] if ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup math-partial? ] [ inline-math-partial ] }
|
||||
[ 2drop t ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,21 +83,11 @@ sequences.private combinators ;
|
|||
] "constraints" set-word-prop
|
||||
|
||||
! eq? on the same object is always t
|
||||
{ eq? bignum= float= number= = } {
|
||||
{ eq? = } {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
|
||||
! Specializers
|
||||
{ 1+ 1- sq neg recip sgn } [
|
||||
{ number } "specializer" set-word-prop
|
||||
] each
|
||||
|
||||
\ 2/ { fixnum } "specializer" set-word-prop
|
||||
|
||||
{ min max } [
|
||||
{ number number } "specializer" set-word-prop
|
||||
] each
|
||||
|
||||
{ first first2 first3 first4 }
|
||||
[ { array } "specializer" set-word-prop ] each
|
||||
|
||||
|
|
|
|||
|
|
@ -8,80 +8,91 @@ namespaces assocs quotations math.intervals sequences.private
|
|||
combinators splitting layouts math.parser classes
|
||||
classes.algebra generic.math optimizer.pattern-match
|
||||
optimizer.backend optimizer.def-use optimizer.inlining
|
||||
generic.standard system ;
|
||||
optimizer.math.partial generic.standard system ;
|
||||
|
||||
{ + bignum+ float+ fixnum+ fixnum+fast } {
|
||||
: define-math-identities ( word identities -- )
|
||||
>r all-derived-ops r> define-identities ;
|
||||
|
||||
\ number= {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-math-identities
|
||||
|
||||
\ + {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ - fixnum- bignum- float- fixnum-fast } {
|
||||
\ - {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { @ @ } [ 2drop 0 ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ < fixnum< bignum< float< } {
|
||||
\ < {
|
||||
{ { @ @ } [ 2drop f ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ <= fixnum<= bignum<= float<= } {
|
||||
\ <= {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ > fixnum> bignum> float>= } {
|
||||
\ > {
|
||||
{ { @ @ } [ 2drop f ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ >= fixnum>= bignum>= float>= } {
|
||||
\ >= {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ * fixnum* fixnum*fast bignum* float* } {
|
||||
\ * {
|
||||
{ { number 1 } [ drop ] }
|
||||
{ { 1 number } [ nip ] }
|
||||
{ { number 0 } [ nip ] }
|
||||
{ { 0 number } [ drop ] }
|
||||
{ { number -1 } [ drop 0 swap - ] }
|
||||
{ { -1 number } [ nip 0 swap - ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ / fixnum/i bignum/i float/f } {
|
||||
\ / {
|
||||
{ { number 1 } [ drop ] }
|
||||
{ { number -1 } [ drop 0 swap - ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ fixnum-mod bignum-mod } {
|
||||
{ { number 1 } [ 2drop 0 ] }
|
||||
} define-identities
|
||||
\ mod {
|
||||
{ { integer 1 } [ 2drop 0 ] }
|
||||
} define-math-identities
|
||||
|
||||
{ bitand fixnum-bitand bignum-bitand } {
|
||||
\ rem {
|
||||
{ { integer 1 } [ 2drop 0 ] }
|
||||
} define-math-identities
|
||||
|
||||
\ bitand {
|
||||
{ { number -1 } [ drop ] }
|
||||
{ { -1 number } [ nip ] }
|
||||
{ { @ @ } [ drop ] }
|
||||
{ { number 0 } [ nip ] }
|
||||
{ { 0 number } [ drop ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ bitor fixnum-bitor bignum-bitor } {
|
||||
\ bitor {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
{ { @ @ } [ drop ] }
|
||||
{ { number -1 } [ nip ] }
|
||||
{ { -1 number } [ drop ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ bitxor fixnum-bitxor bignum-bitxor } {
|
||||
\ bitxor {
|
||||
{ { number 0 } [ drop ] }
|
||||
{ { 0 number } [ nip ] }
|
||||
{ { number -1 } [ drop bitnot ] }
|
||||
{ { -1 number } [ nip bitnot ] }
|
||||
{ { @ @ } [ 2drop 0 ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
|
||||
\ shift {
|
||||
{ { 0 number } [ drop ] }
|
||||
{ { number 0 } [ drop ] }
|
||||
} define-identities
|
||||
} define-math-identities
|
||||
|
||||
: math-closure ( class -- newclass )
|
||||
{ fixnum bignum integer rational float real number }
|
||||
|
|
@ -126,15 +137,9 @@ generic.standard system ;
|
|||
r> post-process ; inline
|
||||
|
||||
{
|
||||
{ 1+ integer interval-1+ }
|
||||
{ 1- integer interval-1- }
|
||||
{ neg integer interval-neg }
|
||||
{ shift integer interval-recip }
|
||||
{ bitnot fixnum interval-bitnot }
|
||||
{ fixnum-bitnot f interval-bitnot }
|
||||
{ bignum-bitnot f interval-bitnot }
|
||||
{ 2/ fixnum interval-2/ }
|
||||
{ sq integer f }
|
||||
} [
|
||||
first3 [
|
||||
math-output-class/interval-1
|
||||
|
|
@ -164,35 +169,16 @@ generic.standard system ;
|
|||
{ * integer interval* }
|
||||
{ / rational interval/ }
|
||||
{ /i integer interval/i }
|
||||
|
||||
{ fixnum+ f interval+ }
|
||||
{ fixnum+fast f interval+ }
|
||||
{ fixnum- f interval- }
|
||||
{ fixnum-fast f interval- }
|
||||
{ fixnum* f interval* }
|
||||
{ fixnum*fast f interval* }
|
||||
{ fixnum/i f interval/i }
|
||||
|
||||
{ bignum+ f interval+ }
|
||||
{ bignum- f interval- }
|
||||
{ bignum* f interval* }
|
||||
{ bignum/i f interval/i }
|
||||
{ bignum-shift f interval-shift-safe }
|
||||
|
||||
{ float+ f interval+ }
|
||||
{ float- f interval- }
|
||||
{ float* f interval* }
|
||||
{ float/f f interval/ }
|
||||
|
||||
{ min fixnum interval-min }
|
||||
{ max fixnum interval-max }
|
||||
{ shift f interval-shift-safe }
|
||||
} [
|
||||
first3 [
|
||||
[
|
||||
math-output-class/interval-2
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
{ fixnum-shift fixnum-shift-fast shift } [
|
||||
\ shift [
|
||||
[
|
||||
dup
|
||||
node-in-d second value-interval*
|
||||
|
|
@ -200,7 +186,7 @@ generic.standard system ;
|
|||
\ interval-shift-safe
|
||||
math-output-class/interval-2
|
||||
] "output-classes" set-word-prop
|
||||
] each
|
||||
] each-derived-op
|
||||
|
||||
: real-value? ( value -- n ? )
|
||||
dup value? [ value-literal dup real? ] [ drop f f ] if ;
|
||||
|
|
@ -231,21 +217,17 @@ generic.standard system ;
|
|||
|
||||
{
|
||||
{ mod fixnum mod-range }
|
||||
{ fixnum-mod f mod-range }
|
||||
{ bignum-mod f mod-range }
|
||||
{ float-mod f mod-range }
|
||||
|
||||
{ rem integer rem-range }
|
||||
|
||||
{ bitand fixnum bitand-range }
|
||||
{ fixnum-bitand f bitand-range }
|
||||
|
||||
{ bitor fixnum f }
|
||||
{ bitxor fixnum f }
|
||||
} [
|
||||
first3 [
|
||||
[
|
||||
math-output-class/interval-special
|
||||
] 2curry "output-classes" set-word-prop
|
||||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
: twiddle-interval ( i1 -- i2 )
|
||||
|
|
@ -275,26 +257,12 @@ generic.standard system ;
|
|||
{ <= assume<= assume> }
|
||||
{ > assume> assume<= }
|
||||
{ >= assume>= assume< }
|
||||
|
||||
{ fixnum< assume< assume>= }
|
||||
{ fixnum<= assume<= assume> }
|
||||
{ fixnum> assume> assume<= }
|
||||
{ fixnum>= assume>= assume< }
|
||||
|
||||
{ bignum< assume< assume>= }
|
||||
{ bignum<= assume<= assume> }
|
||||
{ bignum> assume> assume<= }
|
||||
{ bignum>= assume>= assume< }
|
||||
|
||||
{ float< assume< assume>= }
|
||||
{ float<= assume<= assume> }
|
||||
{ float> assume> assume<= }
|
||||
{ float>= assume>= assume< }
|
||||
} [
|
||||
first3
|
||||
first3 [
|
||||
[
|
||||
[ comparison-constraints ] with-scope
|
||||
] 2curry "constraints" set-word-prop
|
||||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
{
|
||||
|
|
@ -347,20 +315,15 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
|
||||
{
|
||||
{ + [ fixnum+fast ] }
|
||||
{ +-integer-fixnum [ fixnum+fast ] }
|
||||
{ - [ fixnum-fast ] }
|
||||
{ * [ fixnum*fast ] }
|
||||
{ *-integer-fixnum [ fixnum*fast ] }
|
||||
{ shift [ fixnum-shift-fast ] }
|
||||
{ fixnum+ [ fixnum+fast ] }
|
||||
{ fixnum- [ fixnum-fast ] }
|
||||
{ fixnum* [ fixnum*fast ] }
|
||||
{ fixnum-shift [ fixnum-shift-fast ] }
|
||||
! these are here as an optimization. if they weren't given
|
||||
! explicitly, the same would be inferred after an extra
|
||||
! optimization step (see optimistic-inline?)
|
||||
{ 1+ [ 1 fixnum+fast ] }
|
||||
{ 1- [ 1 fixnum-fast ] }
|
||||
{ 2/ [ -1 fixnum-shift-fast ] }
|
||||
{ neg [ 0 swap fixnum-fast ] }
|
||||
} [
|
||||
[
|
||||
[ dup remove-overflow-check? ] ,
|
||||
|
|
@ -394,26 +357,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
{ <= interval<= }
|
||||
{ > interval> }
|
||||
{ >= interval>= }
|
||||
|
||||
{ fixnum< interval< }
|
||||
{ fixnum<= interval<= }
|
||||
{ fixnum> interval> }
|
||||
{ fixnum>= interval>= }
|
||||
|
||||
{ bignum< interval< }
|
||||
{ bignum<= interval<= }
|
||||
{ bignum> interval> }
|
||||
{ bignum>= interval>= }
|
||||
|
||||
{ float< interval< }
|
||||
{ float<= interval<= }
|
||||
{ float> interval> }
|
||||
{ float>= interval>= }
|
||||
} [
|
||||
[
|
||||
[
|
||||
dup [ dupd foldable-comparison? ] curry ,
|
||||
[ fold-comparison ] curry ,
|
||||
] { } make 1array define-optimizers
|
||||
] curry each-derived-op
|
||||
] assoc-each
|
||||
|
||||
! The following words are handled in a similar way except if
|
||||
|
|
@ -428,13 +378,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
[ \ >fixnum consumed-by? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
{ fixnum+ [ fixnum+fast ] }
|
||||
{ fixnum- [ fixnum-fast ] }
|
||||
{ fixnum* [ fixnum*fast ] }
|
||||
{ + [ >r >fixnum r> >fixnum fixnum+fast ] }
|
||||
{ - [ >r >fixnum r> >fixnum fixnum-fast ] }
|
||||
{ * [ >r >fixnum r> >fixnum fixnum*fast ] }
|
||||
{ + [ [ >fixnum ] bi@ fixnum+fast ] }
|
||||
{ - [ [ >fixnum ] bi@ fixnum-fast ] }
|
||||
{ * [ [ >fixnum ] bi@ fixnum*fast ] }
|
||||
{ shift [ [ >fixnum ] bi@ fixnum-shift-fast ] }
|
||||
} [
|
||||
>r derived-ops r> [
|
||||
[
|
||||
[
|
||||
dup remove-overflow-check?
|
||||
|
|
@ -442,6 +391,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
] ,
|
||||
[ f splice-quot ] curry ,
|
||||
] { } make 1array define-optimizers
|
||||
] curry each
|
||||
] assoc-each
|
||||
|
||||
: convert-rem-to-and? ( #call -- ? )
|
||||
|
|
@ -461,14 +411,14 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
dup node-in-d second node-literal 1-
|
||||
[ nip bitand ] curry f splice-quot ;
|
||||
|
||||
{ mod bignum-mod fixnum-mod } [
|
||||
\ mod [
|
||||
{
|
||||
{
|
||||
[ dup convert-mod-to-and? ]
|
||||
[ convert-mod-to-and ]
|
||||
}
|
||||
} define-optimizers
|
||||
] each
|
||||
] each-derived-op
|
||||
|
||||
\ rem {
|
||||
{
|
||||
|
|
@ -481,7 +431,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
dup node-in-d second node-interval fixnum fits? ;
|
||||
|
||||
: fixnumify-bitand ( #call -- node )
|
||||
[ >r >fixnum r> >fixnum fixnum-bitand ] f splice-quot ;
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
|
||||
|
||||
\ bitand {
|
||||
{
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
IN: optimizer.math.partial.tests
|
||||
USING: optimizer.math.partial tools.test math kernel
|
||||
sequences ;
|
||||
|
||||
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
|
||||
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
|
||||
[ t ] [ \ + integer bignum math-both-known? ] unit-test
|
||||
[ t ] [ \ + float fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ + real fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ + object number math-both-known? ] unit-test
|
||||
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
|
||||
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
|
||||
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
|
||||
|
|
@ -0,0 +1,172 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private math math.private words
|
||||
sequences parser namespaces assocs quotations arrays
|
||||
generic generic.math hashtables effects ;
|
||||
IN: optimizer.math.partial
|
||||
|
||||
! Partial dispatch.
|
||||
|
||||
! This code will be overhauled and generalized when
|
||||
! multi-methods go into the core.
|
||||
PREDICATE: math-partial < word
|
||||
"derived-from" word-prop >boolean ;
|
||||
|
||||
: fixnum-integer-op ( a b fix-word big-word -- c )
|
||||
pick tag 0 eq? [
|
||||
drop execute
|
||||
] [
|
||||
>r drop >r fixnum>bignum r> r> execute
|
||||
] if ; inline
|
||||
|
||||
: integer-fixnum-op ( a b fix-word big-word -- c )
|
||||
>r pick tag 0 eq? [
|
||||
r> drop execute
|
||||
] [
|
||||
drop fixnum>bignum r> execute
|
||||
] if ; inline
|
||||
|
||||
: integer-integer-op ( a b fix-word big-word -- c )
|
||||
pick tag 0 eq? [
|
||||
integer-fixnum-op
|
||||
] [
|
||||
>r drop over tag 0 eq? [
|
||||
>r fixnum>bignum r> r> execute
|
||||
] [
|
||||
r> execute
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
<<
|
||||
: integer-op-combinator ( triple -- word )
|
||||
[
|
||||
[ second word-name % "-" % ]
|
||||
[ third word-name % "-op" % ]
|
||||
bi
|
||||
] "" make in get lookup ;
|
||||
|
||||
: integer-op-word ( triple fix-word big-word -- word )
|
||||
[
|
||||
drop
|
||||
word-name "fast" tail? >r
|
||||
[ "-" % ] [ word-name % ] interleave
|
||||
r> [ "-fast" % ] when
|
||||
] "" make in get create ;
|
||||
|
||||
: integer-op-quot ( word fix-word big-word -- quot )
|
||||
rot integer-op-combinator 1quotation 2curry ;
|
||||
|
||||
: define-integer-op-word ( word fix-word big-word -- )
|
||||
[
|
||||
[ integer-op-word ] [ integer-op-quot ] 3bi
|
||||
2 1 <effect> define-declared
|
||||
]
|
||||
[
|
||||
[ integer-op-word ] [ 2drop ] 3bi
|
||||
"derived-from" set-word-prop
|
||||
] 3bi ;
|
||||
|
||||
: define-integer-op-words ( words fix-word big-word -- )
|
||||
[ define-integer-op-word ] 2curry each ;
|
||||
|
||||
: integer-op-triples ( word -- triples )
|
||||
{
|
||||
{ fixnum integer }
|
||||
{ integer fixnum }
|
||||
{ integer integer }
|
||||
} swap [ prefix ] curry map ;
|
||||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
>r >r integer-op-triples r> r>
|
||||
[ define-integer-op-words ]
|
||||
[ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
|
||||
3bi ;
|
||||
|
||||
: define-math-ops ( op -- )
|
||||
{ fixnum bignum float }
|
||||
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
|
||||
[ nip ] assoc-subset
|
||||
[ word-def peek ] assoc-map % ;
|
||||
|
||||
SYMBOL: math-ops
|
||||
|
||||
[
|
||||
\ + define-math-ops
|
||||
\ - define-math-ops
|
||||
\ * define-math-ops
|
||||
\ shift define-math-ops
|
||||
\ mod define-math-ops
|
||||
\ /i define-math-ops
|
||||
|
||||
\ bitand define-math-ops
|
||||
\ bitor define-math-ops
|
||||
\ bitxor define-math-ops
|
||||
|
||||
\ < define-math-ops
|
||||
\ <= define-math-ops
|
||||
\ > define-math-ops
|
||||
\ >= define-math-ops
|
||||
\ number= define-math-ops
|
||||
|
||||
\ + \ fixnum+ \ bignum+ define-integer-ops
|
||||
\ - \ fixnum- \ bignum- define-integer-ops
|
||||
\ * \ fixnum* \ bignum* define-integer-ops
|
||||
\ shift \ fixnum-shift \ bignum-shift define-integer-ops
|
||||
\ mod \ fixnum-mod \ bignum-mod define-integer-ops
|
||||
\ /i \ fixnum/i \ bignum/i define-integer-ops
|
||||
|
||||
\ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
|
||||
\ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
|
||||
\ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
|
||||
|
||||
\ < \ fixnum< \ bignum< define-integer-ops
|
||||
\ <= \ fixnum<= \ bignum<= define-integer-ops
|
||||
\ > \ fixnum> \ bignum> define-integer-ops
|
||||
\ >= \ fixnum>= \ bignum>= define-integer-ops
|
||||
\ number= \ eq? \ bignum= define-integer-ops
|
||||
] { } make >hashtable math-ops set-global
|
||||
|
||||
SYMBOL: fast-math-ops
|
||||
|
||||
[
|
||||
{ { + fixnum fixnum } fixnum+fast } ,
|
||||
{ { - fixnum fixnum } fixnum-fast } ,
|
||||
{ { * fixnum fixnum } fixnum*fast } ,
|
||||
{ { shift fixnum fixnum } fixnum-shift-fast } ,
|
||||
|
||||
\ + \ fixnum+fast \ bignum+ define-integer-ops
|
||||
\ - \ fixnum-fast \ bignum- define-integer-ops
|
||||
\ * \ fixnum*fast \ bignum* define-integer-ops
|
||||
\ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
|
||||
] { } make >hashtable fast-math-ops set-global
|
||||
|
||||
>>
|
||||
|
||||
: math-op ( word left right -- word' ? )
|
||||
3array math-ops get at* ;
|
||||
|
||||
: math-method* ( word left right -- quot )
|
||||
3dup math-op
|
||||
[ >r 3drop r> 1quotation ] [ drop math-method ] if ;
|
||||
|
||||
: math-both-known? ( word left right -- ? )
|
||||
3dup math-op
|
||||
[ 2drop 2drop t ]
|
||||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap [ rot first eq? nip ] curry assoc-subset values ;
|
||||
|
||||
: derived-ops ( word -- words )
|
||||
[ 1array ]
|
||||
[ math-ops get (derived-ops) ]
|
||||
bi append ;
|
||||
|
||||
: fast-derived-ops ( word -- words )
|
||||
fast-math-ops get (derived-ops) ;
|
||||
|
||||
: all-derived-ops ( word -- words )
|
||||
[ derived-ops ] [ fast-derived-ops ] bi append ;
|
||||
|
||||
: each-derived-op ( word quot -- )
|
||||
>r derived-ops r> each ; inline
|
||||
Loading…
Reference in New Issue