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

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