basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors assocs combinators
   4 combinators.short-circuit compiler.tree
   5 compiler.tree.combinators compiler.tree.def-use.simplified
   6 compiler.tree.late-optimizations compiler.tree.propagation.info
   7 fry kernel layouts math math.intervals math.partial-dispatch
   8 math.private memoize namespaces sequences sets words ;
   9 FROM: namespaces => set ;
  10 IN: compiler.tree.modular-arithmetic
  11
  12 ! This is a late-stage optimization.
  13 ! See the comment in compiler.tree.late-optimizations.
  14
  15 ! Modular arithmetic optimization pass.
  16 !
  17 ! { integer integer } declare + >fixnum
  18 !    ==>
  19 !        [ >fixnum ] bi@ fixnum+fast
  20
  21 ! Words where the low-order bits of the output only depends on the
  22 ! low-order bits of the input. If the output is only used for its
  23 ! low-order bits, then the word can be converted into a form that is
  24 ! cheaper to compute.
  25 { + - * bitand bitor bitxor } [
  26     [
  27         t "modular-arithmetic" set-word-prop
  28     ] each-integer-derived-op
  29 ] each
  30
  31 { bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
  32 [ t "modular-arithmetic" set-word-prop ] each
  33
  34 ! Words that only use the low-order bits of their input. If the input
  35 ! is a modular arithmetic word, then the input can be converted into
  36 ! a form that is cheaper to compute.
  37 {
  38     >fixnum bignum>fixnum integer>fixnum
  39     float>fixnum
  40     set-alien-unsigned-1 set-alien-signed-1
  41     set-alien-unsigned-2 set-alien-signed-2
  42 }
  43 cell 8 = [
  44     { set-alien-unsigned-4 set-alien-signed-4 } append
  45 ] when
  46 [ t "low-order" set-word-prop ] each
  47
  48 ! Values which only have their low-order bits used. This set starts out
  49 ! big and is gradually refined.
  50 SYMBOL: modular-values
  51
  52 : modular-value? ( value -- ? )
  53     modular-values get in? ;
  54
  55 : modular-value ( value -- )
  56     modular-values get adjoin ;
  57
  58 ! Values which are known to be fixnums.
  59 SYMBOL: fixnum-values
  60
  61 : fixnum-value? ( value -- ? )
  62     fixnum-values get in? ;
  63
  64 : fixnum-value ( value -- )
  65     fixnum-values get adjoin ;
  66
  67 GENERIC: compute-modular-candidates* ( node -- )
  68
  69 M: #push compute-modular-candidates*
  70     [ out-d>> first ] [ literal>> ] bi
  71     real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
  72
  73 : small-shift? ( interval -- ? )
  74     0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
  75
  76 : modular-word? ( #call -- ? )
  77     dup word>> { shift fixnum-shift bignum-shift } member-eq?
  78     [ node-input-infos second interval>> small-shift? ]
  79     [ word>> "modular-arithmetic" word-prop ]
  80     if ;
  81
  82 : output-candidate ( #call -- )
  83     out-d>> first [ modular-value ] [ fixnum-value ] bi ;
  84
  85 : low-order-word? ( #call -- ? )
  86     word>> "low-order" word-prop ;
  87
  88 : input-candidiate ( #call -- )
  89     in-d>> first modular-value ;
  90
  91 M: #call compute-modular-candidates*
  92     {
  93         { [ dup modular-word? ] [ output-candidate ] }
  94         { [ dup low-order-word? ] [ input-candidiate ] }
  95         [ drop ]
  96     } cond ;
  97
  98 M: node compute-modular-candidates*
  99     drop ;
 100
 101 : compute-modular-candidates ( nodes -- )
 102     HS{ } clone modular-values set
 103     HS{ } clone fixnum-values set
 104     [ compute-modular-candidates* ] each-node ;
 105
 106 GENERIC: only-reads-low-order? ( node -- ? )
 107
 108 : output-modular? ( #call -- ? )
 109     out-d>> first modular-value? ;
 110
 111 M: #call only-reads-low-order?
 112     {
 113         [ low-order-word? ]
 114         [ { [ modular-word? ] [ output-modular? ] } 1&& ]
 115     } 1|| ;
 116
 117 M: node only-reads-low-order? drop f ;
 118
 119 SYMBOL: changed?
 120
 121 : only-used-as-low-order? ( value -- ? )
 122     actually-used-by [ node>> only-reads-low-order? ] all? ;
 123
 124 : (compute-modular-values) ( -- )
 125     modular-values get members [
 126         dup only-used-as-low-order?
 127         [ drop ] [ modular-values get delete changed? on ] if
 128     ] each ;
 129
 130 : compute-modular-values ( -- )
 131     [ changed? off (compute-modular-values) changed? get ] loop ;
 132
 133 GENERIC: optimize-modular-arithmetic* ( node -- nodes )
 134
 135 M: #push optimize-modular-arithmetic*
 136     dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
 137     [ [ >fixnum ] change-literal ] when ;
 138
 139 : redundant->fixnum? ( #call -- ? )
 140     in-d>> first actually-defined-by
 141     [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ;
 142
 143 : optimize->fixnum ( #call -- nodes )
 144     dup redundant->fixnum? [ drop f ] when ;
 145
 146 : should-be->fixnum? ( #call -- ? )
 147     out-d>> first modular-value? ;
 148
 149 : optimize->integer ( #call -- nodes )
 150     dup should-be->fixnum? [ \ >fixnum >>word ] when ;
 151
 152 MEMO: fixnum-coercion ( flags -- nodes )
 153     ! flags indicate which input parameters are already known to be fixnums,
 154     ! and don't need a coercion as a result.
 155     [ [ ] [ >fixnum ] ? ] map shallow-spread>quot
 156     '[ _ call ] splice-quot ;
 157
 158 : modular-value-info ( #call -- alist )
 159     [ in-d>> ] [ out-d>> ] bi append
 160     fixnum <class-info> '[ _ ] { } map>assoc ;
 161
 162 : optimize-modular-op ( #call -- nodes )
 163     dup out-d>> first modular-value? [
 164         [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
 165         [
 166             [
 167                 [ actually-defined-by [ value>> modular-value? ] all? ]
 168                 [ fixnum eq? ]
 169                 bi* or
 170             ] 2map fixnum-coercion
 171         ] [ [ modular-variant ] change-word ] bi* suffix
 172     ] when ;
 173
 174 : optimize-low-order-op ( #call -- nodes )
 175     dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [
 176         [ ] [ in-d>> first ] [ info>> ] tri
 177         [ drop fixnum <class-info> ] change-at
 178     ] when ;
 179
 180 : like->fixnum? ( #call -- ? )
 181     word>> {
 182         >fixnum bignum>fixnum float>fixnum
 183         integer>fixnum integer>fixnum-strict
 184     } member-eq? ;
 185
 186 : like->integer? ( #call -- ? )
 187     word>> { >integer >bignum fixnum>bignum } member-eq? ;
 188
 189 M: #call optimize-modular-arithmetic*
 190     {
 191         { [ dup like->fixnum? ] [ optimize->fixnum ] }
 192         { [ dup like->integer? ] [ optimize->integer ] }
 193         { [ dup modular-word? ] [ optimize-modular-op ] }
 194         { [ dup low-order-word? ] [ optimize-low-order-op ] }
 195         [ ]
 196     } cond ;
 197
 198 M: node optimize-modular-arithmetic* ;
 199
 200 : optimize-modular-arithmetic ( nodes -- nodes' )
 201     dup compute-modular-candidates compute-modular-values
 202     modular-values get null? [
 203         [ optimize-modular-arithmetic* ] map-nodes
 204     ] unless ;