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