extra/compiler/cfg/gvn/math/math.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators combinators.short-circuit
   4 cpu.architecture fry kernel layouts locals make math sequences
   5 compiler.cfg.instructions
   6 compiler.cfg.registers
   7 compiler.cfg.utilities
   8 compiler.cfg.gvn.folding
   9 compiler.cfg.gvn.graph
  10 compiler.cfg.gvn.avail
  11 compiler.cfg.gvn.rewrite ;
  12 IN: compiler.cfg.gvn.math
  13
  14 : f-insn? ( insn -- ? )
  15     { [ ##load-reference? ] [ obj>> not ] } 1&& ; inline
  16
  17 : zero-insn? ( insn -- ? )
  18     { [ ##load-integer? ] [ val>> 0 = ] } 1&& ; inline
  19
  20 M: ##tagged>integer rewrite
  21     [ dst>> ] [ src>> vreg>insn ] bi {
  22         { [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] }
  23         { [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] }
  24         [ 2drop f ]
  25     } cond ;
  26
  27 : self-inverse? ( insn quot -- ? )
  28     [ src>> vreg>insn ] dip with-available-uses? ; inline
  29
  30 : self-inverse ( insn -- insn' )
  31     [ dst>> ] [ src>> vreg>insn src>> ] bi <copy> ;
  32
  33 : identity ( insn -- insn' )
  34     [ dst>> ] [ src1>> ] bi <copy> ;
  35
  36 M: ##neg rewrite
  37     {
  38         { [ dup [ ##neg? ] self-inverse? ] [ self-inverse ] }
  39         { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
  40         [ drop f ]
  41     } cond ;
  42
  43 M: ##not rewrite
  44     {
  45         { [ dup [ ##not? ] self-inverse? ] [ self-inverse ] }
  46         { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
  47         [ drop f ]
  48     } cond ;
  49
  50 ! Reassociation converts
  51 ! ## *-imm 2 1 X
  52 ! ## *-imm 3 2 Y
  53 ! into
  54 ! ## *-imm 3 1 (X $ Y)
  55 ! If * is associative, then $ is the same operation as *.
  56 ! In the case of shifts, $ is addition.
  57 : (reassociate) ( insn -- dst src1 src2' src2'' )
  58     {
  59         [ dst>> ]
  60         [ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ]
  61         [ src2>> ]
  62     } cleave ; inline
  63
  64 : reassociate ( insn -- dst src1 src2 )
  65     [ (reassociate) ] keep binary-constant-fold* ;
  66
  67 : ?new-insn ( dst src1 src2 ? class -- insn/f )
  68     '[ _ new-insn ] [ 3drop f ] if ; inline
  69
  70 : reassociate-arithmetic ( insn new-insn -- insn/f )
  71     [ reassociate dup immediate-arithmetic? ] dip ?new-insn ; inline
  72
  73 : reassociate-bitwise ( insn new-insn -- insn/f )
  74     [ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline
  75
  76 : reassociate-shift ( insn new-insn -- insn/f )
  77     [ (reassociate) + dup immediate-shift-count? ] dip ?new-insn ; inline
  78
  79 M: ##add-imm rewrite
  80     {
  81         { [ dup src2>> 0 = ] [ identity ] }
  82         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
  83         { [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] }
  84         [ drop f ]
  85     } cond ;
  86
  87 : sub-imm>add-imm ( insn -- insn' )
  88     [ dst>> ] [ src1>> ] [ src2>> neg ] tri
  89     dup immediate-arithmetic?
  90     \ ##add-imm ?new-insn ;
  91
  92 M: ##sub-imm rewrite sub-imm>add-imm ;
  93
  94 ! Convert ##mul-imm -1 => ##neg
  95 : mul-to-neg? ( insn -- ? )
  96     src2>> -1 = ;
  97
  98 : mul-to-neg ( insn -- insn' )
  99     [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
 100
 101 ! Convert ##mul-imm 2^X => ##shl-imm X
 102 : mul-to-shl? ( insn -- ? )
 103     src2>> power-of-2? ;
 104
 105 : mul-to-shl ( insn -- insn' )
 106     [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
 107
 108 ! Distribution converts
 109 ! ##+-imm 2 1 X
 110 ! ##*-imm 3 2 Y
 111 ! Into
 112 ! ##*-imm 4 1 Y
 113 ! ##+-imm 3 4 X*Y
 114 ! Where * is mul or shl, + is add or sub
 115 ! Have to make sure that X*Y fits in an immediate
 116 :: (distribute) ( outer inner imm temp add-op mul-op -- new-outers/f )
 117     imm immediate-arithmetic? [
 118         [
 119             temp inner src1>> outer src2>> mul-op execute
 120             outer dst>> temp imm add-op execute
 121         ] { } make
 122     ] [ f ] if ; inline
 123
 124 : distribute-over-add? ( insn -- ? )
 125     drop f ;
 126     ! src1>> vreg>insn [ ##add-imm? ] with-available-uses? ;
 127
 128 : distribute-over-sub? ( insn -- ? )
 129     drop f ;
 130     ! src1>> vreg>insn [ ##sub-imm? ] with-available-uses? ;
 131
 132 ! XXX next-vreg makes vregs>vns change on every iteration
 133 : distribute ( insn add-op mul-op -- new-insns/f )
 134     [
 135         dup src1>> vreg>insn
 136         2dup src2>> swap [ src2>> ] keep binary-constant-fold*
 137         next-vreg
 138     ] 2dip (distribute) ; inline
 139
 140 M: ##mul-imm rewrite
 141     {
 142         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 143         { [ dup mul-to-neg? ] [ mul-to-neg ] }
 144         { [ dup mul-to-shl? ] [ mul-to-shl ] }
 145         { [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] }
 146         { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
 147         { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
 148         [ drop f ]
 149     } cond ;
 150
 151 M: ##and-imm rewrite
 152     {
 153         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 154         { [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] }
 155         { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] }
 156         { [ dup src2>> -1 = ] [ identity ] }
 157         [ drop f ]
 158     } cond ;
 159
 160 M: ##or-imm rewrite
 161     {
 162         { [ dup src2>> 0 = ] [ identity ] }
 163         { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] }
 164         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 165         { [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] }
 166         [ drop f ]
 167     } cond ;
 168
 169 M: ##xor-imm rewrite
 170     {
 171         { [ dup src2>> 0 = ] [ identity ] }
 172         { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] }
 173         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 174         { [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] }
 175         [ drop f ]
 176     } cond ;
 177
 178 M: ##shl-imm rewrite
 179     {
 180         { [ dup src2>> 0 = ] [ identity ] }
 181         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 182         { [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] }
 183         { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
 184         { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
 185         [ drop f ]
 186     } cond ;
 187
 188 M: ##shr-imm rewrite
 189     {
 190         { [ dup src2>> 0 = ] [ identity ] }
 191         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 192         { [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] }
 193         [ drop f ]
 194     } cond ;
 195
 196 M: ##sar-imm rewrite
 197     {
 198         { [ dup src2>> 0 = ] [ identity ] }
 199         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
 200         { [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] }
 201         [ drop f ]
 202     } cond ;
 203
 204 ! Convert
 205 ! ##load-integer 2 X
 206 ! ##* 3 1 2
 207 ! Where * is an operation with an -imm equivalent into
 208 ! ##*-imm 3 1 X
 209 : insn>imm-insn ( insn op swap? -- new-insn )
 210     swap [
 211         [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
 212         [ swap ] when vreg>integer
 213     ] dip new-insn ; inline
 214
 215 M: ##add rewrite
 216     {
 217         { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] }
 218         { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] }
 219         [ drop f ]
 220     } cond ;
 221
 222 : diagonal? ( insn -- ? )
 223     [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi = ; inline
 224
 225 ! ##sub 2 1 1 => ##load-integer 2 0
 226 : rewrite-subtraction-identity ( insn -- insn' )
 227     dst>> 0 \ ##load-integer new-insn ;
 228
 229 ! ##load-integer 1 0
 230 ! ##sub 3 1 2
 231 ! =>
 232 ! ##neg 3 2
 233 : sub-to-neg? ( ##sub -- ? )
 234     src1>> vreg>insn zero-insn? ;
 235
 236 : sub-to-neg ( ##sub -- insn )
 237     [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
 238
 239 M: ##sub rewrite
 240     {
 241         { [ dup sub-to-neg? ] [ sub-to-neg ] }
 242         { [ dup diagonal? ] [ rewrite-subtraction-identity ] }
 243         { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] }
 244         [ drop f ]
 245     } cond ;
 246
 247 M: ##mul rewrite
 248     {
 249         { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] }
 250         { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] }
 251         [ drop f ]
 252     } cond ;
 253
 254 M: ##and rewrite
 255     {
 256         { [ dup diagonal? ] [ identity ] }
 257         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] }
 258         { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] }
 259         [ drop f ]
 260     } cond ;
 261
 262 M: ##or rewrite
 263     {
 264         { [ dup diagonal? ] [ identity ] }
 265         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] }
 266         { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] }
 267         [ drop f ]
 268     } cond ;
 269
 270 M: ##xor rewrite
 271     {
 272         { [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] }
 273         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] }
 274         { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] }
 275         [ drop f ]
 276     } cond ;
 277
 278 M: ##shl rewrite
 279     {
 280         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] }
 281         [ drop f ]
 282     } cond ;
 283
 284 M: ##shr rewrite
 285     {
 286         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] }
 287         [ drop f ]
 288     } cond ;
 289
 290 M: ##sar rewrite
 291     {
 292         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] }
 293         [ drop f ]
 294     } cond ;