basis/compiler/tree/cleanup/cleanup-tests.factor

   1 USING: accessors alien alien.c-types alien.data arrays assocs
   2 combinators combinators.short-circuit compiler.tree
   3 compiler.tree.builder compiler.tree.checker compiler.tree.cleanup
   4 compiler.tree.combinators compiler.tree.debugger
   5 compiler.tree.normalization compiler.tree.propagation
   6 compiler.tree.propagation.info generalizations grouping hashtables
   7 io.encodings io.encodings.ascii io.encodings.utf8 kernel
   8 kernel.private layouts math math.functions math.intervals math.order
   9 math.partial-dispatch math.private prettyprint quotations sequences
  10 sequences.private slots slots.private sorting.private tools.test
  11 vectors ;
  12 FROM: math => float ;
  13 QUALIFIED-WITH: alien.c-types c
  14 IN: compiler.tree.cleanup.tests
  15
  16 { t } [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
  17
  18 { f } [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
  19
  20 { f } [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
  21
  22 { t } [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
  23
  24 : recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
  25
  26 { t } [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
  27
  28 { f } [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
  29
  30 { t } [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
  31
  32 { f } [
  33     [ { integer } declare >fixnum ]
  34     \ >fixnum inlined?
  35 ] unit-test
  36
  37 GENERIC: mynot ( x -- y )
  38
  39 M: f mynot drop t ; inline
  40
  41 M: object mynot drop f ; inline
  42
  43 GENERIC: detect-f ( x -- y )
  44
  45 M: f detect-f ; inline
  46
  47 { t } [
  48     [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
  49 ] unit-test
  50
  51 GENERIC: xyz ( n -- n )
  52
  53 M: integer xyz ; inline
  54
  55 M: object xyz ; inline
  56
  57 { t } [
  58     [ { integer } declare xyz ] \ xyz inlined?
  59 ] unit-test
  60
  61 { t } [
  62     [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
  63     \ xyz inlined?
  64 ] unit-test
  65
  66 : (fx-repeat) ( i n quot: ( i -- i ) -- )
  67     2over fixnum>= [
  68         3drop
  69     ] [
  70         [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
  71     ] if ; inline recursive
  72
  73 : fx-repeat ( n quot -- )
  74     0 -rot (fx-repeat) ; inline
  75
  76 ! The + should be optimized into fixnum+, if it was not, then
  77 ! the type of the loop index was not inferred correctly
  78 { t } [
  79     [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
  80 ] unit-test
  81
  82 : (i-repeat) ( i n quot: ( i -- i ) -- )
  83     2over dup xyz drop >= [
  84         3drop
  85     ] [
  86         [ swap [ call 1 + ] dip ] keep (i-repeat)
  87     ] if ; inline recursive
  88
  89 : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
  90
  91 { t } [
  92     [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
  93 ] unit-test
  94
  95 { t } [
  96     [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
  97 ] unit-test
  98
  99 { t } [
 100     [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
 101     \ + inlined?
 102 ] unit-test
 103
 104 { t } [
 105     [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
 106     \ + inlined?
 107 ] unit-test
 108
 109 { t } [
 110     [ { fixnum } declare [ ] times ] \ >= inlined?
 111 ] unit-test
 112
 113 { t } [
 114     [ { fixnum } declare [ ] times ] \ + inlined?
 115 ] unit-test
 116
 117 { t } [
 118     [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
 119 ] unit-test
 120
 121 { t } [
 122     [ { integer fixnum } declare dupd < [ 1 + ] when ]
 123     \ + inlined?
 124 ] unit-test
 125
 126 { f } [
 127     [ { integer fixnum } declare dupd < [ 1 + ] when ]
 128     \ +-integer-fixnum inlined?
 129 ] unit-test
 130
 131 { t } [
 132     [
 133         [ no-cond ] 1
 134         [ 1array dup quotation? [ >quotation ] unless ] times
 135     ] \ quotation? inlined?
 136 ] unit-test
 137
 138 { t } [
 139     [
 140         1000000000000000000000000000000000 [ ] times
 141     ] \ + inlined?
 142 ] unit-test
 143 { f } [
 144     [
 145         1000000000000000000000000000000000 [ ] times
 146     ] \ +-integer-fixnum inlined?
 147 ] unit-test
 148
 149 { f } [
 150     [ { bignum } declare [ ] times ]
 151     \ +-integer-fixnum inlined?
 152 ] unit-test
 153
 154 { t } [
 155     [ { array-capacity } declare 0 < ] \ < inlined?
 156 ] unit-test
 157
 158 { t } [
 159     [ { array-capacity } declare 0 < ] \ fixnum< inlined?
 160 ] unit-test
 161
 162 { t } [
 163     [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 164 ] unit-test
 165
 166 GENERIC: annotate-entry-test-1 ( x -- )
 167
 168 M: fixnum annotate-entry-test-1 drop ;
 169
 170 : (annotate-entry-test-2) ( from to -- )
 171     2dup >= [
 172         2drop
 173     ] [
 174         [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
 175     ] if ; inline recursive
 176
 177 : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
 178
 179 { f } [
 180     [ { bignum } declare annotate-entry-test-2 ]
 181     \ annotate-entry-test-1 inlined?
 182 ] unit-test
 183
 184 { t } [
 185     [ { float } declare 10 [ 2.3 * ] times >float ]
 186     \ >float inlined?
 187 ] unit-test
 188
 189 GENERIC: detect-float ( a -- b )
 190
 191 M: float detect-float ;
 192
 193 { t } [
 194     [ { real float } declare + detect-float ]
 195     \ detect-float inlined?
 196 ] unit-test
 197
 198 { t } [
 199     [ { float real } declare + detect-float ]
 200     \ detect-float inlined?
 201 ] unit-test
 202
 203 { f } [
 204     [ { fixnum fixnum } declare 7 bitand neg shift ]
 205     \ fixnum-shift-fast inlined?
 206 ] unit-test
 207
 208 { t } [
 209     [ { fixnum fixnum } declare 7 bitand neg shift ]
 210     { shift fixnum-shift } inlined?
 211 ] unit-test
 212
 213 { t } [
 214     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 215     { shift fixnum-shift } inlined?
 216 ] unit-test
 217
 218 { f } [
 219     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 220     { fixnum-shift-fast } inlined?
 221 ] unit-test
 222
 223 { t } [
 224     [ 1 swap 7 bitand shift ]
 225     { shift fixnum-shift } inlined?
 226 ] unit-test
 227
 228 cell-bits 32 = [
 229     [ t ] [
 230         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 231         \ shift inlined?
 232     ] unit-test
 233
 234     [ f ] [
 235         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 236         \ fixnum-shift inlined?
 237     ] unit-test
 238 ] when
 239
 240 { t } [
 241     [ B{ 1 0 } c:short deref 0 number= ]
 242     \ number= inlined?
 243 ] unit-test
 244
 245 { t } [
 246     [ B{ 1 0 } c:short deref 0 { number number } declare number= ]
 247     \ number= inlined?
 248 ] unit-test
 249
 250 { t } [
 251     [ B{ 1 0 } c:short deref 0 = ]
 252     \ number= inlined?
 253 ] unit-test
 254
 255 { t } [
 256     [ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
 257     \ number= inlined?
 258 ] unit-test
 259
 260 { t } [
 261     [ 0xff bitand 0 0xff between? ]
 262     \ >= inlined?
 263 ] unit-test
 264
 265 { t } [
 266     [ 0xff swap 0xff bitand >= ]
 267     \ >= inlined?
 268 ] unit-test
 269
 270 { t } [
 271     [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
 272 ] unit-test
 273
 274 { t } [
 275     [
 276         dup integer? [
 277             dup fixnum? [
 278                 1 +
 279             ] [
 280                 2 +
 281             ] if
 282         ] when
 283     ] \ + inlined?
 284 ] unit-test
 285
 286 : rec ( a -- b )
 287     dup 0 > [ 1 - rec ] when ; inline recursive
 288
 289 { t } [
 290     [ { fixnum } declare rec 1 + ]
 291     { > - + } inlined?
 292 ] unit-test
 293
 294 : fib ( m -- n )
 295     dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
 296
 297 { t } [
 298     [ 27.0 fib ] { < - + } inlined?
 299 ] unit-test
 300
 301 { f } [
 302     [ 27.0 fib ] { +-integer-integer } inlined?
 303 ] unit-test
 304
 305 { t } [
 306     [ 27 fib ] { < - + } inlined?
 307 ] unit-test
 308
 309 { t } [
 310     [ 27 >bignum fib ] { < - + } inlined?
 311 ] unit-test
 312
 313 { f } [
 314     [ 27/2 fib ] { < - } inlined?
 315 ] unit-test
 316
 317 { t } [
 318     [ 10 [ -1 shift ] times ] \ shift inlined?
 319 ] unit-test
 320
 321 { f } [
 322     [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
 323     \ fixnum-bitand inlined?
 324 ] unit-test
 325
 326 { t } [
 327     [ { fixnum } declare [ drop ] each-integer ]
 328     { < <-integer-fixnum +-integer-fixnum + } inlined?
 329 ] unit-test
 330
 331 { t } [
 332     [ { fixnum } declare <iota> [ drop ] each ]
 333     { < <-integer-fixnum +-integer-fixnum + } inlined?
 334 ] unit-test
 335
 336 { t } [
 337     [ { fixnum } declare <iota> 0 [ + ] reduce ]
 338     { < <-integer-fixnum nth-unsafe } inlined?
 339 ] unit-test
 340
 341 { f } [
 342     [ { fixnum } declare <iota> 0 [ + ] reduce ]
 343     \ +-integer-fixnum inlined?
 344 ] unit-test
 345
 346 { t } [
 347     [
 348         { integer } declare <iota> [ ] map
 349     ] \ integer>fixnum inlined?
 350 ] unit-test
 351
 352 { f } [
 353     [
 354         { integer } declare { } set-nth-unsafe
 355     ] \ integer>fixnum inlined?
 356 ] unit-test
 357
 358 { f } [
 359     [
 360         { integer } declare 1 + { } set-nth-unsafe
 361     ] \ >fixnum inlined?
 362 ] unit-test
 363
 364 { t } [
 365     [
 366         { array } declare length
 367         1 + dup 100 fixnum> [ 1 fixnum+ ] when
 368     ] \ fixnum+ inlined?
 369 ] unit-test
 370
 371 { t } [
 372     [ [ resize-array ] keep length ] \ length inlined?
 373 ] unit-test
 374
 375 { t } [
 376     [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
 377 ] unit-test
 378
 379 { t } [
 380     [ { utf8 } declare decode-char ] \ decode-char inlined?
 381 ] unit-test
 382
 383 { t } [
 384     [ { ascii } declare decode-char ] \ decode-char inlined?
 385 ] unit-test
 386
 387 { t } [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
 388
 389 { t } [
 390     [
 391         { integer } declare <iota> [ 0 >= ] map
 392     ] { >= fixnum>= } inlined?
 393 ] unit-test
 394
 395 { } [
 396     [
 397         4 pick array-capacity?
 398         [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
 399     ] cleaned-up-tree drop
 400 ] unit-test
 401
 402 { } [
 403     [ { merge-state } declare accum>> 0 >>length ] cleaned-up-tree drop
 404 ] unit-test
 405
 406 { } [
 407     [
 408         [ "X" throw ]
 409         [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
 410         if
 411     ] cleaned-up-tree drop
 412 ] unit-test
 413
 414 { t } [
 415     [ [ 2array ] [ 0 3array ] if first ]
 416     { nth-unsafe < <= > >= } inlined?
 417 ] unit-test
 418
 419 { } [
 420     [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
 421     cleaned-up-tree drop
 422 ] unit-test
 423
 424 ! Regression from benchmark.nsieve
 425 : chicken-fingers ( i seq -- )
 426     2dup < [
 427         2drop
 428     ] [
 429         chicken-fingers
 430     ] if ; inline recursive
 431
 432 : buffalo-wings ( i seq -- )
 433     2dup < [
 434         2dup chicken-fingers
 435         [ 1 + ] dip buffalo-wings
 436     ] [
 437         2drop
 438     ] if ; inline recursive
 439
 440 { t } [
 441     [ 2 swap >fixnum buffalo-wings ]
 442     { <-integer-fixnum +-integer-fixnum } inlined?
 443 ] unit-test
 444
 445 ! A reduction
 446 : buffalo-sauce ( -- value ) f ;
 447
 448 : steak ( -- )
 449     buffalo-sauce [ steak ] when ; inline recursive
 450
 451 : ribs ( i seq -- )
 452     2dup < [
 453         steak
 454         [ 1 + ] dip ribs
 455     ] [
 456         2drop
 457     ] if ; inline recursive
 458
 459 { t } [
 460     [ 2 swap >fixnum ribs ]
 461     { <-integer-fixnum +-integer-fixnum } inlined?
 462 ] unit-test
 463
 464 { t } [
 465     [ hashtable new ] \ new inlined?
 466 ] unit-test
 467
 468 { t } [
 469     [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
 470     [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
 471 ] unit-test
 472
 473 { } [
 474     [ { null } declare [ 1 ] [ 2 ] if ]
 475     build-tree normalize propagate cleanup-tree check-nodes
 476 ] unit-test
 477
 478 { t } [
 479     [ { array } declare 2 <groups> [ . . ] assoc-each ]
 480     \ nth-unsafe inlined?
 481 ] unit-test
 482
 483 { t } [
 484     [ { fixnum fixnum } declare = ]
 485     \ both-fixnums? inlined?
 486 ] unit-test
 487
 488 { t } [
 489     [ { integer integer } declare + drop ]
 490     { + +-integer-integer } inlined?
 491 ] unit-test
 492
 493 { [ ] } [
 494     [
 495         20 f <array>
 496         [ 0 swap nth ] keep
 497         [ 1 swap nth ] keep
 498         [ 2 swap nth ] keep
 499         [ 3 swap nth ] keep
 500         [ 4 swap nth ] keep
 501         [ 5 swap nth ] keep
 502         [ 6 swap nth ] keep
 503         [ 7 swap nth ] keep
 504         [ 8 swap nth ] keep
 505         [ 9 swap nth ] keep
 506         [ 10 swap nth ] keep
 507         [ 11 swap nth ] keep
 508         [ 12 swap nth ] keep
 509         14 ndrop
 510     ] cleaned-up-tree nodes>quot
 511 ] unit-test
 512
 513 { t } [
 514     [ int { } cdecl [ 2 2 + ] alien-callback ]
 515     { + } inlined?
 516 ] unit-test
 517
 518 { t } [
 519     [ double { double double } cdecl [ + ] alien-callback ]
 520     \ + inlined?
 521 ] unit-test
 522
 523 { f } [
 524     [ double { double double } cdecl [ + ] alien-callback ]
 525     \ float+ inlined?
 526 ] unit-test
 527
 528 { f } [
 529     [ char { char char } cdecl [ + ] alien-callback ]
 530     \ fixnum+fast inlined?
 531 ] unit-test
 532
 533 { t } [
 534     [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]
 535     \ >c-ptr inlined?
 536 ] unit-test
 537
 538 MIXIN: foo-mix
 539
 540 ! cleanup-folding?
 541 : call-node-foldable2 ( -- node )
 542     T{ #call
 543        { word foo-mix? }
 544        { in-d V{ 8815401 } }
 545        { out-d { 8815405 } }
 546        { info
 547          H{
 548              {
 549                  8815401
 550                  T{ value-info-state
 551                     { class
 552                       intersection{
 553                           not{
 554                               POSTPONE: f
 555                           }
 556                           not{ foo-mix }
 557                       }
 558                     }
 559                     { interval
 560                       full-interval
 561                     }
 562                   }
 563              }
 564              {
 565                  8815405
 566                  T{ value-info-state
 567                     { class POSTPONE: f }
 568                     { interval
 569                       empty-interval
 570                     }
 571                     { literal? t }
 572                   }
 573              }
 574          }
 575        }
 576     } ;
 577
 578 { t } [
 579     call-node-foldable2 cleanup-folding?
 580 ] unit-test
 581
 582
 583 ! cleanup-folding
 584 : call-node-foldable ( -- node )
 585     T{ #call
 586        { word set-slot }
 587        { in-d V{ 1 2 } }
 588        { out-d V{ 3 } }
 589        { info
 590          H{
 591              {
 592                  1
 593                  T{ value-info-state
 594                     { class fixnum }
 595                     { literal 2 }
 596                     { literal? t }
 597                  }
 598              }
 599              {
 600                  2
 601                  T{ value-info-state
 602                     { class fixnum }
 603                     { literal 3 }
 604                     { literal? t }
 605                  }
 606              }
 607              {
 608                  3
 609                  T{ value-info-state
 610                     { class fixnum }
 611                     { literal 5 }
 612                     { literal? t }
 613                  }
 614              }
 615          }
 616        }
 617     } ;
 618
 619 { t t } [
 620     call-node-foldable cleanup-folding
 621     [ length 2 = ] [ last literal>> 5 = ] bi
 622 ] unit-test