Partial dispatch on integer operations

core/generic/generic.factor

@@ -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 )

core/inference/class/class-tests.factor

@@ -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 ] [

core/math/intervals/intervals.factor

@@ -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 ] }

core/math/math.factor

@@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
 
 M: object zero? drop f ;
 
-: 1+ ( x -- y ) 1 + ; foldable
+: 1+ ( x -- y ) 1 + ; inline
-: 1- ( x -- y ) 1 - ; foldable
+: 1- ( x -- y ) 1 - ; inline
-: 2/ ( x -- y ) -1 shift ; foldable
+: 2/ ( x -- y ) -1 shift ; inline
-: sq ( x -- y ) dup * ; foldable
+: sq ( x -- y ) dup * ; inline
-: neg ( x -- -x ) 0 swap - ; foldable
+: neg ( x -- -x ) 0 swap - ; inline
-: recip ( x -- y ) 1 swap / ; foldable
+: 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
+: max ( x y -- z ) [ > ] most ; inline
-: min ( x y -- z ) [ < ] most ; foldable
+: 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
 

core/optimizer/inlining/inlining-tests.factor

@@ -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

core/optimizer/inlining/inlining.factor

@@ -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
+combinators classes classes.algebra generic.math
-optimizer.def-use optimizer.backend generic.standard
+optimizer.math.partial continuations optimizer.def-use
-optimizer.specializers optimizer.def-use optimizer.pattern-match
+optimizer.backend generic.standard optimizer.specializers
-generic.standard optimizer.control kernel.private ;
+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 -- ? )
+: inlining-math-method ( #call word -- quot/f )
-    math-class-max swap specific-method ;
+    swap node-input-classes
-
-: inline-math-method ( #call word -- node )
-    over node-input-classes
     [ first normalize-math-class ]
     [ second normalize-math-class ] bi
-    3dup math-both-known?
+    3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
-    [ math-method f splice-quot ]
+
-    [ 2drop 2drop t ] 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 ;
 

core/optimizer/known-words/known-words.factor

@@ -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
 

core/optimizer/math/math.factor

@@ -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 } {
+\ mod {
-    { { number 1 } [ 2drop 0 ] }
+    { { integer 1 } [ 2drop 0 ] }
-} define-identities
+} 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 }
-
+    { shift f interval-shift-safe }
-    { 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 }
 } [
     first3 [
-        math-output-class/interval-2
+        [
-    ] 2curry "output-classes" set-word-prop
+            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
+            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
+            [ comparison-constraints ] with-scope
-    ] 2curry "constraints" set-word-prop
+        ] 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 ,
+            dup [ dupd foldable-comparison? ] curry ,
-    ] { } make 1array define-optimizers
+            [ 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,20 +378,20 @@ most-negative-fixnum most-positive-fixnum [a,b]
     [ \ >fixnum consumed-by? ] [ drop f ] if ;
 
 {
-    { fixnum+ [ fixnum+fast ] }
+    { + [ [ >fixnum ] bi@ fixnum+fast ] }
-    { fixnum- [ fixnum-fast ] }
+    { - [ [ >fixnum ] bi@ fixnum-fast ] }
-    { fixnum* [ fixnum*fast ] }
+    { * [ [ >fixnum ] bi@ fixnum*fast ] }
-    { + [ >r >fixnum r> >fixnum fixnum+fast ] }
+    { shift [ [ >fixnum ] bi@ fixnum-shift-fast ] }
-    { - [ >r >fixnum r> >fixnum fixnum-fast ] }
-    { * [ >r >fixnum r> >fixnum fixnum*fast ] }
 } [
-    [
+    >r derived-ops r> [
         [
-            dup remove-overflow-check?
+            [
-            over coerced-to-fixnum? or
+                dup remove-overflow-check?
-        ] ,
+                over coerced-to-fixnum? or
-        [ f splice-quot ] curry ,
+            ] ,
-    ] { } make 1array define-optimizers
+            [ 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 {
     {

core/optimizer/math/partial/partial-tests.factor

@@ -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

core/optimizer/math/partial/partial.factor

@@ -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