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