1 ;;;; floating point support for the x86
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 (macrolet ((ea-for-xf-desc (tn slot
)
17 :disp
(- (* ,slot n-word-bytes
)
18 other-pointer-lowtag
))))
19 (defun ea-for-df-desc (tn)
20 (ea-for-xf-desc tn double-float-value-slot
))
22 (defun ea-for-csf-data-desc (tn)
23 (ea-for-xf-desc tn complex-single-float-data-slot
))
24 (defun ea-for-csf-real-desc (tn)
25 (ea-for-xf-desc tn complex-single-float-data-slot
))
26 (defun ea-for-csf-imag-desc (tn)
27 (ea-for-xf-desc tn
(+ complex-single-float-data-slot
1/2)))
29 (defun ea-for-cdf-data-desc (tn)
30 (ea-for-xf-desc tn complex-double-float-real-slot
))
31 (defun ea-for-cdf-real-desc (tn)
32 (ea-for-xf-desc tn complex-double-float-real-slot
))
33 (defun ea-for-cdf-imag-desc (tn)
34 (ea-for-xf-desc tn complex-double-float-imag-slot
)))
36 (macrolet ((ea-for-xf-stack (tn kind
)
37 (declare (ignore kind
))
40 :disp
(frame-byte-offset (tn-offset ,tn
)))))
41 (defun ea-for-sf-stack (tn)
42 (ea-for-xf-stack tn
:single
))
43 (defun ea-for-df-stack (tn)
44 (ea-for-xf-stack tn
:double
)))
46 ;;; complex float stack EAs
47 (macrolet ((ea-for-cxf-stack (tn kind slot
&optional base
)
50 :disp
(frame-byte-offset
52 (cond ((= (tn-offset ,base
) rsp-offset
)
54 ((= (tn-offset ,base
) rbp-offset
)
56 (t (error "Unexpected offset.")))
66 (defun ea-for-csf-data-stack (tn &optional
(base rbp-tn
))
67 (ea-for-cxf-stack tn
:single
:real base
))
68 (defun ea-for-csf-real-stack (tn &optional
(base rbp-tn
))
69 (ea-for-cxf-stack tn
:single
:real base
))
70 (defun ea-for-csf-imag-stack (tn &optional
(base rbp-tn
))
71 (ea-for-cxf-stack tn
:single
:imag base
))
73 (defun ea-for-cdf-data-stack (tn &optional
(base rbp-tn
))
74 (ea-for-cxf-stack tn
:double
:real base
))
75 (defun ea-for-cdf-real-stack (tn &optional
(base rbp-tn
))
76 (ea-for-cxf-stack tn
:double
:real base
))
77 (defun ea-for-cdf-imag-stack (tn &optional
(base rbp-tn
))
78 (ea-for-cxf-stack tn
:double
:imag base
)))
80 (defun ea-for-sse-stack (tn &optional
(base rbp-tn
))
81 (make-ea :qword
:base base
82 :disp
(- (* (+ (tn-offset tn
)
89 ;;; X is source, Y is destination.
91 (define-move-fun (load-fp-zero 1) (vop x y
)
92 ((fp-single-zero) (single-reg)
93 (fp-double-zero) (double-reg)
94 (fp-complex-single-zero) (complex-single-reg)
95 (fp-complex-double-zero) (complex-double-reg))
98 ((single-reg complex-single-reg
) (inst xorps y y
))
99 ((double-reg complex-double-reg
) (inst xorpd y y
))))
101 (define-move-fun (load-fp-immediate 1) (vop x y
)
102 ((fp-single-immediate) (single-reg)
103 (fp-double-immediate) (double-reg)
104 (fp-complex-single-immediate) (complex-single-reg)
105 (fp-complex-double-immediate) (complex-double-reg))
106 (let ((x (register-inline-constant (tn-value x
))))
108 (single-reg (inst movss y x
))
109 (double-reg (inst movsd y x
))
110 (complex-single-reg (inst movq y x
))
111 (complex-double-reg (inst movapd y x
)))))
113 (define-move-fun (load-single 2) (vop x y
)
114 ((single-stack) (single-reg))
115 (inst movss y
(ea-for-sf-stack x
)))
117 (define-move-fun (store-single 2) (vop x y
)
118 ((single-reg) (single-stack))
119 (inst movss
(ea-for-sf-stack y
) x
))
121 (define-move-fun (load-double 2) (vop x y
)
122 ((double-stack) (double-reg))
123 (inst movsd y
(ea-for-df-stack x
)))
125 (define-move-fun (store-double 2) (vop x y
)
126 ((double-reg) (double-stack))
127 (inst movsd
(ea-for-df-stack y
) x
))
129 (eval-when (:compile-toplevel
:execute
)
130 (setf *read-default-float-format
* 'single-float
))
132 ;;;; complex float and SSE move functions
134 ;;; X is source, Y is destination.
135 (define-move-fun (load-complex-single 2) (vop x y
)
136 ((complex-single-stack) (complex-single-reg))
137 (inst movq y
(ea-for-csf-data-stack x
)))
139 (define-move-fun (store-complex-single 2) (vop x y
)
140 ((complex-single-reg) (complex-single-stack))
141 (inst movq
(ea-for-csf-data-stack y
) x
))
143 (define-move-fun (load-complex-double 2) (vop x y
)
144 ((complex-double-stack) (complex-double-reg))
145 (inst movupd y
(ea-for-cdf-data-stack x
)))
147 (define-move-fun (store-complex-double 2) (vop x y
)
148 ((complex-double-reg) (complex-double-stack))
149 (inst movupd
(ea-for-cdf-data-stack y
) x
))
151 (define-move-fun (load-sse-pack 2) (vop x y
)
152 ((sse-stack) (sse-reg))
153 (inst movdqu y
(ea-for-sse-stack x
)))
155 (define-move-fun (store-sse-pack 2) (vop x y
)
156 ((sse-reg) (sse-stack))
157 (inst movdqu
(ea-for-sse-stack y
) x
))
161 ;;; float register to register moves
162 (macrolet ((frob (vop sc
)
167 :load-if
(not (location= x y
))))
168 (:results
(y :scs
(,sc
)
169 :load-if
(not (location= x y
))))
173 (define-move-vop ,vop
:move
(,sc
) (,sc
)))))
174 (frob single-move single-reg
)
175 (frob double-move double-reg
)
176 (frob complex-single-move complex-single-reg
)
177 (frob complex-double-move complex-double-reg
)
178 (frob sse-move sse-reg
))
181 ;;; Move from float to a descriptor reg. allocating a new float
182 ;;; object in the process.
183 (define-vop (move-from-single)
184 (:args
(x :scs
(single-reg) :to
:save
))
185 (:results
(y :scs
(descriptor-reg)))
186 (:note
"float to pointer coercion")
190 (inst or y single-float-widetag
)))
192 (define-move-vop move-from-single
:move
193 (single-reg) (descriptor-reg))
195 (define-vop (move-from-double)
196 (:args
(x :scs
(double-reg) :to
:save
))
197 (:results
(y :scs
(descriptor-reg)))
199 (:note
"float to pointer coercion")
201 (with-fixed-allocation (y
205 (inst movsd
(ea-for-df-desc y
) x
))))
206 (define-move-vop move-from-double
:move
207 (double-reg) (descriptor-reg))
209 (define-vop (move-from-sse)
210 (:args
(x :scs
(sse-reg)))
211 (:results
(y :scs
(descriptor-reg)))
213 (:note
"SSE to pointer coercion")
215 (with-fixed-allocation (y
219 (inst movdqa
(make-ea-for-object-slot
220 y sse-pack-lo-value-slot other-pointer-lowtag
)
222 (define-move-vop move-from-sse
:move
223 (sse-reg) (descriptor-reg))
225 ;;; Move from a descriptor to a float register.
226 (define-vop (move-to-single)
227 (:args
(x :scs
(descriptor-reg) :target tmp
))
228 (:temporary
(:sc unsigned-reg
) tmp
)
229 (:results
(y :scs
(single-reg)))
230 (:note
"pointer to float coercion")
236 (define-move-vop move-to-single
:move
(descriptor-reg) (single-reg))
238 (define-vop (move-to-double)
239 (:args
(x :scs
(descriptor-reg)))
240 (:results
(y :scs
(double-reg)))
241 (:note
"pointer to float coercion")
243 (inst movsd y
(ea-for-df-desc x
))))
244 (define-move-vop move-to-double
:move
(descriptor-reg) (double-reg))
246 (define-vop (move-to-sse)
247 (:args
(x :scs
(descriptor-reg)))
248 (:results
(y :scs
(sse-reg)))
249 (:note
"pointer to SSE coercion")
251 (inst movdqa y
(make-ea-for-object-slot
252 x sse-pack-lo-value-slot other-pointer-lowtag
))))
253 (define-move-vop move-to-sse
:move
(descriptor-reg) (sse-reg))
256 ;;; Move from complex float to a descriptor reg. allocating a new
257 ;;; complex float object in the process.
258 (define-vop (move-from-complex-single)
259 (:args
(x :scs
(complex-single-reg) :to
:save
))
260 (:results
(y :scs
(descriptor-reg)))
262 (:note
"complex float to pointer coercion")
264 (with-fixed-allocation (y
265 complex-single-float-widetag
266 complex-single-float-size
268 (inst movq
(ea-for-csf-data-desc y
) x
))))
269 (define-move-vop move-from-complex-single
:move
270 (complex-single-reg) (descriptor-reg))
272 (define-vop (move-from-complex-double)
273 (:args
(x :scs
(complex-double-reg) :to
:save
))
274 (:results
(y :scs
(descriptor-reg)))
276 (:note
"complex float to pointer coercion")
278 (with-fixed-allocation (y
279 complex-double-float-widetag
280 complex-double-float-size
282 (inst movapd
(ea-for-cdf-data-desc y
) x
))))
283 (define-move-vop move-from-complex-double
:move
284 (complex-double-reg) (descriptor-reg))
286 ;;; Move from a descriptor to a complex float register.
287 (macrolet ((frob (name sc format
)
290 (:args
(x :scs
(descriptor-reg)))
291 (:results
(y :scs
(,sc
)))
292 (:note
"pointer to complex float coercion")
296 '(inst movq y
(ea-for-csf-data-desc x
)))
298 '(inst movapd y
(ea-for-cdf-data-desc x
))))))
299 (define-move-vop ,name
:move
(descriptor-reg) (,sc
)))))
300 (frob move-to-complex-single complex-single-reg
:single
)
301 (frob move-to-complex-double complex-double-reg
:double
))
303 ;;;; the move argument vops
305 ;;;; Note these are also used to stuff fp numbers onto the c-call
306 ;;;; stack so the order is different than the lisp-stack.
308 ;;; the general MOVE-ARG VOP
309 (macrolet ((frob (name sc stack-sc format
)
312 (:args
(x :scs
(,sc
) :target y
)
314 :load-if
(not (sc-is y
,sc
))))
316 (:note
"float argument move")
317 (:generator
,(case format
(:single
2) (:double
3) )
322 (if (= (tn-offset fp
) esp-offset
)
323 (let* ((offset (* (tn-offset y
) n-word-bytes
))
324 (ea (make-ea :dword
:base fp
:disp offset
)))
326 (:single
'((inst movss ea x
)))
327 (:double
'((inst movsd ea x
)))))
330 :disp
(frame-byte-offset (tn-offset y
)))))
332 (:single
'((inst movss ea x
)))
333 (:double
'((inst movsd ea x
))))))))))
334 (define-move-vop ,name
:move-arg
335 (,sc descriptor-reg
) (,sc
)))))
336 (frob move-single-float-arg single-reg single-stack
:single
)
337 (frob move-double-float-arg double-reg double-stack
:double
))
339 (define-vop (move-sse-arg)
340 (:args
(x :scs
(sse-reg) :target y
)
342 :load-if
(not (sc-is y sse-reg
))))
344 (:note
"SSE argument move")
348 (unless (location= x y
)
351 (inst movdqa
(ea-for-sse-stack y fp
) x
)))))
352 (define-move-vop move-sse-arg
:move-arg
353 (sse-reg descriptor-reg
) (sse-reg))
355 ;;;; complex float MOVE-ARG VOP
356 (macrolet ((frob (name sc stack-sc format
)
359 (:args
(x :scs
(,sc
) :target y
)
361 :load-if
(not (sc-is y
,sc
))))
363 (:note
"complex float argument move")
364 (:generator
,(ecase format
(:single
2) (:double
3))
371 '(inst movq
(ea-for-csf-data-stack y fp
) x
))
373 '(inst movupd
(ea-for-cdf-data-stack y fp
) x
)))))))
374 (define-move-vop ,name
:move-arg
375 (,sc descriptor-reg
) (,sc
)))))
376 (frob move-complex-single-float-arg
377 complex-single-reg complex-single-stack
:single
)
378 (frob move-complex-double-float-arg
379 complex-double-reg complex-double-stack
:double
))
381 (define-move-vop move-arg
:move-arg
382 (single-reg double-reg
383 complex-single-reg complex-double-reg
390 (define-vop (float-op)
394 (:note
"inline float arithmetic")
396 (:save-p
:compute-only
))
398 (macrolet ((frob (name comm-name sc constant-sc ptype
)
400 (define-vop (,name float-op
)
401 (:args
(x :scs
(,sc
,constant-sc
)
403 :load-if
(not (sc-is x
,constant-sc
)))
404 (y :scs
(,sc
,constant-sc
)
405 :load-if
(not (sc-is y
,constant-sc
))))
406 (:results
(r :scs
(,sc
)))
407 (:arg-types
,ptype
,ptype
)
408 (:result-types
,ptype
))
409 (define-vop (,comm-name float-op
)
410 (:args
(x :scs
(,sc
,constant-sc
)
412 :load-if
(not (sc-is x
,constant-sc
)))
413 (y :scs
(,sc
,constant-sc
)
415 :load-if
(not (sc-is y
,constant-sc
))))
416 (:results
(r :scs
(,sc
)))
417 (:arg-types
,ptype
,ptype
)
418 (:result-types
,ptype
)))))
419 (frob single-float-op single-float-comm-op
420 single-reg fp-single-immediate single-float
)
421 (frob double-float-op double-float-comm-op
422 double-reg fp-double-immediate double-float
)
423 (frob complex-single-float-op complex-single-float-comm-op
424 complex-single-reg fp-complex-single-immediate
425 complex-single-float
)
426 (frob complex-double-float-op complex-double-float-comm-op
427 complex-double-reg fp-complex-double-immediate
428 complex-double-float
))
430 (macrolet ((generate (opinst commutative constant-sc load-inst
)
431 `(flet ((get-constant (tn)
432 (register-inline-constant
433 ,@(and (eq constant-sc
'fp-single-immediate
)
436 (declare (ignorable #'get-constant
))
439 (when (sc-is y
,constant-sc
)
440 (setf y
(get-constant y
)))
442 ((and ,commutative
(location= y r
))
443 (when (sc-is x
,constant-sc
)
444 (setf x
(get-constant x
)))
446 ((not (location= r y
))
447 (if (sc-is x
,constant-sc
)
448 (inst ,load-inst r
(get-constant x
))
450 (when (sc-is y
,constant-sc
)
451 (setf y
(get-constant y
)))
454 (if (sc-is x
,constant-sc
)
455 (inst ,load-inst tmp
(get-constant x
))
459 (frob (op sinst sname scost dinst dname dcost commutative
460 &optional csinst csname cscost cdinst cdname cdcost
)
462 (define-vop (,sname
,(if commutative
463 'single-float-comm-op
466 (:temporary
(:sc single-reg
) tmp
)
468 (generate ,sinst
,commutative fp-single-immediate movss
)))
469 (define-vop (,dname
,(if commutative
470 'double-float-comm-op
473 (:temporary
(:sc double-reg
) tmp
)
475 (generate ,dinst
,commutative fp-double-immediate movsd
)))
477 `(define-vop (,csname
479 'complex-single-float-comm-op
480 'complex-single-float-op
))
482 (:temporary
(:sc complex-single-reg
) tmp
)
484 (generate ,csinst
,commutative
485 fp-complex-single-immediate movq
))))
487 `(define-vop (,cdname
489 'complex-double-float-comm-op
490 'complex-double-float-op
))
492 (:temporary
(:sc complex-double-reg
) tmp
)
494 (generate ,cdinst
,commutative
495 fp-complex-double-immediate movapd
)))))))
496 (frob + addss
+/single-float
2 addsd
+/double-float
2 t
497 addps
+/complex-single-float
3 addpd
+/complex-double-float
3)
498 (frob - subss -
/single-float
2 subsd -
/double-float
2 nil
499 subps -
/complex-single-float
3 subpd -
/complex-double-float
3)
500 (frob * mulss
*/single-float
4 mulsd
*/double-float
5 t
)
501 (frob / divss
//single-float
12 divsd
//double-float
19 nil
))
503 (macrolet ((frob (op cost commutativep
504 duplicate-inst op-inst real-move-inst complex-move-inst
505 real-sc real-constant-sc real-type
506 complex-sc complex-constant-sc complex-type
507 real-complex-name complex-real-name
)
508 (cond ((not duplicate-inst
) ; simple case
509 `(flet ((load-into (r x
)
512 (inst ,real-move-inst r
513 (register-inline-constant (tn-value x
))))
514 (,complex-constant-sc
515 (inst ,complex-move-inst r
516 (register-inline-constant (tn-value x
))))
518 ,(when real-complex-name
519 `(define-vop (,real-complex-name float-op
)
521 (:args
(x :scs
(,real-sc
,real-constant-sc
)
523 :load-if
(not (sc-is x
,real-constant-sc
)))
524 (y :scs
(,complex-sc
,complex-constant-sc
)
525 ,@(when commutativep
'(:target r
))
526 :load-if
(not (sc-is y
,complex-constant-sc
))))
527 (:arg-types
,real-type
,complex-type
)
528 (:results
(r :scs
(,complex-sc
)
529 ,@(unless commutativep
'(:from
(:argument
0)))))
530 (:result-types
,complex-type
)
533 `(when (location= y r
)
536 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
537 (setf y
(register-inline-constant
538 :aligned
(tn-value y
))))
539 (inst ,op-inst r y
))))
541 ,(when complex-real-name
542 `(define-vop (,complex-real-name float-op
)
544 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
546 :load-if
(not (sc-is x
,complex-constant-sc
)))
547 (y :scs
(,real-sc
,real-constant-sc
)
548 ,@(when commutativep
'(:target r
))
549 :load-if
(not (sc-is y
,real-constant-sc
))))
550 (:arg-types
,complex-type
,real-type
)
551 (:results
(r :scs
(,complex-sc
)
552 ,@(unless commutativep
'(:from
(:argument
0)))))
553 (:result-types
,complex-type
)
556 `(when (location= y r
)
559 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
560 (setf y
(register-inline-constant
561 :aligned
(tn-value y
))))
562 (inst ,op-inst r y
))))))
563 (commutativep ; must duplicate, but commutative
565 ,(when real-complex-name
566 `(define-vop (,real-complex-name float-op
)
568 (:args
(x :scs
(,real-sc
,real-constant-sc
)
570 :load-if
(not (sc-is x
,real-constant-sc
)))
571 (y :scs
(,complex-sc
,complex-constant-sc
)
574 :load-if
(not (sc-is y
,complex-constant-sc
))))
575 (:arg-types
,real-type
,complex-type
)
576 (:temporary
(:sc
,complex-sc
:target r
580 (:results
(r :scs
(,complex-sc
)))
581 (:result-types
,complex-type
)
583 (if (sc-is x
,real-constant-sc
)
584 (inst ,complex-move-inst dup
585 (register-inline-constant
586 (complex (tn-value x
) (tn-value x
))))
590 (when (location= dup r
)
592 (if (sc-is y
,complex-constant-sc
)
593 (inst ,complex-move-inst r
594 (register-inline-constant (tn-value y
)))
596 (when (sc-is dup
,complex-constant-sc
)
597 (setf dup
(register-inline-constant
598 :aligned
(tn-value dup
))))
599 (inst ,op-inst r dup
))))
601 ,(when complex-real-name
602 `(define-vop (,complex-real-name float-op
)
604 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
607 :load-if
(not (sc-is x
,complex-constant-sc
)))
608 (y :scs
(,real-sc
,real-constant-sc
)
610 :load-if
(not (sc-is y
,real-constant-sc
))))
611 (:arg-types
,complex-type
,real-type
)
612 (:temporary
(:sc
,complex-sc
:target r
616 (:results
(r :scs
(,complex-sc
)))
617 (:result-types
,complex-type
)
619 (if (sc-is y
,real-constant-sc
)
620 (inst ,complex-move-inst dup
621 (register-inline-constant
622 (complex (tn-value y
) (tn-value y
))))
625 (when (location= dup r
)
627 (if (sc-is x
,complex-constant-sc
)
628 (inst ,complex-move-inst r
629 (register-inline-constant (tn-value x
)))
631 (when (sc-is dup
,complex-constant-sc
)
632 (setf dup
(register-inline-constant
633 :aligned
(tn-value dup
))))
634 (inst ,op-inst r dup
))))))
635 (t ; duplicate, not commutative
637 ,(when real-complex-name
638 `(define-vop (,real-complex-name float-op
)
640 (:args
(x :scs
(,real-sc
,real-constant-sc
)
642 :load-if
(not (sc-is x
,real-constant-sc
)))
643 (y :scs
(,complex-sc
,complex-constant-sc
)
645 :load-if
(not (sc-is y
,complex-constant-sc
))))
646 (:arg-types
,real-type
,complex-type
)
647 (:results
(r :scs
(,complex-sc
) :from
(:argument
0)))
648 (:result-types
,complex-type
)
650 (if (sc-is x
,real-constant-sc
)
651 (inst ,complex-move-inst dup
652 (register-inline-constant
653 (complex (tn-value x
) (tn-value x
))))
657 (when (sc-is y
,complex-constant-sc
)
658 (setf y
(register-inline-constant
659 :aligned
(tn-value y
))))
660 (inst ,op-inst r y
))))
662 ,(when complex-real-name
663 `(define-vop (,complex-real-name float-op
)
665 (:args
(x :scs
(,complex-sc
)
668 (y :scs
(,real-sc
,real-constant-sc
)
670 :load-if
(not (sc-is y
,complex-constant-sc
))))
671 (:arg-types
,complex-type
,real-type
)
672 (:temporary
(:sc
,complex-sc
:from
(:argument
1))
674 (:results
(r :scs
(,complex-sc
) :from
:eval
))
675 (:result-types
,complex-type
)
677 (if (sc-is y
,real-constant-sc
)
678 (setf dup
(register-inline-constant
679 :aligned
(complex (tn-value y
)
684 (inst ,op-inst r dup
))))))))
685 (def-real-complex-op (op commutativep duplicatep
686 single-inst single-real-complex-name single-complex-real-name single-cost
687 double-inst double-real-complex-name double-complex-real-name double-cost
)
689 (frob ,op
,single-cost
,commutativep
693 (inst unpcklps dup dup
)))
694 ,single-inst movss movq
695 single-reg fp-single-immediate single-float
696 complex-single-reg fp-complex-single-immediate complex-single-float
697 ,single-real-complex-name
,single-complex-real-name
)
698 (frob ,op
,double-cost
,commutativep
702 (inst unpcklpd dup dup
)))
703 ,double-inst movsd movapd
704 double-reg fp-double-immediate double-float
705 complex-double-reg fp-complex-double-immediate complex-double-float
706 ,double-real-complex-name
,double-complex-real-name
))))
707 (def-real-complex-op + t nil
708 addps
+/real-complex-single-float
+/complex-real-single-float
3
709 addpd
+/real-complex-double-float
+/complex-real-double-float
4)
710 (def-real-complex-op - nil nil
711 subps -
/real-complex-single-float -
/complex-real-single-float
3
712 subpd -
/real-complex-double-float -
/complex-real-double-float
4)
713 (def-real-complex-op * t t
714 mulps
*/real-complex-single-float
*/complex-real-single-float
4
715 mulpd
*/real-complex-double-float
*/complex-real-double-float
5)
716 (def-real-complex-op / nil t
718 divpd nil
//complex-real-double-float
19))
720 (define-vop (//complex-real-single-float float-op
)
722 (:args
(x :scs
(complex-single-reg fp-complex-single-immediate fp-complex-single-zero
)
725 :load-if
(not (sc-is x fp-complex-single-immediate fp-complex-single-zero
)))
726 (y :scs
(single-reg fp-single-immediate fp-single-zero
)
728 :load-if
(not (sc-is y fp-single-immediate fp-single-zero
))))
729 (:arg-types complex-single-float single-float
)
730 (:temporary
(:sc complex-single-reg
:from
(:argument
1)) dup
)
731 (:results
(r :scs
(complex-single-reg)))
732 (:result-types complex-single-float
)
734 (flet ((duplicate (x)
735 (let ((word (ldb (byte 64 0)
736 (logior (ash (single-float-bits (imagpart x
)) 32)
738 (single-float-bits (realpart x
)))))))
739 (register-inline-constant :oword
(logior (ash word
64) word
)))))
742 (setf dup
(duplicate (complex (tn-value y
) (tn-value y
)))))
744 (inst xorps dup dup
))
746 (inst shufps dup dup
#b00000000
)))
748 (fp-complex-single-immediate
749 (inst movaps r
(duplicate (tn-value x
))))
750 (fp-complex-single-zero
754 (inst unpcklpd r r
)))
758 ;; Complex multiplication
759 ;; r := rx * ry - ix * iy
760 ;; i := rx * iy + ix * ry
762 ;; Transpose for SIMDness
767 ;;+ [ix ix] * [-iy ry]
770 (macrolet ((define-complex-* (name cost type sc tmp-p
&body body
)
771 `(define-vop (,name float-op
)
773 (:args
(x :scs
(,sc
) :target r
)
774 (y :scs
(,sc
) :target copy-y
))
775 (:arg-types
,type
,type
)
776 (:temporary
(:sc
,sc
) imag
)
777 (:temporary
(:sc
,sc
:from
:eval
) copy-y
)
779 `((:temporary
(:sc
,sc
) xmm
)))
780 (:results
(r :scs
(,sc
) :from
:eval
))
781 (:result-types
,type
)
783 (when (or (location= x copy-y
)
787 (define-complex-* */complex-single-float
20
788 complex-single-float complex-single-reg t
793 (inst unpckhpd imag xmm
)
794 (inst unpcklpd r xmm
)
795 (move copy-y y
) ; y == r only if y == x == r
800 (inst shufps y y
#b11110001
)
801 (inst xorps y
(register-inline-constant :oword
(ash 1 31)))
805 (define-complex-* */complex-double-float
25
806 complex-double-float complex-double-reg nil
812 (inst unpckhpd imag imag
)
816 (inst shufpd y y
#b01
)
817 (inst xorpd y
(register-inline-constant :oword
(ash 1 63)))
820 (inst addpd r imag
)))
823 (:args
(x :scs
(double-reg)))
824 (:results
(y :scs
(double-reg)))
827 (:arg-types double-float
)
828 (:result-types double-float
)
829 (:note
"inline float arithmetic")
831 (:save-p
:compute-only
)
833 (note-this-location vop
:internal-error
)
836 (macrolet ((frob ((name translate sc type
) &body body
)
838 (:args
(x :scs
(,sc
) :target y
))
839 (:results
(y :scs
(,sc
)))
840 (:translate
,translate
)
843 (:result-types
,type
)
844 (:note
"inline float arithmetic")
846 (:save-p
:compute-only
)
848 (note-this-location vop
:internal-error
)
849 ;; we should be able to do this better. what we
850 ;; really would like to do is use the target as the
851 ;; temp whenever it's not also the source
854 (frob (%negate
/double-float %negate double-reg double-float
)
855 (inst xorpd y
(register-inline-constant :oword
(ash 1 63))))
856 (frob (%negate
/complex-double-float %negate complex-double-reg complex-double-float
)
857 (inst xorpd y
(register-inline-constant
858 :oword
(logior (ash 1 127) (ash 1 63)))))
859 (frob (conjugate/complex-double-float conjugate complex-double-reg complex-double-float
)
860 (inst xorpd y
(register-inline-constant :oword
(ash 1 127))))
861 (frob (%negate
/single-float %negate single-reg single-float
)
862 (inst xorps y
(register-inline-constant :oword
(ash 1 31))))
863 (frob (%negate
/complex-single-float %negate complex-single-reg complex-single-float
)
864 (inst xorps y
(register-inline-constant
865 :oword
(logior (ash 1 31) (ash 1 63)))))
866 (frob (conjugate/complex-single-float conjugate complex-single-reg complex-single-float
)
867 (inst xorpd y
(register-inline-constant :oword
(ash 1 63))))
868 (frob (abs/double-float abs double-reg double-float
)
869 (inst andpd y
(register-inline-constant :oword
(ldb (byte 63 0) -
1))))
870 (frob (abs/single-float abs single-reg single-float
)
871 (inst andps y
(register-inline-constant :oword
(ldb (byte 31 0) -
1)))))
876 (define-vop (float-compare)
879 (:save-p
:compute-only
)
880 (:note
"inline float comparison"))
883 (macrolet ((define-float-eql (name cost sc constant-sc type
)
884 `(define-vop (,name float-compare
)
886 (:args
(x :scs
(,sc
,constant-sc
)
888 :load-if
(not (sc-is x
,constant-sc
)))
889 (y :scs
(,sc
,constant-sc
)
891 :load-if
(not (sc-is y
,constant-sc
))))
892 (:arg-types
,type
,type
)
893 (:temporary
(:sc
,sc
:from
:eval
) mask
)
894 (:temporary
(:sc any-reg
) bits
)
897 (when (or (location= y mask
)
898 (not (xmm-register-p x
)))
900 (aver (xmm-register-p x
))
902 (when (sc-is y
,constant-sc
)
903 (setf y
(register-inline-constant :aligned
(tn-value y
))))
904 (inst pcmpeqd mask y
)
905 (inst movmskps bits mask
)
906 (inst cmp bits
#b1111
)))))
907 (define-float-eql eql
/single-float
4
908 single-reg fp-single-immediate single-float
)
909 (define-float-eql eql
/double-float
4
910 double-reg fp-double-immediate double-float
)
911 (define-float-eql eql
/complex-single-float
5
912 complex-single-reg fp-complex-single-immediate complex-single-float
)
913 (define-float-eql eql
/complex-double-float
5
914 complex-double-reg fp-complex-double-immediate complex-double-float
))
916 ;;; comiss and comisd can cope with one or other arg in memory: we
917 ;;; could (should, indeed) extend these to cope with descriptor args
920 (define-vop (single-float-compare float-compare
)
921 (:args
(x :scs
(single-reg))
922 (y :scs
(single-reg single-stack fp-single-immediate
)
923 :load-if
(not (sc-is y single-stack fp-single-immediate
))))
924 (:arg-types single-float single-float
))
925 (define-vop (double-float-compare float-compare
)
926 (:args
(x :scs
(double-reg))
927 (y :scs
(double-reg double-stack descriptor-reg fp-double-immediate
)
928 :load-if
(not (sc-is y double-stack descriptor-reg fp-double-immediate
))))
929 (:arg-types double-float double-float
))
931 (define-vop (=/single-float single-float-compare
)
933 (:args
(x :scs
(single-reg single-stack fp-single-immediate
)
935 :load-if
(not (sc-is x single-stack fp-single-immediate
)))
936 (y :scs
(single-reg single-stack fp-single-immediate
)
938 :load-if
(not (sc-is y single-stack fp-single-immediate
))))
939 (:temporary
(:sc single-reg
:from
:eval
) xmm
)
941 (:conditional not
:p
:ne
)
944 (when (or (location= y xmm
)
945 (and (not (xmm-register-p x
))
949 (single-reg (setf xmm x
))
950 (single-stack (inst movss xmm
(ea-for-sf-stack x
)))
952 (inst movss xmm
(register-inline-constant (tn-value x
)))))
955 (setf y
(ea-for-sf-stack y
)))
957 (setf y
(register-inline-constant (tn-value y
))))
959 (note-this-location vop
:internal-error
)
961 ;; if PF&CF, there was a NaN involved => not equal
962 ;; otherwise, ZF => equal
965 (define-vop (=/double-float double-float-compare
)
967 (:args
(x :scs
(double-reg double-stack fp-double-immediate descriptor-reg
)
969 :load-if
(not (sc-is x double-stack fp-double-immediate descriptor-reg
)))
970 (y :scs
(double-reg double-stack fp-double-immediate descriptor-reg
)
972 :load-if
(not (sc-is y double-stack fp-double-immediate descriptor-reg
))))
973 (:temporary
(:sc double-reg
:from
:eval
) xmm
)
975 (:conditional not
:p
:ne
)
978 (when (or (location= y xmm
)
979 (and (not (xmm-register-p x
))
986 (inst movsd xmm
(ea-for-df-stack x
)))
988 (inst movsd xmm
(register-inline-constant (tn-value x
))))
990 (inst movsd xmm
(ea-for-df-desc x
))))
993 (setf y
(ea-for-df-stack y
)))
995 (setf y
(register-inline-constant (tn-value y
))))
997 (setf y
(ea-for-df-desc y
)))
999 (note-this-location vop
:internal-error
)
1000 (inst comisd xmm y
)))
1002 (macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name
1003 real-sc real-constant-sc real-type
1004 complex-sc complex-constant-sc complex-type
1005 real-move-inst complex-move-inst
1006 cmp-inst mask-inst mask
)
1008 (define-vop (,complex-complex-name float-compare
)
1010 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
1012 :load-if
(not (sc-is x
,complex-constant-sc
)))
1013 (y :scs
(,complex-sc
,complex-constant-sc
)
1015 :load-if
(not (sc-is y
,complex-constant-sc
))))
1016 (:arg-types
,complex-type
,complex-type
)
1017 (:temporary
(:sc
,complex-sc
:from
:eval
) cmp
)
1018 (:temporary
(:sc unsigned-reg
) bits
)
1022 (when (location= y cmp
)
1026 (inst ,real-move-inst cmp
(register-inline-constant
1028 (,complex-constant-sc
1029 (inst ,complex-move-inst cmp
(register-inline-constant
1033 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
1034 (setf y
(register-inline-constant :aligned
(tn-value y
))))
1035 (note-this-location vop
:internal-error
)
1036 (inst ,cmp-inst
:eq cmp y
)
1037 (inst ,mask-inst bits cmp
)
1038 (inst cmp bits
,mask
)))
1039 (define-vop (,complex-real-name
,complex-complex-name
)
1040 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
1042 :load-if
(not (sc-is x
,complex-constant-sc
)))
1043 (y :scs
(,real-sc
,real-constant-sc
)
1045 :load-if
(not (sc-is y
,real-constant-sc
))))
1046 (:arg-types
,complex-type
,real-type
))
1047 (define-vop (,real-complex-name
,complex-complex-name
)
1048 (:args
(x :scs
(,real-sc
,real-constant-sc
)
1050 :load-if
(not (sc-is x
,real-constant-sc
)))
1051 (y :scs
(,complex-sc
,complex-constant-sc
)
1053 :load-if
(not (sc-is y
,complex-constant-sc
))))
1054 (:arg-types
,real-type
,complex-type
)))))
1055 (define-complex-float-= =/complex-single-float
=/complex-real-single-float
=/real-complex-single-float
1056 single-reg fp-single-immediate single-float
1057 complex-single-reg fp-complex-single-immediate complex-single-float
1058 movss movq cmpps movmskps
#b1111
)
1059 (define-complex-float-= =/complex-double-float
=/complex-real-double-float
=/real-complex-double-float
1060 double-reg fp-double-immediate double-float
1061 complex-double-reg fp-complex-double-immediate complex-double-float
1062 movsd movapd cmppd movmskpd
#b11
))
1064 (macrolet ((define-</> (op single-name double-name
&rest flags
)
1066 (define-vop (,double-name double-float-compare
)
1069 (:conditional
,@flags
)
1073 (setf y
(ea-for-df-stack y
)))
1075 (setf y
(ea-for-df-desc y
)))
1076 (fp-double-immediate
1077 (setf y
(register-inline-constant (tn-value y
))))
1080 (define-vop (,single-name single-float-compare
)
1083 (:conditional
,@flags
)
1087 (setf y
(ea-for-sf-stack y
)))
1088 (fp-single-immediate
1089 (setf y
(register-inline-constant (tn-value y
))))
1091 (inst comiss x y
))))))
1092 (define-</> < <single-float
<double-float not
:p
:nc
)
1093 (define-</> > >single-float
>double-float not
:p
:na
))
1098 (macrolet ((frob (name translate inst to-sc to-type
)
1099 `(define-vop (,name
)
1100 (:args
(x :scs
(signed-stack signed-reg
) :target temp
))
1101 (:temporary
(:sc signed-stack
) temp
)
1102 (:results
(y :scs
(,to-sc
)))
1103 (:arg-types signed-num
)
1104 (:result-types
,to-type
)
1105 (:policy
:fast-safe
)
1106 (:note
"inline float coercion")
1107 (:translate
,translate
)
1109 (:save-p
:compute-only
)
1114 (note-this-location vop
:internal-error
)
1115 (inst ,inst y temp
))
1117 (note-this-location vop
:internal-error
)
1118 (inst ,inst y x
)))))))
1119 (frob %single-float
/signed %single-float cvtsi2ss single-reg single-float
)
1120 (frob %double-float
/signed %double-float cvtsi2sd double-reg double-float
))
1122 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type
)
1123 `(define-vop (,name
)
1124 (:args
(x :scs
(,from-sc
) :target y
))
1125 (:results
(y :scs
(,to-sc
)))
1126 (:arg-types
,from-type
)
1127 (:result-types
,to-type
)
1128 (:policy
:fast-safe
)
1129 (:note
"inline float coercion")
1130 (:translate
,translate
)
1132 (:save-p
:compute-only
)
1134 (note-this-location vop
:internal-error
)
1135 (inst ,inst y x
)))))
1136 (frob %single-float
/double-float %single-float cvtsd2ss double-reg
1137 double-float single-reg single-float
)
1139 (frob %double-float
/single-float %double-float cvtss2sd
1140 single-reg single-float double-reg double-float
))
1142 (macrolet ((frob (trans inst from-sc from-type round-p
)
1143 (declare (ignore round-p
))
1144 `(define-vop (,(symbolicate trans
"/" from-type
))
1145 (:args
(x :scs
(,from-sc
)))
1146 (:temporary
(:sc any-reg
) temp-reg
)
1147 (:results
(y :scs
(signed-reg)))
1148 (:arg-types
,from-type
)
1149 (:result-types signed-num
)
1151 (:policy
:fast-safe
)
1152 (:note
"inline float truncate")
1154 (:save-p
:compute-only
)
1158 (inst ,inst temp-reg x
)
1163 (frob %unary-truncate
/single-float cvttss2si single-reg single-float nil
)
1164 (frob %unary-truncate
/double-float cvttsd2si double-reg double-float nil
)
1166 (frob %unary-round cvtss2si single-reg single-float t
)
1167 (frob %unary-round cvtsd2si double-reg double-float t
))
1169 (define-vop (make-single-float)
1170 (:args
(bits :scs
(signed-reg) :target res
1171 :load-if
(not (or (and (sc-is bits signed-stack
)
1172 (sc-is res single-reg
))
1173 (and (sc-is bits signed-stack
)
1174 (sc-is res single-stack
)
1175 (location= bits res
))))))
1176 (:results
(res :scs
(single-reg single-stack
)))
1177 (:arg-types signed-num
)
1178 (:result-types single-float
)
1179 (:translate make-single-float
)
1180 (:policy
:fast-safe
)
1187 (inst mov res bits
))
1189 (aver (location= bits res
)))))
1193 (inst movd res bits
))
1195 (inst movd res bits
)))))))
1197 (define-vop (make-double-float)
1198 (:args
(hi-bits :scs
(signed-reg))
1199 (lo-bits :scs
(unsigned-reg)))
1200 (:results
(res :scs
(double-reg)))
1201 (:temporary
(:sc unsigned-reg
) temp
)
1202 (:arg-types signed-num unsigned-num
)
1203 (:result-types double-float
)
1204 (:translate make-double-float
)
1205 (:policy
:fast-safe
)
1210 (inst or temp lo-bits
)
1211 (inst movd res temp
)))
1213 (define-vop (single-float-bits)
1214 (:args
(float :scs
(single-reg descriptor-reg
)
1215 :load-if
(not (sc-is float single-stack
))))
1216 (:results
(bits :scs
(signed-reg)))
1217 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) stack-temp
)
1218 (:arg-types single-float
)
1219 (:result-types signed-num
)
1220 (:translate single-float-bits
)
1221 (:policy
:fast-safe
)
1228 (inst movss stack-temp float
)
1229 (move bits stack-temp
))
1234 (inst shr bits
32))))
1238 (inst movss bits float
)))))
1241 (inst sar bits
32)))
1243 (define-vop (double-float-high-bits)
1244 (:args
(float :scs
(double-reg descriptor-reg
)
1245 :load-if
(not (sc-is float double-stack
))))
1246 (:results
(hi-bits :scs
(signed-reg)))
1247 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) temp
)
1248 (:arg-types double-float
)
1249 (:result-types signed-num
)
1250 (:translate double-float-high-bits
)
1251 (:policy
:fast-safe
)
1256 (inst movsd temp float
)
1257 (move hi-bits temp
))
1259 (loadw hi-bits ebp-tn
(frame-word-offset (tn-offset float
))))
1261 (loadw hi-bits float double-float-value-slot
1262 other-pointer-lowtag
)))
1263 (inst sar hi-bits
32)))
1265 (define-vop (double-float-low-bits)
1266 (:args
(float :scs
(double-reg descriptor-reg
)
1267 :load-if
(not (sc-is float double-stack
))))
1268 (:results
(lo-bits :scs
(unsigned-reg)))
1269 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) temp
)
1270 (:arg-types double-float
)
1271 (:result-types unsigned-num
)
1272 (:translate double-float-low-bits
)
1273 (:policy
:fast-safe
)
1278 (inst movsd temp float
)
1279 (move lo-bits temp
))
1281 (loadw lo-bits ebp-tn
(frame-word-offset (tn-offset float
))))
1283 (loadw lo-bits float double-float-value-slot
1284 other-pointer-lowtag
)))
1285 (inst shl lo-bits
32)
1286 (inst shr lo-bits
32)))
1290 ;;;; complex float VOPs
1292 (define-vop (make-complex-single-float)
1293 (:translate complex
)
1294 (:args
(real :scs
(single-reg fp-single-zero
)
1296 :load-if
(not (sc-is real fp-single-zero
)))
1297 (imag :scs
(single-reg fp-single-zero
)
1298 :load-if
(not (sc-is imag fp-single-zero
))))
1299 (:arg-types single-float single-float
)
1300 (:results
(r :scs
(complex-single-reg) :from
(:argument
0)))
1301 (:result-types complex-single-float
)
1302 (:note
"inline complex single-float creation")
1303 (:policy
:fast-safe
)
1305 (cond ((sc-is real fp-single-zero
)
1307 (unless (sc-is imag fp-single-zero
)
1308 (inst unpcklps r imag
)))
1309 ((location= real imag
)
1311 (inst unpcklps r r
))
1314 (unless (sc-is imag fp-single-zero
)
1315 (inst unpcklps r imag
))))))
1317 (define-vop (make-complex-double-float)
1318 (:translate complex
)
1319 (:args
(real :scs
(double-reg fp-double-zero
)
1321 :load-if
(not (sc-is real fp-double-zero
)))
1322 (imag :scs
(double-reg fp-double-zero
)
1323 :load-if
(not (sc-is imag fp-double-zero
))))
1324 (:arg-types double-float double-float
)
1325 (:results
(r :scs
(complex-double-reg) :from
(:argument
0)))
1326 (:result-types complex-double-float
)
1327 (:note
"inline complex double-float creation")
1328 (:policy
:fast-safe
)
1330 (cond ((sc-is real fp-double-zero
)
1332 (unless (sc-is imag fp-double-zero
)
1333 (inst unpcklpd r imag
)))
1334 ((location= real imag
)
1336 (inst unpcklpd r r
))
1339 (unless (sc-is imag fp-double-zero
)
1340 (inst unpcklpd r imag
))))))
1342 (define-vop (complex-float-value)
1343 (:args
(x :target r
))
1344 (:temporary
(:sc complex-double-reg
) zero
)
1346 (:variant-vars offset
)
1347 (:policy
:fast-safe
)
1349 (cond ((sc-is x complex-double-reg
)
1351 (inst xorpd zero zero
)
1353 (0 (inst unpcklpd r zero
))
1354 (1 (inst unpckhpd r zero
))))
1355 ((sc-is x complex-single-reg
)
1358 (0 (inst shufps r r
#b11111100
))
1359 (1 (inst shufps r r
#b11111101
))))
1360 ((sc-is r single-reg
)
1361 (let ((ea (sc-case x
1362 (complex-single-stack
1364 (0 (ea-for-csf-real-stack x
))
1365 (1 (ea-for-csf-imag-stack x
))))
1368 (0 (ea-for-csf-real-desc x
))
1369 (1 (ea-for-csf-imag-desc x
)))))))
1371 ((sc-is r double-reg
)
1372 (let ((ea (sc-case x
1373 (complex-double-stack
1375 (0 (ea-for-cdf-real-stack x
))
1376 (1 (ea-for-cdf-imag-stack x
))))
1379 (0 (ea-for-cdf-real-desc x
))
1380 (1 (ea-for-cdf-imag-desc x
)))))))
1382 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
1384 (define-vop (realpart/complex-single-float complex-float-value
)
1385 (:translate realpart
)
1386 (:args
(x :scs
(complex-single-reg complex-single-stack descriptor-reg
)
1388 (:arg-types complex-single-float
)
1389 (:results
(r :scs
(single-reg)))
1390 (:result-types single-float
)
1391 (:note
"complex float realpart")
1394 (define-vop (realpart/complex-double-float complex-float-value
)
1395 (:translate realpart
)
1396 (:args
(x :scs
(complex-double-reg complex-double-stack descriptor-reg
)
1398 (:arg-types complex-double-float
)
1399 (:results
(r :scs
(double-reg)))
1400 (:result-types double-float
)
1401 (:note
"complex float realpart")
1404 (define-vop (imagpart/complex-single-float complex-float-value
)
1405 (:translate imagpart
)
1406 (:args
(x :scs
(complex-single-reg complex-single-stack descriptor-reg
)
1408 (:arg-types complex-single-float
)
1409 (:results
(r :scs
(single-reg)))
1410 (:result-types single-float
)
1411 (:note
"complex float imagpart")
1414 (define-vop (imagpart/complex-double-float complex-float-value
)
1415 (:translate imagpart
)
1416 (:args
(x :scs
(complex-double-reg complex-double-stack descriptor-reg
)
1418 (:arg-types complex-double-float
)
1419 (:results
(r :scs
(double-reg)))
1420 (:result-types double-float
)
1421 (:note
"complex float imagpart")
1425 ;;; hack dummy VOPs to bias the representation selection of their
1426 ;;; arguments towards a FP register, which can help avoid consing at
1427 ;;; inappropriate locations
1428 (defknown double-float-reg-bias
(double-float) (values))
1429 (define-vop (double-float-reg-bias)
1430 (:translate double-float-reg-bias
)
1431 (:args
(x :scs
(double-reg double-stack
) :load-if nil
))
1432 (:arg-types double-float
)
1433 (:policy
:fast-safe
)
1434 (:note
"inline dummy FP register bias")
1437 (defknown single-float-reg-bias
(single-float) (values))
1438 (define-vop (single-float-reg-bias)
1439 (:translate single-float-reg-bias
)
1440 (:args
(x :scs
(single-reg single-stack
) :load-if nil
))
1441 (:arg-types single-float
)
1442 (:policy
:fast-safe
)
1443 (:note
"inline dummy FP register bias")
1447 ;;; Additional function that must be provided by #!+complex-vops
1449 (defknown swap-complex
((complex float
)) (complex float
)
1450 (foldable flushable movable always-translatable
))
1451 (defoptimizer (swap-complex derive-type
) ((x))
1452 (sb!c
::lvar-type x
))
1453 (defun swap-complex (x)
1454 (complex (imagpart x
) (realpart x
)))
1455 (define-vop (swap-complex-single-float)
1456 (:translate swap-complex
)
1457 (:policy
:fast-safe
)
1458 (:args
(x :scs
(complex-single-reg) :target r
))
1459 (:arg-types complex-single-float
)
1460 (:results
(r :scs
(complex-single-reg)))
1461 (:result-types complex-single-float
)
1464 (inst shufps r r
#b11110001
)))
1465 (define-vop (swap-complex-double-float)
1466 (:translate swap-complex
)
1467 (:policy
:fast-safe
)
1468 (:args
(x :scs
(complex-double-reg) :target r
))
1469 (:arg-types complex-double-float
)
1470 (:results
(r :scs
(complex-double-reg)))
1471 (:result-types complex-double-float
)
1474 (inst shufpd r r
#b01
)))
1477 ;;;; SSE pack operation
1478 (define-vop (%sse-pack-low
)
1479 (:translate %sse-pack-low
)
1480 (:args
(x :scs
(sse-reg)))
1481 (:arg-types sse-pack
)
1482 (:results
(dst :scs
(unsigned-reg)))
1483 (:result-types unsigned-num
)
1484 (:policy
:fast-safe
)
1488 (defun %sse-pack-low
(x)
1489 (declare (type sse-pack x
))
1492 (define-vop (%sse-pack-high
)
1493 (:translate %sse-pack-high
)
1494 (:args
(x :scs
(sse-reg)))
1495 (:arg-types sse-pack
)
1496 (:temporary
(:sc sse-reg
) tmp
)
1497 (:results
(dst :scs
(unsigned-reg)))
1498 (:result-types unsigned-num
)
1499 (:policy
:fast-safe
)
1503 (inst movd dst tmp
)))
1505 (defun %sse-pack-high
(x)
1506 (declare (type sse-pack x
))
1509 (define-vop (%make-sse-pack
)
1510 (:translate %make-sse-pack
)
1511 (:policy
:fast-safe
)
1512 (:args
(lo :scs
(unsigned-reg))
1513 (hi :scs
(unsigned-reg)))
1514 (:arg-types unsigned-num unsigned-num
)
1515 (:temporary
(:sc sse-stack
) tmp
)
1516 (:results
(dst :scs
(sse-reg)))
1517 (:result-types sse-pack
)
1519 (let ((offset (- (* (1+ (tn-offset tmp
))
1521 (inst mov
(make-ea :qword
:base rbp-tn
:disp
(- offset
8)) lo
)
1522 (inst mov
(make-ea :qword
:base rbp-tn
:disp offset
) hi
))
1523 (inst movdqa dst
(ea-for-sse-stack tmp
))))
1525 (defun %make-sse-pack
(low high
)
1526 (declare (type (unsigned-byte 64) low high
))
1527 (%make-sse-pack low high
))