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