steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math.vectors.simd: vlshift, vrshift, hlshift and hrshift were being miscompiled if the shift count was a bignum. Fixes #264

db4
Slava Pestov 2011-10-30 21:49:23 -07:00
parent 3b92ff881c
commit b31ffdfcb4
2 changed files with 48 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
basis/math/vectors/simd/simd-tests.factor
View File

@ -124,7 +124,14 @@ CONSTANT: vector-words
: boa-ctors ( -- seq ) : boa-ctors ( -- seq )
simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ; simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
: check-optimizer ( seq quot eq-quot -- failures ) : check-optimizer ( seq test-quot eq-quot -- 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 ) )
#! eq-quot: ( result1 result2 -- ? )
dup '[ dup '[
@ @
[ dup [ class-of ] { } map-as ] dip '[ _ declare @ ] [ dup [ class-of ] { } map-as ] dip '[ _ declare @ ]
@ -320,6 +327,9 @@ simd-classes&reps [
[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ] [ 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{ 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{ 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{ 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
@ -329,9 +339,21 @@ simd-classes&reps [
[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ] [ 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{ 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{ 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 [ 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 ! 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
@ -510,7 +532,7 @@ TUPLE: inconsistent-vector-test bool branch ;
! Test element access -- it should box bignums for int-4 on x86 ! Test element access -- it should box bignums for int-4 on x86
: test-accesses ( seq -- failures ) : test-accesses ( seq -- failures )
[ length iota >array ] keep [ length iota dup [ >bignum ] map append ] keep
'[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test

43
basis/math/vectors/simd/simd.factor
View File

@ -75,35 +75,40 @@ DEFER: simd-construct-op
: v->v-op ( a rep quot: ( (a) rep -- (c) ) fallback-quot -- c ) : v->v-op ( a rep quot: ( (a) rep -- (c) ) fallback-quot -- c )
drop [ simd-unbox ] 2dip 2curry make-underlying ; inline drop [ simd-unbox ] 2dip 2curry make-underlying ; inline
: vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c ) : vx->v-op ( a obj rep quot: ( (a) obj rep -- (c) ) fallback-quot -- c )
drop [ simd-unbox ] 3dip 3curry make-underlying ; inline drop [ simd-unbox ] 3dip 3curry make-underlying ; inline
: vn->n-op ( a n rep quot: ( (a) n rep -- n ) fallback-quot -- n ) : vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c )
drop [ [ simd-unbox ] [ >fixnum ] bi* ] 2dip 3curry make-underlying ; inline
: vx->x-op ( a obj rep quot: ( (a) obj rep -- obj ) fallback-quot -- obj )
drop [ underlying>> ] 3dip call ; inline drop [ underlying>> ] 3dip call ; inline
: v->n-op ( a rep quot: ( (a) rep -- n ) fallback-quot -- n ) : v->x-op ( a rep quot: ( (a) rep -- obj ) fallback-quot -- obj )
drop [ underlying>> ] 2dip call ; inline drop [ underlying>> ] 2dip call ; inline
: (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c ) : (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c )
[ [ simd-unbox ] [ underlying>> ] bi* ] 2dip 3curry make-underlying ; inline [ [ simd-unbox ] [ underlying>> ] bi* ] 2dip 3curry make-underlying ; inline
: (vv->n-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
: (vv->x-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
[ [ underlying>> ] bi@ ] 2dip 3curry call ; inline [ [ underlying>> ] bi@ ] 2dip 3curry call ; inline
: (vvn->v-op) ( a b n rep quot: ( (a) (b) n rep -- (c) ) -- c )
: (vvx->v-op) ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) -- c )
[ [ simd-unbox ] [ underlying>> ] bi* ] 3dip 2curry 2curry make-underlying ; inline [ [ simd-unbox ] [ underlying>> ] bi* ] 3dip 2curry 2curry make-underlying ; inline
: vv->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c ) : vv->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
[ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
:: vvn->v-op ( a b n rep quot: ( (a) (b) n rep -- (c) ) fallback-quot -- c ) :: vvx->v-op ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) fallback-quot -- c )
a b rep a b rep
[ n swap quot (vvn->v-op) ] [ obj swap quot (vvx->v-op) ]
[ drop n fallback-quot call ] if-both-vectors-match ; inline [ drop obj fallback-quot call ] if-both-vectors-match ; inline
: vv'->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c ) : vv'->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
[ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline
: vv->n-op ( a b rep quot: ( (a) (b) rep -- n ) fallback-quot -- n ) : vv->x-op ( a b rep quot: ( (a) (b) rep -- obj ) fallback-quot -- obj )
[ '[ _ (vv->n-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline [ '[ _ (vv->x-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
PRIVATE> PRIVATE>
>> >>
@ -153,13 +158,13 @@ M: simd-128 vmin
M: simd-128 vmax M: simd-128 vmax
dup simd-rep [ (simd-vmax) ] [ call-next-method ] vv->v-op ; inline dup simd-rep [ (simd-vmax) ] [ call-next-method ] vv->v-op ; inline
M: simd-128 v. M: simd-128 v.
dup simd-rep [ (simd-v.) ] [ call-next-method ] vv->n-op ; inline dup simd-rep [ (simd-v.) ] [ call-next-method ] vv->x-op ; inline
M: simd-128 vsad M: simd-128 vsad
dup simd-rep [ (simd-vsad) ] [ call-next-method ] vv->n-op ; inline dup simd-rep [ (simd-vsad) ] [ call-next-method ] vv->x-op ; inline
M: simd-128 vsqrt M: simd-128 vsqrt
dup simd-rep [ (simd-vsqrt) ] [ call-next-method ] v->v-op ; inline dup simd-rep [ (simd-vsqrt) ] [ call-next-method ] v->v-op ; inline
M: simd-128 sum M: simd-128 sum
dup simd-rep [ (simd-sum) ] [ call-next-method ] v->n-op ; inline dup simd-rep [ (simd-sum) ] [ call-next-method ] v->x-op ; inline
M: simd-128 vabs M: simd-128 vabs
dup simd-rep [ (simd-vabs) ] [ call-next-method ] v->v-op ; inline dup simd-rep [ (simd-vabs) ] [ call-next-method ] v->v-op ; inline
M: simd-128 vbitand M: simd-128 vbitand
@ -191,9 +196,9 @@ M: simd-128 hlshift
M: simd-128 hrshift M: simd-128 hrshift
over simd-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline over simd-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline
M: simd-128 vshuffle-elements M: simd-128 vshuffle-elements
over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vn->v-op ; inline over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vx->v-op ; inline
M: simd-128 vshuffle2-elements M: simd-128 vshuffle2-elements
over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvn->v-op ; inline over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvx->v-op ; inline
M: simd-128 vshuffle-bytes M: simd-128 vshuffle-bytes
dup simd-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline dup simd-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline
M: simd-128 (vmerge-head) M: simd-128 (vmerge-head)
@ -213,11 +218,11 @@ M: simd-128 v>=
M: simd-128 vunordered? M: simd-128 vunordered?
dup simd-rep [ (simd-vunordered?) ] [ call-next-method ] vv->v-op ; inline dup simd-rep [ (simd-vunordered?) ] [ call-next-method ] vv->v-op ; inline
M: simd-128 vany? M: simd-128 vany?
dup simd-rep [ (simd-vany?) ] [ call-next-method ] v->n-op ; inline dup simd-rep [ (simd-vany?) ] [ call-next-method ] v->x-op ; inline
M: simd-128 vall? M: simd-128 vall?
dup simd-rep [ (simd-vall?) ] [ call-next-method ] v->n-op ; inline dup simd-rep [ (simd-vall?) ] [ call-next-method ] v->x-op ; inline
M: simd-128 vnone? M: simd-128 vnone?
dup simd-rep [ (simd-vnone?) ] [ call-next-method ] v->n-op ; inline dup simd-rep [ (simd-vnone?) ] [ call-next-method ] v->x-op ; inline
! SIMD high-level specializations ! SIMD high-level specializations
@ -266,7 +271,7 @@ M: A simd-element-type drop ELT ; inline
M: A simd-with drop A-with ; inline M: A simd-with drop A-with ; inline
M: A nth-unsafe M: A nth-unsafe
swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline swap \ A-rep [ (simd-select) ] [ call-next-method ] vx->x-op ; inline
M: A set-nth-unsafe M: A set-nth-unsafe
[ ELT boolean>element ] 2dip [ ELT boolean>element ] 2dip
underlying>> ELT c:set-alien-element ; inline underlying>> ELT c:set-alien-element ; inline