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

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg.
   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
   6 vectors locals make alien.c-types io.binary grouping
   7 compiler.cfg
   8 compiler.cfg.registers
   9 compiler.cfg.comparisons
  10 compiler.cfg.instructions
  11 compiler.cfg.value-numbering.expressions
  12 compiler.cfg.value-numbering.graph
  13 compiler.cfg.value-numbering.simplify ;
  14 IN: compiler.cfg.value-numbering.rewrite
  15
  16 : vreg-immediate-arithmetic? ( vreg -- ? )
  17     vreg>expr {
  18         [ constant-expr? ]
  19         [ value>> fixnum? ]
  20         [ value>> immediate-arithmetic? ]
  21     } 1&& ;
  22
  23 : vreg-immediate-bitwise? ( vreg -- ? )
  24     vreg>expr {
  25         [ constant-expr? ]
  26         [ value>> fixnum? ]
  27         [ value>> immediate-bitwise? ]
  28     } 1&& ;
  29
  30 ! Outputs f to mean no change
  31
  32 GENERIC: rewrite ( insn -- insn/f )
  33
  34 M: insn rewrite drop f ;
  35
  36 : ##branch-t? ( insn -- ? )
  37     dup ##compare-imm-branch? [
  38         {
  39             [ cc>> cc/= eq? ]
  40             [ src2>> \ f type-number eq? ]
  41         } 1&&
  42     ] [ drop f ] if ; inline
  43
  44 : general-compare-expr? ( insn -- ? )
  45     {
  46         [ compare-expr? ]
  47         [ compare-imm-expr? ]
  48         [ compare-float-unordered-expr? ]
  49         [ compare-float-ordered-expr? ]
  50     } 1|| ;
  51
  52 : general-or-vector-compare-expr? ( insn -- ? )
  53     {
  54         [ compare-expr? ]
  55         [ compare-imm-expr? ]
  56         [ compare-float-unordered-expr? ]
  57         [ compare-float-ordered-expr? ]
  58         [ test-vector-expr? ]
  59     } 1|| ;
  60
  61 : rewrite-boolean-comparison? ( insn -- ? )
  62     dup ##branch-t? [
  63         src1>> vreg>expr general-or-vector-compare-expr?
  64     ] [ drop f ] if ; inline
  65
  66 : >compare-expr< ( expr -- in1 in2 cc )
  67     [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
  68
  69 : >compare-imm-expr< ( expr -- in1 in2 cc )
  70     [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
  71
  72 : >test-vector-expr< ( expr -- src1 temp rep vcc )
  73     {
  74         [ src1>> vn>vreg ]
  75         [ drop next-vreg ]
  76         [ rep>> ]
  77         [ vcc>> ]
  78     } cleave ; inline
  79
  80 : rewrite-boolean-comparison ( expr -- insn )
  81     src1>> vreg>expr {
  82         { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
  83         { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
  84         { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
  85         { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
  86         { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
  87     } cond ;
  88
  89 : tag-fixnum-expr? ( expr -- ? )
  90     dup shl-imm-expr?
  91     [ src2>> vn>constant tag-bits get = ] [ drop f ] if ;
  92
  93 : rewrite-tagged-comparison? ( insn -- ? )
  94     #! Are we comparing two tagged fixnums? Then untag them.
  95     {
  96         [ src1>> vreg>expr tag-fixnum-expr? ]
  97         [ src2>> tag-mask get bitand 0 = ]
  98     } 1&& ; inline
  99
 100 : tagged>constant ( n -- n' )
 101     tag-bits get neg shift ; inline
 102
 103 : (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
 104     [ src1>> vreg>expr src1>> vn>vreg ]
 105     [ src2>> tagged>constant ]
 106     [ cc>> ]
 107     tri ; inline
 108
 109 GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
 110
 111 M: ##compare-imm-branch rewrite-tagged-comparison
 112     (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
 113
 114 M: ##compare-imm rewrite-tagged-comparison
 115     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
 116     next-vreg \ ##compare-imm new-insn ;
 117
 118 : rewrite-redundant-comparison? ( insn -- ? )
 119     {
 120         [ src1>> vreg>expr general-compare-expr? ]
 121         [ src2>> \ f type-number = ]
 122         [ cc>> { cc= cc/= } member-eq? ]
 123     } 1&& ; inline
 124
 125 : rewrite-redundant-comparison ( insn -- insn' )
 126     [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
 127         { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
 128         { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
 129         { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
 130         { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
 131     } cond
 132     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 133
 134 ERROR: bad-comparison ;
 135
 136 : (fold-compare-imm) ( insn -- ? )
 137     [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
 138     pick integer?
 139     [ [ <=> ] dip evaluate-cc ]
 140     [
 141         2nip {
 142             { cc= [ f ] }
 143             { cc/= [ t ] }
 144             [ bad-comparison ]
 145         } case
 146     ] if ;
 147
 148 : fold-compare-imm? ( insn -- ? )
 149     src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
 150
 151 : fold-branch ( ? -- insn )
 152     0 1 ?
 153     basic-block get [ nth 1vector ] change-successors drop
 154     \ ##branch new-insn ;
 155
 156 : fold-compare-imm-branch ( insn -- insn/f )
 157     (fold-compare-imm) fold-branch ;
 158
 159 M: ##compare-imm-branch rewrite
 160     {
 161         { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
 162         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
 163         { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
 164         [ drop f ]
 165     } cond ;
 166
 167 : swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
 168     [ [ swap ] dip swap-cc ] when ; inline
 169
 170 : >compare-imm-branch ( insn swap? -- insn' )
 171     [
 172         [ src1>> ]
 173         [ src2>> ]
 174         [ cc>> ]
 175         tri
 176     ] dip
 177     swap-compare
 178     [ vreg>constant ] dip
 179     \ ##compare-imm-branch new-insn ; inline
 180
 181 : self-compare? ( insn -- ? )
 182     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
 183
 184 : (rewrite-self-compare) ( insn -- ? )
 185     cc>> { cc= cc<= cc>= } member-eq? ;
 186
 187 : rewrite-self-compare-branch ( insn -- insn' )
 188     (rewrite-self-compare) fold-branch ;
 189
 190 M: ##compare-branch rewrite
 191     {
 192         { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] }
 193         { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] }
 194         { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
 195         [ drop f ]
 196     } cond ;
 197
 198 : >compare-imm ( insn swap? -- insn' )
 199     [
 200         {
 201             [ dst>> ]
 202             [ src1>> ]
 203             [ src2>> ]
 204             [ cc>> ]
 205         } cleave
 206     ] dip
 207     swap-compare
 208     [ vreg>constant ] dip
 209     next-vreg \ ##compare-imm new-insn ; inline
 210
 211 : >boolean-insn ( insn ? -- insn' )
 212     [ dst>> ] dip
 213     {
 214         { t [ t \ ##load-constant new-insn ] }
 215         { f [ \ f type-number \ ##load-immediate new-insn ] }
 216     } case ;
 217
 218 : rewrite-self-compare ( insn -- insn' )
 219     dup (rewrite-self-compare) >boolean-insn ;
 220
 221 M: ##compare rewrite
 222     {
 223         { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] }
 224         { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] }
 225         { [ dup self-compare? ] [ rewrite-self-compare ] }
 226         [ drop f ]
 227     } cond ;
 228
 229 : fold-compare-imm ( insn -- insn' )
 230     dup (fold-compare-imm) >boolean-insn ;
 231
 232 M: ##compare-imm rewrite
 233     {
 234         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
 235         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
 236         { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
 237         [ drop f ]
 238     } cond ;
 239
 240 : constant-fold? ( insn -- ? )
 241     src1>> vreg>expr constant-expr? ; inline
 242
 243 GENERIC: constant-fold* ( x y insn -- z )
 244
 245 M: ##add-imm constant-fold* drop + ;
 246 M: ##sub-imm constant-fold* drop - ;
 247 M: ##mul-imm constant-fold* drop * ;
 248 M: ##and-imm constant-fold* drop bitand ;
 249 M: ##or-imm constant-fold* drop bitor ;
 250 M: ##xor-imm constant-fold* drop bitxor ;
 251 M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
 252 M: ##sar-imm constant-fold* drop neg shift ;
 253 M: ##shl-imm constant-fold* drop shift ;
 254
 255 : constant-fold ( insn -- insn' )
 256     [ dst>> ]
 257     [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
 258     \ ##load-immediate new-insn ; inline
 259
 260 : unary-constant-fold? ( insn -- ? )
 261     src>> vreg>expr constant-expr? ; inline
 262
 263 GENERIC: unary-constant-fold* ( x insn -- y )
 264
 265 M: ##not unary-constant-fold* drop bitnot ;
 266 M: ##neg unary-constant-fold* drop neg ;
 267
 268 : unary-constant-fold ( insn -- insn' )
 269     [ dst>> ]
 270     [ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi
 271     \ ##load-immediate new-insn ; inline
 272
 273 : maybe-unary-constant-fold ( insn -- insn' )
 274     dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
 275
 276 M: ##neg rewrite
 277     maybe-unary-constant-fold ;
 278
 279 M: ##not rewrite
 280     maybe-unary-constant-fold ;
 281
 282 : arithmetic-op? ( op -- ? )
 283     {
 284         ##add
 285         ##add-imm
 286         ##sub
 287         ##sub-imm
 288         ##mul
 289         ##mul-imm
 290     } member-eq? ;
 291
 292 : immediate? ( value op -- ? )
 293     arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
 294
 295 : reassociate ( insn op -- insn )
 296     [
 297         {
 298             [ dst>> ]
 299             [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
 300             [ src2>> ]
 301             [ ]
 302         } cleave constant-fold*
 303     ] dip
 304     2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
 305
 306 M: ##add-imm rewrite
 307     {
 308         { [ dup constant-fold? ] [ constant-fold ] }
 309         { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
 310         [ drop f ]
 311     } cond ;
 312
 313 : sub-imm>add-imm ( insn -- insn' )
 314     [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
 315     [ \ ##add-imm new-insn ] [ 3drop f ] if ;
 316
 317 M: ##sub-imm rewrite
 318     {
 319         { [ dup constant-fold? ] [ constant-fold ] }
 320         [ sub-imm>add-imm ]
 321     } cond ;
 322
 323 : mul-to-neg? ( insn -- ? )
 324     src2>> -1 = ;
 325
 326 : mul-to-neg ( insn -- insn' )
 327     [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
 328
 329 : mul-to-shl? ( insn -- ? )
 330     src2>> power-of-2? ;
 331
 332 : mul-to-shl ( insn -- insn' )
 333     [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
 334
 335 M: ##mul-imm rewrite
 336     {
 337         { [ dup constant-fold? ] [ constant-fold ] }
 338         { [ dup mul-to-neg? ] [ mul-to-neg ] }
 339         { [ dup mul-to-shl? ] [ mul-to-shl ] }
 340         { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
 341         [ drop f ]
 342     } cond ;
 343
 344 M: ##and-imm rewrite
 345     {
 346         { [ dup constant-fold? ] [ constant-fold ] }
 347         { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
 348         [ drop f ]
 349     } cond ;
 350
 351 M: ##or-imm rewrite
 352     {
 353         { [ dup constant-fold? ] [ constant-fold ] }
 354         { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
 355         [ drop f ]
 356     } cond ;
 357
 358 M: ##xor-imm rewrite
 359     {
 360         { [ dup constant-fold? ] [ constant-fold ] }
 361         { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
 362         [ drop f ]
 363     } cond ;
 364
 365 M: ##shl-imm rewrite
 366     {
 367         { [ dup constant-fold? ] [ constant-fold ] }
 368         [ drop f ]
 369     } cond ;
 370
 371 M: ##shr-imm rewrite
 372     {
 373         { [ dup constant-fold? ] [ constant-fold ] }
 374         [ drop f ]
 375     } cond ;
 376
 377 M: ##sar-imm rewrite
 378     {
 379         { [ dup constant-fold? ] [ constant-fold ] }
 380         [ drop f ]
 381     } cond ;
 382
 383 : insn>imm-insn ( insn op swap? -- )
 384     swap [
 385         [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
 386         [ swap ] when vreg>constant
 387     ] dip new-insn ; inline
 388
 389 : vreg-immediate? ( vreg op -- ? )
 390     arithmetic-op?
 391     [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
 392
 393 : rewrite-arithmetic ( insn op -- ? )
 394     {
 395         { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
 396         [ 2drop f ]
 397     } cond ; inline
 398
 399 : rewrite-arithmetic-commutative ( insn op -- ? )
 400     {
 401         { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
 402         { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
 403         [ 2drop f ]
 404     } cond ; inline
 405
 406 M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
 407
 408 : subtraction-identity? ( insn -- ? )
 409     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq?  ;
 410
 411 : rewrite-subtraction-identity ( insn -- insn' )
 412     dst>> 0 \ ##load-immediate new-insn ;
 413
 414 : sub-to-neg? ( ##sub -- ? )
 415     src1>> vn>expr expr-zero? ;
 416
 417 : sub-to-neg ( ##sub -- insn )
 418     [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
 419
 420 M: ##sub rewrite
 421     {
 422         { [ dup sub-to-neg? ] [ sub-to-neg ] }
 423         { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
 424         [ \ ##sub-imm rewrite-arithmetic ]
 425     } cond ;
 426
 427 M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
 428
 429 M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
 430
 431 M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
 432
 433 M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
 434
 435 M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
 436
 437 M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
 438
 439 M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
 440
 441 ! ##box-displaced-alien f 1 2 3 <class>
 442 ! ##unbox-c-ptr 4 1 <class>
 443 ! =>
 444 ! ##box-displaced-alien f 1 2 3 <class>
 445 ! ##unbox-c-ptr 5 3 <class>
 446 ! ##add 4 5 2
 447
 448 :: rewrite-unbox-displaced-alien ( insn expr -- insns )
 449     [
 450         next-vreg :> temp
 451         temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
 452         insn dst>> temp expr displacement>> vn>vreg ##add
 453     ] { } make ;
 454
 455 M: ##unbox-any-c-ptr rewrite
 456     dup src>> vreg>expr dup box-displaced-alien-expr?
 457     [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
 458
 459 ! More efficient addressing for alien intrinsics
 460 : rewrite-alien-addressing ( insn -- insn' )
 461     dup src>> vreg>expr dup add-imm-expr? [
 462         [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
 463         [ >>src ] [ '[ _ + ] change-offset ] bi*
 464     ] [ 2drop f ] if ;
 465
 466 M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
 467 M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
 468 M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
 469 M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
 470 M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
 471 M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
 472 M: ##alien-float rewrite rewrite-alien-addressing ;
 473 M: ##alien-double rewrite rewrite-alien-addressing ;
 474 M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
 475 M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
 476 M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
 477 M: ##set-alien-float rewrite rewrite-alien-addressing ;
 478 M: ##set-alien-double rewrite rewrite-alien-addressing ;
 479