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