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 [ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
 140
 141 [ t ] [
 142     [
 143         [ no-cond ] 1
 144         [ 1array dup quotation? [ >quotation ] unless ] times
 145     ] \ quotation? inlined?
 146 ] unit-test
 147
 148 [ t ] [
 149     [
 150         1000000000000000000000000000000000 [ ] times
 151     ] \ + inlined?
 152 ] unit-test
 153 [ f ] [
 154     [
 155         1000000000000000000000000000000000 [ ] times
 156     ] \ +-integer-fixnum inlined?
 157 ] unit-test
 158
 159 [ f ] [
 160     [ { bignum } declare [ ] times ]
 161     \ +-integer-fixnum inlined?
 162 ] unit-test
 163
 164 [ t ] [
 165     [ { array-capacity } declare 0 < ] \ < inlined?
 166 ] unit-test
 167
 168 [ t ] [
 169     [ { array-capacity } declare 0 < ] \ fixnum< inlined?
 170 ] unit-test
 171
 172 [ t ] [
 173     [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 174 ] unit-test
 175
 176 [ t ] [
 177     [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
 178 ] unit-test
 179
 180 [ t ] [
 181     [ 5000 [ [ ] times ] each ] \ 1+ inlined?
 182 ] unit-test
 183
 184 [ t ] [
 185     [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
 186     \ 1+ inlined?
 187 ] unit-test
 188
 189 GENERIC: annotate-entry-test-1 ( x -- )
 190
 191 M: fixnum annotate-entry-test-1 drop ;
 192
 193 : (annotate-entry-test-2) ( from to -- )
 194     2dup >= [
 195         2drop
 196     ] [
 197         [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
 198     ] if ; inline recursive
 199
 200 : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
 201
 202 [ f ] [
 203     [ { bignum } declare annotate-entry-test-2 ]
 204     \ annotate-entry-test-1 inlined?
 205 ] unit-test
 206
 207 [ t ] [
 208     [ { float } declare 10 [ 2.3 * ] times >float ]
 209     \ >float inlined?
 210 ] unit-test
 211
 212 GENERIC: detect-float ( a -- b )
 213
 214 M: float detect-float ;
 215
 216 [ t ] [
 217     [ { real float } declare + detect-float ]
 218     \ detect-float inlined?
 219 ] unit-test
 220
 221 [ t ] [
 222     [ { float real } declare + detect-float ]
 223     \ detect-float inlined?
 224 ] unit-test
 225
 226 [ f ] [
 227     [ { fixnum fixnum } declare 7 bitand neg shift ]
 228     \ fixnum-shift-fast inlined?
 229 ] unit-test
 230
 231 [ t ] [
 232     [ { fixnum fixnum } declare 7 bitand neg shift ]
 233     { shift fixnum-shift } inlined?
 234 ] unit-test
 235
 236 [ t ] [
 237     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 238     { shift fixnum-shift } inlined?
 239 ] unit-test
 240
 241 [ f ] [
 242     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 243     { fixnum-shift-fast } inlined?
 244 ] unit-test
 245
 246 cell-bits 32 = [
 247     [ t ] [
 248         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 249         \ shift inlined?
 250     ] unit-test
 251
 252     [ f ] [
 253         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 254         \ fixnum-shift inlined?
 255     ] unit-test
 256 ] when
 257
 258 [ t ] [
 259     [ B{ 1 0 } *short 0 number= ]
 260     \ number= inlined?
 261 ] unit-test
 262
 263 [ t ] [
 264     [ B{ 1 0 } *short 0 { number number } declare number= ]
 265     \ number= inlined?
 266 ] unit-test
 267
 268 [ t ] [
 269     [ B{ 1 0 } *short 0 = ]
 270     \ number= inlined?
 271 ] unit-test
 272
 273 [ t ] [
 274     [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
 275     \ number= inlined?
 276 ] unit-test
 277
 278 [ t ] [
 279     [ HEX: ff bitand 0 HEX: ff between? ]
 280     \ >= inlined?
 281 ] unit-test
 282
 283 [ t ] [
 284     [ HEX: ff swap HEX: ff bitand >= ]
 285     \ >= inlined?
 286 ] unit-test
 287
 288 [ t ] [
 289     [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
 290 ] unit-test
 291
 292 [ t ] [
 293     [
 294         dup integer? [
 295             dup fixnum? [
 296                 1 +
 297             ] [
 298                 2 +
 299             ] if
 300         ] when
 301     ] \ + inlined?
 302 ] unit-test
 303
 304 [ t ] [
 305     [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
 306 ] unit-test
 307
 308 : rec ( a -- b )
 309     dup 0 > [ 1 - rec ] when ; inline recursive
 310
 311 [ t ] [
 312     [ { fixnum } declare rec 1 + ]
 313     { > - + } inlined?
 314 ] unit-test
 315
 316 : fib ( m -- n )
 317     dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
 318
 319 [ t ] [
 320     [ 27.0 fib ] { < - + } inlined?
 321 ] unit-test
 322
 323 [ f ] [
 324     [ 27.0 fib ] { +-integer-integer } inlined?
 325 ] unit-test
 326
 327 [ t ] [
 328     [ 27 fib ] { < - + } inlined?
 329 ] unit-test
 330
 331 [ t ] [
 332     [ 27 >bignum fib ] { < - + } inlined?
 333 ] unit-test
 334
 335 [ f ] [
 336     [ 27/2 fib ] { < - } inlined?
 337 ] unit-test
 338
 339 [ t ] [
 340     [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
 341 ] unit-test
 342
 343 [ f ] [
 344     [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
 345 ] unit-test
 346
 347 [ f ] [
 348     [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
 349     \ fixnum-bitand inlined?
 350 ] unit-test
 351
 352 [ t ] [
 353     [ { fixnum } declare [ drop ] each-integer ]
 354     { < <-integer-fixnum +-integer-fixnum + } inlined?
 355 ] unit-test
 356
 357 [ t ] [
 358     [ { fixnum } declare length [ drop ] each-integer ]
 359     { < <-integer-fixnum +-integer-fixnum + } inlined?
 360 ] unit-test
 361
 362 [ t ] [
 363     [ { fixnum } declare [ drop ] each ]
 364     { < <-integer-fixnum +-integer-fixnum + } inlined?
 365 ] unit-test
 366
 367 [ t ] [
 368     [ { fixnum } declare 0 [ + ] reduce ]
 369     { < <-integer-fixnum nth-unsafe } inlined?
 370 ] unit-test
 371
 372 [ f ] [
 373     [ { fixnum } declare 0 [ + ] reduce ]
 374     \ +-integer-fixnum inlined?
 375 ] unit-test
 376
 377 [ f ] [
 378     [
 379         { integer } declare [ ] map
 380     ] \ >fixnum inlined?
 381 ] unit-test
 382
 383 [ f ] [
 384     [
 385         { integer } declare { } set-nth-unsafe
 386     ] \ >fixnum inlined?
 387 ] unit-test
 388
 389 [ f ] [
 390     [
 391         { integer } declare 1 + { } set-nth-unsafe
 392     ] \ >fixnum inlined?
 393 ] unit-test
 394
 395 [ t ] [
 396     [
 397         { array } declare length
 398         1 + dup 100 fixnum> [ 1 fixnum+ ] when
 399     ] \ fixnum+ inlined?
 400 ] unit-test
 401
 402 [ t ] [
 403     [ [ resize-array ] keep length ] \ length inlined?
 404 ] unit-test
 405
 406 [ t ] [
 407     [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
 408 ] unit-test
 409
 410 [ t ] [
 411     [ { utf8 } declare decode-char ] \ decode-char inlined?
 412 ] unit-test
 413
 414 [ t ] [
 415     [ { ascii } declare decode-char ] \ decode-char inlined?
 416 ] unit-test
 417
 418 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
 419
 420 [ t ] [
 421     [
 422         { integer } declare [ 0 >= ] map
 423     ] { >= fixnum>= } inlined?
 424 ] unit-test
 425
 426 [ ] [
 427     [
 428         4 pick array-capacity?
 429         [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
 430     ] cleaned-up-tree drop
 431 ] unit-test
 432
 433 [ ] [
 434     [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
 435 ] unit-test
 436
 437 [ ] [
 438     [
 439         [ "X" throw ]
 440         [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
 441         if
 442     ] cleaned-up-tree drop
 443 ] unit-test
 444
 445 [ t ] [
 446     [ [ 2array ] [ 0 3array ] if first ]
 447     { nth-unsafe < <= > >= } inlined?
 448 ] unit-test
 449
 450 [ ] [
 451     [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
 452     cleaned-up-tree drop
 453 ] unit-test
 454
 455 ! Regression from benchmark.nsieve
 456 : chicken-fingers ( i seq -- )
 457     2dup < [
 458         2drop
 459     ] [
 460         chicken-fingers
 461     ] if ; inline recursive
 462
 463 : buffalo-wings ( i seq -- )
 464     2dup < [
 465         2dup chicken-fingers
 466         [ 1+ ] dip buffalo-wings
 467     ] [
 468         2drop
 469     ] if ; inline recursive
 470
 471 [ t ] [
 472     [ 2 swap >fixnum buffalo-wings ]
 473     { <-integer-fixnum +-integer-fixnum } inlined?
 474 ] unit-test
 475
 476 ! A reduction
 477 : buffalo-sauce ( -- value ) f ;
 478
 479 : steak ( -- )
 480     buffalo-sauce [ steak ] when ; inline recursive
 481
 482 : ribs ( i seq -- )
 483     2dup < [
 484         steak
 485         [ 1+ ] dip ribs
 486     ] [
 487         2drop
 488     ] if ; inline recursive
 489
 490 [ t ] [
 491     [ 2 swap >fixnum ribs ]
 492     { <-integer-fixnum +-integer-fixnum } inlined?
 493 ] unit-test
 494
 495 [ t ] [
 496     [ hashtable new ] \ new inlined?
 497 ] unit-test
 498
 499 [ t ] [
 500     [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
 501     [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
 502 ] unit-test
 503
 504 [ ] [
 505     [ { null } declare [ 1 ] [ 2 ] if ]
 506     build-tree normalize propagate cleanup check-nodes
 507 ] unit-test
 508
 509 [ t ] [
 510     [ { array } declare 2 <groups> [ . . ] assoc-each ]
 511     \ nth-unsafe inlined?
 512 ] unit-test
 513
 514 [ t ] [
 515     [ { fixnum fixnum } declare = ]
 516     \ both-fixnums? inlined?
 517 ] unit-test
 518
 519 [ t ] [
 520     [ { integer integer } declare + drop ]
 521     { + +-integer-integer } inlined?
 522 ] unit-test