diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 2e8eb15959..b3ba62b73b 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -13,10 +13,8 @@ compiler.tree.builder compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation -compiler.tree.checker ; - -: cleaned-up-tree ( quot -- nodes ) - build-tree analyze-recursive normalize propagate cleanup dup check-nodes ; +compiler.tree.checker +compiler.tree.debugger ; [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test @@ -34,12 +32,6 @@ compiler.tree.checker ; [ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test -: inlined? ( quot seq/word -- ? ) - [ cleaned-up-tree ] dip - dup word? [ 1array ] when - '[ dup #call? [ word>> _ member? ] [ drop f ] if ] - contains-node? not ; - [ f ] [ [ { integer } declare >fixnum ] \ >fixnum inlined? @@ -498,3 +490,7 @@ cell-bits 32 = [ [ 2 swap >fixnum ribs ] { <-integer-fixnum +-integer-fixnum } inlined? ] unit-test + +[ t ] [ + [ hashtable new ] \ new inlined? +] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 58dc07d868..563926f233 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -64,14 +64,6 @@ GENERIC: cleanup* ( node -- node/nodes ) ] [ body>> cleanup ] bi ; ! Removing overflow checks -: no-overflow-variant ( op -- fast-op ) - H{ - { fixnum+ fixnum+fast } - { fixnum- fixnum-fast } - { fixnum* fixnum*fast } - { fixnum-shift fixnum-shift-fast } - } at ; - : (remove-overflow-check?) ( #call -- ? ) node-output-infos first class>> fixnum class<= ; diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index a19e49494e..719c80f911 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -36,7 +36,7 @@ M: #branch remove-dead-code* '[ _ nth _ key? ] filter ; inline : drop-indexed-values ( values indices -- node ) - [ drop filter-live ] [ nths ] 2bi + [ drop filter-live ] [ swap nths ] 2bi [ make-values ] keep [ drop ] [ zip ] 2bi #shuffle ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 691c564661..4d2881af5a 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,13 +1,21 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs fry match accessors namespaces make effects +USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.sections math words -combinators io sorting hints +combinators io sorting hints qualified compiler.tree +compiler.tree.recursive +compiler.tree.normalization +compiler.tree.cleanup +compiler.tree.propagation +compiler.tree.propagation.info +compiler.tree.def-use compiler.tree.builder compiler.tree.optimizer -compiler.tree.combinators ; +compiler.tree.combinators +compiler.tree.checker ; +RENAME: _ match => __ IN: compiler.tree.debugger ! A simple tool for turning tree IR into quotations and @@ -42,7 +50,7 @@ MATCH-VARS: ?a ?b ?c ; { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } { { { ?a ?b } { ?b } } [ nip ] } { { { ?a ?b ?c } { ?c } } [ 2nip ] } - { _ f } + { __ f } } match-choose ; TUPLE: shuffle-node { effect effect } ; @@ -146,3 +154,32 @@ SYMBOL: node-count : optimizer-report. ( word -- ) make-report report. ; + +! More utilities + +: final-info ( quot -- seq ) + build-tree + analyze-recursive + normalize + propagate + compute-def-use + dup check-nodes + peek node-input-infos ; + +: final-classes ( quot -- seq ) + final-info [ class>> ] map ; + +: final-literals ( quot -- seq ) + final-info [ literal>> ] map ; + +: cleaned-up-tree ( quot -- nodes ) + [ + check-optimizer? on + build-tree optimize-tree + ] with-scope ; + +: inlined? ( quot seq/word -- ? ) + [ cleaned-up-tree ] dip + dup word? [ 1array ] when + '[ dup #call? [ word>> _ member? ] [ drop f ] if ] + contains-node? not ; diff --git a/basis/compiler/tree/def-use/simplified/simplified-tests.factor b/basis/compiler/tree/def-use/simplified/simplified-tests.factor new file mode 100644 index 0000000000..a1a768d429 --- /dev/null +++ b/basis/compiler/tree/def-use/simplified/simplified-tests.factor @@ -0,0 +1,10 @@ +USING: kernel tools.test compiler.tree compiler.tree.builder +compiler.tree.def-use compiler.tree.def-use.simplified accessors +sequences sorting classes ; +IN: compiler.tree.def-use.simplified + +[ { #call #return } ] [ + [ 1 dup reverse ] build-tree compute-def-use + first out-d>> first actually-used-by + [ node>> class ] map natural-sort +] unit-test diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor new file mode 100644 index 0000000000..edfe633057 --- /dev/null +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences sequences.deep kernel +compiler.tree compiler.tree.def-use ; +IN: compiler.tree.def-use.simplified + +! Simplified def-use follows chains of copies. + +! A 'real' usage is a usage of a value that is not a #renaming. +TUPLE: real-usage value node ; + +GENERIC: actually-used-by* ( value node -- real-usages ) + +! Def +GENERIC: actually-defined-by* ( value node -- real-usage ) + +: actually-defined-by ( value -- real-usage ) + dup defined-by actually-defined-by* ; + +M: #renaming actually-defined-by* + inputs/outputs swap [ index ] dip nth actually-defined-by ; + +M: #return-recursive actually-defined-by* real-usage boa ; + +M: node actually-defined-by* real-usage boa ; + +! Use +: (actually-used-by) ( value -- real-usages ) + dup used-by [ actually-used-by* ] with map ; + +M: #renaming actually-used-by* + inputs/outputs [ indices ] dip nths + [ (actually-used-by) ] map ; + +M: #return-recursive actually-used-by* real-usage boa ; + +M: node actually-used-by* real-usage boa ; + +: actually-used-by ( value -- real-usages ) + (actually-used-by) flatten ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index ba7e4ff652..c312cb68dc 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -6,27 +6,20 @@ classes.tuple.private slots.private combinators layouts byte-arrays alien.accessors compiler.intrinsics compiler.tree -compiler.tree.builder -compiler.tree.recursive -compiler.tree.normalization -compiler.tree.propagation +compiler.tree.combinators compiler.tree.propagation.info -compiler.tree.cleanup -compiler.tree.def-use -compiler.tree.dead-code -compiler.tree.combinators ; +compiler.tree.late-optimizations ; IN: compiler.tree.finalization +! This is a late-stage optimization. +! See the comment in compiler.tree.late-optimizations. + ! This pass runs after propagation, so that it can expand ! built-in type predicates and memory allocation; these cannot ! be expanded before propagation since we need to see 'fixnum?' ! instead of 'tag 0 eq?' and so on, for semantic reasoning. ! We also delete empty stack shuffles and copies to facilitate -! tail call optimization in the code generator. After this pass -! runs, stack flow information is no longer accurate, since we -! punt in 'splice-quot' and don't update everything that we -! should; this simplifies the code, improves performance, and we -! don't need the stack flow information after this pass anyway. +! tail call optimization in the code generator. GENERIC: finalize* ( node -- nodes ) @@ -37,18 +30,6 @@ M: #shuffle finalize* [ in>> ] [ out>> ] bi sequence= [ drop f ] when ; -: splice-quot ( quot -- nodes ) - [ - build-tree - analyze-recursive - normalize - propagate - cleanup - compute-def-use - remove-dead-code - but-last - ] with-scope ; - : builtin-predicate? ( #call -- ? ) word>> "predicating" word-prop builtin-class? ; diff --git a/basis/compiler/tree/late-optimizations/late-optimizations.factor b/basis/compiler/tree/late-optimizations/late-optimizations.factor new file mode 100644 index 0000000000..e2641416b2 --- /dev/null +++ b/basis/compiler/tree/late-optimizations/late-optimizations.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences namespaces compiler.tree.builder +compiler.tree.recursive +compiler.tree.normalization +compiler.tree.propagation +compiler.tree.propagation.info +compiler.tree.cleanup +compiler.tree.def-use +compiler.tree.dead-code ; +IN: compiler.tree.late-optimizations + +! Late optimizations modify the tree such that stack flow +! information is no longer accurate, since we punt in +! 'splice-quot' and don't update everything that we should; +! this simplifies the code, improves performance, and we +! don't need the stack flow information after this pass anyway. + +: splice-quot ( quot -- nodes ) + [ + build-tree + analyze-recursive + normalize + propagate + cleanup + compute-def-use + remove-dead-code + but-last + ] with-scope ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor new file mode 100644 index 0000000000..b535dfe39c --- /dev/null +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -0,0 +1,130 @@ +IN: compiler.tree.modular-arithmetic.tests +USING: kernel kernel.private tools.test math math.partial-dispatch +math.private accessors slots.private sequences strings sbufs +compiler.tree.builder +compiler.tree.optimizer +compiler.tree.debugger ; + +: test-modular-arithmetic ( quot -- quot' ) + build-tree optimize-tree nodes>quot ; + +[ [ >r >fixnum r> >fixnum fixnum+fast ] ] +[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test + +[ [ +-integer-integer dup >fixnum ] ] +[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test + +[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ] +[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test + +TUPLE: declared-fixnum { x fixnum } ; + +[ t ] [ + [ { declared-fixnum } declare [ 1 + ] change-x ] + { + fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { declared-fixnum } declare x>> drop ] + { slot } inlined? +] unit-test + +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum bitand } inlined? +] unit-test + +[ f ] [ + [ { integer } declare 127 bitand 3 + ] + { >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 + +[ 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 + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ + inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? +] unit-test + + + +[ t ] [ + [ + { integer } declare [ 256 mod ] map + ] { mod fixnum-mod } inlined? +] unit-test + + +[ f ] [ + [ + 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + +[ f ] [ + [ + dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 256 rem + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare [ 256 rem ] map + ] { mod fixnum-mod rem } inlined? +] unit-test diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor new file mode 100644 index 0000000000..d65b1def16 --- /dev/null +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.partial-dispatch namespaces sequences sets +accessors assocs words kernel memoize fry combinators +compiler.tree +compiler.tree.combinators +compiler.tree.def-use +compiler.tree.def-use.simplified +compiler.tree.late-optimizations ; +IN: compiler.tree.modular-arithmetic + +! This is a late-stage optimization. +! See the comment in compiler.tree.late-optimizations. + +! Modular arithmetic optimization pass. +! +! { integer integer } declare + >fixnum +! ==> +! [ >fixnum ] bi@ fixnum+fast + +{ + - * bitand bitor bitxor } [ + [ + t "modular-arithmetic" set-word-prop + ] each-integer-derived-op +] each + +{ bitand bitor bitxor bitnot } +[ t "modular-arithmetic" set-word-prop ] each + +SYMBOL: modularize-values + +: modular-value? ( value -- ? ) + modularize-values get key? ; + +: modularize-value ( value -- ) modularize-values get conjoin ; + +GENERIC: maybe-modularize* ( value node -- ) + +: maybe-modularize ( value -- ) + actually-defined-by [ value>> ] [ node>> ] bi + over actually-used-by length 1 = [ + maybe-modularize* + ] [ 2drop ] if ; + +M: #call maybe-modularize* + dup word>> "modular-arithmetic" word-prop [ + [ modularize-value ] + [ in-d>> [ maybe-modularize ] each ] bi* + ] [ 2drop ] if ; + +M: node maybe-modularize* 2drop ; + +GENERIC: compute-modularized-values* ( node -- ) + +M: #call compute-modularized-values* + dup word>> { + { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] } + ! { [ + ! { + ! mod-integer-fixnum + ! mod-integer-integer + ! mod-fixnum-integer + ! } memq? + ! ] [ ] } + [ drop ] + } cond ; + +M: node compute-modularized-values* drop ; + +: compute-modularized-values ( nodes -- ) + [ compute-modularized-values* ] each-node ; + +GENERIC: optimize-modular-arithmetic* ( node -- nodes ) + +: redundant->fixnum? ( #call -- ? ) + in-d>> first actually-defined-by value>> modular-value? ; + +: optimize->fixnum ( #call -- nodes ) + dup redundant->fixnum? [ drop f ] when ; + +MEMO: fixnum-coercion ( flags -- nodes ) + [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; + +: optimize-modular-op ( #call -- nodes ) + dup out-d>> first modular-value? [ + [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri + [ + [ + [ actually-defined-by value>> modular-value? ] + [ fixnum eq? ] + bi* or + ] 2map fixnum-coercion + ] [ [ modular-variant ] change-word ] bi* suffix + ] when ; + +M: #call optimize-modular-arithmetic* + dup word>> { + { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } + [ drop ] + } cond ; + +M: node optimize-modular-arithmetic* ; + +: optimize-modular-arithmetic ( nodes -- nodes' ) + H{ } clone modularize-values set + dup compute-modularized-values + [ optimize-modular-arithmetic* ] map-nodes ; diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 3196253d45..e37323a2ec 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -10,7 +10,7 @@ compiler.tree.tuple-unboxing compiler.tree.identities compiler.tree.def-use compiler.tree.dead-code -compiler.tree.strength-reduction +compiler.tree.modular-arithmetic compiler.tree.finalization compiler.tree.checker ; IN: compiler.tree.optimizer @@ -27,9 +27,10 @@ SYMBOL: check-optimizer? apply-identities compute-def-use remove-dead-code - ! strength-reduce check-optimizer? get [ compute-def-use dup check-nodes ] when + compute-def-use + optimize-modular-arithmetic finalize ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 48864d8782..197d1820bf 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces +words namespaces continuations compiler.tree compiler.tree.builder compiler.tree.recursive @@ -33,7 +33,7 @@ M: quotation splicing-nodes body>> (propagate) ; ! Dispatch elimination -: eliminate-dispatch ( #call class/f word/f -- ? ) +: eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip over method>> over = [ drop ] [ @@ -156,12 +156,19 @@ SYMBOL: history : always-inline-word? ( word -- ? ) { curry compose } memq? ; +: custom-inlining? ( word -- ? ) + "custom-inlining" word-prop ; + +: inline-custom ( #call word -- ? ) + [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack + first object swap eliminate-dispatch ; + : do-inlining ( #call word -- ? ) { + { [ dup custom-inlining? ] [ inline-custom ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ dup math-partial? ] [ inline-math-partial ] } { [ dup method-body? ] [ inline-method-body ] } [ 2drop f ] } cond ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d208d31389..9f208bdc12 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -230,6 +230,32 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +{ + mod-integer-integer + mod-integer-fixnum + mod-fixnum-integer + fixnum-mod + rem +} [ + [ + in-d>> second value-info >literal< + [ power-of-2? [ 1- bitand ] f ? ] when + ] "custom-inlining" set-word-prop +] each + +{ + bitand-integer-integer + bitand-integer-fixnum + bitand-fixnum-integer +} [ + [ + in-d>> second value-info >literal< [ + 0 most-positive-fixnum between? + [ [ >fixnum ] bi@ fixnum-bitand ] f ? + ] when + ] "custom-inlining" set-word-prop +] each + { alien-signed-1 alien-unsigned-1 diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index a115ee53c2..6638951723 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -6,27 +6,12 @@ alien.accessors alien.c-types sequences.private byte-arrays classes.algebra classes.tuple.private math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use -compiler.tree.checker slots.private words hashtables -classes assocs ; +compiler.tree.debugger compiler.tree.checker +slots.private words hashtables classes assocs ; IN: compiler.tree.propagation.tests \ propagate must-infer -: final-info ( quot -- seq ) - build-tree - analyze-recursive - normalize - propagate - compute-def-use - dup check-nodes - peek node-input-infos ; - -: final-classes ( quot -- seq ) - final-info [ class>> ] map ; - -: final-literals ( quot -- seq ) - final-info [ literal>> ] map ; - [ V{ } ] [ [ ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test @@ -594,6 +579,14 @@ MIXIN: empty-mixin [ { float } declare 0 eq? ] final-classes ] unit-test +[ V{ integer } ] [ + [ { integer fixnum } declare mod ] final-classes +] unit-test + +[ V{ integer } ] [ + [ { fixnum integer } declare bitand ] final-classes +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/math/partial-dispatch/partial-dispatch-tests.factor b/basis/math/partial-dispatch/partial-dispatch-tests.factor index 64605b1818..388b4127cd 100644 --- a/basis/math/partial-dispatch/partial-dispatch-tests.factor +++ b/basis/math/partial-dispatch/partial-dispatch-tests.factor @@ -1,5 +1,6 @@ IN: math.partial-dispatch.tests -USING: math.partial-dispatch tools.test math kernel sequences ; +USING: math.partial-dispatch math.private +tools.test math kernel sequences ; [ t ] [ \ + integer fixnum math-both-known? ] unit-test [ t ] [ \ + bignum fixnum math-both-known? ] unit-test @@ -10,3 +11,17 @@ USING: math.partial-dispatch tools.test math kernel sequences ; [ 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 + +[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test +[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test +[ { fixnum fixnum } ] [ \ fixnum+fast integer-op-input-classes ] unit-test +[ { integer } ] [ \ bitnot integer-op-input-classes ] unit-test + +[ shift ] [ \ fixnum-shift generic-variant ] unit-test +[ fixnum-shift-fast ] [ \ fixnum-shift no-overflow-variant ] unit-test + +[ fixnum-shift-fast ] [ \ shift modular-variant ] unit-test +[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test +[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test +[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test + diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index b162406e5a..61678eb088 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -6,13 +6,41 @@ generic generic.math hashtables effects compiler.units classes.algebra ; IN: math.partial-dispatch -! 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 ; +GENERIC: integer-op-input-classes ( word -- classes ) + +M: math-partial integer-op-input-classes + "derived-from" word-prop rest ; + +M: word integer-op-input-classes + "input-classes" word-prop + [ "Bug: integer-op-input-classes" throw ] unless* ; + +: generic-variant ( op -- generic-op/f ) + dup "derived-from" word-prop [ first ] [ ] ?if ; + +: no-overflow-variant ( op -- fast-op ) + H{ + { fixnum+ fixnum+fast } + { fixnum- fixnum-fast } + { fixnum* fixnum*fast } + { fixnum-shift fixnum-shift-fast } + } at ; + +: modular-variant ( op -- fast-op ) + generic-variant dup H{ + { + fixnum+fast } + { - fixnum-fast } + { * fixnum*fast } + { shift fixnum-shift-fast } + { bitand fixnum-bitand } + { bitor fixnum-bitor } + { bitxor fixnum-bitxor } + { bitnot fixnum-bitnot } + } at swap or ; + :: fixnum-integer-op ( a b fix-word big-word -- c ) b tag 0 eq? [ a b fix-word execute @@ -69,10 +97,17 @@ PREDICATE: math-partial < word } swap [ prefix ] curry map ; : define-integer-ops ( word fix-word big-word -- ) - >r >r integer-op-triples r> r> - [ define-integer-op-words ] - [ 2drop [ dup integer-op-word ] { } map>assoc % ] - 3bi ; + [ + rot tuck + [ fixnum fixnum 3array "derived-from" set-word-prop ] + [ bignum bignum 3array "derived-from" set-word-prop ] + 2bi* + ] [ + [ integer-op-triples ] 2dip + [ define-integer-op-words ] + [ 2drop [ dup integer-op-word ] { } map>assoc % ] + 3bi + ] 3bi ; : define-math-ops ( op -- ) { fixnum bignum float } @@ -125,6 +160,9 @@ SYMBOL: fast-math-ops : each-fast-derived-op ( word quot -- ) >r fast-derived-ops r> each ; inline +: each-integer-derived-op ( word quot -- ) + >r integer-derived-ops r> each ; inline + [ [ \ + define-math-ops