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

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