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

make math.vectors.simd tests pass again

db4
Joe Groff 2009-11-24 18:30:12 -08:00
parent 9c388bf781
commit c98eb84943
5 changed files with 57 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -253,14 +253,15 @@ IN: compiler.cfg.intrinsics.simd
src rep ^unpack-vector-head :> head src rep ^unpack-vector-head :> head
src rep ^unpack-vector-tail :> tail src rep ^unpack-vector-tail :> tail
rep widen-vector-rep :> wide-rep rep widen-vector-rep :> wide-rep
head tail wide-rep ^^add-vector wide-rep ^(sum-vector) head tail wide-rep ^^add-vector wide-rep
^(sum-vector)
] } ] }
} v-vector-op ; } v-vector-op ;
: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ; : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
: ^shuffle-vector-imm ( src1 src2 rep -- dst ) : ^shuffle-vector-imm ( src1 shuffle rep -- dst )
{ [ rep-length 0 pad-tail ] keep {
[ ^^shuffle-vector-imm ] [ ^^shuffle-vector-imm ]
[ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ] [ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ]
} vl-vector-op ; } vl-vector-op ;
@ -358,7 +359,7 @@ IN: compiler.cfg.intrinsics.simd
: emit-simd-v. ( node -- ) : emit-simd-v. ( node -- )
{ {
[ ^^dot-vector ] [ ^^dot-vector ]
[ [ ^^mul-vector ] [ ^sum-vector ] bi ] { float-vector-rep [ [ ^^mul-vector ] [ ^sum-vector ] bi ] }
} emit-vv-vector-op ; } emit-vv-vector-op ;
: emit-simd-vsqrt ( node -- ) : emit-simd-vsqrt ( node -- )

