New modular arithmetic optimization pass

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 ;
+compiler.tree.checker
-
+compiler.tree.debugger ;
-: cleaned-up-tree ( quot -- nodes )
-    build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
 
 [ 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

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<= ;
 

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 ;

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 ;

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

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 ;

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.combinators
-compiler.tree.recursive
-compiler.tree.normalization
-compiler.tree.propagation
 compiler.tree.propagation.info
-compiler.tree.cleanup
+compiler.tree.late-optimizations ;
-compiler.tree.def-use
-compiler.tree.dead-code
-compiler.tree.combinators ;
 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
+! tail call optimization in the code generator.
-! 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.
 
 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? ;
 

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 ;

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

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 ;

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 ;

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 ;

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

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
+compiler.tree.debugger compiler.tree.checker
-classes assocs ;
+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

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
+

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