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
   9 compiler.tree
  10 compiler.tree.combinators
  11 compiler.tree.cleanup
  12 compiler.tree.builder
  13 compiler.tree.normalization
  14 compiler.tree.propagation
  15 compiler.tree.checker ;
  16
  17 : cleaned-up-tree ( quot -- nodes )
  18     build-tree normalize propagate cleanup dup check-nodes ;
  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 : inlined? ( quot seq/word -- ? )
  37     [ cleaned-up-tree ] dip
  38     dup word? [ 1array ] when
  39     '[ dup #call? [ word>> , member? ] [ drop f ] if ]
  40     contains-node? not ;
  41
  42 [ f ] [
  43     [ { integer } declare >fixnum ]
  44     \ >fixnum inlined?
  45 ] unit-test
  46
  47 GENERIC: mynot ( x -- y )
  48
  49 M: f mynot drop t ;
  50
  51 M: object mynot drop f ;
  52
  53 GENERIC: detect-f ( x -- y )
  54
  55 M: f detect-f ;
  56
  57 [ t ] [
  58     [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
  59 ] unit-test
  60
  61 GENERIC: xyz ( n -- n )
  62
  63 M: integer xyz ;
  64
  65 M: object xyz ;
  66
  67 [ t ] [
  68     [ { integer } declare xyz ] \ xyz inlined?
  69 ] unit-test
  70
  71 [ t ] [
  72     [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
  73     \ xyz inlined?
  74 ] unit-test
  75
  76 : (fx-repeat) ( i n quot: ( i -- i ) -- )
  77     2over fixnum>= [
  78         3drop
  79     ] [
  80         [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
  81     ] if ; inline recursive
  82
  83 : fx-repeat ( n quot -- )
  84     0 -rot (fx-repeat) ; inline
  85
  86 ! The + should be optimized into fixnum+, if it was not, then
  87 ! the type of the loop index was not inferred correctly
  88 [ t ] [
  89     [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
  90 ] unit-test
  91
  92 : (i-repeat) ( i n quot: ( i -- i ) -- )
  93     2over dup xyz drop >= [
  94         3drop
  95     ] [
  96         [ swap >r call 1+ r> ] keep (i-repeat)
  97     ] if ; inline recursive
  98
  99 : i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
 100
 101 [ t ] [
 102     [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
 103 ] unit-test
 104
 105 [ t ] [
 106     [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ 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 fixnum } declare dupd < [ 1 + 1 + ] when ]
 116     \ + inlined?
 117 ] unit-test
 118
 119 [ t ] [
 120     [ { fixnum } declare [ ] times ] \ >= inlined?
 121 ] unit-test
 122
 123 [ t ] [
 124     [ { fixnum } declare [ ] times ] \ 1+ inlined?
 125 ] unit-test
 126
 127 [ t ] [
 128     [ { fixnum } declare [ ] times ] \ + inlined?
 129 ] unit-test
 130
 131 [ t ] [
 132     [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
 133 ] unit-test
 134
 135 [ t ] [
 136     [ { integer fixnum } declare dupd < [ 1 + ] when ]
 137     \ + inlined?
 138 ] unit-test
 139
 140 [ f ] [
 141     [ { integer fixnum } declare dupd < [ 1 + ] when ]
 142     \ +-integer-fixnum inlined?
 143 ] unit-test
 144
 145 [ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
 146
 147 [ t ] [
 148     [
 149         [ no-cond ] 1
 150         [ 1array dup quotation? [ >quotation ] unless ] times
 151     ] \ quotation? inlined?
 152 ] unit-test
 153
 154 [ t ] [
 155     [
 156         1000000000000000000000000000000000 [ ] times
 157     ] \ + inlined?
 158 ] unit-test
 159 [ f ] [
 160     [
 161         1000000000000000000000000000000000 [ ] times
 162     ] \ +-integer-fixnum inlined?
 163 ] unit-test
 164
 165 [ f ] [
 166     [ { bignum } declare [ ] times ]
 167     \ +-integer-fixnum inlined?
 168 ] unit-test
 169
 170 [ t ] [
 171     [ { array-capacity } declare 0 < ] \ < inlined?
 172 ] unit-test
 173
 174 [ t ] [
 175     [ { array-capacity } declare 0 < ] \ fixnum< inlined?
 176 ] unit-test
 177
 178 [ t ] [
 179     [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 180 ] unit-test
 181
 182 [ t ] [
 183     [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
 184 ] unit-test
 185
 186 [ t ] [
 187     [ 5000 [ [ ] times ] each ] \ 1+ inlined?
 188 ] unit-test
 189
 190 [ t ] [
 191     [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
 192     \ 1+ inlined?
 193 ] unit-test
 194
 195 GENERIC: annotate-entry-test-1 ( x -- )
 196
 197 M: fixnum annotate-entry-test-1 drop ;
 198
 199 : (annotate-entry-test-2) ( from to -- )
 200     2dup >= [
 201         2drop
 202     ] [
 203         >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
 204     ] if ; inline recursive
 205
 206 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
 207
 208 [ f ] [
 209     [ { bignum } declare annotate-entry-test-2 ]
 210     \ annotate-entry-test-1 inlined?
 211 ] unit-test
 212
 213 [ t ] [
 214     [ { float } declare 10 [ 2.3 * ] times >float ]
 215     \ >float inlined?
 216 ] unit-test
 217
 218 GENERIC: detect-float ( a -- b )
 219
 220 M: float detect-float ;
 221
 222 [ t ] [
 223     [ { real float } declare + detect-float ]
 224     \ detect-float inlined?
 225 ] unit-test
 226
 227 [ t ] [
 228     [ { float real } declare + detect-float ]
 229     \ detect-float inlined?
 230 ] unit-test
 231
 232 [ f ] [
 233     [ { fixnum fixnum } declare 7 bitand neg shift ]
 234     \ fixnum-shift-fast inlined?
 235 ] unit-test
 236
 237 [ t ] [
 238     [ { fixnum fixnum } declare 7 bitand neg shift ]
 239     { shift fixnum-shift } inlined?
 240 ] unit-test
 241
 242 [ t ] [
 243     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 244     { shift fixnum-shift } inlined?
 245 ] unit-test
 246
 247 [ f ] [
 248     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
 249     { fixnum-shift-fast } inlined?
 250 ] unit-test
 251
 252 cell-bits 32 = [
 253     [ t ] [
 254         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 255         \ shift inlined?
 256     ] unit-test
 257
 258     [ f ] [
 259         [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
 260         \ fixnum-shift inlined?
 261     ] unit-test
 262 ] when
 263
 264 [ t ] [
 265     [ B{ 1 0 } *short 0 number= ]
 266     \ number= inlined?
 267 ] unit-test
 268
 269 [ t ] [
 270     [ B{ 1 0 } *short 0 { number number } declare number= ]
 271     \ number= inlined?
 272 ] unit-test
 273
 274 [ t ] [
 275     [ B{ 1 0 } *short 0 = ]
 276     \ number= inlined?
 277 ] unit-test
 278
 279 [ t ] [
 280     [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
 281     \ number= inlined?
 282 ] unit-test
 283
 284 [ t ] [
 285     [ HEX: ff bitand 0 HEX: ff between? ]
 286     \ >= inlined?
 287 ] unit-test
 288
 289 [ t ] [
 290     [ HEX: ff swap HEX: ff bitand >= ]
 291     \ >= inlined?
 292 ] unit-test
 293
 294 [ t ] [
 295     [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
 296 ] unit-test
 297
 298 [ t ] [
 299     [
 300         dup integer? [
 301             dup fixnum? [
 302                 1 +
 303             ] [
 304                 2 +
 305             ] if
 306         ] when
 307     ] \ + inlined?
 308 ] unit-test
 309
 310 [ t ] [
 311     [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
 312 ] unit-test
 313
 314 : rec ( a -- b )
 315     dup 0 > [ 1 - rec ] when ; inline recursive
 316
 317 [ t ] [
 318     [ { fixnum } declare rec 1 + ]
 319     { > - + } inlined?
 320 ] unit-test
 321
 322 : fib ( m -- n )
 323     dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
 324
 325 [ t ] [
 326     [ 27.0 fib ] { < - + } inlined?
 327 ] unit-test
 328
 329 [ f ] [
 330     [ 27.0 fib ] { +-integer-integer } inlined?
 331 ] unit-test
 332
 333 [ t ] [
 334     [ 27 fib ] { < - + } inlined?
 335 ] unit-test
 336
 337 [ t ] [
 338     [ 27 >bignum fib ] { < - + } inlined?
 339 ] unit-test
 340
 341 [ f ] [
 342     [ 27/2 fib ] { < - } inlined?
 343 ] unit-test
 344
 345 [ t ] [
 346     [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
 347 ] unit-test
 348
 349 [ f ] [
 350     [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
 351 ] unit-test
 352
 353 [ f ] [
 354     [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
 355     \ fixnum-bitand inlined?
 356 ] unit-test
 357
 358 [ t ] [
 359     [ { fixnum } declare [ drop ] each-integer ]
 360     { < <-integer-fixnum +-integer-fixnum + } inlined?
 361 ] unit-test
 362
 363 [ t ] [
 364     [ { fixnum } declare length [ drop ] each-integer ]
 365     { < <-integer-fixnum +-integer-fixnum + } inlined?
 366 ] unit-test
 367
 368 [ t ] [
 369     [ { fixnum } declare [ drop ] each ]
 370     { < <-integer-fixnum +-integer-fixnum + } inlined?
 371 ] unit-test
 372
 373 [ t ] [
 374     [ { fixnum } declare 0 [ + ] reduce ]
 375     { < <-integer-fixnum nth-unsafe } inlined?
 376 ] unit-test
 377
 378 [ f ] [
 379     [ { fixnum } declare 0 [ + ] reduce ]
 380     \ +-integer-fixnum inlined?
 381 ] unit-test
 382
 383 [ f ] [
 384     [
 385         { integer } declare [ ] map
 386     ] \ >fixnum inlined?
 387 ] unit-test
 388
 389 [ f ] [
 390     [
 391         { integer } declare { } set-nth-unsafe
 392     ] \ >fixnum inlined?
 393 ] unit-test
 394
 395 [ f ] [
 396     [
 397         { integer } declare 1 + { } set-nth-unsafe
 398     ] \ >fixnum inlined?
 399 ] unit-test
 400
 401 [ t ] [
 402     [
 403         { array } declare length
 404         1 + dup 100 fixnum> [ 1 fixnum+ ] when
 405     ] \ fixnum+ inlined?
 406 ] unit-test
 407
 408 [ t ] [
 409     [ [ resize-array ] keep length ] \ length inlined?
 410 ] unit-test
 411
 412 [ t ] [
 413     [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
 414 ] unit-test
 415
 416 [ t ] [
 417     [ { utf8 } declare decode-char ] \ decode-char inlined?
 418 ] unit-test
 419
 420 [ t ] [
 421     [ { ascii } declare decode-char ] \ decode-char inlined?
 422 ] unit-test
 423
 424 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
 425
 426 [ t ] [
 427     [
 428         { integer } declare [ 0 >= ] map
 429     ] { >= fixnum>= } inlined?
 430 ] unit-test
 431
 432 [ ] [
 433     [
 434         4 pick array-capacity?
 435         [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
 436     ] cleaned-up-tree drop
 437 ] unit-test
 438
 439 [ ] [
 440     [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
 441 ] unit-test
 442
 443 [ ] [
 444     [
 445         [ "X" throw ]
 446         [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
 447         if
 448     ] cleaned-up-tree drop
 449 ] unit-test
 450
 451 [ t ] [
 452     [ [ 2array ] [ 0 3array ] if first ]
 453     { nth-unsafe < <= > >= } inlined?
 454 ] unit-test
 455
 456 [ ] [
 457     [ [ >r "A" throw r> ] [ "B" throw ] if ]
 458     cleaned-up-tree drop
 459 ] unit-test
 460
 461 ! Regression from benchmark.nsieve
 462 : chicken-fingers ( i seq -- )
 463     2dup < [
 464         2drop
 465     ] [
 466         chicken-fingers
 467     ] if ; inline recursive
 468
 469 : buffalo-wings ( i seq -- )
 470     2dup < [
 471         2dup chicken-fingers
 472         >r 1+ r> buffalo-wings
 473     ] [
 474         2drop
 475     ] if ; inline recursive
 476
 477 [ t ] [
 478     [ 2 swap >fixnum buffalo-wings ]
 479     { <-integer-fixnum +-integer-fixnum } inlined?
 480 ] unit-test