: boa-ctors ( -- seq )
simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup-word ] map ;
-: check-optimizer ( seq test-quot eq-quot -- failures )
+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: ( -- values ) code-quot: ( values -- result ) )
+ #! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
#! eq-quot: ( result1 result2 -- ? )
- dup '[
- @
- [ dup [ class-of ] { } map-as ] dip '[ _ declare @ ]
- {
- [ "print-mr" get [ nip regs. ] [ 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
+ 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" [
+ "print-inline-mr" get [ code-quot' regs. ] when
+ [ 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
+ dup empty? [ dup ... ] unless ! Print full errors
+ ; inline
"== Checking -new constructors" print
] unit-test
[ { } ] [
- simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter
+ simd-classes [ '[ _ new ] compile-call [ zero? ] all? ] reject
] unit-test
"== Checking -with 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 ;
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 [ float? ] both? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
+ [ = ]
} cond ;
: simd-classes&reps ( -- alist )
'[ [ _ 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