-USING: accessors arrays classes compiler compiler.tree.debugger
+USING: accessors arrays classes compiler.test compiler.tree.debugger
effects fry io kernel kernel.private math math.functions
-math.private math.vectors math.vectors.simd
+math.private math.vectors math.vectors.simd math.ranges
math.vectors.simd.private prettyprint random sequences system
tools.test vocabs assocs compiler.cfg.debugger words
-locals math.vectors.specialization combinators cpu.architecture
-math.vectors.conversion.backend
-math.vectors.simd.intrinsics namespaces byte-arrays alien
+locals combinators cpu.architecture namespaces byte-arrays alien
specialized-arrays classes.struct eval classes.algebra sets
-quotations math.constants compiler.units ;
+quotations math.constants compiler.units splitting math.matrices
+math.vectors.simd.cords alien.data ;
+FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float
-SIMD: c:char
-SIMD: c:uchar
-SIMD: c:short
-SIMD: c:ushort
-SIMD: c:int
-SIMD: c:uint
-SIMD: c:longlong
-SIMD: c:ulonglong
-SIMD: c:float
-SIMD: c:double
IN: math.vectors.simd.tests
-! Make sure the functor doesn't generate bogus vocabularies
-2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times
-
-[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test
-
! Test type propagation
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
[ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
-[ V{ int-8 } ] [ [ { int-8 int-8 } declare v+ ] final-classes ] unit-test
-
-[ t ] [ [ { int-8 } declare second ] final-classes first integer class<= ] unit-test
-
! Test puns; only on x86
cpu x86? [
[ double-2{ 4 1024 } ] [
float-4{ 0 1 0 2 }
[ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
] unit-test
-
- [ 33.0 ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
- ] unit-test
] when
! Fuzz testing
{
char-16
uchar-16
- char-32
- uchar-32
short-8
ushort-8
- short-16
- ushort-16
int-4
uint-4
- int-8
- uint-8
longlong-2
ulonglong-2
- longlong-4
- ulonglong-4
float-4
- float-8
double-2
- double-4
}
+SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
+
+CONSTANT: vector-words
+ H{
+ { [v-] { +vector+ +vector+ -> +vector+ } }
+ { distance { +vector+ +vector+ -> +nonnegative+ } }
+ { n*v { +scalar+ +vector+ -> +vector+ } }
+ { n+v { +scalar+ +vector+ -> +vector+ } }
+ { n-v { +scalar+ +vector+ -> +vector+ } }
+ { n/v { +scalar+ +vector+ -> +vector+ } }
+ { norm { +vector+ -> +nonnegative+ } }
+ { norm-sq { +vector+ -> +nonnegative+ } }
+ { normalize { +vector+ -> +vector+ } }
+ { v* { +vector+ +vector+ -> +vector+ } }
+ { vs* { +vector+ +vector+ -> +vector+ } }
+ { v*n { +vector+ +scalar+ -> +vector+ } }
+ { v*high { +vector+ +vector+ -> +vector+ } }
+ { v*hs+ { +vector+ +vector+ -> +vector+ } }
+ { v+ { +vector+ +vector+ -> +vector+ } }
+ { vs+ { +vector+ +vector+ -> +vector+ } }
+ { v+- { +vector+ +vector+ -> +vector+ } }
+ { v+n { +vector+ +scalar+ -> +vector+ } }
+ { v- { +vector+ +vector+ -> +vector+ } }
+ { vneg { +vector+ -> +vector+ } }
+ { vs- { +vector+ +vector+ -> +vector+ } }
+ { v-n { +vector+ +scalar+ -> +vector+ } }
+ { v. { +vector+ +vector+ -> +scalar+ } }
+ { vsad { +vector+ +vector+ -> +scalar+ } }
+ { v/ { +vector+ +vector+ -> +vector+ } }
+ { v/n { +vector+ +scalar+ -> +vector+ } }
+ { vceiling { +vector+ -> +vector+ } }
+ { vfloor { +vector+ -> +vector+ } }
+ { vmax { +vector+ +vector+ -> +vector+ } }
+ { vmin { +vector+ +vector+ -> +vector+ } }
+ { vavg { +vector+ +vector+ -> +vector+ } }
+ { vneg { +vector+ -> +vector+ } }
+ { vtruncate { +vector+ -> +vector+ } }
+ { sum { +vector+ -> +scalar+ } }
+ { vcount { +vector+ -> +scalar+ } }
+ { vabs { +vector+ -> +vector+ } }
+ { vsqrt { +vector+ -> +vector+ } }
+ { vbitand { +vector+ +vector+ -> +vector+ } }
+ { vbitandn { +vector+ +vector+ -> +vector+ } }
+ { vbitor { +vector+ +vector+ -> +vector+ } }
+ { vbitxor { +vector+ +vector+ -> +vector+ } }
+ { vbitnot { +vector+ -> +vector+ } }
+ { vand { +vector+ +vector+ -> +vector+ } }
+ { vandn { +vector+ +vector+ -> +vector+ } }
+ { vor { +vector+ +vector+ -> +vector+ } }
+ { vxor { +vector+ +vector+ -> +vector+ } }
+ { vnot { +vector+ -> +vector+ } }
+ { vlshift { +vector+ +scalar+ -> +vector+ } }
+ { vrshift { +vector+ +scalar+ -> +vector+ } }
+ { (vmerge-head) { +vector+ +vector+ -> +vector+ } }
+ { (vmerge-tail) { +vector+ +vector+ -> +vector+ } }
+ { v<= { +vector+ +vector+ -> +vector+ } }
+ { v< { +vector+ +vector+ -> +vector+ } }
+ { v= { +vector+ +vector+ -> +vector+ } }
+ { v> { +vector+ +vector+ -> +vector+ } }
+ { v>= { +vector+ +vector+ -> +vector+ } }
+ { vunordered? { +vector+ +vector+ -> +vector+ } }
+ }
+
+: vector-word-inputs ( schema -- seq ) { -> } split first ;
+
: with-ctors ( -- seq )
- simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
+ simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup-word ] map ;
: boa-ctors ( -- seq )
- simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
-
-: check-optimizer ( seq quot eq-quot -- failures )
- '[
- @
- [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
- {
- [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
- [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
- [ [ call ] dip call ]
+ simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup-word ] map ;
+
+TUPLE: simd-test-failure
+ input
+ input-quot
+ unoptimized-result
+ optimized-result
+ nonintrinsic-result ;
+
+:: check-optimizer (
+ seq
+ test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
+ eq-quot: ( resulta resultb -- ? )
+ --
+ failures
+)
+ #! Use test-quot to generate a bunch of test cases from the
+ #! given inputs. Run each test case optimized and
+ #! unoptimized. Compare results with eq-quot.
+ #!
+ #! seq: sequence of inputs
+ #! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
+ #! eq-quot: ( result1 result2 -- ? )
+ seq [| input |
+ input test-quot call :> ( input-quot code-quot )
+ input-quot [ class-of ] { } map-as :> input-classes
+ input-classes code-quot '[ _ declare @ ] :> code-quot'
+
+ "print-mr" get [ code-quot' regs. ] when
+ "print-checks" get [ input-quot . code-quot' . ] when
+
+ input-quot code-quot' [ [ call ] dip call ]
+ call( i c -- result ) :> unoptimized-result
+ input-quot code-quot' [ [ call ] dip compile-call ]
+ call( i c -- result ) :> optimized-result
+ input-quot code-quot' [
+ t "always-inline-simd-intrinsics"
[ [ call ] dip compile-call ]
- } 2cleave
- @ not
- ] filter ; inline
+ with-variable
+ ] call( i c -- result ) :> nonintrinsic-result
+
+ unoptimized-result optimized-result eq-quot call
+ optimized-result nonintrinsic-result eq-quot call
+ and
+ [ f ] [
+ input input-quot unoptimized-result optimized-result nonintrinsic-result
+ simd-test-failure boa
+ ] if
+ ] map sift ; inline
"== Checking -new constructors" print
] [ = ] check-optimizer
] unit-test
-[ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
+[ 0xffffffff ] [ 0xffffffff uint-4-with first ] unit-test
-[ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
+[ 0xffffffff ] [ 0xffffffff [ uint-4-with ] compile-call first ] unit-test
-[ HEX: ffffffff ] [ [ HEX: ffffffff uint-4-with ] compile-call first ] unit-test
+[ 0xffffffff ] [ [ 0xffffffff uint-4-with ] compile-call first ] unit-test
"== Checking -boa constructors" print
] [ = ] check-optimizer
] unit-test
-[ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
+[ 0xffffffff ] [ 0xffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
"== Checking vector operations" print
: random-int-vector ( class -- vec )
- new [ drop 1,000 random ] map ;
+ new [ drop 1000 random ] map ;
+
: random-float-vector ( class -- vec )
new [
drop
word '[ _ execute ] ;
: remove-float-words ( alist -- alist' )
- { vsqrt n/v v/n v/ normalize } unique assoc-diff ;
+ { distance vsqrt n/v v/n v/ normalize } unique assoc-diff ;
: remove-integer-words ( alist -- alist' )
- { vlshift vrshift } unique assoc-diff ;
+ { vlshift vrshift v*high v*hs+ } unique assoc-diff ;
: boolean-ops ( -- words )
- { vand vandn vor vxor vnot } ;
+ { vand vandn vor vxor vnot vcount } ;
: remove-boolean-words ( alist -- alist' )
boolean-ops unique assoc-diff ;
-: remove-special-words ( alist -- alist' )
- ! These have their own tests later
- {
- hlshift hrshift vshuffle vbroadcast
- vany? vall? vnone?
- (v>float) (v>integer)
- (vpack-signed) (vpack-unsigned)
- (vunpack-head) (vunpack-tail)
- } unique assoc-diff ;
-
: ops-to-check ( elt-class -- alist )
[ vector-words >alist ] dip
float = [ remove-integer-words ] [ remove-float-words ] if
- remove-boolean-words
- remove-special-words ;
+ remove-boolean-words ;
-: check-vector-ops ( class elt-class compare-quot -- )
+: check-vector-ops ( class elt-class compare-quot -- failures )
[
[ nip ops-to-check ] 2keep
- '[ first2 inputs _ _ check-vector-op ]
+ '[ first2 vector-word-inputs _ _ check-vector-op ]
] dip check-optimizer ; inline
-: approx= ( x y -- ? )
+: (approx=) ( x y -- ? )
{
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
- { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ { [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
- { [ 2dup [ sequence? ] both? ] [
- [
- {
- { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
- { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
- { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
- } cond
- ] 2all?
- ] }
+ { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ [ = ]
} cond ;
+: approx= ( x y -- ? )
+ 2dup [ sequence? ] both?
+ [ [ (approx=) ] 2all? ] [ (approx=) ] if ;
+
: exact= ( x y -- ? )
{
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
+ [ = ]
} cond ;
: simd-classes&reps ( -- alist )
] [ ] map-as
word '[ _ execute ] ;
-: check-boolean-ops ( class elt-class compare-quot -- )
+: check-boolean-ops ( class elt-class compare-quot -- seq )
[
- [ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip
- '[ first2 inputs _ _ check-boolean-op ]
+ [ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
+ '[ first2 vector-word-inputs _ _ check-boolean-op ]
] dip check-optimizer ; inline
simd-classes&reps [
"== Checking shifts and permutations" print
-[ int-4{ 256 512 1024 2048 } ]
-[ int-4{ 1 2 4 8 } 1 hlshift ] unit-test
+[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
+[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hlshift ] unit-test
+
+[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
+[ 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
+
+[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
+[ 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
+
+[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
+[ 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
-[ int-4{ 256 512 1024 2048 } ]
-[ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test
+[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
+[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 hrshift ] unit-test
-[ int-4{ 256 512 1024 2048 } ]
-[ int-4{ 1 2 4 8 } 1 [ { int-4 fixnum } declare hlshift ] compile-call ] unit-test
+[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
+[ 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
-[ int-4{ 1 2 4 8 } ]
-[ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test
+[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
+[ 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
-[ int-4{ 1 2 4 8 } ]
-[ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test
+[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
+[ 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
-[ int-4{ 1 2 4 8 } ]
-[ int-4{ 256 512 1024 2048 } 1 [ { int-4 fixnum } declare hrshift ] compile-call ] unit-test
+[ int-4{ 4 8 12 16 } ]
+[ int-4{ 1 2 3 4 } 2 vlshift ] unit-test
+
+[ int-4{ 4 8 12 16 } ]
+[ int-4{ 1 2 3 4 } 2 [ { int-4 fixnum } declare vlshift ] compile-call ] unit-test
+
+[ int-4{ 4 8 12 16 } ]
+[ int-4{ 1 2 3 4 } 2 >bignum [ { int-4 bignum } declare vlshift ] compile-call ] unit-test
! Invalid inputs should not cause the compiler to throw errors
[ ] [
- [ [ { int-4 } declare t hrshift ] (( a -- b )) define-temp drop ] with-compilation-unit
+ [ [ { int-4 } declare t hrshift ] ( a -- b ) define-temp drop ] with-compilation-unit
] unit-test
[ ] [
- [ [ { int-4 } declare { 3 2 1 } vshuffle ] (( a -- b )) define-temp drop ] with-compilation-unit
+ [ [ { int-4 } declare { 3 2 1 } vshuffle ] ( a -- b ) define-temp drop ] with-compilation-unit
] unit-test
! Shuffles
[ dup '[ _ random ] replicate 1array ]
} case ;
+: 2shuffles-for ( n -- shuffles )
+ {
+ { 2 [
+ {
+ { 0 1 }
+ { 0 3 }
+ { 2 3 }
+ { 2 0 }
+ }
+ ] }
+ { 4 [
+ {
+ { 0 1 2 3 }
+ { 4 1 2 3 }
+ { 0 5 2 3 }
+ { 0 1 6 3 }
+ { 0 1 2 7 }
+ { 4 5 2 3 }
+ { 0 1 6 7 }
+ { 4 5 6 7 }
+ { 0 5 2 7 }
+ }
+ ] }
+ { 8 [
+ 4 2shuffles-for
+ 4 2shuffles-for
+ [ [ 8 + ] map ] map
+ [ append ] 2map
+ ] }
+ [ dup 2 * '[ _ random ] replicate 1array ]
+ } case ;
+
simd-classes [
[ [ { } ] ] dip
[ new length shuffles-for ] keep
] unit-test
] each
+simd-classes [
+ [ [ { } ] ] dip
+ [ new length 2shuffles-for ] keep
+ '[
+ _ [ [
+ _ new
+ [ [ length iota ] keep like ]
+ [ [ length dup dup + [a,b) ] keep like ] bi [ ] 2sequence
+ ] dip '[ _ vshuffle2-elements ] ]
+ [ = ] check-optimizer
+ ] unit-test
+] each
+
+"== Checking variable shuffles" print
+
+: random-shift-vector ( class -- vec )
+ new [ drop 16 random ] map ;
+
+:: test-shift-vector ( class -- ? )
+ [
+ class random-int-vector :> src
+ char-16 random-shift-vector :> perm
+ { class char-16 } :> decl
+
+ src perm vshuffle
+ src perm [ decl declare vshuffle ] compile-call
+ =
+ ] call( -- ? ) ;
+
+{ char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 }
+[ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each
+
"== Checking vector tests" print
:: test-vector-tests-bool ( vector declaration -- none? any? all? )
- vector
- [ [ declaration declare vnone? ] compile-call ]
- [ [ declaration declare vany? ] compile-call ]
- [ [ declaration declare vall? ] compile-call ] tri ; inline
+ [
+ vector
+ [ [ declaration declare vnone? ] compile-call ]
+ [ [ declaration declare vany? ] compile-call ]
+ [ [ declaration declare vall? ] compile-call ] tri
+ ] call( -- none? any? all? ) ;
: yes ( -- x ) t ;
: no ( -- x ) f ;
:: test-vector-tests-branch ( vector declaration -- none? any? all? )
- vector
- [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
- [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
- [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri ; inline
+ [
+ vector
+ [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
+ [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
+ [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri
+ ] call( -- none? any? all? ) ;
-SYMBOL: !!inconsistent!!
+TUPLE: inconsistent-vector-test bool branch ;
-: ?inconsistent ( a b -- ab/inconsistent )
- 2dup = [ drop ] [ 2drop !!inconsistent!! ] if ;
+: ?inconsistent ( bool branch -- ?/inconsistent )
+ 2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
:: test-vector-tests ( vector decl -- none? any? all? )
- vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none
- vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none
-
- bool-none branch-none ?inconsistent
- bool-any branch-any ?inconsistent
- bool-all branch-all ?inconsistent ; inline
+ [
+ vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
+ vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
+
+ bool-none branch-none ?inconsistent
+ bool-any branch-any ?inconsistent
+ bool-all branch-all ?inconsistent
+ ] call( -- none? any? all? ) ;
[ f t t ]
[ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
[ t f f ]
[ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
-[ f t t ]
-[ float-8{ t t t t t t t t } { float-8 } test-vector-tests ] unit-test
-[ f t f ]
-[ float-8{ f t t t t f t t } { float-8 } test-vector-tests ] unit-test
-[ t f f ]
-[ float-8{ f f f f f f f f } { float-8 } test-vector-tests ] unit-test
-
-[ f t t ]
-[ double-4{ t t t t } { double-4 } test-vector-tests ] unit-test
-[ f t f ]
-[ double-4{ f t t f } { double-4 } test-vector-tests ] unit-test
-[ t f f ]
-[ double-4{ f f f f } { double-4 } test-vector-tests ] unit-test
-
-[ f t t ]
-[ int-8{ t t t t t t t t } { int-8 } test-vector-tests ] unit-test
-[ f t f ]
-[ int-8{ f t t t t f f f } { int-8 } test-vector-tests ] unit-test
-[ t f f ]
-[ int-8{ f f f f f f f f } { int-8 } test-vector-tests ] unit-test
-
"== Checking element access" print
! Test element access -- it should box bignums for int-4 on x86
: test-accesses ( seq -- failures )
- [ length >array ] keep
+ [ length iota dup [ >bignum ] map append ] keep
'[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
-[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test
-[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
+[ { } ] [ int-4{ 0x7fffffff 3 4 -8 } test-accesses ] unit-test
+[ { } ] [ uint-4{ 0xffffffff 2 3 4 } test-accesses ] unit-test
-[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
-[ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test
-[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
+[ 0x7fffffff ] [ int-4{ 0x7fffffff 3 4 -8 } first ] unit-test
+[ -8 ] [ int-4{ 0x7fffffff 3 4 -8 } last ] unit-test
+[ 0xffffffff ] [ uint-4{ 0xffffffff 2 3 4 } first ] unit-test
[ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
[ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
[ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
-[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-accesses ] unit-test
-[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
-[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
-
-[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
-[ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test
-[ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test
-
"== Checking broadcast" print
: test-broadcast ( seq -- failures )
- [ length >array ] keep
- '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline
+ [ length iota >array ] keep
+ '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
-[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
-[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test
+[ { } ] [ int-4{ 0x7fffffff 3 4 -8 } test-broadcast ] unit-test
+[ { } ] [ uint-4{ 0xffffffff 2 3 4 } test-broadcast ] unit-test
[ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
[ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
[ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
-[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-broadcast ] unit-test
-[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
-[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
-
-[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
-[ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test
-[ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test
-
! Make sure we use the fallback in the correct situations
[ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test
STRUCT: simd-struct
{ x float-4 }
-{ y double-2 }
-{ z double-4 }
-{ w float-8 } ;
+{ y longlong-2 }
+{ z double-2 }
+{ w int-4 } ;
[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
[
float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
+ longlong-2{ 2 1 }
+ double-2{ 4 3 }
+ int-4{ 1 2 3 4 }
] [
simd-struct <struct>
float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
+ longlong-2{ 2 1 } >>y
+ double-2{ 4 3 } >>z
+ int-4{ 1 2 3 4 } >>w
{ [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] unit-test
[
float-4{ 1 2 3 4 }
- double-2{ 2 1 }
- double-4{ 4 3 2 1 }
- float-8{ 1 2 3 4 5 6 7 8 }
+ longlong-2{ 2 1 }
+ double-2{ 4 3 }
+ int-4{ 1 2 3 4 }
] [
[
simd-struct <struct>
float-4{ 1 2 3 4 } >>x
- double-2{ 2 1 } >>y
- double-4{ 4 3 2 1 } >>z
- float-8{ 1 2 3 4 5 6 7 8 } >>w
+ longlong-2{ 2 1 } >>y
+ double-2{ 4 3 } >>z
+ int-4{ 1 2 3 4 } >>w
{ [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
] compile-call
] unit-test
[ ] [ char-16 new 1array stack. ] unit-test
+! Test some sequence protocol stuff
+[ t ] [ 4 double-4{ 1 2 3 4 } new-sequence double-4? ] unit-test
+[ double-4{ 2 3 4 5 } ] [ double-4{ 1 2 3 4 } [ 1 + ] map ] unit-test
+
+! Test cross product
+[ 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
+[ 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
+[ 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
+[ 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
+
+[ 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
+[ 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
+[ 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
+[ 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
+
! CSSA bug
-[ 8000000 ] [
- int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
- [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+[ 4000000 ] [
+ int-4{ 1000 1000 1000 1000 }
+ [ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
] unit-test
! Coalescing was too aggressive
float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
[ compile-call ] [ call ] 3bi =
] unit-test
+
+! Spilling SIMD values -- this basically just tests that the
+! stack was aligned properly by the runtime
+
+: simd-spill-test-1 ( a b c -- v )
+ { float-4 float-4 float } declare
+ [ v+ ] dip sin v*n ;
+
+[ float-4{ 0 0 0 0 } ]
+[ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
+
+: simd-spill-test-2 ( a b d c -- v )
+ { float float-4 float-4 float } declare
+ [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
+
+[ float-4{ 0 0 0 0 } ]
+[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
+
+: callback-1 ( -- c )
+ c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
+
+: indirect-1 ( x x x x x c -- y )
+ c:int { c:int c:int c:int c:int c:int } cdecl alien-indirect ; inline
+
+: simd-spill-test-3 ( a b d c -- v )
+ { float float-4 float-4 float } declare
+ [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v
+ 10 5 100 50 500 callback-1 indirect-1 665 assert= ;
+
+[ float-4{ 0 0 0 0 } ]
+[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-3 ] unit-test
+
+! Stack allocation of SIMD values -- make sure that everything is
+! aligned right
+
+: simd-stack-test ( -- b c )
+ { c:int float-4 } [
+ [ 123 swap 0 c:int c:set-alien-value ]
+ [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
+ ] with-out-parameters ;
+
+[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
+
+! Stack allocation + spilling
+
+: (simd-stack-spill-test) ( -- n ) 17 ;
+
+: simd-stack-spill-test ( x -- b c )
+ { c:int } [
+ 123 swap 0 c:int c:set-alien-value
+ >float (simd-stack-spill-test) float-4-with swap cos v*n
+ ] with-out-parameters ;
+
+[ ] [
+ 1.047197551196598 simd-stack-spill-test
+ [ float-4{ 8.5 8.5 8.5 8.5 } approx= t assert= ]
+ [ 123 assert= ]
+ bi*
+] unit-test
projects / factor.git / blobdiff