basis/compiler/tests/codegen.factor

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