core/inference/class/class-tests.factor

   1 IN: inference.class.tests
   2 USING: arrays math.private kernel math compiler inference
   3 inference.dataflow optimizer tools.test kernel.private generic
   4 sequences words inference.class quotations alien
   5 alien.c-types strings sbufs sequences.private
   6 slots.private combinators definitions compiler.units
   7 system layouts vectors optimizer.math.partial
   8 optimizer.inlining optimizer.backend math.order math.functions
   9 accessors hashtables classes assocs io.encodings.utf8
  10 io.encodings.ascii io.encodings ;
  11
  12 [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
  13
  14 [ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
  15
  16 ! Make sure these compile even though this is invalid code
  17 [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
  18 [ ] [ [ 10 mod 3.0 shift ] dataflow optimize drop ] unit-test
  19
  20 ! Ensure type inference works as it is supposed to by checking
  21 ! if various methods get inlined
  22
  23 : inlined? ( quot seq/word -- ? )
  24     dup word? [ 1array ] when
  25     swap dataflow optimize
  26     [ node-param swap member? ] with node-exists? not ;
  27
  28 [ f ] [
  29     [ { integer } declare >fixnum ]
  30     \ >fixnum inlined?
  31 ] unit-test
  32
  33 GENERIC: mynot ( x -- y )
  34
  35 M: f mynot drop t ;
  36
  37 M: object mynot drop f ;
  38
  39 GENERIC: detect-f ( x -- y )
  40
  41 M: f detect-f ;
  42
  43 [ t ] [
  44     [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
  45 ] unit-test
  46
  47 [ ] [ [ fixnum< ] dataflow optimize drop ] unit-test
  48
  49 [ ] [ [ fixnum< [ ] [ ] if ] dataflow optimize drop ] unit-test
  50
  51 GENERIC: xyz ( n -- n )
  52
  53 M: integer xyz ;
  54
  55 M: object xyz ;
  56
  57 [ t ] [
  58     [ { integer } declare xyz ] \ xyz inlined?
  59 ] unit-test
  60
  61 [ t ] [
  62     [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
  63     \ xyz inlined?
  64 ] unit-test
  65
  66 : (fx-repeat) ( i n quot -- )
  67     2over fixnum>= [
  68         3drop
  69     ] [
  70         [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
  71     ] if ; inline
  72
  73 : fx-repeat ( n quot -- )
  74     0 -rot (fx-repeat) ; inline
  75
  76 ! The + should be optimized into fixnum+, if it was not, then
  77 ! the type of the loop index was not inferred correctly
  78 [ t ] [
  79     [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
  80 ] unit-test
  81
  82 : (i-repeat) ( i n quot -- )
  83     2over dup xyz drop >= [
  84         3drop
  85     ] [
  86         [ swap >r call 1+ r> ] keep (i-repeat)
  87     ] if ; inline
  88
  89 : i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
  90
  91 [ t ] [
  92     [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
  93 ] unit-test
  94
  95 [ t ] [
  96     [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
  97 ] unit-test
  98
  99 [ t ] [
 100     [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
 101     \ + 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 } declare [ ] times ] \ >= inlined?
 111 ] unit-test
 112
 113 [ t ] [
 114     [ { fixnum } declare [ ] times ] \ 1+ inlined?
 115 ] unit-test
 116
 117 [ t ] [
 118     [ { fixnum } declare [ ] times ] \ + inlined?
 119 ] unit-test
 120
 121 [ t ] [
 122     [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
 123 ] unit-test
 124
 125 [ t ] [
 126     [ { integer fixnum } declare dupd < [ 1 + ] when ]
 127     \ + inlined?
 128 ] unit-test
 129
 130 [ f ] [
 131     [ { integer fixnum } declare dupd < [ 1 + ] when ]
 132     \ +-integer-fixnum inlined?
 133 ] unit-test
 134
 135 [ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
 136
 137 [ f ] [
 138     [
 139         [ no-cond ] 1
 140         [ 1array dup quotation? [ >quotation ] unless ] times
 141     ] \ quotation? inlined?
 142 ] unit-test
 143
 144 [ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
 145
 146 ! We don't want to use = to compare literals
 147 : foo ( seq -- seq' ) reverse ;
 148
 149 \ foo [
 150     [
 151         fixnum 0 `output class,
 152         V{ } dup dup push 0 `input literal,
 153     ] set-constraints
 154 ] "constraints" set-word-prop
 155
 156 DEFER: blah
 157
 158 [ ] [
 159     [
 160         \ blah
 161         [ dup V{ } eq? [ foo ] when ] dup second dup push define
 162     ] with-compilation-unit
 163
 164     \ blah def>> dataflow optimize drop
 165 ] unit-test
 166
 167 GENERIC: detect-fx ( n -- n )
 168
 169 M: fixnum detect-fx ;
 170
 171 [ t ] [
 172     [
 173         [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
 174         >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
 175         255 min 0 max detect-fx
 176     ] \ detect-fx inlined?
 177 ] unit-test
 178
 179 [ t ] [
 180     [
 181         1000000000000000000000000000000000 [ ] times
 182     ] \ + inlined?
 183 ] unit-test
 184 [ f ] [
 185     [
 186         1000000000000000000000000000000000 [ ] times
 187     ] \ +-integer-fixnum inlined?
 188 ] unit-test
 189
 190 [ f ] [
 191     [ { bignum } declare [ ] times ]
 192     \ +-integer-fixnum inlined?
 193 ] unit-test
 194
 195
 196 [ t ] [
 197     [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
 198 ] unit-test
 199
 200 [ t ] [
 201     [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
 202 ] unit-test
 203
 204 [ t ] [
 205     [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
 206 ] unit-test
 207
 208 [ t ] [
 209     [ { array-capacity } declare 0 < ] \ < inlined?
 210 ] unit-test
 211
 212 [ t ] [
 213     [ { array-capacity } declare 0 < ] \ fixnum< inlined?
 214 ] unit-test
 215
 216 [ t ] [
 217     [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 218 ] unit-test
 219
 220 [ t ] [
 221     [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
 222 ] unit-test
 223
 224 [ t ] [
 225     [ 5000 [ [ ] times ] each ] \ 1+ inlined?
 226 ] unit-test
 227
 228 [ t ] [
 229     [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
 230     \ 1+ inlined?
 231 ] unit-test
 232
 233 GENERIC: annotate-entry-test-1 ( x -- )
 234
 235 M: fixnum annotate-entry-test-1 drop ;
 236
 237 : (annotate-entry-test-2) ( from to quot -- )
 238     2over >= [
 239         3drop
 240     ] [
 241         [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
 242     ] if ; inline
 243
 244 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
 245
 246 [ f ] [
 247     [ { bignum } declare [ ] annotate-entry-test-2 ]
 248     \ annotate-entry-test-1 inlined?
 249 ] unit-test
 250
 251 [ t ] [
 252     [ { float } declare 10 [ 2.3 * ] times >float ]
 253     \ >float inlined?
 254 ] unit-test
 255
 256 GENERIC: detect-float ( a -- b )
 257
 258 M: float detect-float ;
 259
 260 [ t ] [
 261     [ { real float } declare + detect-float ]
 262     \ detect-float inlined?
 263 ] unit-test
 264
 265 [ t ] [
 266     [ { float real } declare + detect-float ]
 267     \ detect-float inlined?
 268 ] unit-test
 269
 270 [ t ] [
 271     [ 3 + = ] \ equal? inlined?
 272 ] unit-test
 273
 274 [ f ] [
 275     [ { fixnum fixnum } declare 7 bitand neg shift ]
 276     \ fixnum-shift-fast inlined?
 277 ] unit-test
 278
 279 [ t ] [
 280     [ { fixnum fixnum } declare 7 bitand neg shift ]
 281     { shift fixnum-shift } inlined?
 282 ] unit-test
 283
 284 [ t ] [
 285     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 286     { shift fixnum-shift } inlined?
 287 ] unit-test
 288
 289 [ f ] [
 290     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 291     { fixnum-shift-fast } inlined?
 292 ] unit-test
 293
 294 cell-bits 32 = [
 295     [ t ] [
 296         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 297         \ shift inlined?
 298     ] unit-test
 299
 300     [ f ] [
 301         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 302         \ fixnum-shift inlined?
 303     ] unit-test
 304 ] when
 305
 306 [ f ] [
 307     [ { integer } declare -63 shift 4095 bitand ]
 308     \ shift inlined?
 309 ] unit-test
 310
 311 [ t ] [
 312     [ B{ 1 0 } *short 0 number= ]
 313     \ number= inlined?
 314 ] unit-test
 315
 316 [ t ] [
 317     [ B{ 1 0 } *short 0 { number number } declare number= ]
 318     \ number= inlined?
 319 ] unit-test
 320
 321 [ t ] [
 322     [ B{ 1 0 } *short 0 = ]
 323     \ number= inlined?
 324 ] unit-test
 325
 326 [ t ] [
 327     [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
 328     \ number= inlined?
 329 ] unit-test
 330
 331 [ t ] [
 332     [ HEX: ff bitand 0 HEX: ff between? ]
 333     \ >= inlined?
 334 ] unit-test
 335
 336 [ t ] [
 337     [ HEX: ff swap HEX: ff bitand >= ]
 338     \ >= inlined?
 339 ] unit-test
 340
 341 [ t ] [
 342     [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
 343 ] unit-test
 344
 345 [ t ] [
 346     [
 347         dup integer? [
 348             dup fixnum? [
 349                 1 +
 350             ] [
 351                 2 +
 352             ] if
 353         ] when
 354     ] \ + inlined?
 355 ] unit-test
 356
 357 [ f ] [
 358     [
 359         256 mod
 360     ] { mod fixnum-mod } inlined?
 361 ] unit-test
 362
 363 [ f ] [
 364     [
 365         dup 0 >= [ 256 mod ] when
 366     ] { mod fixnum-mod } inlined?
 367 ] unit-test
 368
 369 [ t ] [
 370     [
 371         { integer } declare dup 0 >= [ 256 mod ] when
 372     ] { mod fixnum-mod } inlined?
 373 ] unit-test
 374
 375 [ t ] [
 376     [
 377         { integer } declare 256 rem
 378     ] { mod fixnum-mod } inlined?
 379 ] unit-test
 380
 381 [ t ] [
 382     [
 383         { integer } declare [ 256 rem ] map
 384     ] { mod fixnum-mod rem } inlined?
 385 ] unit-test
 386
 387 [ t ] [
 388     [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
 389 ] unit-test
 390
 391 : rec ( a -- b )
 392     dup 0 > [ 1 - rec ] when ; inline
 393
 394 [ t ] [
 395     [ { fixnum } declare rec 1 + ]
 396     { > - + } inlined?
 397 ] unit-test
 398
 399 : fib ( m -- n )
 400     dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
 401
 402 [ t ] [
 403     [ 27.0 fib ] { < - + } inlined?
 404 ] unit-test
 405
 406 [ f ] [
 407     [ 27.0 fib ] { +-integer-integer } inlined?
 408 ] unit-test
 409
 410 [ t ] [
 411     [ 27 fib ] { < - + } inlined?
 412 ] unit-test
 413
 414 [ t ] [
 415     [ 27 >bignum fib ] { < - + } inlined?
 416 ] unit-test
 417
 418 [ f ] [
 419     [ 27/2 fib ] { < - } inlined?
 420 ] unit-test
 421
 422 : hang-regression ( m n -- x )
 423     over 0 number= [
 424         nip
 425     ] [
 426         dup [
 427             drop 1 hang-regression
 428         ] [
 429             dupd hang-regression hang-regression
 430         ] if
 431     ] if ; inline
 432
 433 [ t ] [
 434     [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
 435 ] { } inlined? ] unit-test
 436
 437 : detect-null ( a -- b ) dup drop ;
 438
 439 \ detect-null {
 440     { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
 441 } define-optimizers
 442
 443 [ t ] [
 444     [ { null } declare detect-null ] \ detect-null inlined?
 445 ] unit-test
 446
 447 [ t ] [
 448     [ { null null } declare + detect-null ] \ detect-null inlined?
 449 ] unit-test
 450
 451 [ f ] [
 452     [ { null fixnum } declare + detect-null ] \ detect-null inlined?
 453 ] unit-test
 454
 455 GENERIC: detect-integer ( a -- b )
 456
 457 M: integer detect-integer ;
 458
 459 [ t ] [
 460     [ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
 461 ] unit-test
 462
 463 [ t ] [
 464     [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
 465 ] unit-test
 466
 467 [ f ] [
 468     [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
 469 ] unit-test
 470
 471 [ f ] [
 472     [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
 473     \ fixnum-bitand inlined?
 474 ] unit-test
 475
 476 [ t ] [
 477     [ { integer } declare 127 bitand 3 + ]
 478     { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
 479 ] unit-test
 480
 481 [ f ] [
 482     [ { integer } declare 127 bitand 3 + ]
 483     { >fixnum } inlined?
 484 ] unit-test
 485
 486 [ t ] [
 487     [ { fixnum } declare [ drop ] each-integer ]
 488     { < <-integer-fixnum +-integer-fixnum + } inlined?
 489 ] unit-test
 490
 491 [ t ] [
 492     [ { fixnum } declare length [ drop ] each-integer ]
 493     { < <-integer-fixnum +-integer-fixnum + } inlined?
 494 ] unit-test
 495
 496 [ t ] [
 497     [ { fixnum } declare [ drop ] each ]
 498     { < <-integer-fixnum +-integer-fixnum + } inlined?
 499 ] unit-test
 500
 501 [ t ] [
 502     [ { fixnum } declare 0 [ + ] reduce ]
 503     { < <-integer-fixnum } inlined?
 504 ] unit-test
 505
 506 [ f ] [
 507     [ { fixnum } declare 0 [ + ] reduce ]
 508     \ +-integer-fixnum inlined?
 509 ] unit-test
 510
 511 [ t ] [
 512     [
 513         { integer } declare
 514         dup 0 >= [
 515             615949 * 797807 + 20 2^ mod dup 19 2^ -
 516         ] [ dup ] if
 517     ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
 518 ] unit-test
 519
 520 [ t ] [
 521     [
 522         { fixnum } declare
 523         615949 * 797807 + 20 2^ mod dup 19 2^ -
 524     ] { >fixnum } inlined?
 525 ] unit-test
 526
 527 [ f ] [
 528     [
 529         { integer } declare [ ] map
 530     ] \ >fixnum inlined?
 531 ] unit-test
 532
 533 [ f ] [
 534     [
 535         { integer } declare { } set-nth-unsafe
 536     ] \ >fixnum inlined?
 537 ] unit-test
 538
 539 [ f ] [
 540     [
 541         { integer } declare 1 + { } set-nth-unsafe
 542     ] \ >fixnum inlined?
 543 ] unit-test
 544
 545 [ t ] [
 546     [
 547         { integer } declare 0 swap
 548         [
 549             drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
 550         ] map
 551     ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
 552 ] unit-test
 553
 554 [ t ] [
 555     [
 556         { fixnum } declare 0 swap
 557         [
 558             drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
 559         ] map
 560     ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
 561 ] unit-test
 562
 563 [ t ] [
 564     [ { integer } declare bitnot detect-integer ]
 565     \ detect-integer inlined?
 566 ] unit-test
 567
 568 [ t ] [
 569     [ hashtable new ] \ new inlined?
 570 ] unit-test
 571
 572 [ t ] [
 573     [ dup hashtable eq? [ new ] when ] \ new inlined?
 574 ] unit-test
 575
 576 [ t ] [
 577     [ { hashtable } declare hashtable instance? ] \ instance? inlined?
 578 ] unit-test
 579
 580 [ t ] [
 581     [ { vector } declare hashtable instance? ] \ instance? inlined?
 582 ] unit-test
 583
 584 [ f ] [
 585     [ { assoc } declare hashtable instance? ] \ instance? inlined?
 586 ] unit-test
 587
 588 TUPLE: declared-fixnum { x fixnum } ;
 589
 590 [ t ] [
 591     [ { declared-fixnum } declare [ 1 + ] change-x ]
 592     { + fixnum+ >fixnum } inlined?
 593 ] unit-test
 594
 595 [ t ] [
 596     [ { declared-fixnum } declare x>> drop ]
 597     { slot } inlined?
 598 ] unit-test
 599
 600 [ t ] [
 601     [
 602         { array } declare length
 603         1 + dup 100 fixnum> [ 1 fixnum+ ] when
 604     ] \ fixnum+ inlined?
 605 ] unit-test
 606
 607 [ t ] [
 608     [ [ resize-array ] keep length ] \ length inlined?
 609 ] unit-test
 610
 611 [ t ] [
 612     [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
 613 ] unit-test
 614
 615 [ t ] [
 616     [ { utf8 } declare decode-char ] \ decode-char inlined?
 617 ] unit-test
 618
 619 [ t ] [
 620     [ { ascii } declare decode-char ] \ decode-char inlined?
 621 ] unit-test
 622
 623 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
 624
 625 ! Later
 626
 627 ! [ t ] [
 628 !     [
 629 !         { integer } declare [ 256 mod ] map
 630 !     ] { mod fixnum-mod } inlined?
 631 ! ] unit-test
 632 !
 633 ! [ t ] [
 634 !     [
 635 !         { integer } declare [ 0 >= ] map
 636 !     ] { >= fixnum>= } inlined?
 637 ! ] unit-test