1 USING: accessors alien.c-types arrays byte-arrays classes combinators
2 cpu.architecture effects fry functors generalizations generic
3 generic.parser kernel lexer literals macros math math.functions
4 math.vectors math.vectors.private namespaces parser
5 prettyprint.custom quotations sequences sequences.private vocabs
7 QUALIFIED-WITH: alien.c-types c
15 ERROR: bad-simd-call word ;
16 ERROR: bad-simd-length got expected ;
20 ! Primitive SIMD constructors
22 GENERIC: new-underlying ( underlying seq -- seq' )
24 : make-underlying ( seq quot -- seq' )
25 dip new-underlying ; inline
26 : change-underlying ( seq quot -- seq' )
27 '[ underlying>> @ ] keep new-underlying ; inline
35 : (simd-v+) ( a b rep -- c ) \ v+ bad-simd-call ;
36 : (simd-v-) ( a b rep -- c ) \ v- bad-simd-call ;
37 : (simd-vneg) ( a rep -- c ) \ vneg bad-simd-call ;
38 : (simd-v+-) ( a b rep -- c ) \ v+- bad-simd-call ;
39 : (simd-vs+) ( a b rep -- c ) \ vs+ bad-simd-call ;
40 : (simd-vs-) ( a b rep -- c ) \ vs- bad-simd-call ;
41 : (simd-vs*) ( a b rep -- c ) \ vs* bad-simd-call ;
42 : (simd-v*) ( a b rep -- c ) \ v* bad-simd-call ;
43 : (simd-v/) ( a b rep -- c ) \ v/ bad-simd-call ;
44 : (simd-vmin) ( a b rep -- c ) \ vmin bad-simd-call ;
45 : (simd-vmax) ( a b rep -- c ) \ vmax bad-simd-call ;
46 : (simd-v.) ( a b rep -- n ) \ v. bad-simd-call ;
47 : (simd-vsqrt) ( a rep -- c ) \ vsqrt bad-simd-call ;
48 : (simd-sum) ( a rep -- n ) \ sum bad-simd-call ;
49 : (simd-vabs) ( a rep -- c ) \ vabs bad-simd-call ;
50 : (simd-vbitand) ( a b rep -- c ) \ vbitand bad-simd-call ;
51 : (simd-vbitandn) ( a b rep -- c ) \ vbitandn bad-simd-call ;
52 : (simd-vbitor) ( a b rep -- c ) \ vbitor bad-simd-call ;
53 : (simd-vbitxor) ( a b rep -- c ) \ vbitxor bad-simd-call ;
54 : (simd-vbitnot) ( a rep -- c ) \ vbitnot bad-simd-call ;
55 : (simd-vand) ( a b rep -- c ) \ vand bad-simd-call ;
56 : (simd-vandn) ( a b rep -- c ) \ vandn bad-simd-call ;
57 : (simd-vor) ( a b rep -- c ) \ vor bad-simd-call ;
58 : (simd-vxor) ( a b rep -- c ) \ vxor bad-simd-call ;
59 : (simd-vnot) ( a rep -- c ) \ vnot bad-simd-call ;
60 : (simd-vlshift) ( a n rep -- c ) \ vlshift bad-simd-call ;
61 : (simd-vrshift) ( a n rep -- c ) \ vrshift bad-simd-call ;
62 : (simd-hlshift) ( a n rep -- c ) \ hlshift bad-simd-call ;
63 : (simd-hrshift) ( a n rep -- c ) \ hrshift bad-simd-call ;
64 : (simd-vshuffle-elements) ( a n rep -- c ) \ vshuffle-elements bad-simd-call ;
65 : (simd-vshuffle-bytes) ( a b rep -- c ) \ vshuffle-bytes bad-simd-call ;
66 : (simd-vmerge-head) ( a b rep -- c ) \ (vmerge-head) bad-simd-call ;
67 : (simd-vmerge-tail) ( a b rep -- c ) \ (vmerge-tail) bad-simd-call ;
68 : (simd-v<=) ( a b rep -- c ) \ v<= bad-simd-call ;
69 : (simd-v<) ( a b rep -- c ) \ v< bad-simd-call ;
70 : (simd-v=) ( a b rep -- c ) \ v= bad-simd-call ;
71 : (simd-v>) ( a b rep -- c ) \ v> bad-simd-call ;
72 : (simd-v>=) ( a b rep -- c ) \ v>= bad-simd-call ;
73 : (simd-vunordered?) ( a b rep -- c ) \ vunordered? bad-simd-call ;
74 : (simd-vany?) ( a rep -- ? ) \ vany? bad-simd-call ;
75 : (simd-vall?) ( a rep -- ? ) \ vall? bad-simd-call ;
76 : (simd-vnone?) ( a rep -- ? ) \ vnone? bad-simd-call ;
77 : (simd-v>float) ( a rep -- c ) \ vconvert bad-simd-call ;
78 : (simd-v>integer) ( a rep -- c ) \ vconvert bad-simd-call ;
79 : (simd-vpack-signed) ( a b rep -- c ) \ vconvert bad-simd-call ;
80 : (simd-vpack-unsigned) ( a b rep -- c ) \ vconvert bad-simd-call ;
81 : (simd-vunpack-head) ( a rep -- c ) \ vconvert bad-simd-call ;
82 : (simd-vunpack-tail) ( a rep -- c ) \ vconvert bad-simd-call ;
83 : (simd-with) ( n rep -- v ) \ simd-with bad-simd-call ;
84 : (simd-gather-2) ( m n rep -- v ) \ simd-boa bad-simd-call ;
85 : (simd-gather-4) ( m n o p rep -- v ) \ simd-boa bad-simd-call ;
86 : (simd-select) ( a n rep -- n ) \ nth bad-simd-call ;
90 : alien-vector ( c-ptr n rep -- value ) \ alien-vector bad-simd-call ;
91 : set-alien-vector ( c-ptr n rep -- value ) \ set-alien-vector bad-simd-call ;
95 ! Helper for boolean vector literals
97 : vector-true-value ( class -- value )
98 { c:float c:double } member? [ -1 bits>double ] [ -1 ] if ; foldable
100 : vector-false-value ( type -- value )
101 { c:float c:double } member? [ 0.0 ] [ 0 ] if ; foldable
103 : boolean>element ( bool/elt type -- elt )
105 { t [ vector-true-value ] }
106 { f [ vector-false-value ] }
115 { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
117 GENERIC: simd-element-type ( obj -- c-type )
118 GENERIC: simd-rep ( simd -- rep )
121 : rep-length ( rep -- n )
122 16 swap rep-component-type heap-size /i ; foldable
126 DEFER: simd-construct-op
128 ! SIMD concrete type functor
130 FUNCTOR: define-simd-128 ( T -- )
135 A-boa DEFINES ${T}-boa
136 A-with DEFINES ${T}-with
137 A-cast DEFINES ${T}-cast
140 ELT [ A-rep rep-component-type ]
141 N [ A-rep rep-length ]
143 SET-NTH [ ELT dup c:c-setter c:array-accessor ]
145 BOA-EFFECT [ N "n" <repetition> >array { "v" } <effect> ]
149 TUPLE: A < simd-128 ;
151 M: A new-underlying drop \ A boa ; inline
152 M: A simd-rep drop A-rep ; inline
153 M: A simd-element-type drop ELT ; inline
156 [ ELT boolean>element ] 2dip
157 underlying>> SET-NTH call ; inline
159 : >A ( seq -- simd ) \ A new clone-like ; inline
161 M: A like drop dup \ A instance? [ >A ] unless ; inline
163 : A-with ( n -- v ) \ A new simd-with ; inline
164 : A-cast ( v -- v' ) \ A new simd-cast ; inline
167 { 2 [ '[ _ [ (simd-gather-2) ] simd-construct-op ] ] }
168 { 4 [ '[ _ [ (simd-gather-4) ] simd-construct-op ] ] }
169 [ swap '[ _ _ nsequence ] ]
170 } case BOA-EFFECT define-inline
172 M: A pprint-delims drop \ A{ \ } ;
173 SYNTAX: A{ \ } [ >A ] parse-literal ;
178 [ A-rep alien-vector \ A boa ] >>getter
179 [ [ underlying>> ] 2dip A-rep set-alien-vector ] >>setter
188 scan define-simd-128 ;
194 : assert-positive ( x -- y ) ;
196 ! SIMD vectors as sequences
198 M: simd-128 hashcode* underlying>> hashcode* ; inline
199 M: simd-128 clone [ clone ] change-underlying ; inline
200 M: simd-128 length simd-rep rep-length ; inline
201 M: simd-128 nth-unsafe [ nip ] 2keep simd-rep (simd-select) ; inline
202 M: simd-128 c:byte-length drop 16 ; inline
204 M: simd-128 new-sequence
206 [ nip [ 16 (byte-array) ] make-underlying ]
207 [ length bad-simd-length ] if ; inline
209 ! M: simd-128 >pprint-sequence ;
210 ! M: simd-128 pprint* pprint-object ;
212 INSTANCE: simd-128 sequence
214 ! Unboxers for SIMD operations
218 : if-both-vectors ( a b t f -- )
219 [ 2dup [ simd-128? ] both? ] 2dip if ; inline
221 : if-both-vectors-match ( a b t f -- )
222 [ 2dup [ [ simd-128? ] both? ] [ [ simd-rep ] bi@ eq? ] 2bi and ]
225 : simd-construct-op ( exemplar quot: ( rep -- v ) -- v )
226 [ dup simd-rep ] dip curry make-underlying ; inline
228 : simd-unbox ( a -- a (a) a-rep )
229 [ ] [ underlying>> ] [ simd-rep ] tri ; inline
231 : simd-v->v-op ( a quot: ( (a) rep -- (c) ) -- c )
232 [ simd-unbox ] dip 2curry make-underlying ; inline
234 : simd-vn->v-op ( a n quot: ( (a) n rep -- (c) ) -- c )
235 [ simd-unbox ] [ swap ] [ 3curry ] tri* make-underlying ; inline
237 : simd-v->n-op ( a quot: ( (a) rep -- n ) -- n )
238 [ [ underlying>> ] [ simd-rep ] bi ] dip call ; inline
240 : ((simd-vv->v-op)) ( a b quot: ( (a) (b) rep -- (c) ) -- c )
241 [ simd-unbox ] [ underlying>> swap ] [ 3curry ] tri* make-underlying ; inline
243 : ((simd-vv->n-op)) ( a b quot: ( (a) (b) rep -- n ) -- n )
244 [ [ underlying>> ] [ simd-rep ] bi ]
245 [ underlying>> swap ] [ ] tri* call ; inline
247 : (simd-vv->v-op) ( a b quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
248 [ '[ _ ((simd-vv->v-op)) ] ] dip if-both-vectors-match ; inline
250 : (simd-vv'->v-op) ( a b quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
251 [ '[ _ ((simd-vv->v-op)) ] ] dip if-both-vectors ; inline
253 : (simd-vv->n-op) ( a b quot: ( (a) (b) rep -- n ) fallback-quot -- n )
254 [ '[ _ ((simd-vv->n-op)) ] ] dip if-both-vectors-match ; inline
256 : (simd-method-fallback) ( accum word -- accum )
257 [ current-method get literalize \ (call-next-method) [ ] 2sequence suffix! ]
260 SYNTAX: simd-vv->v-op
261 \ (simd-vv->v-op) (simd-method-fallback) ;
262 SYNTAX: simd-vv'->v-op
263 \ (simd-vv'->v-op) (simd-method-fallback) ;
264 SYNTAX: simd-vv->n-op
265 \ (simd-vv->n-op) (simd-method-fallback) ;
271 [ v= vall? ] [ 2drop f ] if-both-vectors-match ; inline
275 : simd-with ( n seq -- v )
276 [ (simd-with) ] simd-construct-op ; inline
278 MACRO: simd-boa ( class -- )
280 { 2 [ '[ _ [ (simd-gather-2) ] simd-construct-op ] ] }
281 { 4 [ '[ _ [ (simd-gather-4) ] simd-construct-op ] ] }
282 [ swap '[ _ _ nsequence ] ]
285 : simd-cast ( v seq -- v' )
286 [ underlying>> ] dip new-underlying ; inline
288 ! SIMD primitive operations
290 M: simd-128 v+ [ (simd-v+) ] simd-vv->v-op ; inline
291 M: simd-128 v- [ (simd-v-) ] simd-vv->v-op ; inline
292 M: simd-128 vneg [ (simd-vneg) ] simd-v->v-op ; inline
293 M: simd-128 v+- [ (simd-v+-) ] simd-vv->v-op ; inline
294 M: simd-128 vs+ [ (simd-vs+) ] simd-vv->v-op ; inline
295 M: simd-128 vs- [ (simd-vs-) ] simd-vv->v-op ; inline
296 M: simd-128 vs* [ (simd-vs*) ] simd-vv->v-op ; inline
297 M: simd-128 v* [ (simd-v*) ] simd-vv->v-op ; inline
298 M: simd-128 v/ [ (simd-v/) ] simd-vv->v-op ; inline
299 M: simd-128 vmin [ (simd-vmin) ] simd-vv->v-op ; inline
300 M: simd-128 vmax [ (simd-vmax) ] simd-vv->v-op ; inline
301 M: simd-128 v. [ (simd-v.) ] simd-vv->n-op ; inline
302 M: simd-128 vsqrt [ (simd-vsqrt) ] simd-v->v-op ; inline
303 M: simd-128 sum [ (simd-sum) ] simd-v->n-op ; inline
304 M: simd-128 vabs [ (simd-vabs) ] simd-v->v-op ; inline
305 M: simd-128 vbitand [ (simd-vbitand) ] simd-vv->v-op ; inline
306 M: simd-128 vbitandn [ (simd-vbitandn) ] simd-vv->v-op ; inline
307 M: simd-128 vbitor [ (simd-vbitor) ] simd-vv->v-op ; inline
308 M: simd-128 vbitxor [ (simd-vbitxor) ] simd-vv->v-op ; inline
309 M: simd-128 vbitnot [ (simd-vbitnot) ] simd-v->v-op ; inline
310 M: simd-128 vand [ (simd-vand) ] simd-vv->v-op ; inline
311 M: simd-128 vandn [ (simd-vandn) ] simd-vv->v-op ; inline
312 M: simd-128 vor [ (simd-vor) ] simd-vv->v-op ; inline
313 M: simd-128 vxor [ (simd-vxor) ] simd-vv->v-op ; inline
314 M: simd-128 vnot [ (simd-vnot) ] simd-v->v-op ; inline
315 M: simd-128 vlshift [ (simd-vlshift) ] simd-vn->v-op ; inline
316 M: simd-128 vrshift [ (simd-vrshift) ] simd-vn->v-op ; inline
317 M: simd-128 hlshift [ (simd-hlshift) ] simd-vn->v-op ; inline
318 M: simd-128 hrshift [ (simd-hrshift) ] simd-vn->v-op ; inline
319 M: simd-128 vshuffle-elements [ (simd-vshuffle-elements) ] simd-vn->v-op ; inline
320 M: simd-128 vshuffle-bytes [ (simd-vshuffle-bytes) ] simd-vv->v-op ; inline
321 M: simd-128 (vmerge-head) [ (simd-vmerge-head) ] simd-vv->v-op ; inline
322 M: simd-128 (vmerge-tail) [ (simd-vmerge-tail) ] simd-vv->v-op ; inline
323 M: simd-128 v<= [ (simd-v<=) ] simd-vv->v-op ; inline
324 M: simd-128 v< [ (simd-v<) ] simd-vv->v-op ; inline
325 M: simd-128 v= [ (simd-v=) ] simd-vv->v-op ; inline
326 M: simd-128 v> [ (simd-v>) ] simd-vv->v-op ; inline
327 M: simd-128 v>= [ (simd-v>=) ] simd-vv->v-op ; inline
328 M: simd-128 vunordered? [ (simd-vunordered?) ] simd-vv->v-op ; inline
329 M: simd-128 vany? [ (simd-vany?) ] simd-v->n-op ; inline
330 M: simd-128 vall? [ (simd-vall?) ] simd-v->n-op ; inline
331 M: simd-128 vnone? [ (simd-vnone?) ] simd-v->n-op ; inline
333 ! SIMD high-level specializations
335 M: simd-128 vbroadcast [ swap nth ] keep simd-with ; inline
336 M: simd-128 n+v [ simd-with ] keep v+ ; inline
337 M: simd-128 n-v [ simd-with ] keep v- ; inline
338 M: simd-128 n*v [ simd-with ] keep v* ; inline
339 M: simd-128 n/v [ simd-with ] keep v/ ; inline
340 M: simd-128 v+n over simd-with v+ ; inline
341 M: simd-128 v-n over simd-with v- ; inline
342 M: simd-128 v*n over simd-with v* ; inline
343 M: simd-128 v/n over simd-with v/ ; inline
344 M: simd-128 norm-sq dup v. assert-positive ; inline
345 M: simd-128 norm norm-sq sqrt ; inline
346 M: simd-128 distance v- norm ; inline
357 SIMD-128: ulonglong-2
363 M: simd-128 vshuffle ( u perm -- v )
364 vshuffle-bytes ; inline
366 "compiler.tree.propagation.simd" require
367 "compiler.cfg.intrinsics.simd" require
368 "compiler.cfg.value-numbering.simd" require
371 "math.vectors.simd.mirrors" require