basis/compiler/tests/codegen.factor

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