basis/math/vectors/simd/simd-tests.factor

   1 USING: accessors arrays classes compiler compiler.tree.debugger
   2 effects fry io kernel kernel.private math math.functions
   3 math.private math.vectors math.vectors.simd
   4 math.vectors.simd.private prettyprint random sequences system
   5 tools.test vocabs assocs compiler.cfg.debugger words
   6 locals math.vectors.specialization combinators cpu.architecture
   7 math.vectors.conversion.backend
   8 math.vectors.simd.intrinsics namespaces byte-arrays alien
   9 specialized-arrays classes.struct eval classes.algebra sets
  10 quotations math.constants compiler.units ;
  11 QUALIFIED-WITH: alien.c-types c
  12 SPECIALIZED-ARRAY: c:float
  13 SIMD: c:char
  14 SIMDS: c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double ;
  15 IN: math.vectors.simd.tests
  16
  17 ! Make sure the functor doesn't generate bogus vocabularies
  18 2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times
  19
  20 [ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test
  21
  22 ! Test type propagation
  23 [ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
  24
  25 [ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
  26
  27 [ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
  28
  29 [ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
  30
  31 [ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test
  32
  33 [ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test
  34
  35 [ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test
  36
  37 [ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test
  38
  39 [ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
  40
  41 [ V{ int-8 } ] [ [ { int-8 int-8 } declare v+ ] final-classes ] unit-test
  42
  43 [ t ] [ [ { int-8 } declare second ] final-classes first integer class<= ] unit-test
  44
  45 ! Test puns; only on x86
  46 cpu x86? [
  47     [ double-2{ 4 1024 } ] [
  48         float-4{ 0 1 0 2 }
  49         [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
  50     ] unit-test
  51 ] when
  52
  53 ! Fuzz testing
  54 CONSTANT: simd-classes
  55     {
  56         char-16
  57         uchar-16
  58         char-32
  59         uchar-32
  60         short-8
  61         ushort-8
  62         short-16
  63         ushort-16
  64         int-4
  65         uint-4
  66         int-8
  67         uint-8
  68         longlong-2
  69         ulonglong-2
  70         longlong-4
  71         ulonglong-4
  72         float-4
  73         float-8
  74         double-2
  75         double-4
  76     }
  77
  78 : with-ctors ( -- seq )
  79     simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
  80
  81 : boa-ctors ( -- seq )
  82     simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
  83
  84 : check-optimizer ( seq quot eq-quot -- failures )
  85     '[
  86         @
  87         [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
  88         {
  89             [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
  90             [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
  91             [ [ [ call ] dip call ] call( quot quot -- result ) ]
  92             [ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
  93         } 2cleave
  94         @ not
  95     ] filter ; inline
  96
  97 "== Checking -new constructors" print
  98
  99 [ { } ] [
 100     simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
 101 ] unit-test
 102
 103 [ { } ] [
 104     simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
 105 ] unit-test
 106
 107 "== Checking -with constructors" print
 108
 109 [ { } ] [
 110     with-ctors [
 111         [ 1000 random '[ _ ] ] dip '[ _ execute ]
 112     ] [ = ] check-optimizer
 113 ] unit-test
 114
 115 [ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
 116
 117 [ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
 118
 119 [ HEX: ffffffff ] [ [ HEX: ffffffff uint-4-with ] compile-call first ] unit-test
 120
 121 "== Checking -boa constructors" print
 122
 123 [ { } ] [
 124     boa-ctors [
 125         [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
 126         '[ _ execute ]
 127     ] [ = ] check-optimizer
 128 ] unit-test
 129
 130 [ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
 131
 132 "== Checking vector operations" print
 133
 134 : random-int-vector ( class -- vec )
 135     new [ drop 1,000 random ] map ;
 136 : random-float-vector ( class -- vec )
 137     new [
 138         drop
 139         1000 random
 140         10 swap <array> 0/0. suffix random
 141     ] map ;
 142
 143 : random-vector ( class elt-class -- vec )
 144     float =
 145     [ random-float-vector ]
 146     [ random-int-vector ] if ;
 147
 148 :: check-vector-op ( word inputs class elt-class -- inputs quot )
 149     inputs [
 150         {
 151             { +vector+ [ class elt-class random-vector ] }
 152             { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
 153         } case
 154     ] [ ] map-as
 155     word '[ _ execute ] ;
 156
 157 : remove-float-words ( alist -- alist' )
 158     { vsqrt n/v v/n v/ normalize } unique assoc-diff ;
 159
 160 : remove-integer-words ( alist -- alist' )
 161     { vlshift vrshift } unique assoc-diff ;
 162
 163 : boolean-ops ( -- words )
 164     { vand vandn vor vxor vnot } ;
 165
 166 : remove-boolean-words ( alist -- alist' )
 167     boolean-ops unique assoc-diff ;
 168
 169 : remove-special-words ( alist -- alist' )
 170     ! These have their own tests later
 171     {
 172         hlshift hrshift vshuffle-bytes vshuffle-elements vbroadcast
 173         vany? vall? vnone?
 174         (v>float) (v>integer)
 175         (vpack-signed) (vpack-unsigned)
 176         (vunpack-head) (vunpack-tail)
 177     } unique assoc-diff ;
 178
 179 : ops-to-check ( elt-class -- alist )
 180     [ vector-words >alist ] dip
 181     float = [ remove-integer-words ] [ remove-float-words ] if
 182     remove-boolean-words
 183     remove-special-words ;
 184
 185 : check-vector-ops ( class elt-class compare-quot -- )
 186     [
 187         [ nip ops-to-check ] 2keep
 188         '[ first2 inputs _ _ check-vector-op ]
 189     ] dip check-optimizer ; inline
 190
 191 : (approx=) ( x y -- ? )
 192     {
 193         { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
 194         { [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
 195         { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
 196         { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
 197     } cond ;
 198
 199 : approx= ( x y -- ? )
 200     2dup [ sequence? ] both?
 201     [ [ (approx=) ] 2all? ] [ (approx=) ] if ;
 202
 203 : exact= ( x y -- ? )
 204     {
 205         { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
 206         { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
 207     } cond ;
 208
 209 : simd-classes&reps ( -- alist )
 210     simd-classes [
 211         {
 212             { [ dup name>> "float" head? ] [ float [ approx= ] ] }
 213             { [ dup name>> "double" head? ] [ float [ exact= ] ] }
 214             [ fixnum [ = ] ]
 215         } cond 3array
 216     ] map ;
 217
 218 simd-classes&reps [
 219     [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
 220 ] each
 221
 222 "== Checking boolean operations" print
 223
 224 : random-boolean-vector ( class -- vec )
 225     new [ drop 2 random zero? ] map ;
 226
 227 :: check-boolean-op ( word inputs class elt-class -- inputs quot )
 228     inputs [
 229         {
 230             { +vector+ [ class random-boolean-vector ] }
 231             { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
 232         } case
 233     ] [ ] map-as
 234     word '[ _ execute ] ;
 235
 236 : check-boolean-ops ( class elt-class compare-quot -- seq )
 237     [
 238         [ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip
 239         '[ first2 inputs _ _ check-boolean-op ]
 240     ] dip check-optimizer ; inline
 241
 242 simd-classes&reps [
 243     [ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
 244 ] each
 245
 246 "== Checking vector blend" print
 247
 248 [ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
 249 [
 250     char-16{ t  t  f  f  t  t  t  f  t  f   f   f   t   f   t   t }
 251     char-16{ 0  1  2  3  4  5  6  7  8  9  10  11  12  13  14  15 }
 252     char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v?
 253 ] unit-test
 254
 255 [ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
 256 [
 257     char-16{ t  t  f  f  t  t  t  f  t  f   f   f   t   f   t   t }
 258     char-16{ 0  1  2  3  4  5  6  7  8  9  10  11  12  13  14  15 }
 259     char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 }
 260     [ { char-16 char-16 char-16 } declare v? ] compile-call
 261 ] unit-test
 262
 263 [ int-4{ 1 22 33 4 } ]
 264 [ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test
 265
 266 [ int-4{ 1 22 33 4 } ]
 267 [
 268     int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 }
 269     [ { int-4 int-4 int-4 } declare v? ] compile-call
 270 ] unit-test
 271
 272 [ float-4{ 1.0 22.0 33.0 4.0 } ]
 273 [ float-4{ t f f t } float-4{ 1.0 2.0 3.0 4.0 } float-4{ 11.0 22.0 33.0 44.0 } v? ] unit-test
 274
 275 [ float-4{ 1.0 22.0 33.0 4.0 } ]
 276 [
 277     float-4{ t f f t } float-4{ 1.0 2.0 3.0 4.0 } float-4{ 11.0 22.0 33.0 44.0 }
 278     [ { float-4 float-4 float-4 } declare v? ] compile-call
 279 ] unit-test
 280
 281 "== Checking shifts and permutations" print
 282
 283 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
 284 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hlshift ] unit-test
 285
 286 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
 287 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 hlshift ] compile-call ] unit-test
 288
 289 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
 290 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 [ { char-16 fixnum } declare hlshift ] compile-call ] unit-test
 291
 292 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
 293 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hrshift ] unit-test
 294
 295 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
 296 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 hrshift ] compile-call ] unit-test
 297
 298 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
 299 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 [ { char-16 fixnum } declare hrshift ] compile-call ] unit-test
 300
 301 ! Invalid inputs should not cause the compiler to throw errors
 302 [ ] [
 303     [ [ { int-4 } declare t hrshift ] (( a -- b )) define-temp drop ] with-compilation-unit
 304 ] unit-test
 305
 306 [ ] [
 307     [ [ { int-4 } declare { 3 2 1 } vshuffle ] (( a -- b )) define-temp drop ] with-compilation-unit
 308 ] unit-test
 309
 310 ! Shuffles
 311 : shuffles-for ( n -- shuffles )
 312     {
 313         { 2 [
 314             {
 315                 { 0 1 }
 316                 { 1 1 }
 317                 { 1 0 }
 318                 { 0 0 }
 319             }
 320         ] }
 321         { 4 [
 322             {
 323                 { 1 2 3 0 }
 324                 { 0 1 2 3 }
 325                 { 1 1 2 2 }
 326                 { 0 0 1 1 }
 327                 { 2 2 3 3 }
 328                 { 0 1 0 1 }
 329                 { 2 3 2 3 }
 330                 { 0 0 2 2 }
 331                 { 1 1 3 3 }
 332                 { 0 1 0 1 }
 333                 { 2 2 3 3 }
 334             }
 335         ] }
 336         { 8 [
 337             4 shuffles-for
 338             4 shuffles-for
 339             [ [ 4 + ] map ] map
 340             [ append ] 2map
 341         ] }
 342         [ dup '[ _ random ] replicate 1array ]
 343     } case ;
 344
 345 simd-classes [
 346     [ [ { } ] ] dip
 347     [ new length shuffles-for ] keep
 348     '[
 349         _ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ]
 350         [ = ] check-optimizer
 351     ] unit-test
 352 ] each
 353
 354 "== Checking variable shuffles" print
 355
 356 : random-shift-vector ( class -- vec )
 357     new [ drop 16 random ] map ;
 358
 359 :: test-shift-vector ( class -- ? )
 360     [
 361         class random-int-vector :> src
 362         char-16 random-shift-vector :> perm
 363         { class char-16 } :> decl
 364
 365         src perm vshuffle
 366         src perm [ decl declare vshuffle ] compile-call
 367         =
 368     ] call( -- ? ) ;
 369
 370 { char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 }
 371 [ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each
 372
 373 "== Checking vector tests" print
 374
 375 :: test-vector-tests-bool ( vector declaration -- none? any? all? )
 376     [
 377         vector
 378         [ [ declaration declare vnone? ] compile-call ]
 379         [ [ declaration declare vany?  ] compile-call ]
 380         [ [ declaration declare vall?  ] compile-call ] tri
 381     ] call( -- none? any? all? ) ;
 382
 383 : yes ( -- x ) t ;
 384 : no ( -- x ) f ;
 385
 386 :: test-vector-tests-branch ( vector declaration -- none? any? all? )
 387     [
 388         vector
 389         [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
 390         [ [ declaration declare vany?  [ yes ] [ no ] if ] compile-call ]
 391         [ [ declaration declare vall?  [ yes ] [ no ] if ] compile-call ] tri
 392     ] call( -- none? any? all? ) ;
 393
 394 TUPLE: inconsistent-vector-test bool branch ;
 395
 396 : ?inconsistent ( bool branch -- ?/inconsistent )
 397     2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
 398
 399 :: test-vector-tests ( vector decl -- none? any? all? )
 400     [
 401         vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
 402         vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
 403
 404         bool-none branch-none ?inconsistent
 405         bool-any  branch-any  ?inconsistent
 406         bool-all  branch-all  ?inconsistent
 407     ] call( -- none? any? all? ) ;
 408
 409 [ f t t ]
 410 [ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
 411 [ f t f ]
 412 [ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test
 413 [ t f f ]
 414 [ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test
 415
 416 [ f t t ]
 417 [ double-2{ t t } { double-2 } test-vector-tests ] unit-test
 418 [ f t f ]
 419 [ double-2{ f t } { double-2 } test-vector-tests ] unit-test
 420 [ t f f ]
 421 [ double-2{ f f } { double-2 } test-vector-tests ] unit-test
 422
 423 [ f t t ]
 424 [ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test
 425 [ f t f ]
 426 [ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test
 427 [ t f f ]
 428 [ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
 429
 430 [ f t t ]
 431 [ float-8{ t t t t t t t t } { float-8 } test-vector-tests ] unit-test
 432 [ f t f ]
 433 [ float-8{ f t t t t f t t } { float-8 } test-vector-tests ] unit-test
 434 [ t f f ]
 435 [ float-8{ f f f f f f f f } { float-8 } test-vector-tests ] unit-test
 436
 437 [ f t t ]
 438 [ double-4{ t t t t } { double-4 } test-vector-tests ] unit-test
 439 [ f t f ]
 440 [ double-4{ f t t f } { double-4 } test-vector-tests ] unit-test
 441 [ t f f ]
 442 [ double-4{ f f f f } { double-4 } test-vector-tests ] unit-test
 443
 444 [ f t t ]
 445 [ int-8{ t t t t t t t t } { int-8 } test-vector-tests ] unit-test
 446 [ f t f ]
 447 [ int-8{ f t t t t f f f } { int-8 } test-vector-tests ] unit-test
 448 [ t f f ]
 449 [ int-8{ f f f f f f f f } { int-8 } test-vector-tests ] unit-test
 450
 451 "== Checking element access" print
 452
 453 ! Test element access -- it should box bignums for int-4 on x86
 454 : test-accesses ( seq -- failures )
 455     [ length >array ] keep
 456     '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
 457
 458 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
 459 [ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test
 460 [ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
 461
 462 [ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
 463 [ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test
 464 [ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
 465
 466 [ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
 467 [ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
 468 [ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
 469
 470 [ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-accesses ] unit-test
 471 [ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
 472 [ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
 473
 474 [ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
 475 [ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test
 476 [ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test
 477
 478 "== Checking broadcast" print
 479 : test-broadcast ( seq -- failures )
 480     [ length >array ] keep
 481     '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
 482
 483 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
 484 [ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
 485 [ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test
 486
 487 [ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
 488 [ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
 489 [ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
 490
 491 [ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-broadcast ] unit-test
 492 [ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
 493 [ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
 494
 495 [ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
 496 [ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test
 497 [ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test
 498
 499 ! Make sure we use the fallback in the correct situations
 500 [ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test
 501
 502 "== Checking alien operations" print
 503
 504 [ float-4{ 1 2 3 4 } ] [
 505     [
 506         float-4{ 1 2 3 4 }
 507         underlying>> 0 float-4-rep alien-vector
 508     ] compile-call float-4 boa
 509 ] unit-test
 510
 511 [ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
 512     16 [ 1 ] B{ } replicate-as 16 <byte-array>
 513     [
 514         0 [
 515             { byte-array c-ptr fixnum } declare
 516             float-4-rep set-alien-vector
 517         ] compile-call
 518     ] keep
 519 ] unit-test
 520
 521 [ float-array{ 1 2 3 4 } ] [
 522     [
 523         float-array{ 1 2 3 4 } underlying>>
 524         float-array{ 4 3 2 1 } clone
 525         [ underlying>> 0 float-4-rep set-alien-vector ] keep
 526     ] compile-call
 527 ] unit-test
 528
 529 STRUCT: simd-struct
 530 { x float-4 }
 531 { y longlong-2 }
 532 { z double-4 }
 533 { w int-8 } ;
 534
 535 [ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
 536
 537 [
 538     float-4{ 1 2 3 4 }
 539     longlong-2{ 2 1 }
 540     double-4{ 4 3 2 1 }
 541     int-8{ 1 2 3 4 5 6 7 8 }
 542 ] [
 543     simd-struct <struct>
 544     float-4{ 1 2 3 4 } >>x
 545     longlong-2{ 2 1 } >>y
 546     double-4{ 4 3 2 1 } >>z
 547     int-8{ 1 2 3 4 5 6 7 8 } >>w
 548     { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
 549 ] unit-test
 550
 551 [
 552     float-4{ 1 2 3 4 }
 553     longlong-2{ 2 1 }
 554     double-4{ 4 3 2 1 }
 555     int-8{ 1 2 3 4 5 6 7 8 }
 556 ] [
 557     [
 558         simd-struct <struct>
 559         float-4{ 1 2 3 4 } >>x
 560         longlong-2{ 2 1 } >>y
 561         double-4{ 4 3 2 1 } >>z
 562         int-8{ 1 2 3 4 5 6 7 8 } >>w
 563         { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
 564     ] compile-call
 565 ] unit-test
 566
 567 "== Misc tests" print
 568
 569 [ ] [ char-16 new 1array stack. ] unit-test
 570
 571 ! CSSA bug
 572 [ 8000000 ] [
 573     int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
 574     [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
 575 ] unit-test
 576
 577 ! Coalescing was too aggressive
 578 :: broken ( axis theta -- a b c )
 579    axis { float-4 } declare drop
 580    theta { float } declare drop
 581
 582    theta cos float-4-with :> cc
 583    theta sin float-4-with :> ss
 584
 585    axis cc v+ :> diagonal
 586
 587    diagonal cc ss ; inline
 588
 589 [ t ] [
 590     float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
 591     [ compile-call ] [ call ] 3bi =
 592 ] unit-test
 593
 594 ! Spilling SIMD values -- this basically just tests that the
 595 ! stack was aligned properly by the runtime
 596
 597 : simd-spill-test-1 ( a b c -- v )
 598     { float-4 float-4 float } declare
 599     [ v+ ] dip sin v*n ;
 600
 601 [ float-4{ 0 0 0 0 } ]
 602 [ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
 603
 604 : simd-spill-test-2 ( a b d c -- v )
 605     { float float-4 float-4 float } declare
 606     [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
 607
 608 [ float-4{ 0 0 0 0 } ]
 609 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test