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