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