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
)
909 (:args
(x :scs
(,sc
,constant-sc
)
911 :load-if
(not (sc-is x
,constant-sc
)))
912 (y :scs
(,sc
,constant-sc
)
914 :load-if
(not (sc-is y
,constant-sc
))))
915 (:arg-types
,type
,type
)
916 (:temporary
(:sc
,sc
:from
:eval
) mask
)
917 (:temporary
(:sc dword-reg
) bits
)
920 (when (or (location= y mask
)
921 (not (xmm-register-p x
)))
923 (aver (xmm-register-p x
))
925 (when (sc-is y
,constant-sc
)
926 (setf y
(register-inline-constant :aligned
(tn-value y
))))
927 (inst pcmpeqd mask y
)
928 (inst movmskps bits mask
)
929 (inst cmp
(if (location= bits eax-tn
) al-tn bits
)
931 (define-float-eql eql
/single-float
4
932 single-reg fp-single-immediate single-float
)
933 (define-float-eql eql
/double-float
4
934 double-reg fp-double-immediate double-float
)
935 (define-float-eql eql
/complex-single-float
5
936 complex-single-reg fp-complex-single-immediate complex-single-float
)
937 (define-float-eql eql
/complex-double-float
5
938 complex-double-reg fp-complex-double-immediate complex-double-float
))
940 (define-vop (generic-eq/single-float
/c float-compare
)
942 (:args
(x :scs
(any-reg descriptor-reg
)))
944 (:arg-types
* (:constant single-float
))
947 (inst cmp x
(constantize (dpb (single-float-bits y
) (byte 32 32)
948 single-float-widetag
)))))
950 ;;; comiss and comisd can cope with one or other arg in memory: we
951 ;;; could (should, indeed) extend these to cope with descriptor args
954 (define-vop (single-float-compare float-compare
)
955 (:args
(x :scs
(single-reg))
956 (y :scs
(single-reg single-stack fp-single-immediate
)
957 :load-if
(not (sc-is y single-stack fp-single-immediate
))))
958 (:arg-types single-float single-float
))
959 (define-vop (double-float-compare float-compare
)
960 (:args
(x :scs
(double-reg))
961 (y :scs
(double-reg double-stack descriptor-reg fp-double-immediate
)
962 :load-if
(not (sc-is y double-stack descriptor-reg fp-double-immediate
))))
963 (:arg-types double-float double-float
))
965 (define-vop (=/single-float single-float-compare
)
967 (:args
(x :scs
(single-reg single-stack fp-single-immediate
)
969 :load-if
(not (sc-is x single-stack fp-single-immediate
)))
970 (y :scs
(single-reg single-stack fp-single-immediate
)
972 :load-if
(not (sc-is y single-stack fp-single-immediate
))))
973 (:temporary
(:sc single-reg
:from
:eval
) xmm
)
974 (:conditional not
:p
:ne
)
977 (when (or (location= y xmm
)
978 (and (not (xmm-register-p x
))
982 (single-reg (setf xmm x
))
983 (single-stack (inst movss xmm
(ea-for-sf-stack x
)))
985 (inst movss xmm
(register-inline-constant (tn-value x
)))))
986 (note-float-location '= vop xmm y
)
989 (setf y
(ea-for-sf-stack y
)))
991 (setf y
(register-inline-constant (tn-value y
))))
994 ;; if PF&CF, there was a NaN involved => not equal
995 ;; otherwise, ZF => equal
998 (define-vop (=/double-float double-float-compare
)
1000 (:args
(x :scs
(double-reg double-stack fp-double-immediate descriptor-reg
)
1002 :load-if
(not (sc-is x double-stack fp-double-immediate descriptor-reg
)))
1003 (y :scs
(double-reg double-stack fp-double-immediate descriptor-reg
)
1005 :load-if
(not (sc-is y double-stack fp-double-immediate descriptor-reg
))))
1006 (:temporary
(:sc double-reg
:from
:eval
) xmm
)
1007 (:conditional not
:p
:ne
)
1010 (when (or (location= y xmm
)
1011 (and (not (xmm-register-p x
))
1012 (xmm-register-p y
)))
1018 (inst movsd xmm
(ea-for-df-stack x
)))
1019 (fp-double-immediate
1020 (inst movsd xmm
(register-inline-constant (tn-value x
))))
1022 (inst movsd xmm
(ea-for-df-desc x
))))
1023 (note-float-location '= vop xmm y
)
1026 (setf y
(ea-for-df-stack y
)))
1027 (fp-double-immediate
1028 (setf y
(register-inline-constant (tn-value y
))))
1030 (setf y
(ea-for-df-desc y
)))
1032 (inst comisd xmm y
)))
1034 (macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name
1035 real-sc real-constant-sc real-type
1036 complex-sc complex-constant-sc complex-type
1037 real-move-inst complex-move-inst
1038 cmp-inst mask-inst mask
)
1040 (define-vop (,complex-complex-name float-compare
)
1042 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
1044 :load-if
(not (sc-is x
,complex-constant-sc
)))
1045 (y :scs
(,complex-sc
,complex-constant-sc
)
1047 :load-if
(not (sc-is y
,complex-constant-sc
))))
1048 (:arg-types
,complex-type
,complex-type
)
1049 (:temporary
(:sc
,complex-sc
:from
:eval
) cmp
)
1050 (:temporary
(:sc dword-reg
) bits
)
1054 (when (location= y cmp
)
1058 (inst ,real-move-inst cmp
(register-inline-constant
1060 (,complex-constant-sc
1061 (inst ,complex-move-inst cmp
(register-inline-constant
1065 (note-float-location '= vop cmp y
)
1066 (when (sc-is y
,real-constant-sc
,complex-constant-sc
)
1067 (setf y
(register-inline-constant :aligned
(tn-value y
))))
1068 (inst ,cmp-inst
:eq cmp y
)
1069 (inst ,mask-inst bits cmp
)
1070 (inst cmp
(if (location= bits eax-tn
) al-tn bits
)
1072 (define-vop (,complex-real-name
,complex-complex-name
)
1073 (:args
(x :scs
(,complex-sc
,complex-constant-sc
)
1075 :load-if
(not (sc-is x
,complex-constant-sc
)))
1076 (y :scs
(,real-sc
,real-constant-sc
)
1078 :load-if
(not (sc-is y
,real-constant-sc
))))
1079 (:arg-types
,complex-type
,real-type
))
1080 (define-vop (,real-complex-name
,complex-complex-name
)
1081 (:args
(x :scs
(,real-sc
,real-constant-sc
)
1083 :load-if
(not (sc-is x
,real-constant-sc
)))
1084 (y :scs
(,complex-sc
,complex-constant-sc
)
1086 :load-if
(not (sc-is y
,complex-constant-sc
))))
1087 (:arg-types
,real-type
,complex-type
)))))
1088 (define-complex-float-= =/complex-single-float
=/complex-real-single-float
=/real-complex-single-float
1089 single-reg fp-single-immediate single-float
1090 complex-single-reg fp-complex-single-immediate complex-single-float
1091 movss movq cmpps movmskps
#b1111
)
1092 (define-complex-float-= =/complex-double-float
=/complex-real-double-float
=/real-complex-double-float
1093 double-reg fp-double-immediate double-float
1094 complex-double-reg fp-complex-double-immediate complex-double-float
1095 movsd movapd cmppd movmskpd
#b11
))
1097 (macrolet ((define-</> (op single-name double-name
&rest flags
)
1099 (define-vop (,double-name double-float-compare
)
1103 (:conditional
,@flags
)
1105 (note-float-location ',op vop x y
)
1108 (setf y
(ea-for-df-stack y
)))
1110 (setf y
(ea-for-df-desc y
)))
1111 (fp-double-immediate
1112 (setf y
(register-inline-constant (tn-value y
))))
1115 (define-vop (,single-name single-float-compare
)
1118 (:conditional
,@flags
)
1120 (note-float-location ',op vop x y
)
1123 (setf y
(ea-for-sf-stack y
)))
1124 (fp-single-immediate
1125 (setf y
(register-inline-constant (tn-value y
))))
1127 (inst comiss x y
))))))
1128 (define-</> < <single-float
<double-float not
:p
:nc
)
1129 (define-</> > >single-float
>double-float not
:p
:na
))
1134 (macrolet ((frob (name translate inst to-sc to-type
)
1135 `(define-vop (,name
)
1136 (:args
(x :scs
(signed-stack signed-reg
)))
1137 (:results
(y :scs
(,to-sc
)))
1138 (:arg-types signed-num
)
1139 (:result-types
,to-type
)
1140 (:policy
:fast-safe
)
1141 (:note
"inline float coercion")
1142 (:translate
,translate
)
1144 (:save-p
:compute-only
)
1147 (single-reg (inst xorps y y
))
1148 (double-reg (inst xorpd y y
)))
1149 (note-float-location 'coerce vop x
',to-type
)
1150 (inst ,inst y x
)))))
1151 (frob %single-float
/signed %single-float cvtsi2ss single-reg single-float
)
1152 (frob %double-float
/signed %double-float cvtsi2sd double-reg double-float
))
1154 (macrolet ((frob (name translate inst from-scs from-type ea-func to-sc to-type
)
1155 `(define-vop (,name
)
1156 (:args
(x :scs
,from-scs
:target y
))
1157 (:results
(y :scs
(,to-sc
)))
1158 (:arg-types
,from-type
)
1159 (:result-types
,to-type
)
1160 (:policy
:fast-safe
)
1161 (:note
"inline float coercion")
1162 (:translate
,translate
)
1164 (:save-p
:compute-only
)
1166 (unless (location= x y
)
1168 (single-reg (inst xorps y y
))
1169 (double-reg (inst xorpd y y
))))
1170 (note-float-location 'coerce vop x
',to-type
)
1171 (inst ,inst y
(sc-case x
1172 (,(first from-scs
) x
)
1173 (,(second from-scs
) (,ea-func x
))))
1174 ,(when (and (eq from-type
'double-float
) ; if the input is wider
1175 (eq to-type
'single-float
)) ; than the output, clear
1176 `(when (location= x y
) ; noise in the high part
1177 (inst shufps y y
#4r3330
)))))))
1178 (frob %single-float
/double-float %single-float cvtsd2ss
1179 (double-reg double-stack
) double-float ea-for-df-stack
1180 single-reg single-float
)
1182 (frob %double-float
/single-float %double-float cvtss2sd
1183 (single-reg single-stack
) single-float ea-for-sf-stack
1184 double-reg double-float
))
1186 (macrolet ((frob (trans op inst from-scs from-type ea-func
)
1187 `(define-vop (,(symbolicate trans
"/" from-type
))
1188 (:args
(x :scs
,from-scs
))
1189 (:results
(y :scs
(signed-reg)))
1190 (:arg-types
,from-type
)
1191 (:result-types signed-num
)
1193 (:policy
:fast-safe
)
1194 (:note
"inline float truncate")
1196 (:save-p
:compute-only
)
1198 (note-float-location ',op vop x
)
1199 (inst ,inst y
(sc-case x
1200 (,(first from-scs
) x
)
1201 (,(second from-scs
) (,ea-func x
))))))))
1202 (frob %unary-truncate
/single-float truncate cvttss2si
1203 (single-reg single-stack
) single-float ea-for-sf-stack
)
1204 (frob %unary-truncate
/double-float truncate cvttsd2si
1205 (double-reg double-stack
) double-float ea-for-df-stack
)
1207 (frob %unary-round round cvtss2si
1208 (single-reg single-stack
) single-float ea-for-sf-stack
)
1209 (frob %unary-round round cvtsd2si
1210 (double-reg double-stack
) double-float ea-for-df-stack
))
1212 (define-vop (make-single-float)
1213 (:args
(bits :scs
(signed-reg) :target res
1214 :load-if
(not (or (and (sc-is bits signed-stack
)
1215 (sc-is res single-reg
))
1216 (and (sc-is bits signed-stack
)
1217 (sc-is res single-stack
)
1218 (location= bits res
))))))
1219 (:results
(res :scs
(single-reg single-stack
)))
1220 (:arg-types signed-num
)
1221 (:result-types single-float
)
1222 (:translate make-single-float
)
1223 (:policy
:fast-safe
)
1230 (inst mov res bits
))
1232 (aver (location= bits res
)))))
1236 (inst movd res
(reg-in-size bits
:dword
)))
1239 (make-ea :dword
:base rbp-tn
1240 :disp
(frame-byte-offset (tn-offset bits
))))))))))
1242 (define-vop (make-single-float-c)
1243 (:results
(res :scs
(single-reg single-stack descriptor-reg
)))
1244 (:arg-types
(:constant
(signed-byte 32)))
1245 (:result-types single-float
)
1247 (:translate make-single-float
)
1248 (:policy
:fast-safe
)
1253 (inst mov res bits
))
1255 (inst movss res
(register-inline-constant :dword bits
)))
1257 (inst mov res
(logior (ash bits
32)
1258 single-float-widetag
))))))
1260 (define-vop (make-double-float)
1261 (:args
(hi-bits :scs
(signed-reg))
1262 (lo-bits :scs
(unsigned-reg)))
1263 (:results
(res :scs
(double-reg)))
1264 (:temporary
(:sc unsigned-reg
) temp
)
1265 (:arg-types signed-num unsigned-num
)
1266 (:result-types double-float
)
1267 (:translate make-double-float
)
1268 (:policy
:fast-safe
)
1273 (inst or temp lo-bits
)
1274 (inst movd res temp
)))
1276 (define-vop (make-double-float-c)
1277 (:results
(res :scs
(double-reg)))
1278 (:arg-types
(:constant
(signed-byte 32)) (:constant
(unsigned-byte 32)))
1279 (:result-types double-float
)
1281 (:translate make-double-float
)
1282 (:policy
:fast-safe
)
1285 (inst movsd res
(register-inline-constant :qword
(logior (ash hi
32) lo
)))))
1287 (define-vop (single-float-bits)
1288 (:args
(float :scs
(single-reg descriptor-reg
)
1289 :load-if
(not (sc-is float single-stack
))))
1290 (:results
(bits :scs
(signed-reg)))
1291 (:arg-types single-float
)
1292 (:result-types signed-num
)
1293 (:translate single-float-bits
)
1294 (:policy
:fast-safe
)
1298 (let ((dword-bits (reg-in-size bits
:dword
)))
1299 (inst movd dword-bits float
)
1300 (inst movsxd bits dword-bits
)))
1302 (inst movsxd bits
(make-ea :dword
; c.f. ea-for-sf-stack
1304 :disp
(frame-byte-offset (tn-offset float
)))))
1307 (inst sar bits
32)))))
1309 (define-vop (double-float-high-bits)
1310 (:args
(float :scs
(double-reg descriptor-reg
)
1311 :load-if
(not (sc-is float double-stack
))))
1312 (:results
(hi-bits :scs
(signed-reg)))
1313 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) temp
)
1314 (:arg-types double-float
)
1315 (:result-types signed-num
)
1316 (:translate double-float-high-bits
)
1317 (:policy
:fast-safe
)
1322 (inst movsd temp float
)
1323 (move hi-bits temp
))
1325 (loadw hi-bits ebp-tn
(frame-word-offset (tn-offset float
))))
1327 (loadw hi-bits float double-float-value-slot
1328 other-pointer-lowtag
)))
1329 (inst sar hi-bits
32)))
1331 (define-vop (double-float-low-bits)
1332 (:args
(float :scs
(double-reg descriptor-reg
)
1333 :load-if
(not (sc-is float double-stack
))))
1334 (:results
(lo-bits :scs
(unsigned-reg)))
1335 (:temporary
(:sc signed-stack
:from
:argument
:to
:result
) temp
)
1336 (:arg-types double-float
)
1337 (:result-types unsigned-num
)
1338 (:translate double-float-low-bits
)
1339 (:policy
:fast-safe
)
1342 (let ((dword-lo-bits (reg-in-size lo-bits
:dword
)))
1345 (inst movsd temp float
)
1346 (inst mov dword-lo-bits
1347 (make-ea :dword
:base rbp-tn
1348 :disp
(frame-byte-offset (tn-offset temp
)))))
1350 (inst mov dword-lo-bits
1351 (make-ea :dword
:base rbp-tn
1352 :disp
(frame-byte-offset (tn-offset float
)))))
1354 (inst mov dword-lo-bits
1355 (make-ea-for-object-slot-half float double-float-value-slot
1356 other-pointer-lowtag
)))))))
1360 ;;;; complex float VOPs
1362 (define-vop (make-complex-single-float)
1363 (:translate complex
)
1364 (:args
(real :scs
(single-reg fp-single-zero
)
1366 :load-if
(not (sc-is real fp-single-zero
)))
1367 (imag :scs
(single-reg fp-single-zero
)
1368 :load-if
(not (sc-is imag fp-single-zero
))))
1369 (:arg-types single-float single-float
)
1370 (:results
(r :scs
(complex-single-reg) :from
(:argument
0)))
1371 (:result-types complex-single-float
)
1372 (:note
"inline complex single-float creation")
1373 (:policy
:fast-safe
)
1375 (cond ((sc-is real fp-single-zero
)
1377 (unless (sc-is imag fp-single-zero
)
1378 (inst unpcklps r imag
)))
1379 ((location= real imag
)
1381 (inst unpcklps r r
))
1384 (unless (sc-is imag fp-single-zero
)
1385 (inst unpcklps r imag
))))))
1387 (define-vop (make-complex-double-float)
1388 (:translate complex
)
1389 (:args
(real :scs
(double-reg fp-double-zero
)
1391 :load-if
(not (sc-is real fp-double-zero
)))
1392 (imag :scs
(double-reg fp-double-zero
)
1393 :load-if
(not (sc-is imag fp-double-zero
))))
1394 (:arg-types double-float double-float
)
1395 (:results
(r :scs
(complex-double-reg) :from
(:argument
0)))
1396 (:result-types complex-double-float
)
1397 (:note
"inline complex double-float creation")
1398 (:policy
:fast-safe
)
1400 (cond ((sc-is real fp-double-zero
)
1402 (unless (sc-is imag fp-double-zero
)
1403 (inst unpcklpd r imag
)))
1404 ((location= real imag
)
1406 (inst unpcklpd r r
))
1409 (unless (sc-is imag fp-double-zero
)
1410 (inst unpcklpd r imag
))))))
1412 (define-vop (complex-float-value)
1413 (:args
(x :target r
))
1414 (:temporary
(:sc complex-double-reg
) zero
)
1416 (:variant-vars offset
)
1417 (:policy
:fast-safe
)
1419 (cond ((sc-is x complex-double-reg
)
1421 (inst xorpd zero zero
)
1423 (0 (inst unpcklpd r zero
))
1424 (1 (inst unpckhpd r zero
))))
1425 ((sc-is x complex-single-reg
)
1428 (0 (inst shufps r r
#b11111100
))
1429 (1 (inst shufps r r
#b11111101
))))
1430 ((sc-is r single-reg
)
1431 (let ((ea (sc-case x
1432 (complex-single-stack
1434 (0 (ea-for-csf-real-stack x
))
1435 (1 (ea-for-csf-imag-stack x
))))
1438 (0 (ea-for-csf-real-desc x
))
1439 (1 (ea-for-csf-imag-desc x
)))))))
1441 ((sc-is r double-reg
)
1442 (let ((ea (sc-case x
1443 (complex-double-stack
1445 (0 (ea-for-cdf-real-stack x
))
1446 (1 (ea-for-cdf-imag-stack x
))))
1449 (0 (ea-for-cdf-real-desc x
))
1450 (1 (ea-for-cdf-imag-desc x
)))))))
1452 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
1454 (define-vop (realpart/complex-single-float complex-float-value
)
1455 (:translate realpart
)
1456 (:args
(x :scs
(complex-single-reg complex-single-stack descriptor-reg
)
1458 (:arg-types complex-single-float
)
1459 (:results
(r :scs
(single-reg)))
1460 (:result-types single-float
)
1461 (:note
"complex float realpart")
1464 (define-vop (realpart/complex-double-float complex-float-value
)
1465 (:translate realpart
)
1466 (:args
(x :scs
(complex-double-reg complex-double-stack descriptor-reg
)
1468 (:arg-types complex-double-float
)
1469 (:results
(r :scs
(double-reg)))
1470 (:result-types double-float
)
1471 (:note
"complex float realpart")
1474 (define-vop (imagpart/complex-single-float complex-float-value
)
1475 (:translate imagpart
)
1476 (:args
(x :scs
(complex-single-reg complex-single-stack descriptor-reg
)
1478 (:arg-types complex-single-float
)
1479 (:results
(r :scs
(single-reg)))
1480 (:result-types single-float
)
1481 (:note
"complex float imagpart")
1484 (define-vop (imagpart/complex-double-float complex-float-value
)
1485 (:translate imagpart
)
1486 (:args
(x :scs
(complex-double-reg complex-double-stack descriptor-reg
)
1488 (:arg-types complex-double-float
)
1489 (:results
(r :scs
(double-reg)))
1490 (:result-types double-float
)
1491 (:note
"complex float imagpart")
1495 ;;; hack dummy VOPs to bias the representation selection of their
1496 ;;; arguments towards a FP register, which can help avoid consing at
1497 ;;; inappropriate locations
1498 (defknown double-float-reg-bias
(double-float) (values))
1499 (define-vop (double-float-reg-bias)
1500 (:translate double-float-reg-bias
)
1501 (:args
(x :scs
(double-reg double-stack
) :load-if nil
))
1502 (:arg-types double-float
)
1503 (:policy
:fast-safe
)
1504 (:note
"inline dummy FP register bias")
1507 (defknown single-float-reg-bias
(single-float) (values))
1508 (define-vop (single-float-reg-bias)
1509 (:translate single-float-reg-bias
)
1510 (:args
(x :scs
(single-reg single-stack
) :load-if nil
))
1511 (:arg-types single-float
)
1512 (:policy
:fast-safe
)
1513 (:note
"inline dummy FP register bias")
1517 (defknown swap-complex
((complex float
)) (complex float
)
1518 (foldable flushable movable always-translatable
))
1519 (defoptimizer (swap-complex derive-type
) ((x))
1520 (sb!c
::lvar-type x
))
1521 (defun swap-complex (x)
1522 (complex (imagpart x
) (realpart x
)))
1523 (define-vop (swap-complex-single-float)
1524 (:translate swap-complex
)
1525 (:policy
:fast-safe
)
1526 (:args
(x :scs
(complex-single-reg) :target r
))
1527 (:arg-types complex-single-float
)
1528 (:results
(r :scs
(complex-single-reg)))
1529 (:result-types complex-single-float
)
1532 (inst shufps r r
#b11110001
)))
1533 (define-vop (swap-complex-double-float)
1534 (:translate swap-complex
)
1535 (:policy
:fast-safe
)
1536 (:args
(x :scs
(complex-double-reg) :target r
))
1537 (:arg-types complex-double-float
)
1538 (:results
(r :scs
(complex-double-reg)))
1539 (:result-types complex-double-float
)
1542 (inst shufpd r r
#b01
)))