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         { vcount { +vector+ -> +scalar+ } }
  96         { vabs { +vector+ -> +vector+ } }
  97         { vsqrt { +vector+ -> +vector+ } }
  98         { vbitand { +vector+ +vector+ -> +vector+ } }
  99         { vbitandn { +vector+ +vector+ -> +vector+ } }
 100         { vbitor { +vector+ +vector+ -> +vector+ } }
 101         { vbitxor { +vector+ +vector+ -> +vector+ } }
 102         { vbitnot { +vector+ -> +vector+ } }
 103         { vand { +vector+ +vector+ -> +vector+ } }
 104         { vandn { +vector+ +vector+ -> +vector+ } }
 105         { vor { +vector+ +vector+ -> +vector+ } }
 106         { vxor { +vector+ +vector+ -> +vector+ } }
 107         { vnot { +vector+ -> +vector+ } }
 108         { vlshift { +vector+ +scalar+ -> +vector+ } }
 109         { vrshift { +vector+ +scalar+ -> +vector+ } }
 110         { (vmerge-head) { +vector+ +vector+ -> +vector+ } }
 111         { (vmerge-tail) { +vector+ +vector+ -> +vector+ } }
 112         { v<= { +vector+ +vector+ -> +vector+ } }
 113         { v< { +vector+ +vector+ -> +vector+ } }
 114         { v= { +vector+ +vector+ -> +vector+ } }
 115         { v> { +vector+ +vector+ -> +vector+ } }
 116         { v>= { +vector+ +vector+ -> +vector+ } }
 117         { vunordered? { +vector+ +vector+ -> +vector+ } }
 118     }
 119
 120 : vector-word-inputs ( schema -- seq ) { -> } split first ;
 121
 122 : with-ctors ( -- seq )
 123     simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup-word ] map ;
 124
 125 : boa-ctors ( -- seq )
 126     simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup-word ] map ;
 127
 128 TUPLE: simd-test-failure
 129     input
 130     input-quot
 131     unoptimized-result
 132     optimized-result
 133     nonintrinsic-result ;
 134
 135 :: check-optimizer (
 136     seq
 137     test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
 138     eq-quot: ( resulta resultb -- ? )
 139     --
 140     failures
 141 )
 142     ! Use test-quot to generate a bunch of test cases from the
 143     ! given inputs. Run each test case optimized and
 144     ! unoptimized. Compare results with eq-quot.
 145     !
 146     ! seq: sequence of inputs
 147     ! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
 148     ! eq-quot: ( result1 result2 -- ? )
 149     seq [| input |
 150         input test-quot call :> ( input-quot code-quot )
 151         input-quot [ class-of ] { } map-as :> input-classes
 152         input-classes code-quot '[ _ declare @ ] :> code-quot'
 153
 154         "print-mr" get [ code-quot' regs. ] when
 155         "print-checks" get [ input-quot . code-quot' . ] when
 156
 157         input-quot code-quot' [ [ call ] dip call ]
 158         call( i c -- result ) :> unoptimized-result
 159         input-quot code-quot' [ [ call ] dip compile-call ]
 160         call( i c -- result ) :> optimized-result
 161         input-quot code-quot' [
 162             t "always-inline-simd-intrinsics" [
 163                 "print-inline-mr" get [ code-quot' regs. ] when
 164                 [ call ] dip compile-call
 165             ] with-variable
 166         ] call( i c -- result ) :> nonintrinsic-result
 167
 168         unoptimized-result optimized-result eq-quot call
 169         optimized-result nonintrinsic-result eq-quot call
 170         and
 171         [ f ] [
 172             input input-quot unoptimized-result optimized-result nonintrinsic-result
 173             simd-test-failure boa
 174         ] if
 175     ] map sift
 176     dup empty? [ dup ... ] unless ! Print full errors
 177     ; inline
 178
 179 "== Checking -new constructors" print
 180
 181 { { } } [
 182     simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
 183 ] unit-test
 184
 185 { { } } [
 186     simd-classes [ '[ _ new ] compile-call [ zero? ] all? ] reject
 187 ] unit-test
 188
 189 "== Checking -with constructors" print
 190
 191 { { } } [
 192     with-ctors [
 193         [ 1000 random '[ _ ] ] dip '[ _ execute ]
 194     ] [ = ] check-optimizer
 195 ] unit-test
 196
 197 { 0xffffffff } [ 0xffffffff uint-4-with first ] unit-test
 198
 199 { 0xffffffff } [ 0xffffffff [ uint-4-with ] compile-call first ] unit-test
 200
 201 { 0xffffffff } [ [ 0xffffffff uint-4-with ] compile-call first ] unit-test
 202
 203 "== Checking -boa constructors" print
 204
 205 { { } } [
 206     boa-ctors [
 207         [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
 208         '[ _ execute ]
 209     ] [ = ] check-optimizer
 210 ] unit-test
 211
 212 { 0xffffffff } [ 0xffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
 213
 214 "== Checking vector operations" print
 215
 216 : random-int-vector ( class -- vec )
 217     new [ drop 1000 random ] map ;
 218
 219 : random-float-vector ( class -- vec )
 220     new [
 221         drop
 222         1000 random
 223         10 swap <array> 0/0. suffix random
 224     ] map ;
 225
 226 : random-vector ( class elt-class -- vec )
 227     float =
 228     [ random-float-vector ]
 229     [ random-int-vector ] if ;
 230
 231 :: check-vector-op ( word inputs class elt-class -- inputs quot )
 232     inputs [
 233         {
 234             { +vector+ [ class elt-class random-vector ] }
 235             { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
 236         } case
 237     ] [ ] map-as
 238     word '[ _ execute ] ;
 239
 240 : remove-float-words ( alist -- alist' )
 241     { distance vsqrt n/v v/n v/ normalize }
 242     '[ drop _ member? ] assoc-reject ;
 243
 244 : remove-integer-words ( alist -- alist' )
 245     { vlshift vrshift v*high v*hs+ }
 246     '[ drop _ member? ] assoc-reject ;
 247
 248 : boolean-ops ( -- words )
 249     { vand vandn vor vxor vnot vcount } ;
 250
 251 : remove-boolean-words ( alist -- alist' )
 252     boolean-ops '[ drop _ member? ] assoc-reject ;
 253
 254 : ops-to-check ( elt-class -- alist )
 255     [ vector-words >alist ] dip
 256     float = [ remove-integer-words ] [ remove-float-words ] if
 257     remove-boolean-words ;
 258
 259 : check-vector-ops ( class elt-class compare-quot -- failures )
 260     [
 261         [ nip ops-to-check ] 2keep
 262         '[ first2 vector-word-inputs _ _ check-vector-op ]
 263     ] dip check-optimizer ; inline
 264
 265 : (approx=) ( x y -- ? )
 266     {
 267         { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
 268         { [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
 269         { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
 270         { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
 271         [ = ]
 272     } cond ;
 273
 274 : approx= ( x y -- ? )
 275     2dup [ sequence? ] both?
 276     [ [ (approx=) ] 2all? ] [ (approx=) ] if ;
 277
 278 : exact= ( x y -- ? )
 279     {
 280         { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
 281         { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
 282         [ = ]
 283     } cond ;
 284
 285 : simd-classes&reps ( -- alist )
 286     simd-classes [
 287         {
 288             { [ dup name>> "float" head? ] [ float [ approx= ] ] }
 289             { [ dup name>> "double" head? ] [ float [ exact= ] ] }
 290             [ fixnum [ = ] ]
 291         } cond 3array
 292     ] map ;
 293
 294 simd-classes&reps [
 295     [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
 296 ] each
 297
 298 "== Checking boolean operations" print
 299
 300 : random-boolean-vector ( class -- vec )
 301     new [ drop 2 random zero? ] map ;
 302
 303 :: check-boolean-op ( word inputs class elt-class -- inputs quot )
 304     inputs [
 305         {
 306             { +vector+ [ class random-boolean-vector ] }
 307             { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
 308         } case
 309     ] [ ] map-as
 310     word '[ _ execute ] ;
 311
 312 : check-boolean-ops ( class elt-class compare-quot -- seq )
 313     [
 314         [ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
 315         '[ first2 vector-word-inputs _ _ check-boolean-op ]
 316     ] dip check-optimizer ; inline
 317
 318 simd-classes&reps [
 319     [ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
 320 ] each
 321
 322 "== Checking vector blend" print
 323
 324 { char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } }
 325 [
 326     char-16{ t  t  f  f  t  t  t  f  t  f   f   f   t   f   t   t }
 327     char-16{ 0  1  2  3  4  5  6  7  8  9  10  11  12  13  14  15 }
 328     char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v?
 329 ] unit-test
 330
 331 { char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } }
 332 [
 333     char-16{ t  t  f  f  t  t  t  f  t  f   f   f   t   f   t   t }
 334     char-16{ 0  1  2  3  4  5  6  7  8  9  10  11  12  13  14  15 }
 335     char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 }
 336     [ { char-16 char-16 char-16 } declare v? ] compile-call
 337 ] unit-test
 338
 339 { int-4{ 1 22 33 4 } }
 340 [ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test
 341
 342 { int-4{ 1 22 33 4 } }
 343 [
 344     int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 }
 345     [ { int-4 int-4 int-4 } declare v? ] compile-call
 346 ] unit-test
 347
 348 { float-4{ 1.0 22.0 33.0 4.0 } }
 349 [ 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
 350
 351 { float-4{ 1.0 22.0 33.0 4.0 } }
 352 [
 353     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 }
 354     [ { float-4 float-4 float-4 } declare v? ] compile-call
 355 ] unit-test
 356
 357 "== Checking shifts and permutations" print
 358
 359 { char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } }
 360 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hlshift ] unit-test
 361
 362 { char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } }
 363 [ 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
 364
 365 { char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } }
 366 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 >bignum hlshift ] compile-call ] unit-test
 367
 368 { char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } }
 369 [ 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
 370
 371 { char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } }
 372 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hrshift ] unit-test
 373
 374 { char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } }
 375 [ 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
 376
 377 { char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } }
 378 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 >bignum hrshift ] compile-call ] unit-test
 379
 380 { char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } }
 381 [ 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
 382
 383 { int-4{ 4 8 12 16 } }
 384 [ int-4{ 1 2 3 4 } 2 vlshift ] unit-test
 385
 386 { int-4{ 4 8 12 16 } }
 387 [ int-4{ 1 2 3 4 } 2 [ { int-4 fixnum } declare vlshift ] compile-call ] unit-test
 388
 389 { int-4{ 4 8 12 16 } }
 390 [ int-4{ 1 2 3 4 } 2 >bignum [ { int-4 bignum } declare vlshift ] compile-call ] unit-test
 391
 392 ! Invalid inputs should not cause the compiler to throw errors
 393 { } [
 394     [ [ { int-4 } declare t hrshift ] ( a -- b ) define-temp drop ] with-compilation-unit
 395 ] unit-test
 396
 397 { } [
 398     [ [ { int-4 } declare { 3 2 1 } vshuffle ] ( a -- b ) define-temp drop ] with-compilation-unit
 399 ] unit-test
 400
 401 ! Shuffles
 402 : shuffles-for ( n -- shuffles )
 403     {
 404         { 2 [
 405             {
 406                 { 0 1 }
 407                 { 1 1 }
 408                 { 1 0 }
 409                 { 0 0 }
 410             }
 411         ] }
 412         { 4 [
 413             {
 414                 { 1 2 3 0 }
 415                 { 0 1 2 3 }
 416                 { 1 1 2 2 }
 417                 { 0 0 1 1 }
 418                 { 2 2 3 3 }
 419                 { 0 1 0 1 }
 420                 { 2 3 2 3 }
 421                 { 0 0 2 2 }
 422                 { 1 1 3 3 }
 423                 { 0 1 0 1 }
 424                 { 2 2 3 3 }
 425             }
 426         ] }
 427         { 8 [
 428             4 shuffles-for
 429             4 shuffles-for
 430             [ [ 4 + ] map ] map
 431             [ append ] 2map
 432         ] }
 433         [ dup '[ _ random ] replicate 1array ]
 434     } case ;
 435
 436 : 2shuffles-for ( n -- shuffles )
 437     {
 438         { 2 [
 439             {
 440                 { 0 1 }
 441                 { 0 3 }
 442                 { 2 3 }
 443                 { 2 0 }
 444             }
 445         ] }
 446         { 4 [
 447             {
 448                 { 0 1 2 3 }
 449                 { 4 1 2 3 }
 450                 { 0 5 2 3 }
 451                 { 0 1 6 3 }
 452                 { 0 1 2 7 }
 453                 { 4 5 2 3 }
 454                 { 0 1 6 7 }
 455                 { 4 5 6 7 }
 456                 { 0 5 2 7 }
 457             }
 458         ] }
 459         { 8 [
 460             4 2shuffles-for
 461             4 2shuffles-for
 462             [ [ 8 + ] map ] map
 463             [ append ] 2map
 464         ] }
 465         [ dup 2 * '[ _ random ] replicate 1array ]
 466     } case ;
 467
 468 simd-classes [
 469     [ [ { } ] ] dip
 470     [ new length shuffles-for ] keep
 471     '[
 472         _ [ [ _ new [ length <iota> ] keep like 1quotation ] dip '[ _ vshuffle ] ]
 473         [ = ] check-optimizer
 474     ] unit-test
 475 ] each
 476
 477 simd-classes [
 478     [ [ { } ] ] dip
 479     [ new length 2shuffles-for ] keep
 480     '[
 481         _ [ [
 482             _ new
 483             [ [ length <iota> ] keep like ]
 484             [ [ length dup dup + [a,b) ] keep like ] bi [ ] 2sequence
 485         ] dip '[ _ vshuffle2-elements ] ]
 486         [ = ] check-optimizer
 487     ] unit-test
 488 ] each
 489
 490 "== Checking variable shuffles" print
 491
 492 : random-shift-vector ( class -- vec )
 493     new [ drop 16 random ] map ;
 494
 495 :: test-shift-vector ( class -- ? )
 496     [
 497         class random-int-vector :> src
 498         char-16 random-shift-vector :> perm
 499         { class char-16 } :> decl
 500
 501         src perm vshuffle
 502         src perm [ decl declare vshuffle ] compile-call
 503         =
 504     ] call( -- ? ) ;
 505
 506 { char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 }
 507 [ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each
 508
 509 "== Checking vector tests" print
 510
 511 :: test-vector-tests-bool ( vector declaration -- none? any? all? )
 512     [
 513         vector
 514         [ [ declaration declare vnone? ] compile-call ]
 515         [ [ declaration declare vany?  ] compile-call ]
 516         [ [ declaration declare vall?  ] compile-call ] tri
 517     ] call( -- none? any? all? ) ;
 518
 519 : yes ( -- x ) t ;
 520 : no ( -- x ) f ;
 521
 522 :: test-vector-tests-branch ( vector declaration -- none? any? all? )
 523     [
 524         vector
 525         [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
 526         [ [ declaration declare vany?  [ yes ] [ no ] if ] compile-call ]
 527         [ [ declaration declare vall?  [ yes ] [ no ] if ] compile-call ] tri
 528     ] call( -- none? any? all? ) ;
 529
 530 TUPLE: inconsistent-vector-test bool branch ;
 531
 532 : ?inconsistent ( bool branch -- ?/inconsistent )
 533     2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
 534
 535 :: test-vector-tests ( vector decl -- none? any? all? )
 536     [
 537         vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
 538         vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
 539
 540         bool-none branch-none ?inconsistent
 541         bool-any  branch-any  ?inconsistent
 542         bool-all  branch-all  ?inconsistent
 543     ] call( -- none? any? all? ) ;
 544
 545 { f t t }
 546 [ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
 547 { f t f }
 548 [ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test
 549 { t f f }
 550 [ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test
 551
 552 { f t t }
 553 [ double-2{ t t } { double-2 } test-vector-tests ] unit-test
 554 { f t f }
 555 [ double-2{ f t } { double-2 } test-vector-tests ] unit-test
 556 { t f f }
 557 [ double-2{ f f } { double-2 } test-vector-tests ] unit-test
 558
 559 { f t t }
 560 [ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test
 561 { f t f }
 562 [ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test
 563 { t f f }
 564 [ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
 565
 566 "== Checking element access" print
 567
 568 ! Test element access -- it should box bignums for int-4 on x86
 569 : test-accesses ( seq -- failures )
 570     [ length <iota> dup [ >bignum ] map append ] keep
 571     '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
 572
 573 { { } } [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
 574 { { } } [ int-4{ 0x7fffffff 3 4 -8 } test-accesses ] unit-test
 575 { { } } [ uint-4{ 0xffffffff 2 3 4 } test-accesses ] unit-test
 576
 577 { 0x7fffffff } [ int-4{ 0x7fffffff 3 4 -8 } first ] unit-test
 578 { -8 } [ int-4{ 0x7fffffff 3 4 -8 } last ] unit-test
 579 { 0xffffffff } [ uint-4{ 0xffffffff 2 3 4 } first ] unit-test
 580
 581 { { } } [ double-2{ 1.0 2.0 } test-accesses ] unit-test
 582 { { } } [ longlong-2{ 1 2 } test-accesses ] unit-test
 583 { { } } [ ulonglong-2{ 1 2 } test-accesses ] unit-test
 584
 585 "== Checking broadcast" print
 586 : test-broadcast ( seq -- failures )
 587     [ length <iota> >array ] keep
 588     '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
 589
 590 { { } } [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
 591 { { } } [ int-4{ 0x7fffffff 3 4 -8 } test-broadcast ] unit-test
 592 { { } } [ uint-4{ 0xffffffff 2 3 4 } test-broadcast ] unit-test
 593
 594 { { } } [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
 595 { { } } [ longlong-2{ 1 2 } test-broadcast ] unit-test
 596 { { } } [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
 597
 598 ! Make sure we use the fallback in the correct situations
 599 { int-4{ 3 3 3 3 } } [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test
 600
 601 "== Checking alien operations" print
 602
 603 { float-4{ 1 2 3 4 } } [
 604     [
 605         float-4{ 1 2 3 4 }
 606         underlying>> 0 float-4-rep alien-vector
 607     ] compile-call float-4 boa
 608 ] unit-test
 609
 610 { B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } } [
 611     16 [ 1 ] B{ } replicate-as 16 <byte-array>
 612     [
 613         0 [
 614             { byte-array c-ptr fixnum } declare
 615             float-4-rep set-alien-vector
 616         ] compile-call
 617     ] keep
 618 ] unit-test
 619
 620 { float-array{ 1 2 3 4 } } [
 621     [
 622         float-array{ 1 2 3 4 } underlying>>
 623         float-array{ 4 3 2 1 } clone
 624         [ underlying>> 0 float-4-rep set-alien-vector ] keep
 625     ] compile-call
 626 ] unit-test
 627
 628 STRUCT: simd-struct
 629 { x float-4 }
 630 { y longlong-2 }
 631 { z double-2 }
 632 { w int-4 } ;
 633
 634 { t } [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
 635
 636 {
 637     float-4{ 1 2 3 4 }
 638     longlong-2{ 2 1 }
 639     double-2{ 4 3 }
 640     int-4{ 1 2 3 4 }
 641 } [
 642     simd-struct <struct>
 643     float-4{ 1 2 3 4 } >>x
 644     longlong-2{ 2 1 } >>y
 645     double-2{ 4 3 } >>z
 646     int-4{ 1 2 3 4 } >>w
 647     { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
 648 ] unit-test
 649
 650 {
 651     float-4{ 1 2 3 4 }
 652     longlong-2{ 2 1 }
 653     double-2{ 4 3 }
 654     int-4{ 1 2 3 4 }
 655 } [
 656     [
 657         simd-struct <struct>
 658         float-4{ 1 2 3 4 } >>x
 659         longlong-2{ 2 1 } >>y
 660         double-2{ 4 3 } >>z
 661         int-4{ 1 2 3 4 } >>w
 662         { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
 663     ] compile-call
 664 ] unit-test
 665
 666 "== Misc tests" print
 667
 668 { } [ char-16 new 1array stack. ] unit-test
 669
 670 ! Test some sequence protocol stuff
 671 { t } [ 4 double-4{ 1 2 3 4 } new-sequence double-4? ] unit-test
 672 { double-4{ 2 3 4 5 } } [ double-4{ 1 2 3 4 } [ 1 + ] map ] unit-test
 673
 674 ! Test cross product
 675 { 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
 676 { 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 } [ { float-4 float-4 } declare cross ] compile-call ] unit-test
 677 { 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
 678 { 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 } [ { float-4 float-4 } declare cross ] compile-call ] unit-test
 679
 680 { 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
 681 { 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 } [ { double-4 double-4 } declare cross ] compile-call ] unit-test
 682 { 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
 683 { 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 } [ { double-4 double-4 } declare cross ] compile-call ] unit-test
 684
 685 ! CSSA bug
 686 { 4000000 } [
 687     int-4{ 1000 1000 1000 1000 }
 688     [ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
 689 ] unit-test
 690
 691 ! Coalescing was too aggressive
 692 :: broken ( axis theta -- a b c )
 693    axis { float-4 } declare drop
 694    theta { float } declare drop
 695
 696    theta cos float-4-with :> cc
 697    theta sin float-4-with :> ss
 698
 699    axis cc v+ :> diagonal
 700
 701    diagonal cc ss ; inline
 702
 703 { t } [
 704     float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
 705     [ compile-call ] [ call ] 3bi =
 706 ] unit-test
 707
 708 ! Spilling SIMD values -- this basically just tests that the
 709 ! stack was aligned properly by the runtime
 710
 711 : simd-spill-test-1 ( a b c -- v )
 712     { float-4 float-4 float } declare
 713     [ v+ ] dip sin v*n ;
 714
 715 { float-4{ 0 0 0 0 } }
 716 [ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
 717
 718 : simd-spill-test-2 ( a b d c -- v )
 719     { float float-4 float-4 float } declare
 720     [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
 721
 722 { float-4{ 0 0 0 0 } }
 723 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
 724
 725 : callback-1 ( -- c )
 726     c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
 727
 728 : indirect-1 ( x x x x x c -- y )
 729     c:int { c:int c:int c:int c:int c:int } cdecl alien-indirect ; inline
 730
 731 : simd-spill-test-3 ( a b d c -- v )
 732     { float float-4 float-4 float } declare
 733     [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v
 734     10 5 100 50 500 callback-1 indirect-1 665 assert= ;
 735
 736 { float-4{ 0 0 0 0 } }
 737 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-3 ] unit-test
 738
 739 ! Stack allocation of SIMD values -- make sure that everything is
 740 ! aligned right
 741
 742 : simd-stack-test ( -- b c )
 743     { c:int float-4 } [
 744         [ 123 swap 0 c:int c:set-alien-value ]
 745         [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
 746     ] with-out-parameters ;
 747
 748 { 123 float-4{ 1 2 3 4 } } [ simd-stack-test ] unit-test
 749
 750 ! Stack allocation + spilling
 751
 752 : (simd-stack-spill-test) ( -- n ) 17 ;
 753
 754 : simd-stack-spill-test ( x -- b c )
 755     { c:int } [
 756         123 swap 0 c:int c:set-alien-value
 757         >float (simd-stack-spill-test) float-4-with swap cos v*n
 758     ] with-out-parameters ;
 759
 760 { } [
 761     1.047197551196598 simd-stack-spill-test
 762     [ float-4{ 8.5 8.5 8.5 8.5 } approx= t assert= ]
 763     [ 123 assert= ]
 764     bi*
 765 ] unit-test
 766
 767 ! #1308
 768 : test-1308 ( a b -- c )
 769     { double-4 double-4 } declare
 770     v+ dup first 10 > [ first ] [ third ] if 1array ;
 771
 772 ! Before the fix, this evaluated to an uninitialized value.
 773 { 33.0 } [
 774     double-4{ 2 20 30 40 } double-4{ 2 4 3 2 } test-1308 first
 775 ] unit-test