1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien byte-arrays fry classes.algebra
4 cpu.architecture kernel math sequences math.vectors
5 math.vectors.simd.intrinsics macros generalizations combinators
6 combinators.short-circuit arrays locals
7 compiler.tree.propagation.info compiler.cfg.builder.blocks
8 compiler.cfg.comparisons
9 compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
10 compiler.cfg.instructions compiler.cfg.registers
11 compiler.cfg.intrinsics.alien
13 FROM: alien.c-types => heap-size char uchar float double ;
14 SPECIALIZED-ARRAYS: float double ;
15 IN: compiler.cfg.intrinsics.simd
17 MACRO: check-elements ( quots -- )
18 [ length '[ _ firstn ] ]
20 [ length 1 - \ and <repetition> [ ] like ]
23 MACRO: if-literals-match ( quots -- )
24 [ length ] [ ] [ length ] tri
30 _ tail-slice* [ literal>> ] map
37 ] [ 2drop emit-primitive ] if
40 : emit-vector-op ( node quot: ( rep -- ) -- )
41 { [ representation? ] } if-literals-match ; inline
43 : [binary] ( quot -- quot' )
44 '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
46 : emit-binary-vector-op ( node quot -- )
47 [binary] emit-vector-op ; inline
49 : [unary] ( quot -- quot' )
50 '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
52 : emit-unary-vector-op ( node quot -- )
53 [unary] emit-vector-op ; inline
55 : [unary/param] ( quot -- quot' )
56 '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
58 : emit-horizontal-shift ( node quot -- )
60 { [ integer? ] [ representation? ] } if-literals-match ; inline
62 : emit-gather-vector-2 ( node -- )
63 [ ^^gather-vector-2 ] emit-binary-vector-op ;
65 : emit-gather-vector-4 ( node -- )
79 : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
81 : >variable-shuffle ( shuffle rep -- shuffle' )
82 rep-component-type heap-size
83 [ dup <repetition> >byte-array ]
84 [ iota >byte-array ] bi
85 '[ _ n*v _ v+ ] map concat ;
87 : generate-shuffle-vector-imm ( src shuffle rep -- dst )
88 dup %shuffle-vector-imm-reps member?
89 [ ^^shuffle-vector-imm ]
91 [ >variable-shuffle ^^load-constant ] keep
95 : emit-shuffle-vector-imm ( node -- )
96 ! Pad the permutation with zeroes if it's too short, since we
97 ! can't throw an error at this point.
98 [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param]
99 { [ shuffle? ] [ representation? ] } if-literals-match ;
101 : emit-shuffle-vector-var ( node -- )
102 [ ^^shuffle-vector ] [binary]
103 { [ %shuffle-vector-reps member? ] } if-literals-match ;
105 : emit-shuffle-vector ( node -- )
106 dup node-input-infos {
108 [ first class>> byte-array class<= ]
109 [ second class>> byte-array class<= ]
110 [ third literal>> representation? ]
111 } 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ;
113 : ^^broadcast-vector ( src n rep -- dst )
114 [ rep-components swap <array> ] keep
115 generate-shuffle-vector-imm ;
117 : emit-broadcast-vector ( node -- )
118 [ ^^broadcast-vector ] [unary/param]
119 { [ integer? ] [ representation? ] } if-literals-match ;
121 : ^^with-vector ( src rep -- dst )
122 [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
124 : ^^select-vector ( src n rep -- dst )
125 [ ^^broadcast-vector ] keep ^^vector>scalar ;
127 : emit-select-vector ( node -- )
128 [ ^^select-vector ] [unary/param]
129 { [ integer? ] [ representation? ] } if-literals-match ; inline
131 : emit-alien-vector-op ( node quot: ( rep -- ) -- )
132 { [ %alien-vector-reps member? ] } if-literals-match ; inline
134 : emit-alien-vector ( node -- )
137 ds-drop prepare-alien-getter
138 _ ^^alien-vector ds-push
140 [ inline-alien-getter? ] inline-alien
141 ] with emit-alien-vector-op ;
143 : emit-set-alien-vector ( node -- )
146 ds-drop prepare-alien-setter ds-pop
149 [ byte-array inline-alien-setter? ]
151 ] with emit-alien-vector-op ;
153 : generate-not-vector ( src rep -- dst )
154 dup %not-vector-reps member?
156 [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
158 :: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
159 {cc,swap} first2 :> swap? :> cc
161 [ src2 src1 rep cc ^^compare-vector ]
162 [ src1 src2 rep cc ^^compare-vector ] if ;
164 :: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
165 rep orig-cc %compare-vector-ccs :> not? :> ccs
168 [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
170 ccs unclip :> first-cc :> rest-ccs
171 src1 src2 rep first-cc (generate-compare-vector) :> first-dst
174 [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
177 not? [ rep generate-not-vector ] when
180 :: generate-unpack-vector-head ( src rep -- dst )
183 [ rep %unpack-vector-head-reps member? ]
184 [ src rep ^^unpack-vector-head ]
187 rep ^^zero-vector :> zero
188 zero src rep cc> ^^compare-vector :> sign
189 src sign rep ^^merge-vector-head
193 :: generate-unpack-vector-tail ( src rep -- dst )
196 [ rep %unpack-vector-tail-reps member? ]
197 [ src rep ^^unpack-vector-tail ]
200 [ rep %unpack-vector-head-reps member? ]
202 src rep ^^tail>head-vector :> tail
203 tail rep ^^unpack-vector-head
207 rep ^^zero-vector :> zero
208 zero src rep cc> ^^compare-vector :> sign
209 src sign rep ^^merge-vector-tail
213 :: generate-load-neg-zero-vector ( rep -- dst )
215 { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
216 { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
217 [ drop rep ^^zero-vector ]
220 :: generate-neg-vector ( src rep -- dst )
221 rep generate-load-neg-zero-vector
222 src rep ^^sub-vector ;
224 :: generate-blend-vector ( mask true false rep -- dst )
225 mask true rep ^^and-vector
226 mask false rep ^^andn-vector
229 :: generate-abs-vector ( src rep -- dst )
232 [ rep unsigned-int-vector-rep? ]
236 [ rep %abs-vector-reps member? ]
237 [ src rep ^^abs-vector ]
240 [ rep float-vector-rep? ]
242 rep generate-load-neg-zero-vector
243 src rep ^^andn-vector
247 rep ^^zero-vector :> zero
248 zero src rep ^^sub-vector :> -src
249 zero src rep cc> ^^compare-vector :> sign
250 sign -src src rep generate-blend-vector