1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors byte-arrays fry cpu.architecture kernel math
4 sequences math.vectors.simd.intrinsics macros generalizations
5 combinators combinators.short-circuit arrays locals
6 compiler.tree.propagation.info compiler.cfg.builder.blocks
7 compiler.cfg.comparisons
8 compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
9 compiler.cfg.instructions compiler.cfg.registers
10 compiler.cfg.intrinsics.alien ;
11 IN: compiler.cfg.intrinsics.simd
13 MACRO: check-elements ( quots -- )
14 [ length '[ _ firstn ] ]
16 [ length 1 - \ and <repetition> [ ] like ]
19 MACRO: if-literals-match ( quots -- )
20 [ length ] [ ] [ length ] tri
26 _ tail-slice* [ literal>> ] map
33 ] [ 2drop emit-primitive ] if
36 : emit-vector-op ( node quot: ( rep -- ) -- )
37 { [ representation? ] } if-literals-match ; inline
39 : [binary] ( quot -- quot' )
40 '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
42 : emit-binary-vector-op ( node quot -- )
43 [binary] emit-vector-op ; inline
45 : [unary] ( quot -- quot' )
46 '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
48 : emit-unary-vector-op ( node quot -- )
49 [unary] emit-vector-op ; inline
51 : [unary/param] ( quot -- quot' )
52 '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
54 : emit-horizontal-shift ( node quot -- )
56 { [ integer? ] [ representation? ] } if-literals-match ; inline
58 : emit-gather-vector-2 ( node -- )
59 [ ^^gather-vector-2 ] emit-binary-vector-op ;
61 : emit-gather-vector-4 ( node -- )
75 : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
77 : emit-shuffle-vector ( node -- )
78 ! Pad the permutation with zeroes if its too short, since we
79 ! can't throw an error at this point.
80 [ [ rep-components 0 pad-tail ] keep ^^shuffle-vector ] [unary/param]
81 { [ shuffle? ] [ representation? ] } if-literals-match ;
83 : ^^broadcast-vector ( src n rep -- dst )
84 [ rep-components swap <array> ] keep
87 : emit-broadcast-vector ( node -- )
88 [ ^^broadcast-vector ] [unary/param]
89 { [ integer? ] [ representation? ] } if-literals-match ;
91 : ^^with-vector ( src rep -- dst )
92 [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
94 : ^^select-vector ( src n rep -- dst )
95 [ ^^broadcast-vector ] keep ^^vector>scalar ;
97 : emit-select-vector ( node -- )
98 [ ^^select-vector ] [unary/param]
99 { [ integer? ] [ representation? ] } if-literals-match ; inline
101 : emit-alien-vector ( node -- )
104 ds-drop prepare-alien-getter
105 _ ^^alien-vector ds-push
107 [ inline-alien-getter? ] inline-alien
108 ] with emit-vector-op ;
110 : emit-set-alien-vector ( node -- )
113 ds-drop prepare-alien-setter ds-pop
116 [ byte-array inline-alien-setter? ]
118 ] with emit-vector-op ;
120 : generate-not-vector ( src rep -- dst )
121 dup %not-vector-reps member?
123 [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
125 :: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
126 {cc,swap} first2 :> swap? :> cc
128 [ src2 src1 rep cc ^^compare-vector ]
129 [ src1 src2 rep cc ^^compare-vector ] if ;
131 :: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
132 rep orig-cc %compare-vector-ccs :> not? :> ccs
135 [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
137 ccs unclip :> first-cc :> rest-ccs
138 src1 src2 rep first-cc (generate-compare-vector) :> first-dst
141 [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
144 not? [ rep generate-not-vector ] when
147 :: generate-unpack-vector-head ( src rep -- dst )
150 [ rep %unpack-vector-head-reps member? ]
151 [ src rep ^^unpack-vector-head ]
154 rep ^^zero-vector :> zero
155 zero src rep cc> ^^compare-vector :> sign
156 src sign rep ^^merge-vector-head
160 :: generate-unpack-vector-tail ( src rep -- dst )
163 [ rep %unpack-vector-tail-reps member? ]
164 [ src rep ^^unpack-vector-tail ]
167 [ rep %unpack-vector-head-reps member? ]
169 src rep ^^tail>head-vector :> tail
170 tail rep ^^unpack-vector-head
174 rep ^^zero-vector :> zero
175 zero src rep cc> ^^compare-vector :> sign
176 src sign rep ^^merge-vector-tail