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
4 math.vectors.simd.private prettyprint random sequences system
5 tools.test vocabs assocs compiler.cfg.debugger words
6 locals combinators cpu.architecture namespaces byte-arrays alien
7 specialized-arrays classes.struct eval classes.algebra sets
8 quotations math.constants compiler.units splitting ;
9 FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
10 QUALIFIED-WITH: alien.c-types c
11 SPECIALIZED-ARRAY: c:float
12 IN: math.vectors.simd.tests
14 ! Test type propagation
15 [ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
17 [ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
19 [ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
21 [ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
23 [ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test
25 [ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test
27 [ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test
29 [ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test
31 [ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
33 ! Test puns; only on x86
35 [ double-2{ 4 1024 } ] [
37 [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
42 CONSTANT: simd-classes
56 SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
58 CONSTANT: vector-words
60 { [v-] { +vector+ +vector+ -> +vector+ } }
61 { distance { +vector+ +vector+ -> +nonnegative+ } }
62 { n*v { +scalar+ +vector+ -> +vector+ } }
63 { n+v { +scalar+ +vector+ -> +vector+ } }
64 { n-v { +scalar+ +vector+ -> +vector+ } }
65 { n/v { +scalar+ +vector+ -> +vector+ } }
66 { norm { +vector+ -> +nonnegative+ } }
67 { norm-sq { +vector+ -> +nonnegative+ } }
68 { normalize { +vector+ -> +vector+ } }
69 { v* { +vector+ +vector+ -> +vector+ } }
70 { vs* { +vector+ +vector+ -> +vector+ } }
71 { v*n { +vector+ +scalar+ -> +vector+ } }
72 { v*high { +vector+ +vector+ -> +vector+ } }
73 { v*hs+ { +vector+ +vector+ -> +vector+ } }
74 { v+ { +vector+ +vector+ -> +vector+ } }
75 { vs+ { +vector+ +vector+ -> +vector+ } }
76 { v+- { +vector+ +vector+ -> +vector+ } }
77 { v+n { +vector+ +scalar+ -> +vector+ } }
78 { v- { +vector+ +vector+ -> +vector+ } }
79 { vneg { +vector+ -> +vector+ } }
80 { vs- { +vector+ +vector+ -> +vector+ } }
81 { v-n { +vector+ +scalar+ -> +vector+ } }
82 { v. { +vector+ +vector+ -> +scalar+ } }
83 { vsad { +vector+ +vector+ -> +scalar+ } }
84 { v/ { +vector+ +vector+ -> +vector+ } }
85 { v/n { +vector+ +scalar+ -> +vector+ } }
86 { vceiling { +vector+ -> +vector+ } }
87 { vfloor { +vector+ -> +vector+ } }
88 { vmax { +vector+ +vector+ -> +vector+ } }
89 { vmin { +vector+ +vector+ -> +vector+ } }
90 { vavg { +vector+ +vector+ -> +vector+ } }
91 { vneg { +vector+ -> +vector+ } }
92 { vtruncate { +vector+ -> +vector+ } }
93 { sum { +vector+ -> +scalar+ } }
94 { vabs { +vector+ -> +vector+ } }
95 { vsqrt { +vector+ -> +vector+ } }
96 { vbitand { +vector+ +vector+ -> +vector+ } }
97 { vbitandn { +vector+ +vector+ -> +vector+ } }
98 { vbitor { +vector+ +vector+ -> +vector+ } }
99 { vbitxor { +vector+ +vector+ -> +vector+ } }
100 { vbitnot { +vector+ -> +vector+ } }
101 { vand { +vector+ +vector+ -> +vector+ } }
102 { vandn { +vector+ +vector+ -> +vector+ } }
103 { vor { +vector+ +vector+ -> +vector+ } }
104 { vxor { +vector+ +vector+ -> +vector+ } }
105 { vnot { +vector+ -> +vector+ } }
106 { vlshift { +vector+ +scalar+ -> +vector+ } }
107 { vrshift { +vector+ +scalar+ -> +vector+ } }
108 { (vmerge-head) { +vector+ +vector+ -> +vector+ } }
109 { (vmerge-tail) { +vector+ +vector+ -> +vector+ } }
110 { v<= { +vector+ +vector+ -> +vector+ } }
111 { v< { +vector+ +vector+ -> +vector+ } }
112 { v= { +vector+ +vector+ -> +vector+ } }
113 { v> { +vector+ +vector+ -> +vector+ } }
114 { v>= { +vector+ +vector+ -> +vector+ } }
115 { vunordered? { +vector+ +vector+ -> +vector+ } }
118 : vector-word-inputs ( schema -- seq ) { -> } split first ;
120 : with-ctors ( -- seq )
121 simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
123 : boa-ctors ( -- seq )
124 simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
126 : check-optimizer ( seq quot eq-quot -- failures )
129 [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
131 [ "print-mr" get [ nip regs. ] [ 2drop ] if ]
132 [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
133 [ [ [ call ] dip call ] call( quot quot -- result ) ]
134 [ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
135 [ [ t "always-inline-simd-intrinsics" [ [ call ] dip compile-call ] with-variable ] call( quot quot -- result ) ]
137 [ drop @ ] [ nip @ ] 3bi and not
140 "== Checking -new constructors" print
143 simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
147 simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
150 "== Checking -with constructors" print
154 [ 1000 random '[ _ ] ] dip '[ _ execute ]
155 ] [ = ] check-optimizer
158 [ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
160 [ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
162 [ HEX: ffffffff ] [ [ HEX: ffffffff uint-4-with ] compile-call first ] unit-test
164 "== Checking -boa constructors" print
168 [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
170 ] [ = ] check-optimizer
173 [ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
175 "== Checking vector operations" print
177 : random-int-vector ( class -- vec )
178 new [ drop 1000 random ] map ;
180 : random-float-vector ( class -- vec )
184 10 swap <array> 0/0. suffix random
187 : random-vector ( class elt-class -- vec )
189 [ random-float-vector ]
190 [ random-int-vector ] if ;
192 :: check-vector-op ( word inputs class elt-class -- inputs quot )
195 { +vector+ [ class elt-class random-vector ] }
196 { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
199 word '[ _ execute ] ;
201 : remove-float-words ( alist -- alist' )
202 { vsqrt n/v v/n v/ normalize } unique assoc-diff ;
204 : remove-integer-words ( alist -- alist' )
205 { vlshift vrshift v*high v*hs+ } unique assoc-diff ;
207 : boolean-ops ( -- words )
208 { vand vandn vor vxor vnot } ;
210 : remove-boolean-words ( alist -- alist' )
211 boolean-ops unique assoc-diff ;
213 : ops-to-check ( elt-class -- alist )
214 [ vector-words >alist ] dip
215 float = [ remove-integer-words ] [ remove-float-words ] if
216 remove-boolean-words ;
218 : check-vector-ops ( class elt-class compare-quot -- )
220 [ nip ops-to-check ] 2keep
221 '[ first2 vector-word-inputs _ _ check-vector-op ]
222 ] dip check-optimizer ; inline
224 : (approx=) ( x y -- ? )
226 { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
227 { [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
228 { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
229 { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
232 : approx= ( x y -- ? )
233 2dup [ sequence? ] both?
234 [ [ (approx=) ] 2all? ] [ (approx=) ] if ;
236 : exact= ( x y -- ? )
238 { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
239 { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
242 : simd-classes&reps ( -- alist )
245 { [ dup name>> "float" head? ] [ float [ approx= ] ] }
246 { [ dup name>> "double" head? ] [ float [ exact= ] ] }
252 [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
255 "== Checking boolean operations" print
257 : random-boolean-vector ( class -- vec )
258 new [ drop 2 random zero? ] map ;
260 :: check-boolean-op ( word inputs class elt-class -- inputs quot )
263 { +vector+ [ class random-boolean-vector ] }
264 { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
267 word '[ _ execute ] ;
269 : check-boolean-ops ( class elt-class compare-quot -- seq )
271 [ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
272 '[ first2 vector-word-inputs _ _ check-boolean-op ]
273 ] dip check-optimizer ; inline
276 [ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
279 "== Checking vector blend" print
281 [ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
283 char-16{ t t f f t t t f t f f f t f t t }
284 char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
285 char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v?
288 [ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
290 char-16{ t t f f t t t f t f f f t f t t }
291 char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
292 char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 }
293 [ { char-16 char-16 char-16 } declare v? ] compile-call
296 [ int-4{ 1 22 33 4 } ]
297 [ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test
299 [ int-4{ 1 22 33 4 } ]
301 int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 }
302 [ { int-4 int-4 int-4 } declare v? ] compile-call
305 [ float-4{ 1.0 22.0 33.0 4.0 } ]
306 [ 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 [ float-4{ 1.0 22.0 33.0 4.0 } ]
310 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 }
311 [ { float-4 float-4 float-4 } declare v? ] compile-call
314 "== Checking shifts and permutations" print
316 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
317 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hlshift ] unit-test
319 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
320 [ 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 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
323 [ 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 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
326 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hrshift ] unit-test
328 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
329 [ 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 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
332 [ 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 ! Invalid inputs should not cause the compiler to throw errors
336 [ [ { int-4 } declare t hrshift ] (( a -- b )) define-temp drop ] with-compilation-unit
340 [ [ { int-4 } declare { 3 2 1 } vshuffle ] (( a -- b )) define-temp drop ] with-compilation-unit
344 : shuffles-for ( n -- shuffles )
375 [ dup '[ _ random ] replicate 1array ]
380 [ new length shuffles-for ] keep
382 _ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ]
383 [ = ] check-optimizer
387 "== Checking variable shuffles" print
389 : random-shift-vector ( class -- vec )
390 new [ drop 16 random ] map ;
392 :: test-shift-vector ( class -- ? )
394 class random-int-vector :> src
395 char-16 random-shift-vector :> perm
396 { class char-16 } :> decl
399 src perm [ decl declare vshuffle ] compile-call
403 { char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 }
404 [ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each
406 "== Checking vector tests" print
408 :: test-vector-tests-bool ( vector declaration -- none? any? all? )
411 [ [ declaration declare vnone? ] compile-call ]
412 [ [ declaration declare vany? ] compile-call ]
413 [ [ declaration declare vall? ] compile-call ] tri
414 ] call( -- none? any? all? ) ;
419 :: test-vector-tests-branch ( vector declaration -- none? any? all? )
422 [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
423 [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
424 [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri
425 ] call( -- none? any? all? ) ;
427 TUPLE: inconsistent-vector-test bool branch ;
429 : ?inconsistent ( bool branch -- ?/inconsistent )
430 2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
432 :: test-vector-tests ( vector decl -- none? any? all? )
434 vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
435 vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
437 bool-none branch-none ?inconsistent
438 bool-any branch-any ?inconsistent
439 bool-all branch-all ?inconsistent
440 ] call( -- none? any? all? ) ;
443 [ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
445 [ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test
447 [ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test
450 [ double-2{ t t } { double-2 } test-vector-tests ] unit-test
452 [ double-2{ f t } { double-2 } test-vector-tests ] unit-test
454 [ double-2{ f f } { double-2 } test-vector-tests ] unit-test
457 [ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test
459 [ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test
461 [ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
463 "== Checking element access" print
465 ! Test element access -- it should box bignums for int-4 on x86
466 : test-accesses ( seq -- failures )
467 [ length iota >array ] keep
468 '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
470 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
471 [ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test
472 [ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
474 [ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
475 [ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test
476 [ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
478 [ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
479 [ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
480 [ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
482 "== Checking broadcast" print
483 : test-broadcast ( seq -- failures )
484 [ length iota >array ] keep
485 '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
487 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
488 [ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
489 [ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test
491 [ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
492 [ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
493 [ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
495 ! Make sure we use the fallback in the correct situations
496 [ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test
498 "== Checking alien operations" print
500 [ float-4{ 1 2 3 4 } ] [
503 underlying>> 0 float-4-rep alien-vector
504 ] compile-call float-4 boa
507 [ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
508 16 [ 1 ] B{ } replicate-as 16 <byte-array>
511 { byte-array c-ptr fixnum } declare
512 float-4-rep set-alien-vector
517 [ float-array{ 1 2 3 4 } ] [
519 float-array{ 1 2 3 4 } underlying>>
520 float-array{ 4 3 2 1 } clone
521 [ underlying>> 0 float-4-rep set-alien-vector ] keep
531 [ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
540 float-4{ 1 2 3 4 } >>x
541 longlong-2{ 2 1 } >>y
544 { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
555 float-4{ 1 2 3 4 } >>x
556 longlong-2{ 2 1 } >>y
559 { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
563 "== Misc tests" print
565 [ ] [ char-16 new 1array stack. ] unit-test
569 int-4{ 1000 1000 1000 1000 }
570 [ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
573 ! Coalescing was too aggressive
574 :: broken ( axis theta -- a b c )
575 axis { float-4 } declare drop
576 theta { float } declare drop
578 theta cos float-4-with :> cc
579 theta sin float-4-with :> ss
581 axis cc v+ :> diagonal
583 diagonal cc ss ; inline
586 float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
587 [ compile-call ] [ call ] 3bi =
590 ! Spilling SIMD values -- this basically just tests that the
591 ! stack was aligned properly by the runtime
593 : simd-spill-test-1 ( a b c -- v )
594 { float-4 float-4 float } declare
597 [ float-4{ 0 0 0 0 } ]
598 [ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
600 : simd-spill-test-2 ( a b d c -- v )
601 { float float-4 float-4 float } declare
602 [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
604 [ float-4{ 0 0 0 0 } ]
605 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test