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