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

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