-USING: accessors alien.c-types arrays byte-arrays classes combinators
-cpu.architecture effects fry functors generalizations generic
-generic.parser kernel lexer literals macros math math.functions
-math.vectors math.vectors.private math.vectors.simd.intrinsics namespaces parser
-prettyprint.custom quotations sequences sequences.private vocabs
+USING: accessors alien arrays byte-arrays classes combinators
+cpu.architecture effects functors generalizations kernel lexer
+literals math math.bitwise math.vectors
+math.vectors.simd.intrinsics parser prettyprint.custom
+quotations sequences sequences.generalizations sequences.private
vocabs.loader words ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
ERROR: bad-simd-length got expected ;
+ERROR: bad-simd-vector obj ;
<<
<PRIVATE
GENERIC: simd-element-type ( obj -- c-type )
GENERIC: simd-rep ( simd -- rep )
+GENERIC: simd-with ( n exemplar -- v )
M: object simd-element-type drop f ;
M: object simd-rep drop f ;
: v->v-op ( a rep quot: ( (a) rep -- (c) ) fallback-quot -- c )
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
-: 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
-: 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
: (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c )
[ [ 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
-
+
+: (vvx->v-op) ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) -- c )
+ [ [ 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) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
+:: vvx->v-op ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) fallback-quot -- c )
+ a b rep
+ [ obj swap quot (vvx->v-op) ]
+ [ 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) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline
-: vv->n-op ( a b rep quot: ( (a) (b) rep -- n ) fallback-quot -- n )
- [ '[ _ (vv->n-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
+: vv->x-op ( a b rep quot: ( (a) (b) rep -- obj ) fallback-quot -- obj )
+ [ '[ _ (vv->x-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
+
+: mask>count ( n rep -- n' )
+ [ bit-count ] dip {
+ { float-4-rep [ ] }
+ { double-2-rep [ -1 shift ] }
+ { uchar-16-rep [ ] }
+ { char-16-rep [ ] }
+ { ushort-8-rep [ -1 shift ] }
+ { short-8-rep [ -1 shift ] }
+ { ushort-8-rep [ -1 shift ] }
+ { int-4-rep [ -2 shift ] }
+ { uint-4-rep [ -2 shift ] }
+ { longlong-2-rep [ -3 shift ] }
+ { ulonglong-2-rep [ -3 shift ] }
+ } case ; inline
PRIVATE>
>>
<<
+
+! SIMD vectors as sequences
+
+M: simd-128 hashcode* underlying>> hashcode* ; inline
+M: simd-128 clone [ clone ] change-underlying ; inline
+M: simd-128 byte-length drop 16 ; inline
+
+M: simd-128 new-sequence
+ 2dup length =
+ [ nip [ 16 (byte-array) ] make-underlying ]
+ [ length bad-simd-length ] if ; inline
+
+M: simd-128 equal?
+ dup simd-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
+
+! SIMD primitive operations
+
+M: simd-128 v+
+ dup simd-rep [ (simd-v+) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v-
+ dup simd-rep [ (simd-v-) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vneg
+ dup simd-rep [ (simd-vneg) ] [ call-next-method ] v->v-op ; inline
+M: simd-128 v+-
+ dup simd-rep [ (simd-v+-) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vs+
+ dup simd-rep [ (simd-vs+) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vs-
+ dup simd-rep [ (simd-vs-) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vs*
+ dup simd-rep [ (simd-vs*) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v*
+ dup simd-rep [ (simd-v*) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v*high
+ dup simd-rep [ (simd-v*high) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v/
+ dup simd-rep [ (simd-v/) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vavg
+ dup simd-rep [ (simd-vavg) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vmin
+ dup simd-rep [ (simd-vmin) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vmax
+ dup simd-rep [ (simd-vmax) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vdot
+ dup simd-rep [ (simd-vdot) ] [ call-next-method ] vv->x-op ; inline
+M: simd-128 vsad
+ dup simd-rep [ (simd-vsad) ] [ call-next-method ] vv->x-op ; inline
+M: simd-128 vsqrt
+ dup simd-rep [ (simd-vsqrt) ] [ call-next-method ] v->v-op ; inline
+M: simd-128 sum
+ dup simd-rep [ (simd-sum) ] [ call-next-method ] v->x-op ; inline
+M: simd-128 vabs
+ dup simd-rep [ (simd-vabs) ] [ call-next-method ] v->v-op ; inline
+M: simd-128 vbitand
+ dup simd-rep [ (simd-vbitand) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vbitandn
+ dup simd-rep [ (simd-vbitandn) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vbitor
+ dup simd-rep [ (simd-vbitor) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vbitxor
+ dup simd-rep [ (simd-vbitxor) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vbitnot
+ dup simd-rep [ (simd-vbitnot) ] [ call-next-method ] v->v-op ; inline
+M: simd-128 vand
+ dup simd-rep [ (simd-vand) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vandn
+ dup simd-rep [ (simd-vandn) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vor
+ dup simd-rep [ (simd-vor) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vxor
+ dup simd-rep [ (simd-vxor) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vnot
+ dup simd-rep [ (simd-vnot) ] [ call-next-method ] v->v-op ; inline
+M: simd-128 vlshift
+ over simd-rep [ (simd-vlshift) ] [ call-next-method ] vn->v-op ; inline
+M: simd-128 vrshift
+ over simd-rep [ (simd-vrshift) ] [ call-next-method ] vn->v-op ; inline
+M: simd-128 hlshift
+ over simd-rep [ (simd-hlshift) ] [ call-next-method ] vn->v-op ; inline
+M: simd-128 hrshift
+ over simd-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline
+M: simd-128 vshuffle-elements
+ over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vx->v-op ; inline
+M: simd-128 vshuffle2-elements
+ over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvx->v-op ; inline
+M: simd-128 vshuffle-bytes
+ dup simd-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline
+M: simd-128 (vmerge-head)
+ dup simd-rep [ (simd-vmerge-head) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 (vmerge-tail)
+ dup simd-rep [ (simd-vmerge-tail) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v<=
+ dup simd-rep [ (simd-v<=) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v<
+ dup simd-rep [ (simd-v<) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v=
+ dup simd-rep [ (simd-v=) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v>
+ dup simd-rep [ (simd-v>) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 v>=
+ dup simd-rep [ (simd-v>=) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vunordered?
+ dup simd-rep [ (simd-vunordered?) ] [ call-next-method ] vv->v-op ; inline
+M: simd-128 vany?
+ dup simd-rep [ (simd-vany?) ] [ call-next-method ] v->x-op ; inline
+M: simd-128 vall?
+ dup simd-rep [ (simd-vall?) ] [ call-next-method ] v->x-op ; inline
+M: simd-128 vnone?
+ dup simd-rep [ (simd-vnone?) ] [ call-next-method ] v->x-op ; inline
+M: simd-128 vcount
+ dup simd-rep
+ [ [ (simd-vgetmask) assert-positive ] [ call-next-method ] v->x-op ]
+ [ mask>count ] bi ; inline
+
+! SIMD high-level specializations
+
+M: simd-128 vbroadcast swap [ nth ] [ simd-with ] bi ; inline
+M: simd-128 n+v [ simd-with ] keep v+ ; inline
+M: simd-128 n-v [ simd-with ] keep v- ; inline
+M: simd-128 n*v [ simd-with ] keep v* ; inline
+M: simd-128 n/v [ simd-with ] keep v/ ; inline
+M: simd-128 v+n over simd-with v+ ; inline
+M: simd-128 v-n over simd-with v- ; inline
+M: simd-128 v*n over simd-with v* ; inline
+M: simd-128 v/n over simd-with v/ ; inline
+M: simd-128 norm-sq dup vdot assert-positive ; inline
+M: simd-128 distance v- norm ; inline
+
+M: simd-128 >pprint-sequence ;
+M: simd-128 pprint* pprint-object ;
+
<PRIVATE
! SIMD concrete type functor
-FUNCTOR: define-simd-128 ( T -- )
+<FUNCTOR: define-simd-128 ( T -- )
A DEFINES-CLASS ${T}
A-rep IS ${T}-rep
ELT [ A-rep rep-component-type ]
N [ A-rep rep-length ]
-COERCER [ ELT c-type-class "coercer" word-prop [ ] or ]
+COERCER [ ELT c:c-type-class "coercer" word-prop [ ] or ]
-SET-NTH [ ELT dup c:c-setter c:array-accessor ]
-
-BOA-EFFECT [ N "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
-TUPLE: A < simd-128 ;
+TUPLE: A < simd-128 ; final
M: A new-underlying drop \ A boa ; inline
M: A simd-rep drop A-rep ; inline
M: A simd-element-type drop ELT ; inline
+M: A simd-with drop A-with ; inline
+M: A nth-unsafe
+ swap \ A-rep [ (simd-select) ] [ call-next-method ] vx->x-op ; inline
M: A set-nth-unsafe
[ ELT boolean>element ] 2dip
- underlying>> SET-NTH call ; inline
+ underlying>> ELT c:set-alien-element ; inline
: >A ( seq -- simd ) \ A new clone-like ; inline
: A-with ( n -- v ) COERCER call \ A-rep (simd-with) \ A boa ; inline
: A-cast ( v -- v' ) underlying>> \ A boa ; inline
-! SIMD vectors as sequences
-
-M: A hashcode* underlying>> hashcode* ; inline
-M: A clone [ clone ] change-underlying ; inline
M: A length drop N ; inline
-M: A nth-unsafe
- swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline
-M: A c:byte-length drop 16 ; inline
-
-M: A new-sequence
- 2dup length =
- [ nip [ 16 (byte-array) ] make-underlying ]
- [ length bad-simd-length ] if ; inline
-
-M: A equal?
- \ A-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
-
-! SIMD primitive operations
-
-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
-M: A vneg \ A-rep [ (simd-vneg) ] [ call-next-method ] v->v-op ; inline
-M: A v+- \ A-rep [ (simd-v+-) ] [ call-next-method ] vv->v-op ; inline
-M: A vs+ \ A-rep [ (simd-vs+) ] [ call-next-method ] vv->v-op ; inline
-M: A vs- \ A-rep [ (simd-vs-) ] [ call-next-method ] vv->v-op ; inline
-M: A vs* \ A-rep [ (simd-vs*) ] [ 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
-M: A vmin \ A-rep [ (simd-vmin) ] [ call-next-method ] vv->v-op ; inline
-M: A vmax \ A-rep [ (simd-vmax) ] [ call-next-method ] vv->v-op ; inline
-M: A v. \ A-rep [ (simd-v.) ] [ call-next-method ] vv->n-op ; inline
-M: A vsqrt \ A-rep [ (simd-vsqrt) ] [ call-next-method ] v->v-op ; inline
-M: A sum \ A-rep [ (simd-sum) ] [ call-next-method ] v->n-op ; inline
-M: A vabs \ A-rep [ (simd-vabs) ] [ call-next-method ] v->v-op ; inline
-M: A vbitand \ A-rep [ (simd-vbitand) ] [ call-next-method ] vv->v-op ; inline
-M: A vbitandn \ A-rep [ (simd-vbitandn) ] [ call-next-method ] vv->v-op ; inline
-M: A vbitor \ A-rep [ (simd-vbitor) ] [ call-next-method ] vv->v-op ; inline
-M: A vbitxor \ A-rep [ (simd-vbitxor) ] [ call-next-method ] vv->v-op ; inline
-M: A vbitnot \ A-rep [ (simd-vbitnot) ] [ call-next-method ] v->v-op ; inline
-M: A vand \ A-rep [ (simd-vand) ] [ call-next-method ] vv->v-op ; inline
-M: A vandn \ A-rep [ (simd-vandn) ] [ call-next-method ] vv->v-op ; inline
-M: A vor \ A-rep [ (simd-vor) ] [ call-next-method ] vv->v-op ; inline
-M: A vxor \ A-rep [ (simd-vxor) ] [ call-next-method ] vv->v-op ; inline
-M: A vnot \ A-rep [ (simd-vnot) ] [ call-next-method ] v->v-op ; inline
-M: A vlshift \ A-rep [ (simd-vlshift) ] [ call-next-method ] vn->v-op ; inline
-M: A vrshift \ A-rep [ (simd-vrshift) ] [ 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 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 (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 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
-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
-M: A v>= \ A-rep [ (simd-v>=) ] [ call-next-method ] vv->v-op ; inline
-M: A vunordered? \ A-rep [ (simd-vunordered?) ] [ call-next-method ] vv->v-op ; inline
-M: A vany? \ A-rep [ (simd-vany?) ] [ call-next-method ] v->n-op ; inline
-M: A vall? \ A-rep [ (simd-vall?) ] [ call-next-method ] v->n-op ; inline
-M: A vnone? \ A-rep [ (simd-vnone?) ] [ call-next-method ] v->n-op ; inline
-
-! SIMD high-level specializations
-
-M: A vbroadcast swap nth A-with ; inline
-M: A n+v [ A-with ] dip v+ ; inline
-M: A n-v [ A-with ] dip v- ; inline
-M: A n*v [ A-with ] dip v* ; inline
-M: A n/v [ A-with ] dip v/ ; inline
-M: A v+n A-with v+ ; inline
-M: A v-n A-with v- ; inline
-M: A v*n A-with v* ; inline
-M: A v/n A-with v/ ; inline
-M: A norm-sq dup v. assert-positive ; inline
-M: A distance v- norm ; inline
-
-M: A >pprint-sequence ;
-M: A pprint* pprint-object ;
\ A-boa
[ COERCER N napply ] N {
byte-array >>class
A >>boxed-class
{ A-rep alien-vector A boa } >quotation >>getter
- { [ underlying>> ] 2dip A-rep set-alien-vector } >quotation >>setter
+ {
+ [ dup simd-128? [ bad-simd-vector ] unless underlying>> ] 2dip
+ A-rep set-alien-vector
+ } >quotation >>setter
16 >>size
16 >>align
A-rep >>rep
\ A c:typedef
-;FUNCTOR
+;FUNCTOR>
SYNTAX: SIMD-128:
- scan define-simd-128 ;
+ scan-token define-simd-128 ;
PRIVATE>
! misc
-M: simd-128 vshuffle ( u perm -- v )
+M: simd-128 vshuffle
vshuffle-bytes ; inline
-"mirrors" vocab [
- "math.vectors.simd.mirrors" require
-] when
+M: uchar-16 v*hs+
+ uchar-16-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op short-8-cast ; inline
+M: ushort-8 v*hs+
+ ushort-8-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op uint-4-cast ; inline
+M: uint-4 v*hs+
+ uint-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op ulonglong-2-cast ; inline
+M: char-16 v*hs+
+ char-16-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op short-8-cast ; inline
+M: short-8 v*hs+
+ short-8-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op int-4-cast ; inline
+M: int-4 v*hs+
+ int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
+
+{ "math.vectors.simd" "mirrors" } "math.vectors.simd.mirrors" require-when
projects / factor.git / blobdiff