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