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

math.vectors.simd.intrinsics: use unrolled loops for some software fallbacks

db4
Joe Groff 2010-05-24 18:39:06 -07:00
parent 9391f10164
commit 1041ad5f9b
2 changed files with 56 additions and 33 deletions
basis
math/vectors/simd/intrinsics
sequences/unrolled

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

@ -1,10 +1,10 @@
! (c)2009 Slava Pestov, Joe Groff bsd license ! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.data combinators USING: accessors alien alien.data combinators
sequences.cords cpu.architecture fry generalizations grouping sequences.cords cpu.architecture fry generalizations grouping
kernel libc locals macros math math.libm math.order kernel libc locals macros math math.libm math.order
math.ranges math.vectors sequences sequences.generalizations math.ranges math.vectors sequences sequences.generalizations
sequences.private sequences.unrolled specialized-arrays sequences.private sequences.unrolled sequences.unrolled.private
vocabs.loader words effects.parser locals.parser ; specialized-arrays vocabs.loader words effects.parser locals.parser ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAYS: SPECIALIZED-ARRAYS:
c:char c:short c:int c:longlong c:char c:short c:int c:longlong
@ -111,27 +111,31 @@ SYNTAX: SIMD-INTRINSIC::
[<rep-array>] call( -- a' ) ; inline [<rep-array>] call( -- a' ) ; inline
: components-map ( a rep quot -- c ) : components-map ( a rep quot -- c )
[ >rep-array ] dip map underlying>> ; inline [ [ >rep-array ] [ rep-length ] bi ] dip unrolled-map-unsafe underlying>> ; inline
: components-2map ( a b rep quot -- c ) : components-2map ( a b rep quot -- c )
[ 2>rep-array ] dip 2map underlying>> ; inline [ [ 2>rep-array ] [ rep-length ] bi ] dip unrolled-2map-unsafe underlying>> ; inline
! XXX
: components-reduce ( a rep quot -- x ) : components-reduce ( a rep quot -- x )
[ >rep-array [ ] ] dip map-reduce ; inline [ >rep-array [ ] ] dip map-reduce ; inline
: bitwise-components-map ( a rep quot -- c ) : bitwise-components-map ( a rep quot -- c )
[ >bitwise-vector-rep >rep-array ] dip map underlying>> ; inline [ >bitwise-vector-rep [ >rep-array ] [ rep-length ] bi ] dip
unrolled-map-unsafe underlying>> ; inline
: bitwise-components-2map ( a b rep quot -- c ) : bitwise-components-2map ( a b rep quot -- c )
[ >bitwise-vector-rep 2>rep-array ] dip 2map underlying>> ; inline [ >bitwise-vector-rep [ 2>rep-array ] [ rep-length ] bi ] dip
unrolled-2map-unsafe underlying>> ; inline
! XXX
: bitwise-components-reduce ( a rep quot -- x ) : bitwise-components-reduce ( a rep quot -- x )
[ >bitwise-vector-rep >rep-array [ ] ] dip map-reduce ; inline [ >bitwise-vector-rep >rep-array [ ] ] dip map-reduce ; inline
:: (vshuffle) ( a elts rep -- c ) :: (vshuffle) ( a elts rep -- c )
a rep >rep-array :> a' a rep >rep-array :> a'
rep <rep-array> :> c' rep <rep-array> :> c'
elts [| from to | elts rep rep-length [| from to |
from rep rep-length 1 - bitand from rep rep-length 1 - bitand
a' nth-unsafe a' nth-unsafe
to c' set-nth-unsafe to c' set-nth-unsafe
] each-index ] unrolled-each-index-unsafe
c' underlying>> ; inline c' underlying>> ; inline
:: (vshuffle2) ( a b elts rep -- c ) :: (vshuffle2) ( a b elts rep -- c )
@ -139,13 +143,18 @@ SYNTAX: SIMD-INTRINSIC::
b rep >rep-array :> b' b rep >rep-array :> b'
a' b' cord-append :> ab' a' b' cord-append :> ab'
rep <rep-array> :> c' rep <rep-array> :> c'
elts [| from to | elts rep rep-length [| from to |
from rep rep-length dup + 1 - bitand from rep rep-length dup + 1 - bitand
ab' nth-unsafe ab' nth-unsafe
to c' set-nth-unsafe to c' set-nth-unsafe
] each-index ] unrolled-each-index-unsafe
c' underlying>> ; inline c' underlying>> ; inline
GENERIC: native/ ( x y -- x/y )
M: integer native/ /i ; inline
M: float native/ /f ; inline
PRIVATE> PRIVATE>
SIMD-INTRINSIC: (simd-v+) ( a b rep -- c ) [ + ] components-2map ; SIMD-INTRINSIC: (simd-v+) ( a b rep -- c ) [ + ] components-2map ;
@ -154,23 +163,23 @@ SIMD-INTRINSIC: (simd-vneg) ( a rep -- c ) [ neg ] components-map
SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c ) SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' ) a b rep 2>rep-array :> ( a' b' )
rep <rep-array> :> c' rep <rep-array> :> c'
0 rep rep-length 1 - 2 <range> [| n | 0 rep rep-length [ 1 - 2 <range> ] [ 2 /i ] bi [| n |
n a' nth-unsafe n b' nth-unsafe - n a' nth-unsafe n b' nth-unsafe -
n c' set-nth-unsafe n c' set-nth-unsafe
n 1 + a' nth-unsafe n 1 + b' nth-unsafe + n 1 + a' nth-unsafe n 1 + b' nth-unsafe +
n 1 + c' set-nth-unsafe n 1 + c' set-nth-unsafe
] each ] unrolled-each-unsafe
c' underlying>> ; c' underlying>> ;
SIMD-INTRINSIC: (simd-vs+) ( a b rep -- c ) SIMD-INTRINSIC: (simd-vs+) ( a b rep -- c )
dup rep-component-type '[ + _ c-type-clamp ] components-2map ; dup rep-component-type '[ + _ c:c-type-clamp ] components-2map ;
SIMD-INTRINSIC: (simd-vs-) ( a b rep -- c ) SIMD-INTRINSIC: (simd-vs-) ( a b rep -- c )
dup rep-component-type '[ - _ c-type-clamp ] components-2map ; dup rep-component-type '[ - _ c:c-type-clamp ] components-2map ;
SIMD-INTRINSIC: (simd-vs*) ( a b rep -- c ) SIMD-INTRINSIC: (simd-vs*) ( a b rep -- c )
dup rep-component-type '[ * _ c-type-clamp ] components-2map ; dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
SIMD-INTRINSIC: (simd-v*) ( a b rep -- c ) [ * ] components-2map ; SIMD-INTRINSIC: (simd-v*) ( a b rep -- c ) [ * ] components-2map ;
SIMD-INTRINSIC: (simd-v*high) ( a b rep -- c ) SIMD-INTRINSIC: (simd-v*high) ( a b rep -- c )
dup rep-component-type heap-size -8 * '[ * _ shift ] components-2map ; dup rep-component-type c:heap-size -8 * '[ * _ shift ] components-2map ;
SIMD-INTRINSIC:: (simd-v*hs+) ( a b rep -- c ) SIMD-INTRINSIC:: (simd-v*hs+) ( a b rep -- c )
rep { char-16-rep uchar-16-rep } member-eq? rep { char-16-rep uchar-16-rep } member-eq?
[ uchar-16-rep char-16-rep ] [ uchar-16-rep char-16-rep ]
@ -179,16 +188,17 @@ SIMD-INTRINSIC:: (simd-v*hs+) ( a b rep -- c )
wide-rep rep-component-type :> wide-type wide-rep rep-component-type :> wide-type
a a-rep >rep-array 2 <groups> :> a' a a-rep >rep-array 2 <groups> :> a'
b b-rep >rep-array 2 <groups> :> b' b b-rep >rep-array 2 <groups> :> b'
a' b' [ a' b' rep rep-length 2 /i [
[ [ first ] bi@ * ] [ [ first ] bi@ * ]
[ [ second ] bi@ * ] 2bi + [ [ second ] bi@ * ] 2bi +
wide-type c-type-clamp wide-type c:c-type-clamp
] wide-rep <rep-array> 2map-as underlying>> ; ] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-v/) ( a b rep -- c ) [ / ] components-2map ; SIMD-INTRINSIC: (simd-v/) ( a b rep -- c ) [ native/ ] components-2map ;
SIMD-INTRINSIC: (simd-vavg) ( a b rep -- c ) SIMD-INTRINSIC: (simd-vavg) ( a b rep -- c )
[ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ; [ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ;
SIMD-INTRINSIC: (simd-vmin) ( a b rep -- c ) [ min ] components-2map ; SIMD-INTRINSIC: (simd-vmin) ( a b rep -- c ) [ min ] components-2map ;
SIMD-INTRINSIC: (simd-vmax) ( a b rep -- c ) [ max ] components-2map ; SIMD-INTRINSIC: (simd-vmax) ( a b rep -- c ) [ max ] components-2map ;
! XXX
SIMD-INTRINSIC: (simd-v.) ( a b rep -- n ) SIMD-INTRINSIC: (simd-v.) ( a b rep -- n )
[ 2>rep-array [ [ first ] bi@ * ] 2keep ] keep [ 2>rep-array [ [ first ] bi@ * ] 2keep ] keep
1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ; 1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ;
@ -208,8 +218,10 @@ SIMD-INTRINSIC: (simd-vxor) ( a b rep -- c ) [ bitxor ] bitwise-com
SIMD-INTRINSIC: (simd-vnot) ( a rep -- c ) [ bitnot ] bitwise-components-map ; SIMD-INTRINSIC: (simd-vnot) ( a rep -- c ) [ bitnot ] bitwise-components-map ;
SIMD-INTRINSIC: (simd-vlshift) ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ; SIMD-INTRINSIC: (simd-vlshift) ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
SIMD-INTRINSIC: (simd-vrshift) ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ; SIMD-INTRINSIC: (simd-vrshift) ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
! XXX
SIMD-INTRINSIC: (simd-hlshift) ( a n rep -- c ) SIMD-INTRINSIC: (simd-hlshift) ( a n rep -- c )
drop head-slice* 16 0 pad-head ; drop head-slice* 16 0 pad-head ;
! XXX
SIMD-INTRINSIC: (simd-hrshift) ( a n rep -- c ) SIMD-INTRINSIC: (simd-hrshift) ( a n rep -- c )
drop tail-slice 16 0 pad-tail ; drop tail-slice 16 0 pad-tail ;
SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ; SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
@ -218,19 +230,19 @@ SIMD-INTRINSIC: (simd-vshuffle-bytes) ( a b rep -- c ) drop uchar-16-rep (vsh
SIMD-INTRINSIC:: (simd-vmerge-head) ( a b rep -- c ) SIMD-INTRINSIC:: (simd-vmerge-head) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' ) a b rep 2>rep-array :> ( a' b' )
rep <rep-array> :> c' rep <rep-array> :> c'
rep rep-length 2 /i iota [| n | rep rep-length 2 /i [| n |
n a' nth-unsafe n 2 * c' set-nth-unsafe n a' nth-unsafe n 2 * c' set-nth-unsafe
n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
] each ] unrolled-each-integer
c' underlying>> ; c' underlying>> ;
SIMD-INTRINSIC:: (simd-vmerge-tail) ( a b rep -- c ) SIMD-INTRINSIC:: (simd-vmerge-tail) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' ) a b rep 2>rep-array :> ( a' b' )
rep <rep-array> :> c' rep <rep-array> :> c'
rep rep-length 2 /i :> len rep rep-length 2 /i :> len
len iota [| n | len [| n |
n len + a' nth-unsafe n 2 * c' set-nth-unsafe n len + a' nth-unsafe n 2 * c' set-nth-unsafe
n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
] each ] unrolled-each-integer
c' underlying>> ; c' underlying>> ;
SIMD-INTRINSIC: (simd-v<=) ( a b rep -- c ) SIMD-INTRINSIC: (simd-v<=) ( a b rep -- c )
dup rep-tf-values '[ <= _ _ ? ] components-2map ; dup rep-tf-values '[ <= _ _ ? ] components-2map ;
@ -248,28 +260,33 @@ SIMD-INTRINSIC: (simd-vany?) ( a rep -- ? ) [ bitor ] bitwise-com
SIMD-INTRINSIC: (simd-vall?) ( a rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ; SIMD-INTRINSIC: (simd-vall?) ( a rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
SIMD-INTRINSIC: (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ; SIMD-INTRINSIC: (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ;
SIMD-INTRINSIC: (simd-v>float) ( a rep -- c ) SIMD-INTRINSIC: (simd-v>float) ( a rep -- c )
[ >rep-array [ >float ] ] [ >float-vector-rep <rep-array> ] bi map-as underlying>> ; [ [ >rep-array ] [ rep-length ] bi [ >float ] ]
[ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-v>integer) ( a rep -- c ) SIMD-INTRINSIC: (simd-v>integer) ( a rep -- c )
[ >rep-array [ >integer ] ] [ >int-vector-rep <rep-array> ] bi map-as underlying>> ; [ [ >rep-array ] [ rep-length ] bi [ >integer ] ]
[ >int-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-vpack-signed) ( a b rep -- c ) SIMD-INTRINSIC: (simd-vpack-signed) ( a b rep -- c )
[ 2>rep-array cord-append ] [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
[ 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 underlying>> ; '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-vpack-unsigned) ( a b rep -- c ) SIMD-INTRINSIC: (simd-vpack-unsigned) ( a b rep -- c )
[ 2>rep-array cord-append ] [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
[ 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 underlying>> ; '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
! XXX
SIMD-INTRINSIC: (simd-vunpack-head) ( a rep -- c ) SIMD-INTRINSIC: (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>> ;
! XXX
SIMD-INTRINSIC: (simd-vunpack-tail) ( a rep -- c ) SIMD-INTRINSIC: (simd-vunpack-tail) ( 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
[ tail-slice ] dip call( a' -- c' ) underlying>> ; [ tail-slice ] dip call( a' -- c' ) underlying>> ;
! XXX
SIMD-INTRINSIC: (simd-with) ( n rep -- v ) SIMD-INTRINSIC: (simd-with) ( n rep -- v )
[ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ; underlying>> ;
SIMD-INTRINSIC: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ; SIMD-INTRINSIC: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
SIMD-INTRINSIC: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ; SIMD-INTRINSIC: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
SIMD-INTRINSIC: (simd-select) ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ; SIMD-INTRINSIC: (simd-select) ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
SIMD-INTRINSIC: alien-vector ( c-ptr n rep -- value ) SIMD-INTRINSIC: alien-vector ( c-ptr n rep -- value )

6
basis/sequences/unrolled/unrolled.factor
View File

@ -65,6 +65,12 @@ ERROR: unrolled-2bounds-error
: unrolled-2map-as-unsafe ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq ) : unrolled-2map-as-unsafe ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
[ (unrolled-2each) ] dip unrolled-map-integers ; inline [ (unrolled-2each) ] dip unrolled-map-integers ; inline
: unrolled-map-unsafe ( seq len quot: ( x -- newx ) -- newseq )
pick unrolled-map-as-unsafe ; inline
: unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq )
4 npick unrolled-2map-as-unsafe ; inline
PRIVATE> PRIVATE>
: unrolled-each ( seq len quot: ( x -- ) -- ) : unrolled-each ( seq len quot: ( x -- ) -- )