1 ;;;; SSE intrinsics support for x86-64
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (defun ea-for-sse-stack (tn &optional
(base rbp-tn
))
15 (make-ea :qword
:base base
16 :disp
(frame-byte-offset (1+ (tn-offset tn
)))))
18 (defun float-sse-p (tn)
19 (sc-is tn single-sse-reg single-sse-stack single-sse-immediate
20 double-sse-reg double-sse-stack double-sse-immediate
))
22 (sc-is tn int-sse-reg int-sse-stack int-sse-immediate
))
24 ;; On the target we want stubs for the interpreter.
25 ;; On the host we want not to call these.
28 (defun %simd-pack-low
(x)
29 (declare (type simd-pack x
))
31 (defun %simd-pack-high
(x)
32 (declare (type simd-pack x
))
36 (defun %simd-pack-low
(x) (error "Called %SIMD-PACK-LOW ~S" x
))
37 (defun %simd-pack-high
(x) (error "Called %SIMD-PACK-HIGH ~S" x
)))
39 (define-move-fun (load-int-sse-immediate 1) (vop x y
)
40 ((int-sse-immediate) (int-sse-reg))
41 (let* ((x (tn-value x
))
42 (lo (%simd-pack-low x
))
43 (hi (%simd-pack-high x
)))
46 ((= lo hi
(ldb (byte 64 0) -
1))
47 ;; don't think this is recognized as dependency breaking...
50 (inst movdqa y
(register-inline-constant x
))))))
52 (define-move-fun (load-float-sse-immediate 1) (vop x y
)
53 ((single-sse-immediate double-sse-immediate
)
54 (single-sse-reg double-sse-reg
))
55 (let* ((x (tn-value x
))
56 (lo (%simd-pack-low x
))
57 (hi (%simd-pack-high x
)))
60 ((= lo hi
(ldb (byte 64 0) -
1))
63 (inst movaps y
(register-inline-constant x
))))))
65 (define-move-fun (load-int-sse 2) (vop x y
)
66 ((int-sse-stack) (int-sse-reg))
67 (inst movdqu y
(ea-for-sse-stack x
)))
69 (define-move-fun (load-float-sse 2) (vop x y
)
70 ((single-sse-stack double-sse-stack
) (single-sse-reg double-sse-reg
))
71 (inst movups y
(ea-for-sse-stack x
)))
73 (define-move-fun (store-int-sse 2) (vop x y
)
74 ((int-sse-reg) (int-sse-stack))
75 (inst movdqu
(ea-for-sse-stack y
) x
))
77 (define-move-fun (store-float-sse 2) (vop x y
)
78 ((double-sse-reg single-sse-reg
) (double-sse-stack single-sse-stack
))
79 (inst movups
(ea-for-sse-stack y
) x
))
81 (define-vop (sse-move)
82 (:args
(x :scs
(single-sse-reg double-sse-reg int-sse-reg
)
84 :load-if
(not (location= x y
))))
85 (:results
(y :scs
(single-sse-reg double-sse-reg int-sse-reg
)
86 :load-if
(not (location= x y
))))
90 (define-move-vop sse-move
:move
91 (int-sse-reg single-sse-reg double-sse-reg
)
92 (int-sse-reg single-sse-reg double-sse-reg
))
94 (define-vop (move-from-sse)
95 (:args
(x :scs
(single-sse-reg double-sse-reg int-sse-reg
)))
96 (:results
(y :scs
(descriptor-reg)))
98 (:note
"SSE to pointer coercion")
100 (with-fixed-allocation (y
104 ;; see *simd-pack-element-types*
111 y simd-pack-tag-slot other-pointer-lowtag
)
112 (let ((ea (make-ea-for-object-slot
113 y simd-pack-lo-value-slot other-pointer-lowtag
)))
116 (inst movdqa ea x
))))))
117 (define-move-vop move-from-sse
:move
118 (int-sse-reg single-sse-reg double-sse-reg
) (descriptor-reg))
120 (define-vop (move-to-sse)
121 (:args
(x :scs
(descriptor-reg)))
122 (:results
(y :scs
(int-sse-reg double-sse-reg single-sse-reg
)))
123 (:note
"pointer to SSE coercion")
125 (let ((ea (make-ea-for-object-slot
126 x simd-pack-lo-value-slot other-pointer-lowtag
)))
129 (inst movdqa y ea
)))))
130 (define-move-vop move-to-sse
:move
132 (int-sse-reg double-sse-reg single-sse-reg
))
134 (define-vop (move-sse-arg)
135 (:args
(x :scs
(int-sse-reg double-sse-reg single-sse-reg
) :target y
)
137 :load-if
(not (sc-is y int-sse-reg double-sse-reg single-sse-reg
))))
139 (:note
"SSE argument move")
142 ((int-sse-reg double-sse-reg single-sse-reg
)
143 (unless (location= x y
)
144 (if (or (float-sse-p x
)
148 ((int-sse-stack double-sse-stack single-sse-stack
)
150 (inst movups
(ea-for-sse-stack y fp
) x
)
151 (inst movdqu
(ea-for-sse-stack y fp
) x
))))))
152 (define-move-vop move-sse-arg
:move-arg
153 (int-sse-reg double-sse-reg single-sse-reg descriptor-reg
)
154 (int-sse-reg double-sse-reg single-sse-reg
))
156 (define-move-vop move-arg
:move-arg
157 (int-sse-reg double-sse-reg single-sse-reg
)
161 (define-vop (%simd-pack-low
)
162 (:translate %simd-pack-low
)
163 (:args
(x :scs
(int-sse-reg double-sse-reg single-sse-reg
)))
164 (:arg-types simd-pack
)
165 (:results
(dst :scs
(unsigned-reg)))
166 (:result-types unsigned-num
)
171 (define-vop (%simd-pack-high
)
172 (:translate %simd-pack-high
)
173 (:args
(x :scs
(int-sse-reg double-sse-reg single-sse-reg
)
175 (:arg-types simd-pack
)
176 (:temporary
(:sc sse-reg
:from
(:argument
0)) tmp
)
177 (:results
(dst :scs
(unsigned-reg)))
178 (:result-types unsigned-num
)
183 (inst movd dst tmp
)))
185 (define-vop (%make-simd-pack
)
186 (:translate %make-simd-pack
)
188 (:args
(tag :scs
(any-reg))
189 (lo :scs
(unsigned-reg))
190 (hi :scs
(unsigned-reg)))
191 (:arg-types tagged-num unsigned-num unsigned-num
)
192 (:results
(dst :scs
(descriptor-reg) :from
:load
))
196 (with-fixed-allocation (dst
200 ;; see *simd-pack-element-types*
202 dst simd-pack-tag-slot other-pointer-lowtag
)
204 dst simd-pack-lo-value-slot other-pointer-lowtag
)
206 dst simd-pack-hi-value-slot other-pointer-lowtag
))))
208 (defun %make-simd-pack
(tag low high
)
209 (declare (type fixnum tag
)
210 (type (unsigned-byte 64) low high
))
211 (%make-simd-pack tag low high
))
213 (define-vop (%make-simd-pack-ub64
)
214 (:translate %make-simd-pack-ub64
)
216 (:args
(lo :scs
(unsigned-reg))
217 (hi :scs
(unsigned-reg)))
218 (:arg-types unsigned-num unsigned-num
)
219 (:temporary
(:sc int-sse-reg
) tmp
)
220 (:results
(dst :scs
(int-sse-reg)))
221 (:result-types simd-pack-int
)
225 (inst punpcklqdq dst tmp
)))
227 (defun %make-simd-pack-ub64
(low high
)
228 (declare (type (unsigned-byte 64) low high
))
229 (%make-simd-pack-ub64 low high
))
232 (declaim (inline %make-simd-pack-ub32
))
234 (defun %make-simd-pack-ub32
(w x y z
)
235 (declare (type (unsigned-byte 32) w x y z
))
236 (%make-simd-pack-ub64
(logior w
(ash x
32))
237 (logior y
(ash z
32))))
241 (declaim (inline %simd-pack-ub32s %simd-pack-ub64s
))
242 (defun %simd-pack-ub32s
(pack)
243 (declare (type simd-pack pack
))
244 (let ((lo (%simd-pack-low pack
))
245 (hi (%simd-pack-high pack
)))
246 (values (ldb (byte 32 0) lo
)
251 (defun %simd-pack-ub64s
(pack)
252 (declare (type simd-pack pack
))
253 (values (%simd-pack-low pack
)
254 (%simd-pack-high pack
))))
256 (define-vop (%make-simd-pack-double
)
257 (:translate %make-simd-pack-double
)
259 (:args
(lo :scs
(double-reg) :target dst
)
260 (hi :scs
(double-reg) :target tmp
))
261 (:arg-types double-float double-float
)
262 (:temporary
(:sc double-sse-reg
:from
(:argument
1)) tmp
)
263 (:results
(dst :scs
(double-sse-reg) :from
(:argument
0)))
264 (:result-types simd-pack-double
)
268 (inst unpcklpd dst tmp
)))
270 (defun %make-simd-pack-double
(low high
)
271 (declare (type double-float low high
))
272 (%make-simd-pack-double low high
))
274 (define-vop (%make-simd-pack-single
)
275 (:translate %make-simd-pack-single
)
277 (:args
(x :scs
(single-reg) :target dst
)
278 (y :scs
(single-reg) :target tmp
)
279 (z :scs
(single-reg))
280 (w :scs
(single-reg)))
281 (:arg-types single-float single-float single-float single-float
)
282 (:temporary
(:sc single-sse-reg
:from
(:argument
1)) tmp
)
283 (:results
(dst :scs
(single-sse-reg) :from
(:argument
0)))
284 (:result-types simd-pack-single
)
287 (inst unpcklps dst z
)
289 (inst unpcklps tmp w
)
290 (inst unpcklps dst tmp
)))
292 (defun %make-simd-pack-single
(x y z w
)
293 (declare (type single-float x y z w
))
294 (%make-simd-pack-single x y z w
))
296 (defun %simd-pack-tag
(pack)
297 (%simd-pack-tag pack
))
299 (define-vop (%simd-pack-single-item
)
300 (:args
(x :scs
(int-sse-reg double-sse-reg single-sse-reg
)
302 (:arg-types simd-pack
)
304 (:results
(dst :scs
(single-reg)))
305 (:result-types single-float
)
306 (:temporary
(:sc single-sse-reg
:from
(:argument
0)) tmp
)
309 (cond ((and (zerop index
)
310 (not (location= x dst
)))
316 (inst psrldq tmp
(* 4 index
)))
318 (inst movss dst tmp
)))))
321 (declaim (inline %simd-pack-singles
))
323 (defun %simd-pack-singles
(pack)
324 (declare (type simd-pack pack
))
325 (values (%primitive %simd-pack-single-item pack
0)
326 (%primitive %simd-pack-single-item pack
1)
327 (%primitive %simd-pack-single-item pack
2)
328 (%primitive %simd-pack-single-item pack
3)))
330 (define-vop (%simd-pack-double-item
)
331 (:args
(x :scs
(int-sse-reg double-sse-reg single-sse-reg
)
334 (:arg-types simd-pack
)
335 (:results
(dst :scs
(double-reg)))
336 (:result-types double-float
)
337 (:temporary
(:sc double-sse-reg
:from
(:argument
0)) tmp
)
340 (cond ((and (zerop index
)
341 (not (location= x dst
)))
347 (inst psrldq tmp
(* 8 index
)))
349 (inst movsd dst tmp
)))))
352 (declaim (inline %simd-pack-doubles
))
354 (defun %simd-pack-doubles
(pack)
355 (declare (type simd-pack pack
))
356 (values (%primitive %simd-pack-double-item pack
0)
357 (%primitive %simd-pack-double-item pack
1)))