28
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -112,8 +112,8 @@ IN: math.vectors.simd.intrinsics
a rep >rep-array :> a' a rep >rep-array :> a'
rep <rep-array> :> c' rep <rep-array> :> c'
elts [| from to | elts [| from to |
from a' nth-unsafe from rep rep-length 1 - bitand
rep rep-length 1 - bitand a' nth-unsafe
to c' set-nth-unsafe to c' set-nth-unsafe
] each-index ] each-index
c' underlying>> ; inline c' underlying>> ; inline
@ -134,9 +134,12 @@ PRIVATE>
n 1 + c' set-nth-unsafe n 1 + c' set-nth-unsafe
] each ] each
c' underlying>> ; c' underlying>> ;
: (simd-vs+) ( a b rep -- c ) dup '[ + _ c-type-clamp ] components-2map ; : (simd-vs+) ( a b rep -- c )
: (simd-vs-) ( a b rep -- c ) dup '[ - _ c-type-clamp ] components-2map ; dup rep-component-type '[ + _ c-type-clamp ] components-2map ;
: (simd-vs*) ( a b rep -- c ) dup '[ - _ c-type-clamp ] components-2map ; : (simd-vs-) ( a b rep -- c )
dup rep-component-type '[ - _ c-type-clamp ] components-2map ;
: (simd-vs*) ( a b rep -- c )
dup rep-component-type '[ * _ c-type-clamp ] components-2map ;
: (simd-v*) ( a b rep -- c ) [ * ] components-2map ; : (simd-v*) ( a b rep -- c ) [ * ] components-2map ;
: (simd-v/) ( a b rep -- c ) [ / ] components-2map ; : (simd-v/) ( a b rep -- c ) [ / ] components-2map ;
: (simd-vmin) ( a b rep -- c ) [ min ] components-2map ; : (simd-vmin) ( a b rep -- c ) [ min ] components-2map ;
@ -160,9 +163,9 @@ PRIVATE>
: (simd-vlshift) ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ; : (simd-vlshift) ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
: (simd-vrshift) ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ; : (simd-vrshift) ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
: (simd-hlshift) ( a n rep -- c ) : (simd-hlshift) ( a n rep -- c )
drop tail-slice 16 0 pad-tail ; drop head-slice* 16 0 pad-head ;
: (simd-hrshift) ( a n rep -- c ) : (simd-hrshift) ( a n rep -- c )
drop head-slice 16 0 pad-head ; drop tail-slice 16 0 pad-tail ;
: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ; : (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
: (simd-vshuffle-bytes) ( a b rep -- c ) drop uchar-16-rep (vshuffle) ; : (simd-vshuffle-bytes) ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
:: (simd-vmerge-head) ( a b rep -- c ) :: (simd-vmerge-head) ( a b rep -- c )
@ -198,17 +201,17 @@ PRIVATE>
: (simd-vall?) ( a rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ; : (simd-vall?) ( a rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
: (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ; : (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ;
: (simd-v>float) ( a rep -- c ) : (simd-v>float) ( a rep -- c )
[ >rep-array ] [ >float-vector-rep [>rep-array] ] bi call( i -- f ) ; [ >rep-array ] [ >float-vector-rep [>rep-array] ] bi call( i -- f ) underlying>> ;
: (simd-v>integer) ( a rep -- c ) : (simd-v>integer) ( a rep -- c )
[ >rep-array ] [ >int-vector-rep [>rep-array] ] bi call( i -- f ) ; [ >rep-array ] [ >int-vector-rep [>rep-array] ] bi call( i -- f ) underlying>> ;
: (simd-vpack-signed) ( a b rep -- c ) : (simd-vpack-signed) ( a b rep -- c )
[ 2>rep-array cord-append ] [ 2>rep-array cord-append ]
[ narrow-vector-rep [ [<rep-array>] ] [ rep-component-type ] bi ] bi [ narrow-vector-rep [ [<rep-array>] ] [ rep-component-type ] bi ] bi
'[ _ c-type-clamp ] swap map-as ; '[ _ c-type-clamp ] swap map-as underlying>> ;
: (simd-vpack-unsigned) ( a b rep -- c ) : (simd-vpack-unsigned) ( a b rep -- c )
[ 2>rep-array cord-append ] [ 2>rep-array cord-append ]
[ narrow-vector-rep >uint-vector-rep [ [<rep-array>] ] [ rep-component-type ] bi ] bi [ narrow-vector-rep >uint-vector-rep [ [<rep-array>] ] [ rep-component-type ] bi ] bi
'[ _ c-type-clamp ] swap map-as ; '[ _ c-type-clamp ] swap map-as underlying>> ;
: (simd-vunpack-head) ( a rep -- c ) : (simd-vunpack-head) ( a rep -- c )
[ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
[ head-slice ] dip call( a' -- c' ) underlying>> ; [ head-slice ] dip call( a' -- c' ) underlying>> ;
@ -216,7 +219,8 @@ PRIVATE>
[ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
[ tail-slice ] dip call( a' -- c' ) underlying>> ; [ tail-slice ] dip call( a' -- c' ) underlying>> ;
: (simd-with) ( n rep -- v ) : (simd-with) ( n rep -- v )
[ rep-length iota swap '[ _ ] ] [ <rep-array> ] bi replicate-as ; [ rep-length iota swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ;
: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ; : (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ; : (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
: (simd-select) ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ; : (simd-select) ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;

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

@ -5,7 +5,8 @@ math.vectors.simd.private prettyprint random sequences system
tools.test vocabs assocs compiler.cfg.debugger words tools.test vocabs assocs compiler.cfg.debugger words
locals combinators cpu.architecture namespaces byte-arrays alien locals combinators cpu.architecture namespaces byte-arrays alien
specialized-arrays classes.struct eval classes.algebra sets specialized-arrays classes.struct eval classes.algebra sets
quotations math.constants compiler.units ; quotations math.constants compiler.units splitting ;
FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float SPECIALIZED-ARRAY: c:float
IN: math.vectors.simd.tests IN: math.vectors.simd.tests
@ -261,8 +262,8 @@ simd-classes&reps [
: check-boolean-ops ( class elt-class compare-quot -- seq ) : check-boolean-ops ( class elt-class compare-quot -- seq )
[ [
[ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip [ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
'[ first2 inputs _ _ check-boolean-op ] '[ first2 vector-word-inputs _ _ check-boolean-op ]
] dip check-optimizer ; inline ] dip check-optimizer ; inline
simd-classes&reps [ simd-classes&reps [
@ -558,7 +559,7 @@ STRUCT: simd-struct
[ ] [ char-16 new 1array stack. ] unit-test [ ] [ char-16 new 1array stack. ] unit-test
! CSSA bug ! CSSA bug
[ 8000000 ] [ [ 4000000 ] [
int-4{ 1000 1000 1000 1000 } int-4{ 1000 1000 1000 1000 }
[ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call [ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
] unit-test ] unit-test

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

@ -49,6 +49,9 @@ TUPLE: simd-128
GENERIC: simd-element-type ( obj -- c-type ) GENERIC: simd-element-type ( obj -- c-type )
GENERIC: simd-rep ( simd -- rep ) GENERIC: simd-rep ( simd -- rep )
M: object simd-element-type drop f ;
M: object simd-rep drop f ;
<< <<
<PRIVATE <PRIVATE
@ -62,9 +65,6 @@ DEFER: simd-construct-op
[ 3dup [ drop [ simd-128? ] both? ] [ '[ simd-rep _ eq? ] both? ] 3bi and ] [ 3dup [ drop [ simd-128? ] both? ] [ '[ simd-rep _ eq? ] both? ] 3bi and ]
2dip if ; inline 2dip if ; inline
: simd-construct-op ( exemplar quot: ( rep -- v ) -- v )
[ dup simd-rep ] dip curry make-underlying ; inline
: simd-unbox ( a -- a (a) ) : simd-unbox ( a -- a (a) )
[ ] [ underlying>> ] bi ; inline [ ] [ underlying>> ] bi ; inline
@ -74,6 +74,9 @@ DEFER: simd-construct-op
: vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c ) : vn->v-op ( a n rep quot: ( (a) n 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 )
drop [ underlying>> ] 3dip call ; inline
: v->n-op ( a rep quot: ( (a) rep -- n ) fallback-quot -- n ) : v->n-op ( a rep quot: ( (a) rep -- n ) fallback-quot -- n )
drop [ underlying>> ] 2dip call ; inline drop [ underlying>> ] 2dip call ; inline
@ -95,9 +98,6 @@ DEFER: simd-construct-op
PRIVATE> PRIVATE>
>> >>
DEFER: simd-with
DEFER: simd-cast
<< <<
<PRIVATE <PRIVATE
@ -115,6 +115,7 @@ A{ DEFINES ${T}{
ELT [ A-rep rep-component-type ] ELT [ A-rep rep-component-type ]
N [ A-rep rep-length ] N [ A-rep rep-length ]
COERCER [ ELT c-type-class "coercer" word-prop [ ] or ]
SET-NTH [ ELT dup c:c-setter c:array-accessor ] SET-NTH [ ELT dup c:c-setter c:array-accessor ]
@ -136,8 +137,8 @@ M: A set-nth-unsafe
M: A like drop dup \ A instance? [ >A ] unless ; inline M: A like drop dup \ A instance? [ >A ] unless ; inline
: A-with ( n -- v ) \ A new simd-with ; inline : A-with ( n -- v ) COERCER call \ A-rep (simd-with) \ A boa ; inline
: A-cast ( v -- v' ) \ A new simd-cast ; inline : A-cast ( v -- v' ) underlying>> \ A boa ; inline
! SIMD vectors as sequences ! SIMD vectors as sequences
@ -145,24 +146,7 @@ M: A hashcode* underlying>> hashcode* ; inline
M: A clone [ clone ] change-underlying ; inline M: A clone [ clone ] change-underlying ; inline
M: A length drop N ; inline M: A length drop N ; inline
M: A nth-unsafe M: A nth-unsafe
swap { swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline
{ 0 [ 0 \ A-rep (simd-select) ] }
{ 1 [ 1 \ A-rep (simd-select) ] }
{ 2 [ 2 \ A-rep (simd-select) ] }
{ 3 [ 3 \ A-rep (simd-select) ] }
{ 4 [ 4 \ A-rep (simd-select) ] }
{ 5 [ 5 \ A-rep (simd-select) ] }
{ 6 [ 6 \ A-rep (simd-select) ] }
{ 7 [ 7 \ A-rep (simd-select) ] }
{ 8 [ 8 \ A-rep (simd-select) ] }
{ 9 [ 9 \ A-rep (simd-select) ] }
{ 10 [ 10 \ A-rep (simd-select) ] }
{ 11 [ 11 \ A-rep (simd-select) ] }
{ 12 [ 12 \ A-rep (simd-select) ] }
{ 13 [ 13 \ A-rep (simd-select) ] }
{ 14 [ 14 \ A-rep (simd-select) ] }
{ 15 [ 15 \ A-rep (simd-select) ] }
} case ; inline
M: A c:byte-length drop 16 ; inline M: A c:byte-length drop 16 ; inline
M: A new-sequence M: A new-sequence
@ -171,7 +155,7 @@ M: A new-sequence
[ length bad-simd-length ] if ; inline [ length bad-simd-length ] if ; inline
M: A equal? M: A equal?
\ A [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline \ A-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
! SIMD primitive operations ! SIMD primitive operations
@ -205,7 +189,7 @@ M: A vrshift \ A-rep [ (simd-vrshift) ] [ call-next-method ]
M: A hlshift \ A-rep [ (simd-hlshift) ] [ call-next-method ] vn->v-op ; inline M: A hlshift \ A-rep [ (simd-hlshift) ] [ call-next-method ] vn->v-op ; inline
M: A hrshift \ A-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline M: A hrshift \ A-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline
M: A vshuffle-elements \ A-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vn->v-op ; inline M: A vshuffle-elements \ A-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vn->v-op ; inline
M: A vshuffle-bytes \ A-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv->v-op ; inline M: A vshuffle-bytes \ A-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline
M: A (vmerge-head) \ A-rep [ (simd-vmerge-head) ] [ call-next-method ] vv->v-op ; inline M: A (vmerge-head) \ A-rep [ (simd-vmerge-head) ] [ call-next-method ] vv->v-op ; inline
M: A (vmerge-tail) \ A-rep [ (simd-vmerge-tail) ] [ call-next-method ] vv->v-op ; inline M: A (vmerge-tail) \ A-rep [ (simd-vmerge-tail) ] [ call-next-method ] vv->v-op ; inline
M: A v<= \ A-rep [ (simd-v<=) ] [ call-next-method ] vv->v-op ; inline M: A v<= \ A-rep [ (simd-v<=) ] [ call-next-method ] vv->v-op ; inline
@ -220,15 +204,15 @@ M: A vnone? \ A-rep [ (simd-vnone?) ] [ call-next-method ]
! SIMD high-level specializations ! SIMD high-level specializations
M: A vbroadcast [ swap nth ] keep simd-with ; inline M: A vbroadcast swap nth A-with ; inline
M: A n+v [ simd-with ] keep v+ ; inline M: A n+v [ A-with ] dip v+ ; inline
M: A n-v [ simd-with ] keep v- ; inline M: A n-v [ A-with ] dip v- ; inline
M: A n*v [ simd-with ] keep v* ; inline M: A n*v [ A-with ] dip v* ; inline
M: A n/v [ simd-with ] keep v/ ; inline M: A n/v [ A-with ] dip v/ ; inline
M: A v+n over simd-with v+ ; inline M: A v+n A-with v+ ; inline
M: A v-n over simd-with v- ; inline M: A v-n A-with v- ; inline
M: A v*n over simd-with v* ; inline M: A v*n A-with v* ; inline
M: A v/n over simd-with v/ ; inline M: A v/n A-with v/ ; inline
M: A norm-sq dup v. assert-positive ; inline M: A norm-sq dup v. assert-positive ; inline
M: A norm norm-sq sqrt ; inline M: A norm norm-sq sqrt ; inline
M: A distance v- norm ; inline M: A distance v- norm ; inline
@ -236,11 +220,13 @@ M: A distance v- norm ; inline
! M: simd-128 >pprint-sequence ; ! M: simd-128 >pprint-sequence ;
! M: simd-128 pprint* pprint-object ; ! M: simd-128 pprint* pprint-object ;
\ A-boa \ A new N { \ A-boa
{ 2 [ '[ _ [ (simd-gather-2) ] simd-construct-op ] ] } [ COERCER N napply ] N {
{ 4 [ '[ _ [ (simd-gather-4) ] simd-construct-op ] ] } { 2 [ [ A-rep (simd-gather-2) A boa ] ] }
[ swap '[ _ _ nsequence ] ] { 4 [ [ A-rep (simd-gather-4) A boa ] ] }
} case BOA-EFFECT define-inline [ \ A new '[ _ _ nsequence ] ]
} case compose
BOA-EFFECT define-inline
M: A pprint-delims drop \ A{ \ } ; M: A pprint-delims drop \ A{ \ } ;
SYNTAX: A{ \ } [ >A ] parse-literal ; SYNTAX: A{ \ } [ >A ] parse-literal ;
@ -248,7 +234,7 @@ SYNTAX: A{ \ } [ >A ] parse-literal ;
c:<c-type> c:<c-type>
byte-array >>class byte-array >>class
A >>boxed-class A >>boxed-class
[ A-rep alien-vector \ A boa ] >>getter [ A-rep alien-vector A boa ] >>getter
[ [ underlying>> ] 2dip A-rep set-alien-vector ] >>setter [ [ underlying>> ] 2dip A-rep set-alien-vector ] >>setter
16 >>size 16 >>size
16 >>align 16 >>align
@ -266,21 +252,6 @@ PRIVATE>
INSTANCE: simd-128 sequence INSTANCE: simd-128 sequence
! SIMD constructors
: simd-with ( n seq -- v )
[ (simd-with) ] simd-construct-op ; inline
MACRO: simd-boa ( class -- )
new dup length {
{ 2 [ '[ _ [ (simd-gather-2) ] simd-construct-op ] ] }
{ 4 [ '[ _ [ (simd-gather-4) ] simd-construct-op ] ] }
[ swap '[ _ _ nsequence ] ]
} case ;
: simd-cast ( v seq -- v' )
[ underlying>> ] dip new-underlying ; inline
! SIMD instances ! SIMD instances
SIMD-128: char-16 SIMD-128: char-16

6
basis/math/vectors/vectors.factor
View File

@ -108,10 +108,6 @@ M: object vshuffle-elements
swap [ '[ _ nth ] ] keep map-as ; swap [ '[ _ nth ] ] keep map-as ;
GENERIC# vshuffle-bytes 1 ( u perm -- v ) GENERIC# vshuffle-bytes 1 ( u perm -- v )
M: object vshuffle-bytes
underlying>> [
swap [ '[ 15 bitand _ nth ] ] keep map-as
] curry change-underlying ;
GENERIC: vshuffle ( u perm -- v ) GENERIC: vshuffle ( u perm -- v )
M: array vshuffle ( u perm -- v ) M: array vshuffle ( u perm -- v )
@ -123,9 +119,7 @@ GENERIC# vrshift 1 ( u n -- w )
M: object vrshift neg '[ _ shift ] map ; M: object vrshift neg '[ _ shift ] map ;
GENERIC# hlshift 1 ( u n -- w ) GENERIC# hlshift 1 ( u n -- w )
M: object hlshift '[ _ <byte-array> prepend 16 head ] change-underlying ;
GENERIC# hrshift 1 ( u n -- w ) GENERIC# hrshift 1 ( u n -- w )
M: object hrshift '[ _ <byte-array> append 16 tail* ] change-underlying ;
GENERIC: (vmerge-head) ( u v -- h ) GENERIC: (vmerge-head) ( u v -- h )
M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ;