1 ;;;; floating point 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 (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
)
64 (defun ea-for-csf-data-stack (tn &optional
(base rbp-tn
))
65 (ea-for-cxf-stack tn
:single
:real base
))
66 (defun ea-for-csf-real-stack (tn &optional
(base rbp-tn
))
67 (ea-for-cxf-stack tn
:single
:real base
))
68 (defun ea-for-csf-imag-stack (tn &optional
(base rbp-tn
))
69 (ea-for-cxf-stack tn
:single
:imag base
))
71 (defun ea-for-cdf-data-stack (tn &optional
(base rbp-tn
))
72 (ea-for-cxf-stack tn
:double
:real base
))
73 (defun ea-for-cdf-real-stack (tn &optional
(base rbp-tn
))
74 (ea-for-cxf-stack tn
:double
:real base
))
75 (defun ea-for-cdf-imag-stack (tn &optional
(base rbp-tn
))
76 (ea-for-cxf-stack tn
:double
:imag base
)))
80 ;;; X is source, Y is destination.
82 (define-move-fun (load-fp-zero 1) (vop x y
)
83 ((fp-single-zero) (single-reg)
84 (fp-double-zero) (double-reg)
85 (fp-complex-single-zero) (complex-single-reg)
86 (fp-complex-double-zero) (complex-double-reg))
89 ((single-reg complex-single-reg
) (inst xorps y y
))
90 ((double-reg complex-double-reg
) (inst xorpd y y
))))
92 (define-move-fun (load-fp-immediate 1) (vop x y
)
93 ((fp-single-immediate) (single-reg)
94 (fp-double-immediate) (double-reg)
95 (fp-complex-single-immediate) (complex-single-reg)
96 (fp-complex-double-immediate) (complex-double-reg))
97 (let ((x (register-inline-constant (tn-value x
))))
99 (single-reg (inst movss y x
))
100 (double-reg (inst movsd y x
))
101 (complex-single-reg (inst movq y x
))
102 (complex-double-reg (inst movapd y x
)))))
104 (define-move-fun (load-single 2) (vop x y
)
105 ((single-stack) (single-reg))
106 (inst movss y
(ea-for-sf-stack x
)))
108 (define-move-fun (store-single 2) (vop x y
)
109 ((single-reg) (single-stack))
110 (inst movss
(ea-for-sf-stack y
) x
))
112 (define-move-fun (load-double 2) (vop x y
)
113 ((double-stack) (double-reg))
114 (inst movsd y
(ea-for-df-stack x
)))
116 (define-move-fun (store-double 2) (vop x y
)
117 ((double-reg) (double-stack))
118 (inst movsd
(ea-for-df-stack y
) x
))
120 (eval-when (:compile-toplevel
:execute
)
121 (setf *read-default-float-format
* 'single-float
))
123 ;;;; complex float move functions
125 ;;; X is source, Y is destination.
126 (define-move-fun (load-complex-single 2) (vop x y
)
127 ((complex-single-stack) (complex-single-reg))
128 (inst movq y
(ea-for-csf-data-stack x
)))
130 (define-move-fun (store-complex-single 2) (vop x y
)
131 ((complex-single-reg) (complex-single-stack))
132 (inst movq
(ea-for-csf-data-stack y
) x
))
134 (define-move-fun (load-complex-double 2) (vop x y
)
135 ((complex-double-stack) (complex-double-reg))
136 (inst movupd y
(ea-for-cdf-data-stack x
)))
138 (define-move-fun (store-complex-double 2) (vop x y
)
139 ((complex-double-reg) (complex-double-stack))
140 (inst movupd
(ea-for-cdf-data-stack y
) x
))
144 ;;; float register to register moves
145 (macrolet ((frob (vop sc
)
150 :load-if
(not (location= x y
))))
151 (:results
(y :scs
(,sc
)
152 :load-if
(not (location= x y
))))
156 (define-move-vop ,vop
:move
(,sc
) (,sc
)))))
157 (frob single-move single-reg
)
158 (frob double-move double-reg
)
159 (frob complex-single-move complex-single-reg
)
160 (frob complex-double-move complex-double-reg
))
163 ;;; Move from float to a descriptor reg. allocating a new float
164 ;;; object in the process.
165 (define-vop (move-from-single)
166 (:args
(x :scs
(single-reg) :to
:save
))
167 (:results
(y :scs
(descriptor-reg)))
168 (:note
"float to pointer coercion")
170 (inst movd
(reg-in-size y
:dword
) x
)
172 (inst or y single-float-widetag
)))
174 (define-move-vop move-from-single
:move
175 (single-reg) (descriptor-reg))
177 (define-vop (move-from-double)
178 (:args
(x :scs
(double-reg) :to
:save
))
179 (:results
(y :scs
(descriptor-reg)))
181 (:note
"float to pointer coercion")
183 (with-fixed-allocation (y
187 (inst movsd
(ea-for-df-desc y
) x
))))
188 (define-move-vop move-from-double
:move
189 (double-reg) (descriptor-reg))
191 ;;; Move from a descriptor to a float register.
192 (define-vop (move-to-single-reg)
193 (:args
(x :scs
(descriptor-reg) :target tmp
194 :load-if
(not (sc-is x control-stack
))))
195 (:temporary
(:sc unsigned-reg
:from
:argument
:to
:result
) tmp
)
196 (:results
(y :scs
(single-reg)))
197 (:note
"pointer to float coercion")
203 (inst movd y
(reg-in-size tmp
:dword
)))
205 ;; When the single-float descriptor is in memory, the untagging
206 ;; is done in the target XMM register. This is faster than going
207 ;; through a general-purpose register and the code is smaller.
209 (inst shufps y y
#4r3331
)))))
210 (define-move-vop move-to-single-reg
:move
(descriptor-reg) (single-reg))
212 ;;; Move from a descriptor to a float stack.
213 (define-vop (move-to-single-stack)
214 (:args
(x :scs
(descriptor-reg) :target tmp
))
215 (:temporary
(:sc unsigned-reg
:from
:argument
:to
:result
) tmp
)
216 (:results
(y :scs
(single-stack)))
217 (:note
"pointer to float coercion")
221 (let ((slot (make-ea :dword
:base rbp-tn
222 :disp
(frame-byte-offset (tn-offset y
)))))
223 (inst mov slot
(reg-in-size tmp
:dword
)))))
224 (define-move-vop move-to-single-stack
:move
(descriptor-reg) (single-stack))
226 (define-vop (move-to-double)
227 (:args
(x :scs
(descriptor-reg)))
228 (:results
(y :scs
(double-reg)))
229 (:note
"pointer to float coercion")
231 (inst movsd y
(ea-for-df-desc x
))))
232 (define-move-vop move-to-double
:move
(descriptor-reg) (double-reg))
235 ;;; Move from complex float to a descriptor reg. allocating a new
236 ;;; complex float object in the process.
237 (define-vop (move-from-complex-single)
238 (:args
(x :scs
(complex-single-reg) :to
:save
))
239 (:results
(y :scs
(descriptor-reg)))
241 (:note
"complex float to pointer coercion")
243 (with-fixed-allocation (y
244 complex-single-float-widetag
245 complex-single-float-size
247 (inst movq
(ea-for-csf-data-desc y
) x
))))
248 (define-move-vop move-from-complex-single
:move
249 (complex-single-reg) (descriptor-reg))
251 (define-vop (move-from-complex-double)
252 (:args
(x :scs
(complex-double-reg) :to
:save
))
253 (:results
(y :scs
(descriptor-reg)))
255 (:note
"complex float to pointer coercion")
257 (with-fixed-allocation (y
258 complex-double-float-widetag
259 complex-double-float-size
261 (inst movapd
(ea-for-cdf-data-desc y
) x
))))
262 (define-move-vop move-from-complex-double
:move
263 (complex-double-reg) (descriptor-reg))
265 ;;; Move from a descriptor to a complex float register.
266 (macrolet ((frob (name sc format
)
269 (:args
(x :scs
(descriptor-reg)))
270 (:results
(y :scs
(,sc
)))
271 (:note
"pointer to complex float coercion")
275 '(inst movq y
(ea-for-csf-data-desc x
)))
277 '(inst movapd y
(ea-for-cdf-data-desc x
))))))
278 (define-move-vop ,name
:move
(descriptor-reg) (,sc
)))))
279 (frob move-to-complex-single complex-single-reg
:single
)
280 (frob move-to-complex-double complex-double-reg
:double
))
282 ;;;; the move argument vops
284 ;;;; Note these are also used to stuff fp numbers onto the c-call
285 ;;;; stack so the order is different than the lisp-stack.
287 ;;; the general MOVE-ARG VOP
288 (macrolet ((frob (name sc stack-sc format
)
291 (:args
(x :scs
(,sc
) :target y
)
293 :load-if
(not (sc-is y
,sc
))))
295 (:note
"float argument move")
296 (:generator
,(case format
(:single
2) (:double
3) )
301 (if (= (tn-offset fp
) esp-offset
)
302 (let* ((offset (* (tn-offset y
) n-word-bytes
))
303 (ea (make-ea :dword
:base fp
:disp offset
)))
305 (:single
'((inst movss ea x
)))
306 (:double
'((inst movsd ea x
)))))
309 :disp
(frame-byte-offset (tn-offset y
)))))
311 (:single
'((inst movss ea x
)))
312 (:double
'((inst movsd ea x
))))))))))
313 (define-move-vop ,name
:move-arg
314 (,sc descriptor-reg
) (,sc
)))))
315 (frob move-single-float-arg single-reg single-stack
:single
)
316 (frob move-double-float-arg double-reg double-stack
:double
))
318 ;;;; complex float MOVE-ARG VOP
319 (macrolet ((frob (name sc stack-sc format
)
322 (:args
(x :scs
(,sc
) :target y
)
324 :load-if
(not (sc-is y
,sc
))))
326 (:note
"complex float argument move")
327 (:generator
,(ecase format
(:single
2) (:double
3))
334 '(inst movq
(ea-for-csf-data-stack y fp
) x
))
336 '(inst movupd
(ea-for-cdf-data-stack y fp
) x
)))))))
337 (define-move-vop ,name
:move-arg
338 (,sc descriptor-reg
) (,sc
)))))
339 (frob move-complex-single-float-arg
340 complex-single-reg complex-single-stack
:single
)
341 (frob move-complex-double-float-arg
342 complex-double-reg complex-double-stack
:double
))
344 (define-move-vop move-arg
:move-arg
345 (single-reg double-reg
346 complex-single-reg complex-double-reg
)
352 (define-vop (float-op)
356 (:note
"inline float arithmetic")
358 (:save-p
:compute-only
))
360 (macrolet ((frob (name comm-name sc constant-sc ptype
)
362 (define-vop (,name float-op
)
363 (:args
(x :scs
(,sc
,constant-sc
)
365 :load-if
(not (sc-is x
,constant-sc
)))
366 (y :scs
(,sc
,constant-sc
)
367 :load-if
(not (sc-is y
,constant-sc
))))
368 (:results
(r :scs
(,sc
)))
369 (:arg-types
,ptype
,ptype
)
370 (:result-types
,ptype
))
371 (define-vop (,comm-name float-op
)
372 (:args
(x :scs
(,sc
,constant-sc
)
374 :load-if
(not (sc-is x
,constant-sc
)))
375 (y :scs
(,sc
,constant-sc
)
377 :load-if
(not (sc-is y
,constant-sc
))))
378 (:results
(r :scs
(,sc
)))
379 (:arg-types
,ptype
,ptype
)
380 (:result-types
,ptype
)))))
381 (frob single-float-op single-float-comm-op
382 single-reg fp-single-immediate single-float
)
383 (frob double-float-op double-float-comm-op
384 double-reg fp-double-immediate double-float
)
385 (frob complex-single-float-op complex-single-float-comm-op
386 complex-single-reg fp-complex-single-immediate
387 complex-single-float
)
388 (frob complex-double-float-op complex-double-float-comm-op
389 complex-double-reg fp-complex-double-immediate
390 complex-double-float
))
392 (defun note-float-location (op vop
&rest args
)
393 (let ((*location-context
*
395 (loop for arg in args
397 (cond ((or (symbolp arg
)
400 ((eq (tn-kind arg
) :constant
)
403 (make-sc-offset (sc-number (tn-sc arg
))
404 (or (tn-offset arg
) 0))))))))
405 (note-this-location vop
:internal-error
)))
407 (macrolet ((generate (op opinst commutative constant-sc load-inst
)
408 `(flet ((get-constant (tn &optional maybe-aligned
)
409 (declare (ignorable maybe-aligned
))
410 (let ((value (tn-value tn
)))
411 ,(if (eq constant-sc
'fp-complex-single-immediate
)
413 (register-inline-constant
415 (register-inline-constant value
))
416 `(register-inline-constant value
))))
418 (note-float-location ',op vop x y
)))
419 (declare (ignorable #'get-constant
))
423 (when (sc-is y
,constant-sc
)
424 (setf y
(get-constant y t
)))
426 ((and ,commutative
(location= y r
))
428 (when (sc-is x
,constant-sc
)
429 (setf x
(get-constant x t
)))
431 ((not (location= r y
))
432 (if (sc-is x
,constant-sc
)
433 (inst ,load-inst r
(get-constant x
))
436 (when (sc-is y
,constant-sc
)
437 (setf y
(get-constant y t
)))
440 (if (sc-is x
,constant-sc
)
441 (inst ,load-inst tmp
(get-constant x
))
443 (note-location tmp y
)
446 (frob (op sinst sname scost dinst dname dcost commutative
447 &optional csinst csname cscost cdinst cdname cdcost
)
449 (define-vop (,sname
,(if commutative
450 'single-float-comm-op
453 (:temporary
(:sc single-reg
) tmp
)
456 (generate ,op
,sinst
,commutative fp-single-immediate movss
)))
457 (define-vop (,dname
,(if commutative
458 'double-float-comm-op
461 (:temporary
(:sc double-reg
) tmp
)
464 (generate ,op
,dinst
,commutative fp-double-immediate movsd
)))
466 `(define-vop (,csname
468 'complex-single-float-comm-op
469 'complex-single-float-op
))
471 (:temporary
(:sc complex-single-reg
) tmp
)
474 (generate ,op
,csinst
,commutative
475 fp-complex-single-immediate movq
))))
477 `(define-vop (,cdname
479 'complex-double-float-comm-op
480 'complex-double-float-op
))
482 (:temporary
(:sc complex-double-reg
) tmp
)
485 (generate ,op
,cdinst
,commutative
486 fp-complex-double-immediate movapd
)))))))
487 (frob + addss
+/single-float
2 addsd
+/double-float
2 t
488 addps
+/complex-single-float
3 addpd
+/complex-double-float
3)
489 (frob - subss -
/single-float
2 subsd -
/double-float
2 nil
490 subps -
/complex-single-float
3 subpd -
/complex-double-float
3)
491 (frob * mulss
*/single-float
4 mulsd
*/double-float
5 t
)
492 (frob / divss
//single-float
12 divsd
//double-float
19 nil
))
494 (macrolet ((frob (op cost commutativep
495 duplicate-inst op-inst real-move-inst complex-move-inst
496 real-sc real-constant-sc real-type
497 complex-sc complex-constant-sc complex-type
498 real-complex-name complex-real-name
)
499 (cond ((not duplicate-inst
) ; simple case
500 `(flet ((load-into (r x
)
503 (inst ,real-move-inst r
504 (register-inline-constant (tn-value x
))))
505 (,complex-constant-sc
506 (inst ,complex-move-inst r
507 (register-inline-constant (tn-value x
))))
509 ,(when real-complex-name
510 `(define-vop (,real-complex-name float-op
)
512 (:args
(x :scs
(,real-sc
,real-constant-sc
)
514 :load-if
(not (sc-is x
,real-constant-sc
)))
515 (y :scs
(,complex-sc
,complex-constant-sc
)
516 ,@(when commutativep
'(:target r
))
517 :load-if
(not (sc-is y
,complex-constant-sc
))))
518 (:arg-types
,real-type
,complex-type
)
519 (:results
(r :scs
(,complex-sc
)
520 ,@(unless commutativep
'(:from
(:argument
0)))))
521 (:result-types
,complex-type
)
525 `(when (location= y r
)
528 (note-float-location ',op vop r y
)
529 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
530 (setf y
(register-inline-constant
531 :aligned
(tn-value y
))))
532 (inst ,op-inst r y
))))
534 ,(when complex-real-name
535 `(define-vop (,complex-real-name float-op
)
537 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
539 :load-if
(not (sc-is x
,complex-constant-sc
)))
540 (y :scs
(,real-sc
,real-constant-sc
)
541 ,@(when commutativep
'(:target r
))
542 :load-if
(not (sc-is y
,real-constant-sc
))))
543 (:arg-types
,complex-type
,real-type
)
544 (:results
(r :scs
(,complex-sc
)
545 ,@(unless commutativep
'(:from
(:argument
0)))))
546 (:result-types
,complex-type
)
550 `(when (location= y r
)
553 (note-float-location ',op vop r y
)
554 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
555 (setf y
(register-inline-constant
556 :aligned
(tn-value y
))))
557 (inst ,op-inst r y
))))))
558 (commutativep ; must duplicate, but commutative
560 ,(when real-complex-name
561 `(define-vop (,real-complex-name float-op
)
563 (:args
(x :scs
(,real-sc
,real-constant-sc
)
565 :load-if
(not (sc-is x
,real-constant-sc
)))
566 (y :scs
(,complex-sc
,complex-constant-sc
)
569 :load-if
(not (sc-is y
,complex-constant-sc
))))
570 (:arg-types
,real-type
,complex-type
)
571 (:temporary
(:sc
,complex-sc
:target r
575 (:results
(r :scs
(,complex-sc
)))
576 (:result-types
,complex-type
)
581 (if (sc-is x
,real-constant-sc
)
582 (inst ,complex-move-inst dup
583 (register-inline-constant
584 (complex (setf first-value
(tn-value x
)) (tn-value x
))))
589 (when (location= dup r
)
591 (setf second-value dup
))
592 (if (sc-is y
,complex-constant-sc
)
593 (inst ,complex-move-inst r
594 (register-inline-constant (tn-value y
)))
596 (note-float-location ',op vop first-value second-value
)
597 (when (sc-is dup
,complex-constant-sc
)
598 (setf dup
(register-inline-constant
599 :aligned
(tn-value dup
))))
600 (inst ,op-inst r dup
)))))
602 ,(when complex-real-name
603 `(define-vop (,complex-real-name float-op
)
605 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
608 :load-if
(not (sc-is x
,complex-constant-sc
)))
609 (y :scs
(,real-sc
,real-constant-sc
)
611 :load-if
(not (sc-is y
,real-constant-sc
))))
612 (:arg-types
,complex-type
,real-type
)
613 (:temporary
(:sc
,complex-sc
:target r
617 (:results
(r :scs
(,complex-sc
)))
618 (:result-types
,complex-type
)
621 (let ((first-value r
)
623 (if (sc-is y
,real-constant-sc
)
624 (inst ,complex-move-inst dup
625 (register-inline-constant
626 (complex (setf second-value
(tn-value y
))
629 (setf second-value y
)
631 (when (location= dup r
)
633 (setf first-value dup
))
634 (if (sc-is x
,complex-constant-sc
)
635 (inst ,complex-move-inst r
636 (register-inline-constant (tn-value x
)))
638 (note-float-location ',op vop first-value second-value
)
639 (when (sc-is dup
,complex-constant-sc
)
640 (setf dup
(register-inline-constant
641 :aligned
(tn-value dup
))))
642 (inst ,op-inst r dup
)))))))
643 (t ; duplicate, not commutative
645 ,(when real-complex-name
646 `(define-vop (,real-complex-name float-op
)
648 (:args
(x :scs
(,real-sc
,real-constant-sc
)
650 :load-if
(not (sc-is x
,real-constant-sc
)))
651 (y :scs
(,complex-sc
,complex-constant-sc
)
653 :load-if
(not (sc-is y
,complex-constant-sc
))))
654 (:arg-types
,real-type
,complex-type
)
655 (:results
(r :scs
(,complex-sc
) :from
(:argument
0)))
656 (:result-types
,complex-type
)
659 (if (sc-is x
,real-constant-sc
)
660 (inst ,complex-move-inst dup
661 (register-inline-constant
662 (complex (tn-value x
) (tn-value x
))))
666 (note-float-location ',op vop r y
)
667 (when (sc-is y
,complex-constant-sc
)
668 (setf y
(register-inline-constant
669 :aligned
(tn-value y
))))
670 (inst ,op-inst r y
))))
672 ,(when complex-real-name
673 `(define-vop (,complex-real-name float-op
)
675 (:args
(x :scs
(,complex-sc
)
678 (y :scs
(,real-sc
,real-constant-sc
)
680 :load-if
(not (sc-is y
,complex-constant-sc
))))
681 (:arg-types
,complex-type
,real-type
)
682 (:temporary
(:sc
,complex-sc
:from
(:argument
1))
684 (:results
(r :scs
(,complex-sc
) :from
:eval
))
685 (:result-types
,complex-type
)
689 (if (sc-is y
,real-constant-sc
)
690 (setf dup
(register-inline-constant
691 :aligned
(complex (setf second-value
(tn-value y
))
694 (setf second-value y
)
697 (note-float-location ',op vop r second-value
)
698 (inst ,op-inst r dup
)))))))))
699 (def-real-complex-op (op commutativep duplicatep
700 single-inst single-real-complex-name single-complex-real-name single-cost
701 double-inst double-real-complex-name double-complex-real-name double-cost
)
703 (frob ,op
,single-cost
,commutativep
707 (inst unpcklps dup dup
)))
708 ,single-inst movss movq
709 single-reg fp-single-immediate single-float
710 complex-single-reg fp-complex-single-immediate complex-single-float
711 ,single-real-complex-name
,single-complex-real-name
)
712 (frob ,op
,double-cost
,commutativep
716 (inst unpcklpd dup dup
)))
717 ,double-inst movsd movapd
718 double-reg fp-double-immediate double-float
719 complex-double-reg fp-complex-double-immediate complex-double-float
720 ,double-real-complex-name
,double-complex-real-name
))))
721 (def-real-complex-op + t nil
722 addps
+/real-complex-single-float
+/complex-real-single-float
3
723 addpd
+/real-complex-double-float
+/complex-real-double-float
4)
724 (def-real-complex-op - nil nil
725 subps -
/real-complex-single-float -
/complex-real-single-float
3
726 subpd -
/real-complex-double-float -
/complex-real-double-float
4)
727 (def-real-complex-op * t t
728 mulps
*/real-complex-single-float
*/complex-real-single-float
4
729 mulpd
*/real-complex-double-float
*/complex-real-double-float
5)
730 (def-real-complex-op / nil t
732 divpd nil
//complex-real-double-float
19))
734 (define-vop (//complex-real-single-float float-op
)
736 (:args
(x :scs
(complex-single-reg fp-complex-single-immediate fp-complex-single-zero
)
739 :load-if
(not (sc-is x fp-complex-single-immediate fp-complex-single-zero
)))
740 (y :scs
(single-reg fp-single-immediate fp-single-zero
)
742 :load-if
(not (sc-is y fp-single-immediate fp-single-zero
))))
743 (:arg-types complex-single-float single-float
)
744 (:temporary
(:sc complex-single-reg
:from
(:argument
1)) dup
)
745 (:results
(r :scs
(complex-single-reg)))
746 (:result-types complex-single-float
)
749 (let ((second-value dup
)
751 (flet ((duplicate (x)
752 (let ((word (ldb (byte 64 0)
753 (logior (ash (single-float-bits (imagpart x
)) 32)
755 (single-float-bits (realpart x
)))))))
756 (register-inline-constant :oword
(logior (ash word
64) word
)))))
759 (setf dup
(duplicate (complex (setf second-value
(tn-value y
))
762 (inst xorps dup dup
))
764 (setf second-value y
)
765 (inst shufps dup dup
#b00000000
)))
767 (fp-complex-single-immediate
768 (inst movaps r
(duplicate (setf first-value
(tn-value x
)))))
769 (fp-complex-single-zero
774 (inst unpcklpd r r
)))
775 (note-float-location '/ vop first-value second-value
)
779 ;; Complex multiplication
780 ;; r := rx * ry - ix * iy
781 ;; i := rx * iy + ix * ry
783 ;; Transpose for SIMDness
788 ;;+ [ix ix] * [-iy ry]
791 (macrolet ((define-complex-* (name cost type sc tmp-p
&body body
)
792 `(define-vop (,name float-op
)
794 (:args
(x :scs
(,sc
) :target r
)
795 (y :scs
(,sc
) :target copy-y
))
796 (:arg-types
,type
,type
)
797 (:temporary
(:sc
,sc
) imag
)
798 (:temporary
(:sc
,sc
:from
:eval
) copy-y
)
800 `((:temporary
(:sc
,sc
) xmm
)))
801 (:results
(r :scs
(,sc
) :from
:eval
))
802 (:result-types
,type
)
805 (when (or (location= x copy-y
)
809 (define-complex-* */complex-single-float
20
810 complex-single-float complex-single-reg t
813 (move copy-y y
) ; y == r only if y == x == r
818 (inst unpckhpd imag xmm
)
819 (inst unpcklpd r xmm
)
821 (note-float-location '* vop r y
)
824 (inst shufps y y
#b11110001
)
825 (inst xorps y
(register-inline-constant :oword
(ash 1 31)))
829 (define-complex-* */complex-double-float
25
830 complex-double-float complex-double-reg nil
836 (inst unpckhpd imag imag
)
838 (note-float-location '* vop r y
)
841 (inst shufpd y y
#b01
)
842 (inst xorpd y
(register-inline-constant :oword
(ash 1 63)))
844 (inst addpd r imag
)))
847 (:args
(x :scs
(double-reg)))
848 (:results
(y :scs
(double-reg)))
851 (:arg-types double-float
)
852 (:result-types double-float
)
853 (:note
"inline float arithmetic")
855 (:save-p
:compute-only
)
857 (unless (location= x y
)
859 (note-float-location 'sqrt vop x
)
862 (macrolet ((frob ((name translate sc type
) &body body
)
864 (:args
(x :scs
(,sc
) :target y
))
865 (:results
(y :scs
(,sc
)))
866 (:translate
,translate
)
869 (:result-types
,type
)
870 (:note
"inline float arithmetic")
872 (:save-p
:compute-only
)
875 (note-float-location ',translate vop y
)
877 (frob (%negate
/double-float %negate double-reg double-float
)
878 (inst xorpd y
(register-inline-constant :oword
(ash 1 63))))
879 (frob (%negate
/complex-double-float %negate complex-double-reg complex-double-float
)
880 (inst xorpd y
(register-inline-constant
881 :oword
(logior (ash 1 127) (ash 1 63)))))
882 (frob (conjugate/complex-double-float conjugate complex-double-reg complex-double-float
)
883 (inst xorpd y
(register-inline-constant :oword
(ash 1 127))))
884 (frob (%negate
/single-float %negate single-reg single-float
)
885 (inst xorps y
(register-inline-constant :oword
(ash 1 31))))
886 (frob (%negate
/complex-single-float %negate complex-single-reg complex-single-float
)
887 (inst xorps y
(register-inline-constant
888 :oword
(logior (ash 1 31) (ash 1 63)))))
889 (frob (conjugate/complex-single-float conjugate complex-single-reg complex-single-float
)
890 (inst xorpd y
(register-inline-constant :oword
(ash 1 63))))
891 (frob (abs/double-float abs double-reg double-float
)
892 (inst andpd y
(register-inline-constant :oword
(ldb (byte 63 0) -
1))))
893 (frob (abs/single-float abs single-reg single-float
)
894 (inst andps y
(register-inline-constant :oword
(ldb (byte 31 0) -
1)))))
899 (define-vop (float-compare)
902 (:save-p
:compute-only
)
903 (:note
"inline float comparison"))
906 (macrolet ((define-float-eql (name cost sc constant-sc type
)
907 `(define-vop (,name float-compare
)
911 (y :scs
(,sc
,constant-sc
)
913 (:arg-types
,type
,type
)
914 (:temporary
(:sc
,sc
:from
:eval
) mask
)
915 (:temporary
(:sc dword-reg
) bits
)
918 (when (location= y mask
)
921 (when (sc-is y
,constant-sc
)
922 (setf y
(register-inline-constant :aligned
(tn-value y
))))
923 (inst pcmpeqd mask y
)
924 (inst movmskps bits mask
)
925 (inst cmp
(if (location= bits eax-tn
) al-tn bits
)
927 (define-float-eql eql
/single-float
4
928 single-reg fp-single-immediate single-float
)
929 (define-float-eql eql
/double-float
4
930 double-reg fp-double-immediate double-float
)
931 (define-float-eql eql
/complex-single-float
5
932 complex-single-reg fp-complex-single-immediate complex-single-float
)
933 (define-float-eql eql
/complex-double-float
5
934 complex-double-reg fp-complex-double-immediate complex-double-float
))
936 (define-vop (generic-eq/single-float
/c float-compare
)
938 (:args
(x :scs
(any-reg descriptor-reg
)))
940 (:arg-types
* (:constant single-float
))
943 (inst cmp x
(constantize (dpb (single-float-bits y
) (byte 32 32)
944 single-float-widetag
)))))
946 ;;; comiss and comisd can cope with one or other arg in memory: we
947 ;;; could (should, indeed) extend these to cope with descriptor args
950 (define-vop (single-float-compare float-compare
)
951 (:args
(x :scs
(single-reg))
952 (y :scs
(single-reg single-stack fp-single-immediate
)
953 :load-if
(not (sc-is y single-stack fp-single-immediate
))))
954 (:arg-types single-float single-float
))
955 (define-vop (double-float-compare float-compare
)
956 (:args
(x :scs
(double-reg))
957 (y :scs
(double-reg double-stack descriptor-reg fp-double-immediate
)
958 :load-if
(not (sc-is y double-stack descriptor-reg fp-double-immediate
))))
959 (:arg-types double-float double-float
))
961 (define-vop (=/single-float single-float-compare
)
963 (:args
(x :scs
(single-reg single-stack fp-single-immediate
)
965 :load-if
(not (sc-is x single-stack fp-single-immediate
)))
966 (y :scs
(single-reg single-stack fp-single-immediate
)
968 :load-if
(not (sc-is y single-stack fp-single-immediate
))))
969 (:temporary
(:sc single-reg
:from
:eval
) xmm
)
970 (:conditional not
:p
:ne
)
973 (when (or (location= y xmm
)
974 (and (not (xmm-register-p x
))
978 (single-reg (setf xmm x
))
979 (single-stack (inst movss xmm
(ea-for-sf-stack x
)))
981 (inst movss xmm
(register-inline-constant (tn-value x
)))))
982 (note-float-location '= vop xmm y
)
985 (setf y
(ea-for-sf-stack y
)))
987 (setf y
(register-inline-constant (tn-value y
))))
990 ;; if PF&CF, there was a NaN involved => not equal
991 ;; otherwise, ZF => equal
994 (define-vop (=/double-float double-float-compare
)
996 (:args
(x :scs
(double-reg double-stack fp-double-immediate descriptor-reg
)
998 :load-if
(not (sc-is x double-stack fp-double-immediate descriptor-reg
)))
999 (y :scs
(double-reg double-stack fp-double-immediate descriptor-reg
)
1001 :load-if
(not (sc-is y double-stack fp-double-immediate descriptor-reg
))))
1002 (:temporary
(:sc double-reg
:from
:eval
) xmm
)
1003 (:conditional not
:p
:ne
)
1006 (when (or (location= y xmm
)
1007 (and (not (xmm-register-p x
))
1008 (xmm-register-p y
)))
1014 (inst movsd xmm
(ea-for-df-stack x
)))
1015 (fp-double-immediate
1016 (inst movsd xmm
(register-inline-constant (tn-value x
))))
1018 (inst movsd xmm
(ea-for-df-desc x
))))
1019 (note-float-location '= vop xmm y
)
1022 (setf y
(ea-for-df-stack y
)))
1023 (fp-double-immediate
1024 (setf y
(register-inline-constant (tn-value y
))))
1026 (setf y
(ea-for-df-desc y
)))
1028 (inst comisd xmm y
)))
1030 (macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name
1031 real-sc real-constant-sc real-type
1032 complex-sc complex-constant-sc complex-type
1033 real-move-inst complex-move-inst
1034 cmp-inst mask-inst mask
)
1036 (define-vop (,complex-complex-name float-compare
)
1038 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
1040 :load-if
(not (sc-is x
,complex-constant-sc
)))
1041 (y :scs
(,complex-sc
,complex-constant-sc
)
1043 :load-if
(not (sc-is y
,complex-constant-sc
))))
1044 (:arg-types
,complex-type
,complex-type
)
1045 (:temporary
(:sc
,complex-sc
:from
:eval
) cmp
)
1046 (:temporary
(:sc dword-reg
) bits
)
1050 (when (location= y cmp
)
1054 (inst ,real-move-inst cmp
(register-inline-constant
1056 (,complex-constant-sc
1057 (inst ,complex-move-inst cmp
(register-inline-constant
1061 (note-float-location '= vop cmp y
)
1062 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
1063 (setf y
(register-inline-constant :aligned
(tn-value y
))))
1064 (inst ,cmp-inst
:eq cmp y
)
1065 (inst ,mask-inst bits cmp
)
1066 (inst cmp
(if (location= bits eax-tn
) al-tn bits
)
1068 (define-vop (,complex-real-name
,complex-complex-name
)
1069 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
1071 :load-if
(not (sc-is x
,complex-constant-sc
)))
1072 (y :scs
(,real-sc
,real-constant-sc
)
1074 :load-if
(not (sc-is y
,real-constant-sc
))))
1075 (:arg-types
,complex-type
,real-type
))
1076 (define-vop (,real-complex-name
,complex-complex-name
)
1077 (:args
(x :scs
(,real-sc
,real-constant-sc
)
1079 :load-if
(not (sc-is x
,real-constant-sc
)))
1080 (y :scs
(,complex-sc
,complex-constant-sc
)
1082 :load-if
(not (sc-is y
,complex-constant-sc
))))
1083 (:arg-types
,real-type
,complex-type
)))))
1084 (define-complex-float-= =/complex-single-float
=/complex-real-single-float
=/real-complex-single-float
1085 single-reg fp-single-immediate single-float
1086 complex-single-reg fp-complex-single-immediate complex-single-float
1087 movss movq cmpps movmskps
#b1111
)
1088 (define-complex-float-= =/complex-double-float
=/complex-real-double-float
=/real-complex-double-float
1089 double-reg fp-double-immediate double-float
1090 complex-double-reg fp-complex-double-immediate complex-double-float
1091 movsd movapd cmppd movmskpd
#b11
))
1093 (macrolet ((define-</> (op single-name double-name
&rest flags
)
1095 (define-vop (,double-name double-float-compare
)
1099 (:conditional
,@flags
)
1101 (note-float-location ',op vop x y
)
1104 (setf y
(ea-for-df-stack y
)))
1106 (setf y
(ea-for-df-desc y
)))
1107 (fp-double-immediate
1108 (setf y
(register-inline-constant (tn-value y
))))
1111 (define-vop (,single-name single-float-compare
)
1114 (:conditional
,@flags
)
1116 (note-float-location ',op vop x y
)
1119 (setf y
(ea-for-sf-stack y
)))
1120 (fp-single-immediate
1121 (setf y
(register-inline-constant (tn-value y
))))
1123 (inst comiss x y
))))))
1124 (define-</> < <single-float
<double-float not
:p
:nc
)
1125 (define-</> > >single-float
>double-float not
:p
:na
))
1130 (macrolet ((frob (name translate inst to-sc to-type
)
1131 `(define-vop (,name
)
1132 (:args
(x :scs
(signed-stack signed-reg
)))
1133 (:results
(y :scs
(,to-sc
)))
1134 (:arg-types signed-num
)
1135 (:result-types
,to-type
)
1136 (:policy
:fast-safe
)
1137 (:note
"inline float coercion")
1138 (:translate
,translate
)
1140 (:save-p
:compute-only
)
1143 (single-reg (inst xorps y y
))
1144 (double-reg (inst xorpd y y
)))
1145 (note-float-location 'coerce vop x
',to-type
)
1146 (inst ,inst y x
)))))
1147 (frob %single-float
/signed %single-float cvtsi2ss single-reg single-float
)
1148 (frob %double-float
/signed %double-float cvtsi2sd double-reg double-float
))
1150 (macrolet ((frob (name translate inst from-scs from-type ea-func to-sc to-type
)
1151 `(define-vop (,name
)
1152 (:args
(x :scs
,from-scs
:target y
))
1153 (:results
(y :scs
(,to-sc
)))
1154 (:arg-types
,from-type
)
1155 (:result-types
,to-type
)
1156 (:policy
:fast-safe
)
1157 (:note
"inline float coercion")
1158 (:translate
,translate
)
1160 (:save-p
:compute-only
)
1162 (unless (location= x y
)
1164 (single-reg (inst xorps y y
))
1165 (double-reg (inst xorpd y y
))))
1166 (note-float-location 'coerce vop x
',to-type
)
1167 (inst ,inst y
(sc-case x
1168 (,(first from-scs
) x
)
1169 (,(second from-scs
) (,ea-func x
))))
1170 ,(when (and (eq from-type
'double-float
) ; if the input is wider
1171 (eq to-type
'single-float
)) ; than the output, clear
1172 `(when (location= x y
) ; noise in the high part
1173 (inst shufps y y
#4r3330
)))))))
1174 (frob %single-float
/double-float %single-float cvtsd2ss
1175 (double-reg double-stack
) double-float ea-for-df-stack
1176 single-reg single-float
)
1178 (frob %double-float
/single-float %double-float cvtss2sd
1179 (single-reg single-stack
) single-float ea-for-sf-stack
1180 double-reg double-float
))
1182 (macrolet ((frob (trans op inst from-scs from-type ea-func
)
1183 `(define-vop (,(symbolicate trans
"/" from-type
))
1184 (:args
(x :scs
,from-scs
))
1185 (:results
(y :scs
(signed-reg)))
1186 (:arg-types
,from-type
)
1187 (:result-types signed-num
)
1189 (:policy
:fast-safe
)
1190 (:note
"inline float truncate")
1192 (:save-p
:compute-only
)
1194 (note-float-location ',op vop x
)
1195 (inst ,inst y
(sc-case x
1196 (,(first from-scs
) x
)
1197 (,(second from-scs
) (,ea-func x
))))))))
1198 (frob %unary-truncate
/single-float truncate cvttss2si
1199 (single-reg single-stack
) single-float ea-for-sf-stack
)
1200 (frob %unary-truncate
/double-float truncate cvttsd2si
1201 (double-reg double-stack
) double-float ea-for-df-stack
)
1203 (frob %unary-round round cvtss2si
1204 (single-reg single-stack
) single-float ea-for-sf-stack
)
1205 (frob %unary-round round cvtsd2si
1206 (double-reg double-stack
) double-float ea-for-df-stack
))
1208 (define-vop (make-single-float)
1209 (:args
(bits :scs
(signed-reg) :target res
1210 :load-if
(not (or (and (sc-is bits signed-stack
)
1211 (sc-is res single-reg
))
1212 (and (sc-is bits signed-stack
)
1213 (sc-is res single-stack
)
1214 (location= bits res
))))))
1215 (:results
(res :scs
(single-reg single-stack
)))
1216 (:arg-types signed-num
)
1217 (:result-types single-float
)
1218 (:translate make-single-float
)
1219 (:policy
:fast-safe
)
1226 (inst mov res bits
))
1228 (aver (location= bits res
)))))
1232 (inst movd res
(reg-in-size bits
:dword
)))
1235 (make-ea :dword
:base rbp-tn
1236 :disp
(frame-byte-offset (tn-offset bits
))))))))))
1238 (define-vop (make-single-float-c)
1239 (:results
(res :scs
(single-reg single-stack descriptor-reg
)))
1240 (:arg-types
(:constant
(signed-byte 32)))
1241 (:result-types single-float
)
1243 (:translate make-single-float
)
1244 (:policy
:fast-safe
)
1249 (inst mov res bits
))
1251 (inst movss res
(register-inline-constant :dword bits
)))
1253 (inst mov res
(logior (ash bits
32)
1254 single-float-widetag
))))))
1256 (define-vop (make-double-float)
1257 (:args
(hi-bits :scs
(signed-reg))
1258 (lo-bits :scs
(unsigned-reg)))
1259 (:results
(res :scs
(double-reg)))
1260 (:temporary
(:sc unsigned-reg
) temp
)
1261 (:arg-types signed-num unsigned-num
)
1262 (:result-types double-float
)
1263 (:translate make-double-float
)
1264 (:policy
:fast-safe
)
1269 (inst or temp lo-bits
)
1270 (inst movd res temp
)))
1272 (define-vop (make-double-float-c)
1273 (:results
(res :scs
(double-reg)))
1274 (:arg-types
(:constant
(signed-byte 32)) (:constant
(unsigned-byte 32)))
1275 (:result-types double-float
)
1277 (:translate make-double-float
)
1278 (:policy
:fast-safe
)
1281 (inst movsd res
(register-inline-constant :qword
(logior (ash hi
32) lo
)))))
1283 (define-vop (single-float-bits)
1284 (:args
(float :scs
(single-reg descriptor-reg
)
1285 :load-if
(not (sc-is float single-stack
))))
1286 (:results
(bits :scs
(signed-reg)))
1287 (:arg-types single-float
)
1288 (:result-types signed-num
)
1289 (:translate single-float-bits
)
1290 (:policy
:fast-safe
)
1294 (let ((dword-bits (reg-in-size bits
:dword
)))
1295 (inst movd dword-bits float
)
1296 (inst movsxd bits dword-bits
)))
1298 (inst movsxd bits
(make-ea :dword
; c.f. ea-for-sf-stack
1300 :disp
(frame-byte-offset (tn-offset float
)))))
1303 (inst sar bits
32)))))
1305 (define-vop (double-float-high-bits)
1306 (:args
(float :scs
(double-reg descriptor-reg
)
1307 :load-if
(not (sc-is float double-stack
))))
1308 (:results
(hi-bits :scs
(signed-reg)))
1309 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) temp
)
1310 (:arg-types double-float
)
1311 (:result-types signed-num
)
1312 (:translate double-float-high-bits
)
1313 (:policy
:fast-safe
)
1318 (inst movsd temp float
)
1319 (move hi-bits temp
))
1321 (loadw hi-bits ebp-tn
(frame-word-offset (tn-offset float
))))
1323 (loadw hi-bits float double-float-value-slot
1324 other-pointer-lowtag
)))
1325 (inst sar hi-bits
32)))
1327 (define-vop (double-float-low-bits)
1328 (:args
(float :scs
(double-reg descriptor-reg
)
1329 :load-if
(not (sc-is float double-stack
))))
1330 (:results
(lo-bits :scs
(unsigned-reg)))
1331 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) temp
)
1332 (:arg-types double-float
)
1333 (:result-types unsigned-num
)
1334 (:translate double-float-low-bits
)
1335 (:policy
:fast-safe
)
1338 (let ((dword-lo-bits (reg-in-size lo-bits
:dword
)))
1341 (inst movsd temp float
)
1342 (inst mov dword-lo-bits
1343 (make-ea :dword
:base rbp-tn
1344 :disp
(frame-byte-offset (tn-offset temp
)))))
1346 (inst mov dword-lo-bits
1347 (make-ea :dword
:base rbp-tn
1348 :disp
(frame-byte-offset (tn-offset float
)))))
1350 (inst mov dword-lo-bits
1351 (make-ea-for-object-slot-half float double-float-value-slot
1352 other-pointer-lowtag
)))))))
1356 ;;;; complex float VOPs
1358 (define-vop (make-complex-single-float)
1359 (:translate complex
)
1360 (:args
(real :scs
(single-reg fp-single-zero
)
1362 :load-if
(not (sc-is real fp-single-zero
)))
1363 (imag :scs
(single-reg fp-single-zero
)
1364 :load-if
(not (sc-is imag fp-single-zero
))))
1365 (:arg-types single-float single-float
)
1366 (:results
(r :scs
(complex-single-reg) :from
(:argument
0)))
1367 (:result-types complex-single-float
)
1368 (:note
"inline complex single-float creation")
1369 (:policy
:fast-safe
)
1371 (cond ((sc-is real fp-single-zero
)
1373 (unless (sc-is imag fp-single-zero
)
1374 (inst unpcklps r imag
)))
1375 ((location= real imag
)
1377 (inst unpcklps r r
))
1380 (unless (sc-is imag fp-single-zero
)
1381 (inst unpcklps r imag
))))))
1383 (define-vop (make-complex-double-float)
1384 (:translate complex
)
1385 (:args
(real :scs
(double-reg fp-double-zero
)
1387 :load-if
(not (sc-is real fp-double-zero
)))
1388 (imag :scs
(double-reg fp-double-zero
)
1389 :load-if
(not (sc-is imag fp-double-zero
))))
1390 (:arg-types double-float double-float
)
1391 (:results
(r :scs
(complex-double-reg) :from
(:argument
0)))
1392 (:result-types complex-double-float
)
1393 (:note
"inline complex double-float creation")
1394 (:policy
:fast-safe
)
1396 (cond ((sc-is real fp-double-zero
)
1398 (unless (sc-is imag fp-double-zero
)
1399 (inst unpcklpd r imag
)))
1400 ((location= real imag
)
1402 (inst unpcklpd r r
))
1405 (unless (sc-is imag fp-double-zero
)
1406 (inst unpcklpd r imag
))))))
1408 (define-vop (complex-float-value)
1409 (:args
(x :target r
))
1410 (:temporary
(:sc complex-double-reg
) zero
)
1412 (:variant-vars offset
)
1413 (:policy
:fast-safe
)
1415 (cond ((sc-is x complex-double-reg
)
1417 (inst xorpd zero zero
)
1419 (0 (inst unpcklpd r zero
))
1420 (1 (inst unpckhpd r zero
))))
1421 ((sc-is x complex-single-reg
)
1424 (0 (inst shufps r r
#b11111100
))
1425 (1 (inst shufps r r
#b11111101
))))
1426 ((sc-is r single-reg
)
1427 (let ((ea (sc-case x
1428 (complex-single-stack
1430 (0 (ea-for-csf-real-stack x
))
1431 (1 (ea-for-csf-imag-stack x
))))
1434 (0 (ea-for-csf-real-desc x
))
1435 (1 (ea-for-csf-imag-desc x
)))))))
1437 ((sc-is r double-reg
)
1438 (let ((ea (sc-case x
1439 (complex-double-stack
1441 (0 (ea-for-cdf-real-stack x
))
1442 (1 (ea-for-cdf-imag-stack x
))))
1445 (0 (ea-for-cdf-real-desc x
))
1446 (1 (ea-for-cdf-imag-desc x
)))))))
1448 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
1450 (define-vop (realpart/complex-single-float complex-float-value
)
1451 (:translate realpart
)
1452 (:args
(x :scs
(complex-single-reg complex-single-stack descriptor-reg
)
1454 (:arg-types complex-single-float
)
1455 (:results
(r :scs
(single-reg)))
1456 (:result-types single-float
)
1457 (:note
"complex float realpart")
1460 (define-vop (realpart/complex-double-float complex-float-value
)
1461 (:translate realpart
)
1462 (:args
(x :scs
(complex-double-reg complex-double-stack descriptor-reg
)
1464 (:arg-types complex-double-float
)
1465 (:results
(r :scs
(double-reg)))
1466 (:result-types double-float
)
1467 (:note
"complex float realpart")
1470 (define-vop (imagpart/complex-single-float complex-float-value
)
1471 (:translate imagpart
)
1472 (:args
(x :scs
(complex-single-reg complex-single-stack descriptor-reg
)
1474 (:arg-types complex-single-float
)
1475 (:results
(r :scs
(single-reg)))
1476 (:result-types single-float
)
1477 (:note
"complex float imagpart")
1480 (define-vop (imagpart/complex-double-float complex-float-value
)
1481 (:translate imagpart
)
1482 (:args
(x :scs
(complex-double-reg complex-double-stack descriptor-reg
)
1484 (:arg-types complex-double-float
)
1485 (:results
(r :scs
(double-reg)))
1486 (:result-types double-float
)
1487 (:note
"complex float imagpart")
1491 ;;; hack dummy VOPs to bias the representation selection of their
1492 ;;; arguments towards a FP register, which can help avoid consing at
1493 ;;; inappropriate locations
1494 (defknown double-float-reg-bias
(double-float) (values))
1495 (define-vop (double-float-reg-bias)
1496 (:translate double-float-reg-bias
)
1497 (:args
(x :scs
(double-reg double-stack
) :load-if nil
))
1498 (:arg-types double-float
)
1499 (:policy
:fast-safe
)
1500 (:note
"inline dummy FP register bias")
1503 (defknown single-float-reg-bias
(single-float) (values))
1504 (define-vop (single-float-reg-bias)
1505 (:translate single-float-reg-bias
)
1506 (:args
(x :scs
(single-reg single-stack
) :load-if nil
))
1507 (:arg-types single-float
)
1508 (:policy
:fast-safe
)
1509 (:note
"inline dummy FP register bias")
1513 (defknown swap-complex
((complex float
)) (complex float
)
1514 (foldable flushable movable always-translatable
))
1515 (defoptimizer (swap-complex derive-type
) ((x))
1516 (sb!c
::lvar-type x
))
1517 (defun swap-complex (x)
1518 (complex (imagpart x
) (realpart x
)))
1519 (define-vop (swap-complex-single-float)
1520 (:translate swap-complex
)
1521 (:policy
:fast-safe
)
1522 (:args
(x :scs
(complex-single-reg) :target r
))
1523 (:arg-types complex-single-float
)
1524 (:results
(r :scs
(complex-single-reg)))
1525 (:result-types complex-single-float
)
1528 (inst shufps r r
#b11110001
)))
1529 (define-vop (swap-complex-double-float)
1530 (:translate swap-complex
)
1531 (:policy
:fast-safe
)
1532 (:args
(x :scs
(complex-double-reg) :target r
))
1533 (:arg-types complex-double-float
)
1534 (:results
(r :scs
(complex-double-reg)))
1535 (:result-types complex-double-float
)
1538 (inst shufpd r r
#b01
)))