basis/compiler/tests/codegen.factor

   1 USING: generalizations accessors arrays compiler.test kernel
   2 kernel.private math hashtables.private math.private namespaces
   3 sequences tools.test namespaces.private slots.private
   4 sequences.private byte-arrays alien alien.accessors layouts
   5 words definitions compiler.units io combinators vectors grouping
   6 make alien.c-types alien.data combinators.short-circuit math.order
   7 math.libm math.parser math.functions alien.syntax memory
   8 stack-checker literals system ;
   9 FROM: math => float ;
  10 QUALIFIED: namespaces.private
  11 IN: compiler.tests.codegen
  12
  13 ! Originally, this file did black box testing of templating
  14 ! optimization. We now have a different codegen, but the tests
  15 ! in here are still useful.
  16
  17 ! Oops!
  18 { 5000 } [ [ 5000 ] compile-call ] unit-test
  19 { "hi" } [ [ "hi" ] compile-call ] unit-test
  20
  21 { 1 2 3 4 } [ [ 1 2 3 4 ] compile-call ] unit-test
  22
  23 { 1 1 } [ 1 [ dup ] compile-call ] unit-test
  24 { 0 } [ 3 [ tag ] compile-call ] unit-test
  25 { 0 3 } [ 3 [ [ tag ] keep ] compile-call ] unit-test
  26
  27 { 2 3 } [ 3 [ 2 swap ] compile-call ] unit-test
  28
  29 { 2 1 3 4 } [ 1 2 [ swap 3 4 ] compile-call ] unit-test
  30
  31 { 2 3 4 } [ 3 [ 2 swap 4 ] compile-call ] unit-test
  32
  33 { { 1 2 3 } { 1 4 3 } 2 2 }
  34 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
  35 unit-test
  36
  37 ! Test literals in either side of a shuffle
  38 { 4 1 } [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
  39
  40 { 2 } [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
  41
  42 : foo ( -- ) ;
  43
  44 { 3 3 }
  45 [ 1.2 [ tag [ foo ] keep ] compile-call ]
  46 unit-test
  47
  48 { 1 2 2 }
  49 [ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
  50 unit-test
  51
  52 { 3 }
  53 [
  54     global [ 3 \ foo set ] with-variables
  55     \ foo [ global >n get namespaces.private:ndrop ] compile-call
  56 ] unit-test
  57
  58 : blech ( x -- ) drop ;
  59
  60 { 3 }
  61 [
  62     global [ 3 \ foo set ] with-variables
  63     \ foo [ global [ get ] swap blech call ] compile-call
  64 ] unit-test
  65
  66 { 3 }
  67 [
  68     global [ 3 \ foo set ] with-variables
  69     \ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
  70 ] unit-test
  71
  72 { 3 }
  73 [
  74     global [ 3 \ foo set ] with-variables
  75     \ foo [ global [ get ] with-variables ] compile-call
  76 ] unit-test
  77
  78 { 12 13 } [
  79     -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
  80 ] unit-test
  81
  82 { -1 2 } [ 1 2 [ [ 0 swap fixnum- ] dip ] compile-call ] unit-test
  83
  84 { 12 13 } [
  85     -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
  86 ] unit-test
  87
  88 { 1 } [
  89     SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
  90 ] unit-test
  91
  92 ! Test slow shuffles
  93 { 3 1 2 3 4 5 6 7 8 9 } [
  94     1 2 3 4 5 6 7 8 9
  95     [ [ [ [ [ [ [ [ [ [ 3 ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ]
  96     compile-call
  97 ] unit-test
  98
  99 { 2 2 2 2 2 2 2 2 2 2 1 } [
 100     1 2
 101     [ swap [ dup dup dup dup dup dup dup dup dup ] dip ] compile-call
 102 ] unit-test
 103
 104 { } [ [ 9 [ ] times ] compile-call ] unit-test
 105
 106 { } [
 107     [
 108         [ 200 dup [ 200 3array ] curry map drop ] times
 109     ] [ ( n -- ) define-temp ] with-compilation-unit drop
 110 ] unit-test
 111
 112 ! Test how dispatch handles the end of a basic block
 113 : try-breaking-dispatch ( n a b -- x str )
 114     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 115
 116 : try-breaking-dispatch-2 ( -- ? )
 117     1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
 118
 119 { t } [
 120     10000000 [ drop try-breaking-dispatch-2 ] all-integers?
 121 ] unit-test
 122
 123 ! Regression
 124 : (broken) ( x -- y ) ;
 125
 126 { 2.0 { 2.0 0.0 } } [
 127     2.0 1.0
 128     [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
 129 ] unit-test
 130
 131 ! Regression
 132 : hellish-bug-1 ( a b -- ) 2drop ;
 133
 134 : hellish-bug-2 ( i array x -- x )
 135     2dup 1 slot eq? [ 2drop ] [
 136         2dup array-nth tombstone? [
 137             [
 138                 [ array-nth ] 2keep [ 1 fixnum+fast ] dip array-nth
 139                 pick 2dup hellish-bug-1 3drop
 140             ] 2keep
 141         ] unless [ 2 fixnum+fast ] dip hellish-bug-2
 142     ] if ; inline recursive
 143
 144 : hellish-bug-3 ( hash array -- )
 145     0 swap hellish-bug-2 drop ;
 146
 147 { } [
 148     H{ { 1 2 } { 3 4 } } dup array>>
 149     [ 0 swap hellish-bug-2 drop ] compile-call
 150 ] unit-test
 151
 152 ! Regression
 153 : foox ( obj -- obj )
 154     dup not
 155     [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
 156
 157 { 3 } [ f foox ] unit-test
 158
 159 TUPLE: my-tuple ;
 160
 161 { 4 } [ T{ my-tuple } foox ] unit-test
 162
 163 { 5 } [ "hi" foox ] unit-test
 164
 165 ! Making sure we don't needlessly unbox/rebox
 166 { t 3.0 } [ 1.0 dup [ dup 2.0 float+ [ eq? ] dip ] compile-call ] unit-test
 167
 168 { t 3.0 } [ 1.0 dup [ dup 2.0 float+ ] compile-call [ eq? ] dip ] unit-test
 169
 170 { t } [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
 171
 172 { 1 B{ 1 2 3 4 } } [
 173     B{ 1 2 3 4 } [
 174         { byte-array } declare
 175         [ 0 alien-unsigned-1 ] keep
 176     ] compile-call
 177 ] unit-test
 178
 179 { 2 1 } [
 180     2 1
 181     [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
 182 ] unit-test
 183
 184 ! Regression
 185 : a-dummy ( a -- ) drop "hi" print ;
 186
 187 { } [
 188     1 [
 189         dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
 190             drop - >fixnum {
 191                 [ a-dummy ]
 192                 [ a-dummy ]
 193                 [ a-dummy ]
 194             } dispatch
 195         ] [ 2drop no-case ] if
 196     ] compile-call
 197 ] unit-test
 198
 199 ! Regression
 200 : dispatch-alignment-regression ( -- c )
 201     { tuple vector } 3 slot { word } declare
 202     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 203
 204 { t } [ \ dispatch-alignment-regression word-optimized? ] unit-test
 205
 206 { vector } [ dispatch-alignment-regression ] unit-test
 207
 208 ! Regression
 209 : bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
 210
 211 { { f f f } } [ t bad-value-bug ] unit-test
 212
 213 ! PowerPC regression
 214 TUPLE: id obj ;
 215
 216 : (gc-check-bug) ( a b -- c )
 217     { [ id boa ] [ id boa ] } dispatch ;
 218
 219 : gc-check-bug ( -- )
 220     10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
 221
 222 { } [ gc-check-bug ] unit-test
 223
 224 ! New optimization
 225 : test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
 226
 227 { "a" } [ 8 test-1 ] unit-test
 228 { "b" } [ 9 test-1 ] unit-test
 229
 230 : test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
 231
 232 { "a" } [ 1 test-2 ] unit-test
 233 { "b" } [ 2 test-2 ] unit-test
 234
 235 ! I accidentally fixnum/i-fast on PowerPC
 236 { { { 1 2 } { 3 4 } } } [
 237     { 1 2 3 4 }
 238     [
 239         [ { array } declare 2 group [ , ] each ] compile-call
 240     ] { } make
 241 ] unit-test
 242
 243 { 2 } [
 244     { 1 2 3 4 }
 245     [ { array } declare 2 <groups> length ] compile-call
 246 ] unit-test
 247
 248 ! Oops with new intrinsics
 249 : fixnum-overflow-control-flow-test ( a b -- c )
 250     [ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ;
 251
 252 { 3 } [ 1 t fixnum-overflow-control-flow-test ] unit-test
 253 { 2 } [ 1 f fixnum-overflow-control-flow-test ] unit-test
 254
 255 ! LOL
 256 : blah ( a -- b )
 257     { float } declare dup 0 =
 258     [ drop 1 ] [
 259         dup 0 >=
 260         [ 2 double "libm" "pow" { double double } f alien-invoke ]
 261         [ -0.5 double "libm" "pow" { double double } f alien-invoke ]
 262         if
 263     ] if ;
 264
 265 { 4.0 } [ 2.0 blah ] unit-test
 266
 267 { 4 } [ 2 [ dup fixnum* ] compile-call ] unit-test
 268 { 7 } [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
 269
 270 TUPLE: cucumber ;
 271
 272 M: cucumber equal? "The cucumber has no equal" throw ;
 273
 274 { t } [ [ cucumber ] compile-call cucumber eq? ] unit-test
 275
 276 { 4294967295 B{ 255 255 255 255 } -1 }
 277 [
 278     -1 int <ref>
 279     -1 int <ref>
 280     [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
 281     compile-call
 282 ] unit-test
 283
 284 ! Regression found while working on global register allocation
 285
 286 : linear-scan-regression-1 ( a b c -- ) 3array , ;
 287 : linear-scan-regression-2 ( a b -- ) 2array , ;
 288
 289 : linear-scan-regression ( a b c -- )
 290     [ linear-scan-regression-2 ]
 291     [ linear-scan-regression-1 ]
 292     bi-curry bi-curry interleave ;
 293
 294 {
 295     {
 296         { 1 "x" "y" }
 297         { "x" "y" }
 298         { 2 "x" "y" }
 299         { "x" "y" }
 300         { 3 "x" "y" }
 301     }
 302 } [
 303     [ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
 304 ] unit-test
 305
 306 ! Regression from Doug's value numbering changes
 307 { t } [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
 308 { 3 } [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
 309
 310 cell 4 = [
 311     { 0 } [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
 312 ] when
 313
 314 ! Regression from Slava's value numbering changes
 315 { 1 } [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
 316
 317 ! Bug with ##return node construction
 318 : return-recursive-bug ( nodes -- ? )
 319     { fixnum } declare <iota> [
 320         dup 3 bitand 1 = [ drop t ] [
 321             dup 3 bitand 2 = [
 322                 return-recursive-bug
 323             ] [ drop f ] if
 324         ] if
 325     ] any? ; inline recursive
 326
 327 { t } [ 3 [ return-recursive-bug ] compile-call ] unit-test
 328
 329 ! Coalescing reductions
 330 { f } [ V{ } 0 [ [ vector? ] both? ] compile-call ] unit-test
 331 { f } [ 0 V{ } [ [ vector? ] both? ] compile-call ] unit-test
 332
 333 { f } [
 334     f vector [
 335         [ dup [ \ vector eq? ] [ drop f ] if ] dip
 336         dup [ \ vector eq? ] [ drop f ] if
 337         over rot [ drop ] [ nip ] if
 338     ] compile-call
 339 ] unit-test
 340
 341 ! Coalesing bug reduced from sequence-parser:take-sequence
 342 : coalescing-bug-1 ( a b c d -- a b c d )
 343     3dup {
 344         [ 2drop 0 < ]
 345         [ [ drop ] 2dip length > ]
 346         [ drop > ]
 347     } 3|| [ 3drop f ] [ slice boa ] if swap [ 2length ] 2keep ;
 348
 349 { 0 3 f { 1 2 3 } } [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test
 350 { 0 3 f { 1 2 3 } } [ { 1 2 3 } 0 7 "hello" coalescing-bug-1 ] unit-test
 351 { 0 3 f { 1 2 3 } } [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test
 352 { 2 3 T{ slice f 1 3 "hello" } { 1 2 3 } } [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test
 353
 354 ! Another one, found by Dan
 355 : coalescing-bug-2 ( a -- b )
 356     dup dup 10 fixnum< [ 1 fixnum+fast ] when
 357     fixnum+fast 2 fixnum*fast 2 fixnum-fast 2 fixnum*fast 2 fixnum+fast ;
 358
 359 { 10 } [ 1 coalescing-bug-2 ] unit-test
 360 { 86 } [ 11 coalescing-bug-2 ] unit-test
 361
 362 ! Regression in suffix-arrays code
 363 : coalescing-bug-3 ( from/f to/f seq -- slice )
 364     [
 365         [ drop 0 or ] [ length or ] bi-curry bi*
 366         [ min ] keep
 367     ] keep <slice> ;
 368
 369 { T{ slice f 0 5 "hello" } } [ f f "hello" coalescing-bug-3 ] unit-test
 370 { T{ slice f 1 5 "hello" } } [ 1 f "hello" coalescing-bug-3 ] unit-test
 371 { T{ slice f 0 3 "hello" } } [ f 3 "hello" coalescing-bug-3 ] unit-test
 372 { T{ slice f 1 3 "hello" } } [ 1 3 "hello" coalescing-bug-3 ] unit-test
 373 { T{ slice f 3 3 "hello" } } [ 4 3 "hello" coalescing-bug-3 ] unit-test
 374 { T{ slice f 5 5 "hello" } } [ 6 f "hello" coalescing-bug-3 ] unit-test
 375
 376 ! Reduction
 377 : coalescing-bug-4 ( a b c -- a b c )
 378     [ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
 379
 380 { 2 3 2 } [ 2 3 "" coalescing-bug-4 ] unit-test
 381 { 3 3 2 } [ 4 3 "" coalescing-bug-4 ] unit-test
 382 { 3 3 2 } [ 4 3 "" coalescing-bug-4 ] unit-test
 383 { 2 3 1 } [ 2 3 V{ } coalescing-bug-4 ] unit-test
 384 { 3 3 1 } [ 4 3 V{ } coalescing-bug-4 ] unit-test
 385 { 3 3 1 } [ 4 3 V{ } coalescing-bug-4 ] unit-test
 386
 387 ! Global stack analysis dataflow equations are wrong
 388 : some-word ( a -- b ) 2 + ;
 389 : global-dcn-bug-1 ( a b -- c d )
 390     dup [ [ drop 1 ] dip ] [ [ some-word ] dip ] if
 391     dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
 392
 393 { 2 t } [ 0 t global-dcn-bug-1 ] unit-test
 394 { 1 f } [ 0 f global-dcn-bug-1 ] unit-test
 395
 396 ! Forgot a GC check
 397 : missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
 398 : missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
 399
 400 { } [ missing-gc-check-2 ] unit-test
 401
 402 ! XXX: investigate this mac vs linux/win difference
 403 ${ 1 os macosx? "0.169967142900241" "0.16996714290024104" ? } [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
 404 ${ 1 os macosx? "0.169967142900241" "0.16996714290024104" ? } [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
 405 ${ os macosx? "0.169967142900241" "0.16996714290024104" ? "0.9854497299884601" } [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
 406 ${ 1 os macosx? "0.169967142900241" "0.16996714290024104" ? "0.9854497299884601" } [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
 407
 408 { 6.0 } [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
 409
 410 ! Bug in linearization
 411 { 283686952174081 } [
 412     B{ 1 1 1 1 } [
 413         { byte-array } declare
 414         [ 0 2 ] dip
 415         [
 416             [ drop ] 2dip
 417             [
 418                 swap 1 < [ [ ] dip ] [ [ ] dip ] if
 419                 0 alien-signed-4
 420             ] curry dup bi *
 421         ] curry each-integer
 422     ] compile-call
 423 ] unit-test
 424
 425 ! Bug in CSSA construction
 426 TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
 427
 428 { 2 } [
 429     little-endian?
 430     T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } }
 431     T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ?
 432     [
 433         { myseq } declare
 434         [ 0 2 ] dip dup
 435         [
 436             [
 437                 over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if
 438                 swap 4 * >fixnum alien-signed-4
 439             ] bi-curry@ bi * +
 440         ] 2curry each-integer
 441     ] compile-call
 442 ] unit-test
 443
 444 ! Bug in linear scan's partial sync point logic
 445 { t } [
 446     [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call
 447     1.168852488727981 1.e-9 ~
 448 ] unit-test
 449
 450 { 65537.0 } [
 451     [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call
 452 ] unit-test
 453
 454 ! ##box-displaced-alien is a def-is-use instruction
 455 { ALIEN: 3e9 } [
 456     [
 457         f
 458         100 [ 10 swap <displaced-alien> ] times
 459         1 swap <displaced-alien>
 460     ] compile-call
 461 ] unit-test
 462
 463 ! Forgot to two-operand shifts
 464 { 2 0 } [
 465     1 1
 466     [ [ 0xf bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
 467 ] unit-test
 468
 469 ! Alias analysis bug
 470 { t } [
 471     [
 472         10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
 473     ] compile-call
 474 ] unit-test
 475
 476 ! GC root offsets were computed wrong on x86
 477 : gc-root-messup ( a -- b )
 478     dup [
 479         1024 (byte-array) 2array
 480         10 void* "libc" "malloc" { ulong } f alien-invoke
 481         void "libc" "free" { void* } f alien-invoke
 482     ] when ;
 483
 484 { } [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
 485
 486 ! Write barrier elimination was being done before scheduling and
 487 ! GC check insertion, and didn't take subroutine calls into
 488 ! account. Oops...
 489 : write-barrier-elim-in-wrong-place ( -- obj )
 490     ! A callback used below
 491     void { } cdecl [ compact-gc ] alien-callback
 492     ! Allocate an object A in the nursery
 493     1 f <array>
 494     ! Subroutine call promotes the object to tenured
 495     swap void { } cdecl alien-indirect
 496     ! Allocate another object B in the nursery, store it into
 497     ! the first
 498     1 f <array> over set-first
 499     ! Now object A's card should be marked and minor GC should
 500     ! promote B to aging
 501     minor-gc
 502     ! Do stuff
 503     [ 100 [ ] times ] infer.
 504     ;
 505
 506 { { { f } } } [ write-barrier-elim-in-wrong-place ] unit-test
 507
 508 ! GC maps must support derived pointers
 509 : (derived-pointer-test-1) ( -- byte-array )
 510     2 <byte-array> ;
 511
 512 : derived-pointer-test-1 ( -- byte-array )
 513     ! A callback used below
 514     void { } cdecl [ compact-gc ] alien-callback
 515     ! Put the construction in a word since instruction selection
 516     ! eliminates the untagged pointer entirely if the value is a
 517     ! byte array
 518     (derived-pointer-test-1) { c-ptr } declare
 519     ! Store into an array, an untagged pointer to the payload
 520     ! is now an available expression
 521     123 over 0 set-alien-unsigned-1
 522     ! GC, moving the array and derived pointer
 523     swap void { } cdecl alien-indirect
 524     ! Store into the array again
 525     231 over 1 set-alien-unsigned-1 ;
 526
 527 { B{ 123 231 } } [ derived-pointer-test-1 ] unit-test
 528
 529 : fib-count2 ( -- x y ) 0 1 [ dup 4000000 <= ] [ [ + ] keep swap ] while ;
 530
 531 { 3524578 5702887 } [ fib-count2 ] unit-test
 532
 533 ! Stupid repro
 534 USE: compiler.cfg.registers
 535
 536 reset-vreg-counter
 537
 538 { fib-count2 } compile
 539
 540 { 3524578 5702887 } [ fib-count2 ] unit-test