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