-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 combinators cpu.architecture namespaces byte-arrays alien
specialized-arrays classes.struct eval classes.algebra sets
-quotations math.constants compiler.units splitting ;
+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
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
{ sum { +vector+ -> +scalar+ } }
+ { vcount { +vector+ -> +scalar+ } }
{ vabs { +vector+ -> +vector+ } }
{ vsqrt { +vector+ -> +vector+ } }
{ vbitand { +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 '[
- @
- [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
- {
- [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
- [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
- [ [ [ call ] dip call ] call( quot quot -- result ) ]
- [ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
- [ [ t "always-inline-simd-intrinsics" [ [ call ] dip compile-call ] with-variable ] call( quot quot -- result ) ]
- } 2cleave
- [ drop @ ] [ nip @ ] 3bi and not
- ] filter ; inline
+ 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 ]
+ 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
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 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 ;
float = [ remove-integer-words ] [ remove-float-words ] if
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 vector-word-inputs _ _ check-vector-op ]
{ [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ [ = ]
} cond ;
: approx= ( x y -- ? )
{
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
+ [ = ]
} cond ;
: simd-classes&reps ( -- alist )
[ 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
[ 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
+[ 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
+
[ 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{ 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 )
! Test element access -- it should box bignums for int-4 on x86
: test-accesses ( seq -- failures )
- [ length iota >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
'[ [ _ 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
[ ] [ 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
[ 4000000 ] [
int-4{ 1000 1000 1000 1000 }
[ 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