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
15 ! Test type propagation
16 [ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
18 [ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
20 [ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
22 [ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
24 [ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test
26 [ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test
28 [ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test
30 [ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test
32 [ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
34 ! Test puns; only on x86
36 [ double-2{ 4 1024 } ] [
38 [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
43 CONSTANT: simd-classes
57 SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
59 CONSTANT: vector-words
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+ } }
120 : vector-word-inputs ( schema -- seq ) { -> } split first ;
122 : with-ctors ( -- seq )
123 simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup-word ] map ;
125 : boa-ctors ( -- seq )
126 simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup-word ] map ;
128 TUPLE: simd-test-failure
133 nonintrinsic-result ;
137 test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
138 eq-quot: ( resulta resultb -- ? )
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.
146 #! seq: sequence of inputs
147 #! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
148 #! eq-quot: ( result1 result2 -- ? )
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'
154 "print-mr" get [ code-quot' regs. ] when
155 "print-checks" get [ input-quot . code-quot' . ] when
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 [ [ call ] dip compile-call ]
165 ] call( i c -- result ) :> nonintrinsic-result
167 unoptimized-result optimized-result eq-quot call
168 optimized-result nonintrinsic-result eq-quot call
171 input input-quot unoptimized-result optimized-result nonintrinsic-result
172 simd-test-failure boa
176 "== Checking -new constructors" print
179 simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
183 simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
186 "== Checking -with constructors" print
190 [ 1000 random '[ _ ] ] dip '[ _ execute ]
191 ] [ = ] check-optimizer
194 [ 0xffffffff ] [ 0xffffffff uint-4-with first ] unit-test
196 [ 0xffffffff ] [ 0xffffffff [ uint-4-with ] compile-call first ] unit-test
198 [ 0xffffffff ] [ [ 0xffffffff uint-4-with ] compile-call first ] unit-test
200 "== Checking -boa constructors" print
204 [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
206 ] [ = ] check-optimizer
209 [ 0xffffffff ] [ 0xffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
211 "== Checking vector operations" print
213 : random-int-vector ( class -- vec )
214 new [ drop 1000 random ] map ;
216 : random-float-vector ( class -- vec )
220 10 swap <array> 0/0. suffix random
223 : random-vector ( class elt-class -- vec )
225 [ random-float-vector ]
226 [ random-int-vector ] if ;
228 :: check-vector-op ( word inputs class elt-class -- inputs quot )
231 { +vector+ [ class elt-class random-vector ] }
232 { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
235 word '[ _ execute ] ;
237 : remove-float-words ( alist -- alist' )
238 { distance vsqrt n/v v/n v/ normalize } unique assoc-diff ;
240 : remove-integer-words ( alist -- alist' )
241 { vlshift vrshift v*high v*hs+ } unique assoc-diff ;
243 : boolean-ops ( -- words )
244 { vand vandn vor vxor vnot vcount } ;
246 : remove-boolean-words ( alist -- alist' )
247 boolean-ops unique assoc-diff ;
249 : ops-to-check ( elt-class -- alist )
250 [ vector-words >alist ] dip
251 float = [ remove-integer-words ] [ remove-float-words ] if
252 remove-boolean-words ;
254 : check-vector-ops ( class elt-class compare-quot -- failures )
256 [ nip ops-to-check ] 2keep
257 '[ first2 vector-word-inputs _ _ check-vector-op ]
258 ] dip check-optimizer ; inline
260 : (approx=) ( x y -- ? )
262 { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
263 { [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
264 { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
265 { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
269 : approx= ( x y -- ? )
270 2dup [ sequence? ] both?
271 [ [ (approx=) ] 2all? ] [ (approx=) ] if ;
273 : exact= ( x y -- ? )
275 { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
276 { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
280 : simd-classes&reps ( -- alist )
283 { [ dup name>> "float" head? ] [ float [ approx= ] ] }
284 { [ dup name>> "double" head? ] [ float [ exact= ] ] }
290 [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
293 "== Checking boolean operations" print
295 : random-boolean-vector ( class -- vec )
296 new [ drop 2 random zero? ] map ;
298 :: check-boolean-op ( word inputs class elt-class -- inputs quot )
301 { +vector+ [ class random-boolean-vector ] }
302 { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
305 word '[ _ execute ] ;
307 : check-boolean-ops ( class elt-class compare-quot -- seq )
309 [ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
310 '[ first2 vector-word-inputs _ _ check-boolean-op ]
311 ] dip check-optimizer ; inline
314 [ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
317 "== Checking vector blend" print
319 [ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
321 char-16{ t t f f t t t f t f f f t f t t }
322 char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
323 char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v?
326 [ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
328 char-16{ t t f f t t t f t f f f t f t t }
329 char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
330 char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 }
331 [ { char-16 char-16 char-16 } declare v? ] compile-call
334 [ int-4{ 1 22 33 4 } ]
335 [ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test
337 [ int-4{ 1 22 33 4 } ]
339 int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 }
340 [ { int-4 int-4 int-4 } declare v? ] compile-call
343 [ float-4{ 1.0 22.0 33.0 4.0 } ]
344 [ 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
346 [ float-4{ 1.0 22.0 33.0 4.0 } ]
348 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 }
349 [ { float-4 float-4 float-4 } declare v? ] compile-call
352 "== Checking shifts and permutations" print
354 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
355 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hlshift ] unit-test
357 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
358 [ 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
360 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
361 [ 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
363 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
364 [ 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
366 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
367 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hrshift ] unit-test
369 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
370 [ 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
372 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
373 [ 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
375 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
376 [ 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
378 [ int-4{ 4 8 12 16 } ]
379 [ int-4{ 1 2 3 4 } 2 vlshift ] unit-test
381 [ int-4{ 4 8 12 16 } ]
382 [ int-4{ 1 2 3 4 } 2 [ { int-4 fixnum } declare vlshift ] compile-call ] unit-test
384 [ int-4{ 4 8 12 16 } ]
385 [ int-4{ 1 2 3 4 } 2 >bignum [ { int-4 bignum } declare vlshift ] compile-call ] unit-test
387 ! Invalid inputs should not cause the compiler to throw errors
389 [ [ { int-4 } declare t hrshift ] ( a -- b ) define-temp drop ] with-compilation-unit
393 [ [ { int-4 } declare { 3 2 1 } vshuffle ] ( a -- b ) define-temp drop ] with-compilation-unit
397 : shuffles-for ( n -- shuffles )
428 [ dup '[ _ random ] replicate 1array ]
431 : 2shuffles-for ( n -- shuffles )
460 [ dup 2 * '[ _ random ] replicate 1array ]
465 [ new length shuffles-for ] keep
467 _ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ]
468 [ = ] check-optimizer
474 [ new length 2shuffles-for ] keep
478 [ [ length iota ] keep like ]
479 [ [ length dup dup + [a,b) ] keep like ] bi [ ] 2sequence
480 ] dip '[ _ vshuffle2-elements ] ]
481 [ = ] check-optimizer
485 "== Checking variable shuffles" print
487 : random-shift-vector ( class -- vec )
488 new [ drop 16 random ] map ;
490 :: test-shift-vector ( class -- ? )
492 class random-int-vector :> src
493 char-16 random-shift-vector :> perm
494 { class char-16 } :> decl
497 src perm [ decl declare vshuffle ] compile-call
501 { char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 }
502 [ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each
504 "== Checking vector tests" print
506 :: test-vector-tests-bool ( vector declaration -- none? any? all? )
509 [ [ declaration declare vnone? ] compile-call ]
510 [ [ declaration declare vany? ] compile-call ]
511 [ [ declaration declare vall? ] compile-call ] tri
512 ] call( -- none? any? all? ) ;
517 :: test-vector-tests-branch ( vector declaration -- none? any? all? )
520 [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
521 [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
522 [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri
523 ] call( -- none? any? all? ) ;
525 TUPLE: inconsistent-vector-test bool branch ;
527 : ?inconsistent ( bool branch -- ?/inconsistent )
528 2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
530 :: test-vector-tests ( vector decl -- none? any? all? )
532 vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
533 vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
535 bool-none branch-none ?inconsistent
536 bool-any branch-any ?inconsistent
537 bool-all branch-all ?inconsistent
538 ] call( -- none? any? all? ) ;
541 [ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
543 [ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test
545 [ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test
548 [ double-2{ t t } { double-2 } test-vector-tests ] unit-test
550 [ double-2{ f t } { double-2 } test-vector-tests ] unit-test
552 [ double-2{ f f } { double-2 } test-vector-tests ] unit-test
555 [ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test
557 [ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test
559 [ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
561 "== Checking element access" print
563 ! Test element access -- it should box bignums for int-4 on x86
564 : test-accesses ( seq -- failures )
565 [ length iota dup [ >bignum ] map append ] keep
566 '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
568 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
569 [ { } ] [ int-4{ 0x7fffffff 3 4 -8 } test-accesses ] unit-test
570 [ { } ] [ uint-4{ 0xffffffff 2 3 4 } test-accesses ] unit-test
572 [ 0x7fffffff ] [ int-4{ 0x7fffffff 3 4 -8 } first ] unit-test
573 [ -8 ] [ int-4{ 0x7fffffff 3 4 -8 } last ] unit-test
574 [ 0xffffffff ] [ uint-4{ 0xffffffff 2 3 4 } first ] unit-test
576 [ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
577 [ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
578 [ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
580 "== Checking broadcast" print
581 : test-broadcast ( seq -- failures )
582 [ length iota >array ] keep
583 '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
585 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
586 [ { } ] [ int-4{ 0x7fffffff 3 4 -8 } test-broadcast ] unit-test
587 [ { } ] [ uint-4{ 0xffffffff 2 3 4 } test-broadcast ] unit-test
589 [ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
590 [ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
591 [ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
593 ! Make sure we use the fallback in the correct situations
594 [ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test
596 "== Checking alien operations" print
598 [ float-4{ 1 2 3 4 } ] [
601 underlying>> 0 float-4-rep alien-vector
602 ] compile-call float-4 boa
605 [ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
606 16 [ 1 ] B{ } replicate-as 16 <byte-array>
609 { byte-array c-ptr fixnum } declare
610 float-4-rep set-alien-vector
615 [ float-array{ 1 2 3 4 } ] [
617 float-array{ 1 2 3 4 } underlying>>
618 float-array{ 4 3 2 1 } clone
619 [ underlying>> 0 float-4-rep set-alien-vector ] keep
629 [ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
638 float-4{ 1 2 3 4 } >>x
639 longlong-2{ 2 1 } >>y
642 { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
653 float-4{ 1 2 3 4 } >>x
654 longlong-2{ 2 1 } >>y
657 { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
661 "== Misc tests" print
663 [ ] [ char-16 new 1array stack. ] unit-test
665 ! Test some sequence protocol stuff
666 [ t ] [ 4 double-4{ 1 2 3 4 } new-sequence double-4? ] unit-test
667 [ double-4{ 2 3 4 5 } ] [ double-4{ 1 2 3 4 } [ 1 + ] map ] unit-test
670 [ 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
671 [ 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
672 [ 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
673 [ 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
675 [ 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
676 [ 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
677 [ 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
678 [ 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
682 int-4{ 1000 1000 1000 1000 }
683 [ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
686 ! Coalescing was too aggressive
687 :: broken ( axis theta -- a b c )
688 axis { float-4 } declare drop
689 theta { float } declare drop
691 theta cos float-4-with :> cc
692 theta sin float-4-with :> ss
694 axis cc v+ :> diagonal
696 diagonal cc ss ; inline
699 float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
700 [ compile-call ] [ call ] 3bi =
703 ! Spilling SIMD values -- this basically just tests that the
704 ! stack was aligned properly by the runtime
706 : simd-spill-test-1 ( a b c -- v )
707 { float-4 float-4 float } declare
710 [ float-4{ 0 0 0 0 } ]
711 [ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
713 : simd-spill-test-2 ( a b d c -- v )
714 { float float-4 float-4 float } declare
715 [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
717 [ float-4{ 0 0 0 0 } ]
718 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
720 : callback-1 ( -- c )
721 c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
723 : indirect-1 ( x x x x x c -- y )
724 c:int { c:int c:int c:int c:int c:int } cdecl alien-indirect ; inline
726 : simd-spill-test-3 ( a b d c -- v )
727 { float float-4 float-4 float } declare
728 [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v
729 10 5 100 50 500 callback-1 indirect-1 665 assert= ;
731 [ float-4{ 0 0 0 0 } ]
732 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-3 ] unit-test
734 ! Stack allocation of SIMD values -- make sure that everything is
737 : simd-stack-test ( -- b c )
739 [ 123 swap 0 c:int c:set-alien-value ]
740 [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
741 ] with-out-parameters ;
743 [ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
745 ! Stack allocation + spilling
747 : (simd-stack-spill-test) ( -- n ) 17 ;
749 : simd-stack-spill-test ( x -- b c )
751 123 swap 0 c:int c:set-alien-value
752 >float (simd-stack-spill-test) float-4-with swap cos v*n
753 ] with-out-parameters ;
756 1.047197551196598 simd-stack-spill-test
757 [ float-4{ 8.5 8.5 8.5 8.5 } approx= t assert= ]