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

   1 USING: kernel compiler.tree.builder compiler.tree
   2 compiler.tree.propagation compiler.tree.recursive
   3 compiler.tree.normalization tools.test math math.order
   4 accessors sequences arrays kernel.private vectors
   5 alien.accessors alien.c-types sequences.private
   6 byte-arrays classes.algebra classes.tuple.private
   7 math.functions math.private strings layouts
   8 compiler.tree.propagation.info compiler.tree.def-use
   9 compiler.tree.debugger compiler.tree.checker
  10 slots.private words hashtables classes assocs locals
  11 specialized-arrays.double system sorting math.libm ;
  12 IN: compiler.tree.propagation.tests
  13
  14 \ propagate must-infer
  15
  16 [ V{ } ] [ [ ] final-classes ] unit-test
  17
  18 [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
  19
  20 [ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
  21
  22 [ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
  23
  24 [ V{ array } ] [ [ 10 f <array> ] final-classes ] unit-test
  25
  26 [ V{ array } ] [ [ { array } declare ] final-classes ] unit-test
  27
  28 [ V{ array } ] [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
  29
  30 [ V{ fixnum } ] [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
  31
  32 [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
  33
  34 [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
  35
  36 [ V{ number } ] [ [ + ] final-classes ] unit-test
  37
  38 [ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
  39
  40 [ V{ float } ] [ [ /f ] final-classes ] unit-test
  41
  42 [ V{ integer } ] [ [ /i ] final-classes ] unit-test
  43
  44 [ V{ integer } ] [
  45     [ { integer } declare bitnot ] final-classes
  46 ] unit-test
  47
  48 [ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
  49
  50 [ V{ integer } ] [
  51     [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
  52 ] unit-test
  53
  54 [ V{ fixnum } ] [
  55     [
  56         { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
  57     ] final-classes
  58 ] unit-test
  59
  60 [ V{ integer } ] [
  61     [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
  62 ] unit-test
  63
  64 [ V{ integer } ] [
  65     [ { fixnum } declare 615949 * ] final-classes
  66 ] unit-test
  67
  68 [ V{ null } ] [
  69     [ { null null } declare + ] final-classes
  70 ] unit-test
  71
  72 [ V{ null } ] [
  73     [ { null fixnum } declare + ] final-classes
  74 ] unit-test
  75
  76 [ V{ float } ] [
  77     [ { float fixnum } declare + ] final-classes
  78 ] unit-test
  79
  80 [ V{ fixnum } ] [
  81     [ 255 bitand >fixnum 3 bitor ] final-classes
  82 ] unit-test
  83
  84 [ V{ 0 } ] [
  85     [ >fixnum 1 mod ] final-literals
  86 ] unit-test
  87
  88 [ V{ 69 } ] [
  89     [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
  90 ] unit-test
  91
  92 [ V{ fixnum } ] [
  93     [ >fixnum dup 10 > [ 1 - ] when ] final-classes
  94 ] unit-test
  95
  96 [ V{ integer } ] [ [ >fixnum 2 * ] final-classes ] unit-test
  97
  98 [ V{ integer } ] [
  99     [ >fixnum dup 10 < drop 2 * ] final-classes
 100 ] unit-test
 101
 102 [ V{ integer } ] [
 103     [ >fixnum dup 10 < [ 2 * ] when ] final-classes
 104 ] unit-test
 105
 106 [ V{ integer } ] [
 107     [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
 108 ] unit-test
 109
 110 [ V{ fixnum } ] [
 111     [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
 112 ] unit-test
 113
 114 [ V{ f } ] [
 115     [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
 116 ] unit-test
 117
 118 [ V{ 9 } ] [
 119     [
 120         123 bitand
 121         dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
 122     ] final-literals
 123 ] unit-test
 124
 125 [ V{ string } ] [
 126     [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
 127 ] unit-test
 128
 129 [ V{ string } ] [
 130     [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
 131 ] unit-test
 132
 133 [ f ] [ [ t xor ] final-classes first null-class? ] unit-test
 134
 135 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
 136
 137 [ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
 138
 139 [ t ] [ [ f and ] final-classes first false-class? ] unit-test
 140
 141 [ t ] [ [ f swap and ] final-classes first false-class? ] unit-test
 142
 143 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 144
 145 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 146
 147 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 148
 149 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 150
 151 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 152
 153 [ V{ fixnum } ] [
 154     [
 155         >fixnum
 156         dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
 157     ] final-classes
 158 ] unit-test
 159
 160 [ V{ fixnum } ] [
 161     [ { fixnum } declare (clone) ] final-classes
 162 ] unit-test
 163
 164 [ V{ vector } ] [
 165     [ vector new ] final-classes
 166 ] unit-test
 167
 168 [ V{ fixnum } ] [
 169     [
 170         { fixnum byte-array } declare
 171         [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
 172         >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
 173         255 min 0 max
 174     ] final-classes
 175 ] unit-test
 176
 177 [ V{ fixnum } ] [
 178     [ 0 dup 10 > [ 2 * ] when ] final-classes
 179 ] unit-test
 180
 181 [ V{ f } ] [
 182     [ [ 0.0 ] [ -0.0 ] if ] final-literals
 183 ] unit-test
 184
 185 [ V{ 1.5 } ] [
 186     [ /f 1.5 min 1.5 max ] final-literals
 187 ] unit-test
 188
 189 [ V{ 1.5 } ] [
 190     [
 191         /f
 192         dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 193     ] final-literals
 194 ] unit-test
 195
 196 [ V{ 1.5 } ] [
 197     [
 198         /f
 199         dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 200     ] final-literals
 201 ] unit-test
 202
 203 [ V{ f } ] [
 204     [
 205         /f
 206         dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
 207     ] final-literals
 208 ] unit-test
 209
 210 [ V{ fixnum } ] [
 211     [ 0 dup 10 > [ 100 * ] when ] final-classes
 212 ] unit-test
 213
 214 [ V{ fixnum } ] [
 215     [ 0 dup 10 > [ drop "foo" ] when ] final-classes
 216 ] unit-test
 217
 218 [ V{ fixnum } ] [
 219     [ { fixnum } declare 3 3 - + ] final-classes
 220 ] unit-test
 221
 222 [ V{ t } ] [
 223     [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
 224 ] unit-test
 225
 226 [ V{ "d" } ] [
 227     [
 228         3 {
 229             [ "a" ]
 230             [ "b" ]
 231             [ "c" ]
 232             [ "d" ]
 233             [ "e" ]
 234             [ "f" ]
 235             [ "g" ]
 236             [ "h" ]
 237         } dispatch
 238     ] final-literals
 239 ] unit-test
 240
 241 [ V{ "hi" } ] [
 242     [ [ "hi" ] [ 123 3 throw ] if ] final-literals
 243 ] unit-test
 244
 245 [ V{ fixnum } ] [
 246     [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
 247 ] unit-test
 248
 249 [ V{ -1 } ] [
 250     [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
 251 ] unit-test
 252
 253 [ V{ 2 } ] [
 254     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 255 ] unit-test
 256
 257 [ V{ object } ] [
 258     [ 0 * 10 < ] final-classes
 259 ] unit-test
 260
 261 [ V{ 27 } ] [
 262     [
 263         123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
 264     ] final-literals
 265 ] unit-test
 266
 267 [ V{ 27 } ] [
 268     [
 269         dup number? over sequence? and [
 270             dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
 271         ] [ "B" throw ] if
 272     ] final-literals
 273 ] unit-test
 274
 275 [ V{ string string } ] [
 276     [
 277         2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
 278     ] final-classes
 279 ] unit-test
 280
 281 [ V{ float } ] [
 282     [ { real float } declare + ] final-classes
 283 ] unit-test
 284
 285 [ V{ float } ] [
 286     [ { float real } declare + ] final-classes
 287 ] unit-test
 288
 289 [ V{ fixnum } ] [
 290     [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
 291 ] unit-test
 292
 293 [ V{ fixnum } ] [
 294     [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
 295 ] unit-test
 296
 297 cell-bits 32 = [
 298     [ V{ integer } ] [
 299         [ { fixnum } declare 1 swap 31 bitand shift ]
 300         final-classes
 301     ] unit-test
 302 ] when
 303
 304 ! Array length propagation
 305 [ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
 306
 307 [ V{ t } ] [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
 308
 309 [ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
 310
 311 [ V{ 10 } ] [
 312     [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
 313 ] unit-test
 314
 315 ! Slot propagation
 316 TUPLE: prop-test-tuple { x integer } ;
 317
 318 [ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
 319
 320 TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
 321
 322 [ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
 323 [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
 324 unit-test
 325
 326 TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 327
 328 [ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
 329     [ "hey" immutable-prop-test-tuple boa ] final-literals
 330 ] unit-test
 331
 332 [ V{ { 1 2 } } ] [
 333     [ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
 334 ] unit-test
 335
 336 [ V{ array } ] [
 337     [ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
 338 ] unit-test
 339
 340 [ V{ complex } ] [
 341     [ <complex> ] final-classes
 342 ] unit-test
 343
 344 [ V{ complex } ] [
 345     [ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
 346 ] unit-test
 347
 348 [ V{ float float } ] [
 349     [
 350         { float float } declare
 351         dup 0.0 <= [ "Oops" throw ] when rect>
 352         [ real>> ] [ imaginary>> ] bi
 353     ] final-classes
 354 ] unit-test
 355
 356 [ V{ complex } ] [
 357     [
 358         { float float object } declare
 359         [ "Oops" throw ] [ <complex> ] if
 360     ] final-classes
 361 ] unit-test
 362
 363 [ ] [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info drop ] unit-test
 364
 365 [ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
 366 [ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
 367
 368 [ V{ POSTPONE: f } ] [
 369     [ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
 370 ] unit-test
 371
 372 ! Don't fold this
 373 TUPLE: mutable-tuple-test { x sequence } ;
 374
 375 [ V{ sequence } ] [
 376     [ "hey" mutable-tuple-test boa x>> ] final-classes
 377 ] unit-test
 378
 379 [ V{ sequence } ] [
 380     [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
 381 ] unit-test
 382
 383 [ V{ array } ] [
 384     [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
 385 ] unit-test
 386
 387 ! Mixed mutable and immutable slots
 388 TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 389
 390 [ V{ integer array } ] [
 391     [
 392         3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
 393     ] final-classes
 394 ] unit-test
 395
 396 [ V{ array integer } ] [
 397     [
 398         3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
 399     ] final-classes
 400 ] unit-test
 401
 402 [ V{ integer array } ] [
 403     [
 404         [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
 405         [ { array } declare mixed-mutable-immutable boa ] if
 406         [ x>> ] [ y>> ] bi
 407     ] final-classes
 408 ] unit-test
 409
 410 ! Recursive propagation
 411 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 412
 413 [ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test
 414
 415 : recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
 416
 417 [ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test
 418
 419 : recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
 420
 421 [ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
 422
 423 [ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test
 424
 425 [ V{ float } ] [
 426     [ { float } declare 10 [ 2.3 * ] times ] final-classes
 427 ] unit-test
 428
 429 [ V{ fixnum } ] [
 430     [ 0 10 [ nip ] each-integer ] final-classes
 431 ] unit-test
 432
 433 [ V{ t } ] [
 434     [ t 10 [ nip 0 >= ] each-integer ] final-literals
 435 ] unit-test
 436
 437 : recursive-test-4 ( i n -- )
 438     2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 439
 440 [ ] [ [ recursive-test-4 ] final-info drop ] unit-test
 441
 442 : recursive-test-5 ( a -- b )
 443     dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
 444
 445 [ V{ integer } ] [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
 446
 447 : recursive-test-6 ( a -- b )
 448     dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
 449
 450 [ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
 451
 452 : recursive-test-7 ( a -- b )
 453     dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
 454
 455 [ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
 456
 457 [ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
 458
 459 [ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
 460
 461 [ ] [ [ [ ] [ ] compose curry call ] final-info drop ] unit-test
 462
 463 [ V{ } ] [
 464     [ [ drop ] [ drop ] compose curry (each-integer) ] final-classes
 465 ] unit-test
 466
 467 GENERIC: iterate ( obj -- next-obj ? )
 468 M: fixnum iterate f ;
 469 M: array iterate first t ;
 470
 471 : dead-loop ( obj -- final-obj )
 472     iterate [ dead-loop ] when ; inline recursive
 473
 474 [ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
 475
 476 : hang-1 ( m -- x )
 477     dup 0 number= [ hang-1 ] unless ; inline recursive
 478
 479 [ ] [ [ 3 hang-1 ] final-info drop ] unit-test
 480
 481 : hang-2 ( m n -- x )
 482     over 0 number= [
 483         nip
 484     ] [
 485         dup [
 486             drop 1 hang-2
 487         ] [
 488             dupd hang-2 hang-2
 489         ] if
 490     ] if ; inline recursive
 491
 492 [ ] [ [ 3 over hang-2 ] final-info drop ] unit-test
 493
 494 [ ] [
 495     [
 496         dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if
 497     ] final-info drop
 498 ] unit-test
 499
 500 [ V{ word } ] [
 501     [ { hashtable } declare hashtable instance? ] final-classes
 502 ] unit-test
 503
 504 [ V{ POSTPONE: f } ] [
 505     [ { vector } declare hashtable instance? ] final-classes
 506 ] unit-test
 507
 508 [ V{ object } ] [
 509     [ { assoc } declare hashtable instance? ] final-classes
 510 ] unit-test
 511
 512 [ V{ word } ] [
 513     [ { string } declare string? ] final-classes
 514 ] unit-test
 515
 516 [ V{ POSTPONE: f } ] [
 517     [ 3 string? ] final-classes
 518 ] unit-test
 519
 520 [ V{ fixnum } ] [
 521     [ { fixnum } declare [ ] curry obj>> ] final-classes
 522 ] unit-test
 523
 524 [ V{ fixnum } ] [
 525     [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
 526 ] unit-test
 527
 528 [ V{ f } ] [
 529     [ 10 eq? [ drop 3 ] unless ] final-literals
 530 ] unit-test
 531
 532 GENERIC: bad-generic ( a -- b )
 533 M: fixnum bad-generic 1 fixnum+fast ;
 534 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
 535
 536 [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
 537
 538 [ V{ number } ] [
 539     [
 540         0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
 541     ] final-classes
 542 ] unit-test
 543
 544 GENERIC: infinite-loop ( a -- b )
 545 M: integer infinite-loop infinite-loop ;
 546
 547 [ ] [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
 548
 549 [ V{ tuple } ] [ [ tuple-layout <tuple> ] final-classes ] unit-test
 550
 551 [ ] [ [ instance? ] final-classes drop ] unit-test
 552
 553 [ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test
 554
 555 : fold-throw-test ( a -- b ) "A" throw ; foldable
 556
 557 [ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
 558
 559 : too-deep ( a b -- c )
 560     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
 561
 562 [ ] [ [ too-deep ] final-info drop ] unit-test
 563
 564 [ ] [ [ reversed boa slice boa nth-unsafe * ] final-info drop ] unit-test
 565
 566 MIXIN: empty-mixin
 567
 568 [ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
 569
 570 [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
 571
 572 [ V{ float } ] [
 573     [
 574         [ { float float } declare <complex> ]
 575         [ 2drop C{ 0.0 0.0 } ]
 576         if real-part
 577     ] final-classes
 578 ] unit-test
 579
 580 [ V{ POSTPONE: f } ] [
 581     [ { float } declare 0 eq? ] final-classes
 582 ] unit-test
 583
 584 [ V{ integer } ] [
 585     [ { integer fixnum } declare mod ] final-classes
 586 ] unit-test
 587
 588 [ V{ integer } ] [
 589     [ { fixnum integer } declare bitand ] final-classes
 590 ] unit-test
 591
 592 [ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test
 593
 594 [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
 595
 596 [ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
 597
 598 [ V{ float } ] [ [ fsqrt ] final-classes ] unit-test
 599
 600 [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
 601
 602 ! [ V{ string } ] [
 603 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 604 ! ] unit-test
 605
 606 ! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
 607
 608 ! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
 609
 610 ! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
 611
 612 ! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test