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

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