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     [ 10 [ -1 shift ] times ] \ shift inlined?
 326 ] unit-test
 327
 328 [ f ] [
 329     [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
 330     \ fixnum-bitand inlined?
 331 ] unit-test
 332
 333 [ t ] [
 334     [ { fixnum } declare [ drop ] each-integer ]
 335     { < <-integer-fixnum +-integer-fixnum + } inlined?
 336 ] unit-test
 337
 338 [ t ] [
 339     [ { fixnum } declare iota [ drop ] each ]
 340     { < <-integer-fixnum +-integer-fixnum + } inlined?
 341 ] unit-test
 342
 343 [ t ] [
 344     [ { fixnum } declare iota 0 [ + ] reduce ]
 345     { < <-integer-fixnum nth-unsafe } inlined?
 346 ] unit-test
 347
 348 [ f ] [
 349     [ { fixnum } declare iota 0 [ + ] reduce ]
 350     \ +-integer-fixnum inlined?
 351 ] unit-test
 352
 353 [ f ] [
 354     [
 355         { integer } declare iota [ ] map
 356     ] \ integer>fixnum inlined?
 357 ] unit-test
 358
 359 [ f ] [
 360     [
 361         { integer } declare { } set-nth-unsafe
 362     ] \ integer>fixnum inlined?
 363 ] unit-test
 364
 365 [ f ] [
 366     [
 367         { integer } declare 1 + { } set-nth-unsafe
 368     ] \ >fixnum inlined?
 369 ] unit-test
 370
 371 [ t ] [
 372     [
 373         { array } declare length
 374         1 + dup 100 fixnum> [ 1 fixnum+ ] when
 375     ] \ fixnum+ inlined?
 376 ] unit-test
 377
 378 [ t ] [
 379     [ [ resize-array ] keep length ] \ length inlined?
 380 ] unit-test
 381
 382 [ t ] [
 383     [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
 384 ] unit-test
 385
 386 [ t ] [
 387     [ { utf8 } declare decode-char ] \ decode-char inlined?
 388 ] unit-test
 389
 390 [ t ] [
 391     [ { ascii } declare decode-char ] \ decode-char inlined?
 392 ] unit-test
 393
 394 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
 395
 396 [ t ] [
 397     [
 398         { integer } declare iota [ 0 >= ] map
 399     ] { >= fixnum>= } inlined?
 400 ] unit-test
 401
 402 [ ] [
 403     [
 404         4 pick array-capacity?
 405         [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
 406     ] cleaned-up-tree drop
 407 ] unit-test
 408
 409 [ ] [
 410     [ { merge-state } declare accum>> 0 >>length ] cleaned-up-tree drop
 411 ] unit-test
 412
 413 [ ] [
 414     [
 415         [ "X" throw ]
 416         [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
 417         if
 418     ] cleaned-up-tree drop
 419 ] unit-test
 420
 421 [ t ] [
 422     [ [ 2array ] [ 0 3array ] if first ]
 423     { nth-unsafe < <= > >= } inlined?
 424 ] unit-test
 425
 426 [ ] [
 427     [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
 428     cleaned-up-tree drop
 429 ] unit-test
 430
 431 ! Regression from benchmark.nsieve
 432 : chicken-fingers ( i seq -- )
 433     2dup < [
 434         2drop
 435     ] [
 436         chicken-fingers
 437     ] if ; inline recursive
 438
 439 : buffalo-wings ( i seq -- )
 440     2dup < [
 441         2dup chicken-fingers
 442         [ 1 + ] dip buffalo-wings
 443     ] [
 444         2drop
 445     ] if ; inline recursive
 446
 447 [ t ] [
 448     [ 2 swap >fixnum buffalo-wings ]
 449     { <-integer-fixnum +-integer-fixnum } inlined?
 450 ] unit-test
 451
 452 ! A reduction
 453 : buffalo-sauce ( -- value ) f ;
 454
 455 : steak ( -- )
 456     buffalo-sauce [ steak ] when ; inline recursive
 457
 458 : ribs ( i seq -- )
 459     2dup < [
 460         steak
 461         [ 1 + ] dip ribs
 462     ] [
 463         2drop
 464     ] if ; inline recursive
 465
 466 [ t ] [
 467     [ 2 swap >fixnum ribs ]
 468     { <-integer-fixnum +-integer-fixnum } inlined?
 469 ] unit-test
 470
 471 [ t ] [
 472     [ hashtable new ] \ new inlined?
 473 ] unit-test
 474
 475 [ t ] [
 476     [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
 477     [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
 478 ] unit-test
 479
 480 [ ] [
 481     [ { null } declare [ 1 ] [ 2 ] if ]
 482     build-tree normalize propagate cleanup-tree check-nodes
 483 ] unit-test
 484
 485 [ t ] [
 486     [ { array } declare 2 <groups> [ . . ] assoc-each ]
 487     \ nth-unsafe inlined?
 488 ] unit-test
 489
 490 [ t ] [
 491     [ { fixnum fixnum } declare = ]
 492     \ both-fixnums? inlined?
 493 ] unit-test
 494
 495 [ t ] [
 496     [ { integer integer } declare + drop ]
 497     { + +-integer-integer } inlined?
 498 ] unit-test
 499
 500 [ [ ] ] [
 501     [
 502         20 f <array>
 503         [ 0 swap nth ] keep
 504         [ 1 swap nth ] keep
 505         [ 2 swap nth ] keep
 506         [ 3 swap nth ] keep
 507         [ 4 swap nth ] keep
 508         [ 5 swap nth ] keep
 509         [ 6 swap nth ] keep
 510         [ 7 swap nth ] keep
 511         [ 8 swap nth ] keep
 512         [ 9 swap nth ] keep
 513         [ 10 swap nth ] keep
 514         [ 11 swap nth ] keep
 515         [ 12 swap nth ] keep
 516         14 ndrop
 517     ] cleaned-up-tree nodes>quot
 518 ] unit-test
 519
 520 [ t ] [
 521     [ int { } cdecl [ 2 2 + ] alien-callback ]
 522     { + } inlined?
 523 ] unit-test
 524
 525 [ t ] [
 526     [ double { double double } cdecl [ + ] alien-callback ]
 527     \ + inlined?
 528 ] unit-test
 529
 530 [ f ] [
 531     [ double { double double } cdecl [ + ] alien-callback ]
 532     \ float+ inlined?
 533 ] unit-test
 534
 535 [ f ] [
 536     [ char { char char } cdecl [ + ] alien-callback ]
 537     \ fixnum+fast inlined?
 538 ] unit-test
 539
 540 [ t ] [
 541     [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]
 542     \ >c-ptr inlined?
 543 ] unit-test