2009-09-20 17:48:17 -04:00
|
|
|
USING: accessors arrays classes compiler compiler.tree.debugger
|
|
|
|
effects fry io kernel kernel.private math math.functions
|
|
|
|
math.private math.vectors math.vectors.simd
|
|
|
|
math.vectors.simd.private prettyprint random sequences system
|
|
|
|
tools.test vocabs assocs compiler.cfg.debugger words
|
2009-11-18 23:32:05 -05:00
|
|
|
locals combinators cpu.architecture namespaces byte-arrays alien
|
2009-09-29 05:46:38 -04:00
|
|
|
specialized-arrays classes.struct eval classes.algebra sets
|
2009-11-24 21:30:12 -05:00
|
|
|
quotations math.constants compiler.units splitting ;
|
|
|
|
FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
|
2009-09-28 07:34:22 -04:00
|
|
|
QUALIFIED-WITH: alien.c-types c
|
|
|
|
SPECIALIZED-ARRAY: c:float
|
2009-09-03 03:33:07 -04:00
|
|
|
IN: math.vectors.simd.tests
|
|
|
|
|
2009-09-23 21:23:25 -04:00
|
|
|
! Test type propagation
|
2009-09-03 21:58:56 -04:00
|
|
|
[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
|
2009-09-03 03:33:07 -04:00
|
|
|
|
2009-09-03 21:58:56 -04:00
|
|
|
[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
|
|
|
|
|
2009-09-23 21:23:25 -04:00
|
|
|
[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test
|
|
|
|
|
|
|
|
[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
|
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
[ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test
|
|
|
|
|
|
|
|
[ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test
|
|
|
|
|
|
|
|
[ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test
|
|
|
|
|
|
|
|
[ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test
|
|
|
|
|
|
|
|
[ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
! 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
|
|
|
|
] when
|
2009-09-03 03:33:07 -04:00
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
! Fuzz testing
|
|
|
|
CONSTANT: simd-classes
|
|
|
|
{
|
|
|
|
char-16
|
|
|
|
uchar-16
|
|
|
|
short-8
|
|
|
|
ushort-8
|
|
|
|
int-4
|
|
|
|
uint-4
|
2009-09-23 21:23:25 -04:00
|
|
|
longlong-2
|
|
|
|
ulonglong-2
|
2009-09-20 17:48:17 -04:00
|
|
|
float-4
|
|
|
|
double-2
|
|
|
|
}
|
|
|
|
|
2009-11-18 23:32:05 -05:00
|
|
|
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+ } }
|
2009-12-05 18:42:41 -05:00
|
|
|
{ v*high { +vector+ +vector+ -> +vector+ } }
|
|
|
|
{ v*hs+ { +vector+ +vector+ -> +vector+ } }
|
2009-11-18 23:32:05 -05:00
|
|
|
{ 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+ } }
|
2009-12-05 18:42:41 -05:00
|
|
|
{ vsad { +vector+ +vector+ -> +scalar+ } }
|
2009-11-18 23:32:05 -05:00
|
|
|
{ v/ { +vector+ +vector+ -> +vector+ } }
|
|
|
|
{ v/n { +vector+ +scalar+ -> +vector+ } }
|
|
|
|
{ vceiling { +vector+ -> +vector+ } }
|
|
|
|
{ vfloor { +vector+ -> +vector+ } }
|
|
|
|
{ vmax { +vector+ +vector+ -> +vector+ } }
|
|
|
|
{ vmin { +vector+ +vector+ -> +vector+ } }
|
2009-12-05 18:42:41 -05:00
|
|
|
{ vavg { +vector+ +vector+ -> +vector+ } }
|
2009-11-18 23:32:05 -05:00
|
|
|
{ vneg { +vector+ -> +vector+ } }
|
|
|
|
{ vtruncate { +vector+ -> +vector+ } }
|
|
|
|
{ sum { +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 ;
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
: with-ctors ( -- seq )
|
|
|
|
simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ;
|
|
|
|
|
|
|
|
: boa-ctors ( -- seq )
|
|
|
|
simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
|
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
: check-optimizer ( seq quot eq-quot -- failures )
|
2009-11-26 16:28:40 -05:00
|
|
|
dup '[
|
2009-09-23 02:05:19 -04:00
|
|
|
@
|
2009-09-29 05:46:38 -04:00
|
|
|
[ dup [ class ] { } map-as ] dip '[ _ declare @ ]
|
2009-09-25 22:44:14 -04:00
|
|
|
{
|
|
|
|
[ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
|
|
|
|
[ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
|
2009-11-10 17:48:06 -05:00
|
|
|
[ [ [ call ] dip call ] call( quot quot -- result ) ]
|
|
|
|
[ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
|
2009-11-26 16:28:40 -05:00
|
|
|
[ [ t "always-inline-simd-intrinsics" [ [ call ] dip compile-call ] with-variable ] call( quot quot -- result ) ]
|
2009-09-25 22:44:14 -04:00
|
|
|
} 2cleave
|
2009-11-26 16:28:40 -05:00
|
|
|
[ drop @ ] [ nip @ ] 3bi and not
|
2009-09-23 02:05:19 -04:00
|
|
|
] filter ; inline
|
2009-09-20 17:48:17 -04:00
|
|
|
|
|
|
|
"== Checking -new constructors" print
|
|
|
|
|
|
|
|
[ { } ] [
|
2009-09-23 02:05:19 -04:00
|
|
|
simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer
|
2009-09-20 17:48:17 -04:00
|
|
|
] unit-test
|
|
|
|
|
|
|
|
[ { } ] [
|
|
|
|
simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
"== Checking -with constructors" print
|
|
|
|
|
|
|
|
[ { } ] [
|
|
|
|
with-ctors [
|
2010-01-14 13:48:57 -05:00
|
|
|
[ 1000 random '[ _ ] ] dip '[ _ execute ]
|
2009-09-23 02:05:19 -04:00
|
|
|
] [ = ] check-optimizer
|
2009-09-20 17:48:17 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-09-29 23:58:20 -04:00
|
|
|
[ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
|
|
|
|
|
|
|
|
[ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
|
|
|
|
|
2009-10-07 13:46:08 -04:00
|
|
|
[ HEX: ffffffff ] [ [ HEX: ffffffff uint-4-with ] compile-call first ] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
"== Checking -boa constructors" print
|
|
|
|
|
|
|
|
[ { } ] [
|
|
|
|
boa-ctors [
|
2010-01-14 13:48:57 -05:00
|
|
|
[ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
|
2009-09-29 05:46:38 -04:00
|
|
|
'[ _ execute ]
|
2009-09-23 02:05:19 -04:00
|
|
|
] [ = ] check-optimizer
|
2009-09-20 17:48:17 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-09-29 23:58:20 -04:00
|
|
|
[ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
"== Checking vector operations" print
|
|
|
|
|
2009-10-03 12:47:02 -04:00
|
|
|
: random-int-vector ( class -- vec )
|
2010-01-14 13:48:57 -05:00
|
|
|
new [ drop 1000 random ] map ;
|
2010-01-14 10:10:13 -05:00
|
|
|
|
2009-10-03 12:47:02 -04:00
|
|
|
: random-float-vector ( class -- vec )
|
|
|
|
new [
|
|
|
|
drop
|
2010-01-14 13:48:57 -05:00
|
|
|
1000 random
|
2009-10-03 12:47:02 -04:00
|
|
|
10 swap <array> 0/0. suffix random
|
|
|
|
] map ;
|
|
|
|
|
|
|
|
: random-vector ( class elt-class -- vec )
|
|
|
|
float =
|
|
|
|
[ random-float-vector ]
|
|
|
|
[ random-int-vector ] if ;
|
2009-09-20 17:48:17 -04:00
|
|
|
|
|
|
|
:: check-vector-op ( word inputs class elt-class -- inputs quot )
|
|
|
|
inputs [
|
2009-09-29 05:46:38 -04:00
|
|
|
{
|
2009-10-03 12:47:02 -04:00
|
|
|
{ +vector+ [ class elt-class random-vector ] }
|
2010-01-14 13:48:57 -05:00
|
|
|
{ +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
|
2009-09-29 05:46:38 -04:00
|
|
|
} case
|
|
|
|
] [ ] map-as
|
|
|
|
word '[ _ execute ] ;
|
2009-09-20 17:48:17 -04:00
|
|
|
|
2009-09-23 02:05:19 -04:00
|
|
|
: remove-float-words ( alist -- alist' )
|
2009-09-29 05:46:38 -04:00
|
|
|
{ vsqrt n/v v/n v/ normalize } unique assoc-diff ;
|
2009-09-23 02:05:19 -04:00
|
|
|
|
2009-09-24 04:32:39 -04:00
|
|
|
: remove-integer-words ( alist -- alist' )
|
2009-12-05 20:17:16 -05:00
|
|
|
{ vlshift vrshift v*high v*hs+ } unique assoc-diff ;
|
2009-09-24 04:32:39 -04:00
|
|
|
|
2009-10-02 15:17:01 -04:00
|
|
|
: boolean-ops ( -- words )
|
2009-10-02 21:04:28 -04:00
|
|
|
{ vand vandn vor vxor vnot } ;
|
2009-10-02 15:17:01 -04:00
|
|
|
|
|
|
|
: remove-boolean-words ( alist -- alist' )
|
|
|
|
boolean-ops unique assoc-diff ;
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
: ops-to-check ( elt-class -- alist )
|
2009-09-23 02:05:19 -04:00
|
|
|
[ vector-words >alist ] dip
|
2009-09-28 03:17:46 -04:00
|
|
|
float = [ remove-integer-words ] [ remove-float-words ] if
|
2009-11-18 23:32:05 -05:00
|
|
|
remove-boolean-words ;
|
2009-09-23 02:05:19 -04:00
|
|
|
|
|
|
|
: check-vector-ops ( class elt-class compare-quot -- )
|
|
|
|
[
|
|
|
|
[ nip ops-to-check ] 2keep
|
2009-11-18 23:32:05 -05:00
|
|
|
'[ first2 vector-word-inputs _ _ check-vector-op ]
|
2009-09-23 02:05:19 -04:00
|
|
|
] dip check-optimizer ; inline
|
2009-09-20 17:48:17 -04:00
|
|
|
|
2009-10-17 17:54:51 -04:00
|
|
|
: (approx=) ( x y -- ? )
|
2009-09-23 02:05:19 -04:00
|
|
|
{
|
2009-10-03 12:47:02 -04:00
|
|
|
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
|
2009-10-17 17:54:51 -04:00
|
|
|
{ [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
|
2009-09-30 00:46:21 -04:00
|
|
|
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
|
2009-10-17 17:54:51 -04:00
|
|
|
{ [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
|
2009-09-23 02:05:19 -04:00
|
|
|
} cond ;
|
2009-09-20 17:48:17 -04:00
|
|
|
|
2009-10-17 17:54:51 -04:00
|
|
|
: approx= ( x y -- ? )
|
|
|
|
2dup [ sequence? ] both?
|
|
|
|
[ [ (approx=) ] 2all? ] [ (approx=) ] if ;
|
|
|
|
|
2009-09-30 00:46:21 -04:00
|
|
|
: exact= ( x y -- ? )
|
|
|
|
{
|
|
|
|
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
|
|
|
|
{ [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
|
|
|
|
} cond ;
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
: simd-classes&reps ( -- alist )
|
|
|
|
simd-classes [
|
2009-09-23 02:05:19 -04:00
|
|
|
{
|
|
|
|
{ [ dup name>> "float" head? ] [ float [ approx= ] ] }
|
2009-09-30 00:46:21 -04:00
|
|
|
{ [ dup name>> "double" head? ] [ float [ exact= ] ] }
|
2009-09-23 02:05:19 -04:00
|
|
|
[ fixnum [ = ] ]
|
|
|
|
} cond 3array
|
|
|
|
] map ;
|
2009-09-20 17:48:17 -04:00
|
|
|
|
|
|
|
simd-classes&reps [
|
2009-09-23 02:05:19 -04:00
|
|
|
[ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
|
|
|
|
] each
|
2009-09-20 17:48:17 -04:00
|
|
|
|
2009-10-02 15:17:01 -04:00
|
|
|
"== Checking boolean operations" print
|
|
|
|
|
|
|
|
: random-boolean-vector ( class -- vec )
|
2010-01-14 13:48:57 -05:00
|
|
|
new [ drop 2 random zero? ] map ;
|
2009-10-02 15:17:01 -04:00
|
|
|
|
|
|
|
:: check-boolean-op ( word inputs class elt-class -- inputs quot )
|
|
|
|
inputs [
|
|
|
|
{
|
|
|
|
{ +vector+ [ class random-boolean-vector ] }
|
2010-01-14 13:48:57 -05:00
|
|
|
{ +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
|
2009-10-02 15:17:01 -04:00
|
|
|
} case
|
|
|
|
] [ ] map-as
|
|
|
|
word '[ _ execute ] ;
|
|
|
|
|
2009-11-10 17:48:06 -05:00
|
|
|
: check-boolean-ops ( class elt-class compare-quot -- seq )
|
2009-10-02 15:17:01 -04:00
|
|
|
[
|
2009-11-24 21:30:12 -05:00
|
|
|
[ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
|
|
|
|
'[ first2 vector-word-inputs _ _ check-boolean-op ]
|
2009-10-02 15:17:01 -04:00
|
|
|
] dip check-optimizer ; inline
|
|
|
|
|
|
|
|
simd-classes&reps [
|
|
|
|
[ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
|
|
|
|
] each
|
|
|
|
|
2009-10-03 23:37:35 -04:00
|
|
|
"== Checking vector blend" print
|
|
|
|
|
|
|
|
[ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
|
|
|
|
[
|
|
|
|
char-16{ t t f f t t t f t f f f t f t t }
|
|
|
|
char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
|
|
|
|
char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v?
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
[ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
|
|
|
|
[
|
|
|
|
char-16{ t t f f t t t f t f f f t f t t }
|
|
|
|
char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
|
|
|
|
char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 }
|
|
|
|
[ { char-16 char-16 char-16 } declare v? ] compile-call
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
[ int-4{ 1 22 33 4 } ]
|
|
|
|
[ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test
|
|
|
|
|
|
|
|
[ int-4{ 1 22 33 4 } ]
|
|
|
|
[
|
|
|
|
int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 }
|
|
|
|
[ { int-4 int-4 int-4 } declare v? ] compile-call
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
[ float-4{ 1.0 22.0 33.0 4.0 } ]
|
|
|
|
[ 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
|
|
|
|
|
|
|
|
[ float-4{ 1.0 22.0 33.0 4.0 } ]
|
|
|
|
[
|
|
|
|
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 }
|
|
|
|
[ { float-4 float-4 float-4 } declare v? ] compile-call
|
|
|
|
] unit-test
|
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
"== Checking shifts and permutations" print
|
|
|
|
|
2009-10-17 01:34:35 -04:00
|
|
|
[ 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
|
2009-09-29 05:46:38 -04:00
|
|
|
|
2009-10-17 01:34:35 -04:00
|
|
|
[ 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
|
2009-09-29 05:46:38 -04:00
|
|
|
|
2009-10-17 01:34:35 -04:00
|
|
|
[ 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
|
2009-09-30 21:04:37 -04:00
|
|
|
|
2009-10-17 01:34:35 -04:00
|
|
|
[ 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
|
2009-09-29 05:46:38 -04:00
|
|
|
|
2009-10-17 01:34:35 -04:00
|
|
|
[ 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
|
2009-09-29 05:46:38 -04:00
|
|
|
|
2009-10-17 01:34:35 -04:00
|
|
|
[ 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
|
2009-09-30 21:04:37 -04:00
|
|
|
|
|
|
|
! Invalid inputs should not cause the compiler to throw errors
|
|
|
|
[ ] [
|
|
|
|
[ [ { 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
|
|
|
|
] unit-test
|
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
! Shuffles
|
|
|
|
: shuffles-for ( n -- shuffles )
|
|
|
|
{
|
|
|
|
{ 2 [
|
|
|
|
{
|
|
|
|
{ 0 1 }
|
|
|
|
{ 1 1 }
|
|
|
|
{ 1 0 }
|
|
|
|
{ 0 0 }
|
|
|
|
}
|
|
|
|
] }
|
|
|
|
{ 4 [
|
|
|
|
{
|
|
|
|
{ 1 2 3 0 }
|
|
|
|
{ 0 1 2 3 }
|
|
|
|
{ 1 1 2 2 }
|
|
|
|
{ 0 0 1 1 }
|
|
|
|
{ 2 2 3 3 }
|
|
|
|
{ 0 1 0 1 }
|
|
|
|
{ 2 3 2 3 }
|
|
|
|
{ 0 0 2 2 }
|
|
|
|
{ 1 1 3 3 }
|
|
|
|
{ 0 1 0 1 }
|
|
|
|
{ 2 2 3 3 }
|
|
|
|
}
|
|
|
|
] }
|
|
|
|
{ 8 [
|
|
|
|
4 shuffles-for
|
|
|
|
4 shuffles-for
|
|
|
|
[ [ 4 + ] map ] map
|
|
|
|
[ append ] 2map
|
|
|
|
] }
|
2010-01-14 13:48:57 -05:00
|
|
|
[ dup '[ _ random ] replicate 1array ]
|
2009-09-29 05:46:38 -04:00
|
|
|
} case ;
|
|
|
|
|
|
|
|
simd-classes [
|
|
|
|
[ [ { } ] ] dip
|
|
|
|
[ new length shuffles-for ] keep
|
|
|
|
'[
|
|
|
|
_ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ]
|
|
|
|
[ = ] check-optimizer
|
|
|
|
] unit-test
|
|
|
|
] each
|
|
|
|
|
2009-10-10 11:40:09 -04:00
|
|
|
"== Checking variable shuffles" print
|
|
|
|
|
|
|
|
: random-shift-vector ( class -- vec )
|
2010-01-14 13:48:57 -05:00
|
|
|
new [ drop 16 random ] map ;
|
2009-10-10 11:40:09 -04:00
|
|
|
|
|
|
|
:: test-shift-vector ( class -- ? )
|
2009-11-10 17:48:06 -05:00
|
|
|
[
|
|
|
|
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( -- ? ) ;
|
2009-10-10 11:40:09 -04:00
|
|
|
|
|
|
|
{ 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
|
|
|
|
|
2009-10-03 12:47:02 -04:00
|
|
|
"== Checking vector tests" print
|
2009-10-01 22:24:14 -04:00
|
|
|
|
|
|
|
:: test-vector-tests-bool ( vector declaration -- none? any? all? )
|
2009-11-10 17:48:06 -05:00
|
|
|
[
|
|
|
|
vector
|
|
|
|
[ [ declaration declare vnone? ] compile-call ]
|
|
|
|
[ [ declaration declare vany? ] compile-call ]
|
|
|
|
[ [ declaration declare vall? ] compile-call ] tri
|
|
|
|
] call( -- none? any? all? ) ;
|
2009-10-01 22:24:14 -04:00
|
|
|
|
|
|
|
: yes ( -- x ) t ;
|
|
|
|
: no ( -- x ) f ;
|
|
|
|
|
|
|
|
:: test-vector-tests-branch ( vector declaration -- none? any? all? )
|
2009-11-10 17:48:06 -05:00
|
|
|
[
|
|
|
|
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? ) ;
|
2009-10-01 22:24:14 -04:00
|
|
|
|
2009-10-16 17:28:53 -04:00
|
|
|
TUPLE: inconsistent-vector-test bool branch ;
|
2009-10-01 22:24:14 -04:00
|
|
|
|
2009-10-16 17:28:53 -04:00
|
|
|
: ?inconsistent ( bool branch -- ?/inconsistent )
|
|
|
|
2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
|
2009-10-01 22:24:14 -04:00
|
|
|
|
|
|
|
:: test-vector-tests ( vector decl -- none? any? all? )
|
2009-11-10 17:48:06 -05:00
|
|
|
[
|
|
|
|
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? ) ;
|
2009-10-01 22:24:14 -04:00
|
|
|
|
|
|
|
[ f t t ]
|
|
|
|
[ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
|
|
|
|
[ f t f ]
|
|
|
|
[ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test
|
|
|
|
[ t f f ]
|
|
|
|
[ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test
|
|
|
|
|
|
|
|
[ f t t ]
|
|
|
|
[ double-2{ t t } { double-2 } test-vector-tests ] unit-test
|
|
|
|
[ f t f ]
|
|
|
|
[ double-2{ f t } { double-2 } test-vector-tests ] unit-test
|
|
|
|
[ t f f ]
|
|
|
|
[ double-2{ f f } { double-2 } test-vector-tests ] unit-test
|
|
|
|
|
|
|
|
[ f t t ]
|
|
|
|
[ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test
|
|
|
|
[ f t f ]
|
|
|
|
[ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test
|
|
|
|
[ t f f ]
|
|
|
|
[ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
|
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
"== Checking element access" print
|
|
|
|
|
|
|
|
! Test element access -- it should box bignums for int-4 on x86
|
|
|
|
: test-accesses ( seq -- failures )
|
2010-01-14 10:10:13 -05:00
|
|
|
[ length iota >array ] keep
|
2009-09-29 05:46:38 -04:00
|
|
|
'[ [ _ 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
|
|
|
|
|
2009-09-29 23:58:20 -04:00
|
|
|
[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
|
2009-09-30 21:04:37 -04:00
|
|
|
[ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test
|
2009-09-29 23:58:20 -04:00
|
|
|
[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
|
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
[ { } ] [ 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
|
|
|
|
|
2009-09-29 23:58:20 -04:00
|
|
|
"== Checking broadcast" print
|
|
|
|
: test-broadcast ( seq -- failures )
|
2010-01-14 10:10:13 -05:00
|
|
|
[ length iota >array ] keep
|
2009-11-10 17:48:06 -05:00
|
|
|
'[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
|
2009-09-29 23:58:20 -04:00
|
|
|
|
|
|
|
[ { } ] [ 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
|
|
|
|
|
|
|
|
[ { } ] [ 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
|
|
|
|
|
2009-09-30 21:04:37 -04:00
|
|
|
! 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
|
2009-09-29 23:58:20 -04:00
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
"== Checking alien operations" print
|
2009-09-03 03:33:07 -04:00
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
[ float-4{ 1 2 3 4 } ] [
|
|
|
|
[
|
|
|
|
float-4{ 1 2 3 4 }
|
|
|
|
underlying>> 0 float-4-rep alien-vector
|
|
|
|
] compile-call float-4 boa
|
2009-09-03 03:33:07 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
|
|
|
|
16 [ 1 ] B{ } replicate-as 16 <byte-array>
|
|
|
|
[
|
|
|
|
0 [
|
|
|
|
{ byte-array c-ptr fixnum } declare
|
|
|
|
float-4-rep set-alien-vector
|
|
|
|
] compile-call
|
|
|
|
] keep
|
2009-09-03 03:33:07 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
[ float-array{ 1 2 3 4 } ] [
|
|
|
|
[
|
|
|
|
float-array{ 1 2 3 4 } underlying>>
|
|
|
|
float-array{ 4 3 2 1 } clone
|
|
|
|
[ underlying>> 0 float-4-rep set-alien-vector ] keep
|
|
|
|
] compile-call
|
2009-09-03 03:33:07 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
STRUCT: simd-struct
|
|
|
|
{ x float-4 }
|
2009-10-10 13:23:25 -04:00
|
|
|
{ y longlong-2 }
|
2009-11-18 23:32:05 -05:00
|
|
|
{ z double-2 }
|
|
|
|
{ w int-4 } ;
|
2009-09-03 03:33:07 -04:00
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
|
2009-09-03 03:33:07 -04:00
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
[
|
2009-09-03 21:58:56 -04:00
|
|
|
float-4{ 1 2 3 4 }
|
2009-10-10 13:23:25 -04:00
|
|
|
longlong-2{ 2 1 }
|
2009-11-18 23:32:05 -05:00
|
|
|
double-2{ 4 3 }
|
|
|
|
int-4{ 1 2 3 4 }
|
2009-09-20 17:48:17 -04:00
|
|
|
] [
|
|
|
|
simd-struct <struct>
|
|
|
|
float-4{ 1 2 3 4 } >>x
|
2009-10-10 13:23:25 -04:00
|
|
|
longlong-2{ 2 1 } >>y
|
2009-11-18 23:32:05 -05:00
|
|
|
double-2{ 4 3 } >>z
|
|
|
|
int-4{ 1 2 3 4 } >>w
|
2009-09-20 17:48:17 -04:00
|
|
|
{ [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
|
2009-09-03 21:58:56 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-09-20 17:48:17 -04:00
|
|
|
[
|
|
|
|
float-4{ 1 2 3 4 }
|
2009-10-10 13:23:25 -04:00
|
|
|
longlong-2{ 2 1 }
|
2009-11-18 23:32:05 -05:00
|
|
|
double-2{ 4 3 }
|
|
|
|
int-4{ 1 2 3 4 }
|
2009-09-20 17:48:17 -04:00
|
|
|
] [
|
|
|
|
[
|
|
|
|
simd-struct <struct>
|
|
|
|
float-4{ 1 2 3 4 } >>x
|
2009-10-10 13:23:25 -04:00
|
|
|
longlong-2{ 2 1 } >>y
|
2009-11-18 23:32:05 -05:00
|
|
|
double-2{ 4 3 } >>z
|
|
|
|
int-4{ 1 2 3 4 } >>w
|
2009-09-20 17:48:17 -04:00
|
|
|
{ [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
|
|
|
|
] compile-call
|
2009-09-03 21:58:56 -04:00
|
|
|
] unit-test
|
2009-09-23 03:46:54 -04:00
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
"== Misc tests" print
|
2009-09-29 00:12:13 -04:00
|
|
|
|
2009-09-29 05:46:38 -04:00
|
|
|
[ ] [ char-16 new 1array stack. ] unit-test
|
2009-09-29 00:12:13 -04:00
|
|
|
|
2009-09-29 23:58:20 -04:00
|
|
|
! CSSA bug
|
2009-11-24 21:30:12 -05:00
|
|
|
[ 4000000 ] [
|
2009-11-18 23:32:05 -05:00
|
|
|
int-4{ 1000 1000 1000 1000 }
|
|
|
|
[ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
|
2009-09-29 05:46:38 -04:00
|
|
|
] unit-test
|
2009-09-29 23:58:20 -04:00
|
|
|
|
|
|
|
! Coalescing was too aggressive
|
|
|
|
:: broken ( axis theta -- a b c )
|
|
|
|
axis { float-4 } declare drop
|
|
|
|
theta { float } declare drop
|
|
|
|
|
|
|
|
theta cos float-4-with :> cc
|
|
|
|
theta sin float-4-with :> ss
|
|
|
|
|
|
|
|
axis cc v+ :> diagonal
|
|
|
|
|
|
|
|
diagonal cc ss ; inline
|
|
|
|
|
|
|
|
[ t ] [
|
|
|
|
float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
|
|
|
|
[ compile-call ] [ call ] 3bi =
|
|
|
|
] unit-test
|
2009-11-04 00:51:44 -05:00
|
|
|
|
|
|
|
! 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
|