basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators combinators.short-circuit arrays
   4 fry kernel layouts math namespaces sequences cpu.architecture
   5 math.bitwise math.order classes vectors
   6 compiler.cfg
   7 compiler.cfg.hats
   8 compiler.cfg.comparisons
   9 compiler.cfg.instructions
  10 compiler.cfg.value-numbering.expressions
  11 compiler.cfg.value-numbering.graph
  12 compiler.cfg.value-numbering.simplify ;
  13 IN: compiler.cfg.value-numbering.rewrite
  14
  15 : vreg-small-constant? ( vreg -- ? )
  16     vreg>expr {
  17         [ constant-expr? ]
  18         [ value>> small-enough? ]
  19     } 1&& ;
  20
  21 ! Outputs f to mean no change
  22
  23 GENERIC: rewrite* ( insn -- insn/f )
  24
  25 : rewrite ( insn -- insn' )
  26     dup [ number-values ] [ rewrite* ] bi
  27     [ rewrite ] [ ] ?if ;
  28
  29 M: insn rewrite* drop f ;
  30
  31 : ##branch-t? ( insn -- ? )
  32     dup ##compare-imm-branch? [
  33         {
  34             [ cc>> cc/= eq? ]
  35             [ src2>> \ f tag-number eq? ]
  36         } 1&&
  37     ] [ drop f ] if ; inline
  38
  39 : rewrite-boolean-comparison? ( insn -- ? )
  40     dup ##branch-t? [
  41         src1>> vreg>expr compare-expr?
  42     ] [ drop f ] if ; inline
  43
  44 : >compare-expr< ( expr -- in1 in2 cc )
  45     [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
  46
  47 : >compare-imm-expr< ( expr -- in1 in2 cc )
  48     [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
  49
  50 : rewrite-boolean-comparison ( expr -- insn )
  51     src1>> vreg>expr dup op>> {
  52         { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
  53         { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
  54         { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
  55     } case ;
  56
  57 : tag-fixnum-expr? ( expr -- ? )
  58     dup op>> \ ##shl-imm eq?
  59     [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
  60
  61 : rewrite-tagged-comparison? ( insn -- ? )
  62     #! Are we comparing two tagged fixnums? Then untag them.
  63     {
  64         [ src1>> vreg>expr tag-fixnum-expr? ]
  65         [ src2>> tag-mask get bitand 0 = ]
  66     } 1&& ; inline
  67
  68 : tagged>constant ( n -- n' )
  69     tag-bits get neg shift ; inline
  70
  71 : (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
  72     [ src1>> vreg>expr in1>> vn>vreg ]
  73     [ src2>> tagged>constant ]
  74     [ cc>> ]
  75     tri ; inline
  76
  77 GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
  78
  79 M: ##compare-imm-branch rewrite-tagged-comparison
  80     (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
  81
  82 M: ##compare-imm rewrite-tagged-comparison
  83     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
  84     i \ ##compare-imm new-insn ;
  85
  86 : rewrite-redundant-comparison? ( insn -- ? )
  87     {
  88         [ src1>> vreg>expr compare-expr? ]
  89         [ src2>> \ f tag-number = ]
  90         [ cc>> { cc= cc/= } memq? ]
  91     } 1&& ; inline
  92
  93 : rewrite-redundant-comparison ( insn -- insn' )
  94     [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
  95         { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
  96         { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
  97         { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
  98     } case
  99     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 100
 101 ERROR: bad-comparison ;
 102
 103 : (fold-compare-imm) ( insn -- ? )
 104     [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
 105     pick integer?
 106     [ [ <=> ] dip evaluate-cc ]
 107     [
 108         2nip {
 109             { cc= [ f ] }
 110             { cc/= [ t ] }
 111             [ bad-comparison ]
 112         } case
 113     ] if ;
 114
 115 : fold-compare-imm? ( insn -- ? )
 116     src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
 117
 118 : fold-branch ( ? -- insn )
 119     0 1 ?
 120     basic-block get [ nth 1vector ] change-successors drop
 121     \ ##branch new-insn ;
 122
 123 : fold-compare-imm-branch ( insn -- insn/f )
 124     (fold-compare-imm) fold-branch ;
 125
 126 M: ##compare-imm-branch rewrite*
 127     {
 128         { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
 129         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
 130         { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
 131         [ drop f ]
 132     } cond ;
 133
 134 : swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
 135     [ [ swap ] dip swap-cc ] when ; inline
 136
 137 : >compare-imm-branch ( insn swap? -- insn' )
 138     [
 139         [ src1>> ]
 140         [ src2>> ]
 141         [ cc>> ]
 142         tri
 143     ] dip
 144     swap-compare
 145     [ vreg>constant ] dip
 146     \ ##compare-imm-branch new-insn ; inline
 147
 148 : self-compare? ( insn -- ? )
 149     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
 150
 151 : (rewrite-self-compare) ( insn -- ? )
 152     cc>> { cc= cc<= cc>= } memq? ;
 153
 154 : rewrite-self-compare-branch ( insn -- insn' )
 155     (rewrite-self-compare) fold-branch ;
 156
 157 M: ##compare-branch rewrite*
 158     {
 159         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
 160         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
 161         { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
 162         [ drop f ]
 163     } cond ;
 164
 165 : >compare-imm ( insn swap? -- insn' )
 166     [
 167         {
 168             [ dst>> ]
 169             [ src1>> ]
 170             [ src2>> ]
 171             [ cc>> ]
 172         } cleave
 173     ] dip
 174     swap-compare
 175     [ vreg>constant ] dip
 176     i \ ##compare-imm new-insn ; inline
 177
 178 : >boolean-insn ( insn ? -- insn' )
 179     [ dst>> ] dip
 180     {
 181         { t [ t \ ##load-reference new-insn ] }
 182         { f [ \ f tag-number \ ##load-immediate new-insn ] }
 183     } case ;
 184
 185 : rewrite-self-compare ( insn -- insn' )
 186     dup (rewrite-self-compare) >boolean-insn ;
 187
 188 M: ##compare rewrite*
 189     {
 190         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
 191         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
 192         { [ dup self-compare? ] [ rewrite-self-compare ] }
 193         [ drop f ]
 194     } cond ;
 195
 196 : fold-compare-imm ( insn -- insn' )
 197     dup (fold-compare-imm) >boolean-insn ;
 198
 199 M: ##compare-imm rewrite*
 200     {
 201         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
 202         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
 203         { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
 204         [ drop f ]
 205     } cond ;
 206
 207 : constant-fold? ( insn -- ? )
 208     src1>> vreg>expr constant-expr? ; inline
 209
 210 GENERIC: constant-fold* ( x y insn -- z )
 211
 212 M: ##add-imm constant-fold* drop + ;
 213 M: ##sub-imm constant-fold* drop - ;
 214 M: ##mul-imm constant-fold* drop * ;
 215 M: ##and-imm constant-fold* drop bitand ;
 216 M: ##or-imm constant-fold* drop bitor ;
 217 M: ##xor-imm constant-fold* drop bitxor ;
 218 M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
 219 M: ##sar-imm constant-fold* drop neg shift ;
 220 M: ##shl-imm constant-fold* drop shift ;
 221
 222 : constant-fold ( insn -- insn' )
 223     [ dst>> ]
 224     [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
 225     \ ##load-immediate new-insn ; inline
 226
 227 : reassociate? ( insn -- ? )
 228     [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
 229
 230 : reassociate ( insn op -- insn )
 231     [
 232         {
 233             [ dst>> ]
 234             [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
 235             [ src2>> ]
 236             [ ]
 237         } cleave constant-fold*
 238     ] dip
 239     over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
 240
 241 M: ##add-imm rewrite*
 242     {
 243         { [ dup constant-fold? ] [ constant-fold ] }
 244         { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
 245         [ drop f ]
 246     } cond ;
 247
 248 : sub-imm>add-imm ( insn -- insn' )
 249     [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
 250     [ \ ##add-imm new-insn ] [ 3drop f ] if ;
 251
 252 M: ##sub-imm rewrite*
 253     {
 254         { [ dup constant-fold? ] [ constant-fold ] }
 255         [ sub-imm>add-imm ]
 256     } cond ;
 257
 258 : strength-reduce-mul ( insn -- insn' )
 259     [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
 260
 261 : strength-reduce-mul? ( insn -- ? )
 262     src2>> power-of-2? ;
 263
 264 M: ##mul-imm rewrite*
 265     {
 266         { [ dup constant-fold? ] [ constant-fold ] }
 267         { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
 268         { [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
 269         [ drop f ]
 270     } cond ;
 271
 272 M: ##and-imm rewrite*
 273     {
 274         { [ dup constant-fold? ] [ constant-fold ] }
 275         { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
 276         [ drop f ]
 277     } cond ;
 278
 279 M: ##or-imm rewrite*
 280     {
 281         { [ dup constant-fold? ] [ constant-fold ] }
 282         { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
 283         [ drop f ]
 284     } cond ;
 285
 286 M: ##xor-imm rewrite*
 287     {
 288         { [ dup constant-fold? ] [ constant-fold ] }
 289         { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
 290         [ drop f ]
 291     } cond ;
 292
 293 M: ##shl-imm rewrite*
 294     {
 295         { [ dup constant-fold? ] [ constant-fold ] }
 296         [ drop f ]
 297     } cond ;
 298
 299 M: ##shr-imm rewrite*
 300     {
 301         { [ dup constant-fold? ] [ constant-fold ] }
 302         [ drop f ]
 303     } cond ;
 304
 305 M: ##sar-imm rewrite*
 306     {
 307         { [ dup constant-fold? ] [ constant-fold ] }
 308         [ drop f ]
 309     } cond ;
 310
 311 : insn>imm-insn ( insn op swap? -- )
 312     swap [
 313         [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
 314         [ swap ] when vreg>constant
 315     ] dip new-insn ; inline
 316
 317 : rewrite-arithmetic ( insn op -- ? )
 318     {
 319         { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
 320         [ 2drop f ]
 321     } cond ; inline
 322
 323 : rewrite-arithmetic-commutative ( insn op -- ? )
 324     {
 325         { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
 326         { [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
 327         [ 2drop f ]
 328     } cond ; inline
 329
 330 M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
 331
 332 : subtraction-identity? ( insn -- ? )
 333     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq?  ;
 334
 335 : rewrite-subtraction-identity ( insn -- insn' )
 336     dst>> 0 \ ##load-immediate new-insn ;
 337
 338 M: ##sub rewrite*
 339     {
 340         { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
 341         [ \ ##sub-imm rewrite-arithmetic ]
 342     } cond ;
 343
 344 M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
 345
 346 M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
 347
 348 M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
 349
 350 M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
 351
 352 M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
 353
 354 M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
 355
 356 M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;