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