1 USING: accessors alien arrays byte-arrays classes combinators
2 cpu.architecture effects fry functors generalizations generic
3 generic.parser kernel lexer literals locals macros math math.functions
4 math.vectors math.vectors.private math.vectors.simd.intrinsics
5 namespaces parser prettyprint.custom quotations sequences
6 sequences.generalizations sequences.private vocabs vocabs.loader
8 QUALIFIED-WITH: alien.c-types c
11 ERROR: bad-simd-length got expected ;
13 ERROR: bad-simd-vector obj ;
17 ! Primitive SIMD constructors
19 GENERIC: new-underlying ( underlying seq -- seq' )
21 : make-underlying ( seq quot -- seq' )
22 dip new-underlying ; inline
23 : change-underlying ( seq quot -- seq' )
24 '[ underlying>> @ ] keep new-underlying ; inline
30 ! Helper for boolean vector literals
32 : vector-true-value ( class -- value )
33 { c:float c:double } member? [ -1 bits>double ] [ -1 ] if ; foldable
35 : vector-false-value ( type -- value )
36 { c:float c:double } member? [ 0.0 ] [ 0 ] if ; foldable
38 : boolean>element ( bool/elt type -- elt )
40 { t [ vector-true-value ] }
41 { f [ vector-false-value ] }
50 { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
52 GENERIC: simd-element-type ( obj -- c-type )
53 GENERIC: simd-rep ( simd -- rep )
54 GENERIC: simd-with ( n exemplar -- v )
56 M: object simd-element-type drop f ;
57 M: object simd-rep drop f ;
62 DEFER: simd-construct-op
64 ! Unboxers for SIMD operations
65 : if-both-vectors ( a b rep t f -- )
66 [ 2over [ simd-128? ] both? ] 2dip if ; inline
68 : if-both-vectors-match ( a b rep t f -- )
69 [ 3dup [ drop [ simd-128? ] both? ] [ '[ simd-rep _ eq? ] both? ] 3bi and ]
72 : simd-unbox ( a -- a (a) )
73 [ ] [ underlying>> ] bi ; inline
75 : v->v-op ( a rep quot: ( (a) rep -- (c) ) fallback-quot -- c )
76 drop [ simd-unbox ] 2dip 2curry make-underlying ; inline
78 : vx->v-op ( a obj rep quot: ( (a) obj rep -- (c) ) fallback-quot -- c )
79 drop [ simd-unbox ] 3dip 3curry make-underlying ; inline
81 : vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c )
82 drop [ [ simd-unbox ] [ >fixnum ] bi* ] 2dip 3curry make-underlying ; inline
84 : vx->x-op ( a obj rep quot: ( (a) obj rep -- obj ) fallback-quot -- obj )
85 drop [ underlying>> ] 3dip call ; inline
87 : v->x-op ( a rep quot: ( (a) rep -- obj ) fallback-quot -- obj )
88 drop [ underlying>> ] 2dip call ; inline
90 : (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c )
91 [ [ simd-unbox ] [ underlying>> ] bi* ] 2dip 3curry make-underlying ; inline
93 : (vv->x-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
94 [ [ underlying>> ] bi@ ] 2dip 3curry call ; inline
96 : (vvx->v-op) ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) -- c )
97 [ [ simd-unbox ] [ underlying>> ] bi* ] 3dip 2curry 2curry make-underlying ; inline
99 : vv->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
100 [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
102 :: vvx->v-op ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) fallback-quot -- c )
104 [ obj swap quot (vvx->v-op) ]
105 [ drop obj fallback-quot call ] if-both-vectors-match ; inline
107 : vv'->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
108 [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline
110 : vv->x-op ( a b rep quot: ( (a) (b) rep -- obj ) fallback-quot -- obj )
111 [ '[ _ (vv->x-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
113 : mask>count ( n rep -- n' )
116 { double-2-rep [ -1 shift ] }
119 { ushort-8-rep [ -1 shift ] }
120 { short-8-rep [ -1 shift ] }
121 { ushort-8-rep [ -1 shift ] }
122 { int-4-rep [ -2 shift ] }
123 { uint-4-rep [ -2 shift ] }
124 { longlong-2-rep [ -3 shift ] }
125 { ulonglong-2-rep [ -3 shift ] }
133 ! SIMD vectors as sequences
135 M: simd-128 hashcode* underlying>> hashcode* ; inline
136 M: simd-128 clone [ clone ] change-underlying ; inline
137 M: simd-128 byte-length drop 16 ; inline
139 M: simd-128 new-sequence
141 [ nip [ 16 (byte-array) ] make-underlying ]
142 [ length bad-simd-length ] if ; inline
145 dup simd-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
147 ! SIMD primitive operations
150 dup simd-rep [ (simd-v+) ] [ call-next-method ] vv->v-op ; inline
152 dup simd-rep [ (simd-v-) ] [ call-next-method ] vv->v-op ; inline
154 dup simd-rep [ (simd-vneg) ] [ call-next-method ] v->v-op ; inline
156 dup simd-rep [ (simd-v+-) ] [ call-next-method ] vv->v-op ; inline
158 dup simd-rep [ (simd-vs+) ] [ call-next-method ] vv->v-op ; inline
160 dup simd-rep [ (simd-vs-) ] [ call-next-method ] vv->v-op ; inline
162 dup simd-rep [ (simd-vs*) ] [ call-next-method ] vv->v-op ; inline
164 dup simd-rep [ (simd-v*) ] [ call-next-method ] vv->v-op ; inline
166 dup simd-rep [ (simd-v*high) ] [ call-next-method ] vv->v-op ; inline
168 dup simd-rep [ (simd-v/) ] [ call-next-method ] vv->v-op ; inline
170 dup simd-rep [ (simd-vavg) ] [ call-next-method ] vv->v-op ; inline
172 dup simd-rep [ (simd-vmin) ] [ call-next-method ] vv->v-op ; inline
174 dup simd-rep [ (simd-vmax) ] [ call-next-method ] vv->v-op ; inline
176 dup simd-rep [ (simd-v.) ] [ call-next-method ] vv->x-op ; inline
178 dup simd-rep [ (simd-vsad) ] [ call-next-method ] vv->x-op ; inline
180 dup simd-rep [ (simd-vsqrt) ] [ call-next-method ] v->v-op ; inline
182 dup simd-rep [ (simd-sum) ] [ call-next-method ] v->x-op ; inline
184 dup simd-rep [ (simd-vabs) ] [ call-next-method ] v->v-op ; inline
186 dup simd-rep [ (simd-vbitand) ] [ call-next-method ] vv->v-op ; inline
188 dup simd-rep [ (simd-vbitandn) ] [ call-next-method ] vv->v-op ; inline
190 dup simd-rep [ (simd-vbitor) ] [ call-next-method ] vv->v-op ; inline
192 dup simd-rep [ (simd-vbitxor) ] [ call-next-method ] vv->v-op ; inline
194 dup simd-rep [ (simd-vbitnot) ] [ call-next-method ] v->v-op ; inline
196 dup simd-rep [ (simd-vand) ] [ call-next-method ] vv->v-op ; inline
198 dup simd-rep [ (simd-vandn) ] [ call-next-method ] vv->v-op ; inline
200 dup simd-rep [ (simd-vor) ] [ call-next-method ] vv->v-op ; inline
202 dup simd-rep [ (simd-vxor) ] [ call-next-method ] vv->v-op ; inline
204 dup simd-rep [ (simd-vnot) ] [ call-next-method ] v->v-op ; inline
206 over simd-rep [ (simd-vlshift) ] [ call-next-method ] vn->v-op ; inline
208 over simd-rep [ (simd-vrshift) ] [ call-next-method ] vn->v-op ; inline
210 over simd-rep [ (simd-hlshift) ] [ call-next-method ] vn->v-op ; inline
212 over simd-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline
213 M: simd-128 vshuffle-elements
214 over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vx->v-op ; inline
215 M: simd-128 vshuffle2-elements
216 over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvx->v-op ; inline
217 M: simd-128 vshuffle-bytes
218 dup simd-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline
219 M: simd-128 (vmerge-head)
220 dup simd-rep [ (simd-vmerge-head) ] [ call-next-method ] vv->v-op ; inline
221 M: simd-128 (vmerge-tail)
222 dup simd-rep [ (simd-vmerge-tail) ] [ call-next-method ] vv->v-op ; inline
224 dup simd-rep [ (simd-v<=) ] [ call-next-method ] vv->v-op ; inline
226 dup simd-rep [ (simd-v<) ] [ call-next-method ] vv->v-op ; inline
228 dup simd-rep [ (simd-v=) ] [ call-next-method ] vv->v-op ; inline
230 dup simd-rep [ (simd-v>) ] [ call-next-method ] vv->v-op ; inline
232 dup simd-rep [ (simd-v>=) ] [ call-next-method ] vv->v-op ; inline
233 M: simd-128 vunordered?
234 dup simd-rep [ (simd-vunordered?) ] [ call-next-method ] vv->v-op ; inline
236 dup simd-rep [ (simd-vany?) ] [ call-next-method ] v->x-op ; inline
238 dup simd-rep [ (simd-vall?) ] [ call-next-method ] v->x-op ; inline
240 dup simd-rep [ (simd-vnone?) ] [ call-next-method ] v->x-op ; inline
243 [ [ (simd-vgetmask) assert-positive ] [ call-next-method ] v->x-op ]
244 [ mask>count ] bi ; inline
246 ! SIMD high-level specializations
248 M: simd-128 vbroadcast swap [ nth ] [ simd-with ] bi ; inline
249 M: simd-128 n+v [ simd-with ] keep v+ ; inline
250 M: simd-128 n-v [ simd-with ] keep v- ; inline
251 M: simd-128 n*v [ simd-with ] keep v* ; inline
252 M: simd-128 n/v [ simd-with ] keep v/ ; inline
253 M: simd-128 v+n over simd-with v+ ; inline
254 M: simd-128 v-n over simd-with v- ; inline
255 M: simd-128 v*n over simd-with v* ; inline
256 M: simd-128 v/n over simd-with v/ ; inline
257 M: simd-128 norm-sq dup v. assert-positive ; inline
258 M: simd-128 distance v- norm ; inline
260 M: simd-128 >pprint-sequence ;
261 M: simd-128 pprint* pprint-object ;
265 ! SIMD concrete type functor
267 FUNCTOR: define-simd-128 ( T -- )
272 A-boa DEFINES ${T}-boa
273 A-with DEFINES ${T}-with
274 A-cast DEFINES ${T}-cast
277 ELT [ A-rep rep-component-type ]
278 N [ A-rep rep-length ]
279 COERCER [ ELT c:c-type-class "coercer" word-prop [ ] or ]
281 BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
285 TUPLE: A < simd-128 ; final
287 M: A new-underlying drop \ A boa ; inline
288 M: A simd-rep drop A-rep ; inline
289 M: A simd-element-type drop ELT ; inline
290 M: A simd-with drop A-with ; inline
293 swap \ A-rep [ (simd-select) ] [ call-next-method ] vx->x-op ; inline
295 [ ELT boolean>element ] 2dip
296 underlying>> ELT c:set-alien-element ; inline
298 : >A ( seq -- simd ) \ A new clone-like ; inline
300 M: A like drop dup \ A instance? [ >A ] unless ; inline
302 : A-with ( n -- v ) COERCER call \ A-rep (simd-with) \ A boa ; inline
303 : A-cast ( v -- v' ) underlying>> \ A boa ; inline
305 M: A length drop N ; inline
308 [ COERCER N napply ] N {
309 { 2 [ [ A-rep (simd-gather-2) A boa ] ] }
310 { 4 [ [ A-rep (simd-gather-4) A boa ] ] }
311 [ \ A new '[ _ _ nsequence ] ]
313 BOA-EFFECT define-inline
315 M: A pprint-delims drop \ A{ \ } ;
316 SYNTAX: A{ \ } [ >A ] parse-literal ;
323 { A-rep alien-vector A boa } >quotation >>getter
325 [ dup simd-128? [ bad-simd-vector ] unless underlying>> ] 2dip
326 A-rep set-alien-vector
327 } >quotation >>setter
336 scan-token define-simd-128 ;
351 SIMD-128: ulonglong-2
357 M: simd-128 vshuffle ( u perm -- v )
358 vshuffle-bytes ; inline
361 uchar-16-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op short-8-cast ; inline
363 ushort-8-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op uint-4-cast ; inline
365 uint-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op ulonglong-2-cast ; inline
367 char-16-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op short-8-cast ; inline
369 short-8-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op int-4-cast ; inline
371 int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
373 { "math.vectors.simd" "mirrors" } "math.vectors.simd.mirrors" require-when