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-real-desc (tn)
23 (ea-for-xf-desc tn complex-single-float-real-slot))
24 (defun ea-for-csf-imag-desc (tn)
25 (ea-for-xf-desc tn complex-single-float-imag-slot))
26 (defun ea-for-cdf-real-desc (tn)
27 (ea-for-xf-desc tn complex-double-float-real-slot))
28 (defun ea-for-cdf-imag-desc (tn)
29 (ea-for-xf-desc tn complex-double-float-imag-slot)))
31 (macrolet ((ea-for-xf-stack (tn kind)
32 (declare (ignore kind))
35 :disp (- (* (+ (tn-offset ,tn) 1)
37 (defun ea-for-sf-stack (tn)
38 (ea-for-xf-stack tn :single))
39 (defun ea-for-df-stack (tn)
40 (ea-for-xf-stack tn :double)))
42 ;;; complex float stack EAs
43 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
44 (declare (ignore kind))
47 :disp (- (* (+ (tn-offset ,tn)
48 (* 1 (ecase ,slot (:real 1) (:imag 2))))
50 (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
51 (ea-for-cxf-stack tn :single :real base))
52 (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
53 (ea-for-cxf-stack tn :single :imag base))
54 (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
55 (ea-for-cxf-stack tn :double :real base))
56 (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
57 (ea-for-cxf-stack tn :double :imag base)))
62 ;;; X is source, Y is destination.
64 (define-move-fun (load-fp-zero 1) (vop x y)
65 ((fp-single-zero) (single-reg)
66 (fp-double-zero) (double-reg))
69 (single-reg (inst xorps y y))
70 (double-reg (inst xorpd y y))))
72 (define-move-fun (load-single 2) (vop x y)
73 ((single-stack) (single-reg))
74 (inst movss y (ea-for-sf-stack x)))
76 (define-move-fun (store-single 2) (vop x y)
77 ((single-reg) (single-stack))
78 (inst movss (ea-for-sf-stack y) x))
80 (define-move-fun (load-double 2) (vop x y)
81 ((double-stack) (double-reg))
82 (inst movsd y (ea-for-df-stack x)))
84 (define-move-fun (store-double 2) (vop x y)
85 ((double-reg) (double-stack))
86 (inst movsd (ea-for-df-stack y) x))
88 (eval-when (:compile-toplevel :execute)
89 (setf *read-default-float-format* 'single-float))
91 ;;;; complex float move functions
93 (defun complex-single-reg-real-tn (x)
94 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
95 :offset (tn-offset x)))
96 (defun complex-single-reg-imag-tn (x)
97 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
98 :offset (1+ (tn-offset x))))
100 (defun complex-double-reg-real-tn (x)
101 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
102 :offset (tn-offset x)))
103 (defun complex-double-reg-imag-tn (x)
104 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
105 :offset (1+ (tn-offset x))))
107 ;;; X is source, Y is destination.
108 (define-move-fun (load-complex-single 2) (vop x y)
109 ((complex-single-stack) (complex-single-reg))
110 (let ((real-tn (complex-single-reg-real-tn y)))
111 (inst movss real-tn (ea-for-csf-real-stack x)))
112 (let ((imag-tn (complex-single-reg-imag-tn y)))
113 (inst movss imag-tn (ea-for-csf-imag-stack x))))
115 (define-move-fun (store-complex-single 2) (vop x y)
116 ((complex-single-reg) (complex-single-stack))
117 (let ((real-tn (complex-single-reg-real-tn x))
118 (imag-tn (complex-single-reg-imag-tn x)))
119 (inst movss (ea-for-csf-real-stack y) real-tn)
120 (inst movss (ea-for-csf-imag-stack y) imag-tn)))
122 (define-move-fun (load-complex-double 2) (vop x y)
123 ((complex-double-stack) (complex-double-reg))
124 (let ((real-tn (complex-double-reg-real-tn y)))
125 (inst movsd real-tn (ea-for-cdf-real-stack x)))
126 (let ((imag-tn (complex-double-reg-imag-tn y)))
127 (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
129 (define-move-fun (store-complex-double 2) (vop x y)
130 ((complex-double-reg) (complex-double-stack))
131 (let ((real-tn (complex-double-reg-real-tn x))
132 (imag-tn (complex-double-reg-imag-tn x)))
133 (inst movsd (ea-for-cdf-real-stack y) real-tn)
134 (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
139 ;;; float register to register moves
140 (macrolet ((frob (vop sc)
145 :load-if (not (location= x y))))
146 (:results (y :scs (,sc)
147 :load-if (not (location= x y))))
150 (unless (location= y x)
152 (define-move-vop ,vop :move (,sc) (,sc)))))
153 (frob single-move single-reg)
154 (frob double-move double-reg))
156 ;;; complex float register to register moves
157 (define-vop (complex-float-move)
158 (:args (x :target y :load-if (not (location= x y))))
159 (:results (y :load-if (not (location= x y))))
160 (:note "complex float move")
162 (unless (location= x y)
163 ;; Note the complex-float-regs are aligned to every second
164 ;; float register so there is not need to worry about overlap.
165 ;; (It would be better to put the imagpart in the top half of the
166 ;; register, or something, but let's worry about that later)
167 (let ((x-real (complex-single-reg-real-tn x))
168 (y-real (complex-single-reg-real-tn y)))
169 (inst movq y-real x-real))
170 (let ((x-imag (complex-single-reg-imag-tn x))
171 (y-imag (complex-single-reg-imag-tn y)))
172 (inst movq y-imag x-imag)))))
174 (define-vop (complex-single-move complex-float-move)
175 (:args (x :scs (complex-single-reg) :target y
176 :load-if (not (location= x y))))
177 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
178 (define-move-vop complex-single-move :move
179 (complex-single-reg) (complex-single-reg))
181 (define-vop (complex-double-move complex-float-move)
182 (:args (x :scs (complex-double-reg)
183 :target y :load-if (not (location= x y))))
184 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
185 (define-move-vop complex-double-move :move
186 (complex-double-reg) (complex-double-reg))
189 ;;; Move from float to a descriptor reg. allocating a new float
190 ;;; object in the process.
191 (define-vop (move-from-single)
192 (:args (x :scs (single-reg) :to :save))
193 (:results (y :scs (descriptor-reg)))
194 (:note "float to pointer coercion")
198 (inst or y single-float-widetag)))
200 (define-move-vop move-from-single :move
201 (single-reg) (descriptor-reg))
203 (define-vop (move-from-double)
204 (:args (x :scs (double-reg) :to :save))
205 (:results (y :scs (descriptor-reg)))
207 (:note "float to pointer coercion")
209 (with-fixed-allocation (y
213 (inst movsd (ea-for-df-desc y) x))))
214 (define-move-vop move-from-double :move
215 (double-reg) (descriptor-reg))
217 ;;; Move from a descriptor to a float register.
218 (define-vop (move-to-single)
219 (:args (x :scs (descriptor-reg) :target tmp))
220 (:temporary (:sc unsigned-reg) tmp)
221 (:results (y :scs (single-reg)))
222 (:note "pointer to float coercion")
228 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
230 (define-vop (move-to-double)
231 (:args (x :scs (descriptor-reg)))
232 (:results (y :scs (double-reg)))
233 (:note "pointer to float coercion")
235 (inst movsd y (ea-for-df-desc x))))
236 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
239 ;;; Move from complex float to a descriptor reg. allocating a new
240 ;;; complex float object in the process.
241 (define-vop (move-from-complex-single)
242 (:args (x :scs (complex-single-reg) :to :save))
243 (:results (y :scs (descriptor-reg)))
245 (:note "complex float to pointer coercion")
247 (with-fixed-allocation (y
248 complex-single-float-widetag
249 complex-single-float-size
251 (let ((real-tn (complex-single-reg-real-tn x)))
252 (inst movss (ea-for-csf-real-desc y) real-tn))
253 (let ((imag-tn (complex-single-reg-imag-tn x)))
254 (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
255 (define-move-vop move-from-complex-single :move
256 (complex-single-reg) (descriptor-reg))
258 (define-vop (move-from-complex-double)
259 (:args (x :scs (complex-double-reg) :to :save))
260 (:results (y :scs (descriptor-reg)))
262 (:note "complex float to pointer coercion")
264 (with-fixed-allocation (y
265 complex-double-float-widetag
266 complex-double-float-size
268 (let ((real-tn (complex-double-reg-real-tn x)))
269 (inst movsd (ea-for-cdf-real-desc y) real-tn))
270 (let ((imag-tn (complex-double-reg-imag-tn x)))
271 (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
272 (define-move-vop move-from-complex-double :move
273 (complex-double-reg) (descriptor-reg))
275 ;;; Move from a descriptor to a complex float register.
276 (macrolet ((frob (name sc format)
279 (:args (x :scs (descriptor-reg)))
280 (:results (y :scs (,sc)))
281 (:note "pointer to complex float coercion")
283 (let ((real-tn (complex-double-reg-real-tn y)))
287 '((inst movss real-tn (ea-for-csf-real-desc x))))
289 '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
290 (let ((imag-tn (complex-double-reg-imag-tn y)))
294 '((inst movss imag-tn (ea-for-csf-imag-desc x))))
296 '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
297 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
298 (frob move-to-complex-single complex-single-reg :single)
299 (frob move-to-complex-double complex-double-reg :double))
301 ;;;; the move argument vops
303 ;;;; Note these are also used to stuff fp numbers onto the c-call
304 ;;;; stack so the order is different than the lisp-stack.
306 ;;; the general MOVE-ARG VOP
307 (macrolet ((frob (name sc stack-sc format)
310 (:args (x :scs (,sc) :target y)
312 :load-if (not (sc-is y ,sc))))
314 (:note "float argument move")
315 (:generator ,(case format (:single 2) (:double 3) )
318 (unless (location= x y)
321 (if (= (tn-offset fp) esp-offset)
322 (let* ((offset (* (tn-offset y) n-word-bytes))
323 (ea (make-ea :dword :base fp :disp offset)))
325 (:single '((inst movss ea x)))
326 (:double '((inst movsd ea x)))))
329 :disp (- (* (1+ (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 ;;;; complex float MOVE-ARG VOP
340 (macrolet ((frob (name sc stack-sc format)
343 (:args (x :scs (,sc) :target y)
345 :load-if (not (sc-is y ,sc))))
347 (:note "complex float argument move")
348 (:generator ,(ecase format (:single 2) (:double 3))
351 (unless (location= x y)
352 (let ((x-real (complex-double-reg-real-tn x))
353 (y-real (complex-double-reg-real-tn y)))
354 (inst movsd y-real x-real))
355 (let ((x-imag (complex-double-reg-imag-tn x))
356 (y-imag (complex-double-reg-imag-tn y)))
357 (inst movsd y-imag x-imag))))
359 (let ((real-tn (complex-double-reg-real-tn x)))
363 (ea-for-csf-real-stack y fp)
367 (ea-for-cdf-real-stack y fp)
369 (let ((imag-tn (complex-double-reg-imag-tn x)))
373 (ea-for-csf-imag-stack y fp) imag-tn)))
376 (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
377 (define-move-vop ,name :move-arg
378 (,sc descriptor-reg) (,sc)))))
379 (frob move-complex-single-float-arg
380 complex-single-reg complex-single-stack :single)
381 (frob move-complex-double-float-arg
382 complex-double-reg complex-double-stack :double))
384 (define-move-vop move-arg :move-arg
385 (single-reg double-reg
386 complex-single-reg complex-double-reg)
392 (define-vop (float-op)
396 (:note "inline float arithmetic")
398 (:save-p :compute-only))
400 (macrolet ((frob (name sc ptype)
401 `(define-vop (,name float-op)
402 (:args (x :scs (,sc) :target r)
404 (:results (r :scs (,sc)))
405 (:arg-types ,ptype ,ptype)
406 (:result-types ,ptype))))
407 (frob single-float-op single-reg single-float)
408 (frob double-float-op double-reg double-float))
410 (macrolet ((generate (movinst opinst commutative)
415 ((and ,commutative (location= y r))
417 ((not (location= r y))
421 (inst ,movinst tmp x)
423 (inst ,movinst r tmp)))))
424 (frob (op sinst sname scost dinst dname dcost commutative)
426 (define-vop (,sname single-float-op)
428 (:temporary (:sc single-reg) tmp)
430 (generate movss ,sinst ,commutative)))
431 (define-vop (,dname double-float-op)
433 (:temporary (:sc single-reg) tmp)
435 (generate movsd ,dinst ,commutative))))))
436 (frob + addss +/single-float 2 addsd +/double-float 2 t)
437 (frob - subss -/single-float 2 subsd -/double-float 2 nil)
438 (frob * mulss */single-float 4 mulsd */double-float 5 t)
439 (frob / divss //single-float 12 divsd //double-float 19 nil))
442 (:args (x :scs (double-reg)))
443 (:results (y :scs (double-reg)))
446 (:arg-types double-float)
447 (:result-types double-float)
448 (:note "inline float arithmetic")
450 (:save-p :compute-only)
452 (note-this-location vop :internal-error)
455 (macrolet ((frob ((name translate sc type) &body body)
457 (:args (x :scs (,sc)))
458 (:results (y :scs (,sc)))
459 (:translate ,translate)
462 (:result-types ,type)
463 (:temporary (:sc any-reg) hex8)
466 (:note "inline float arithmetic")
468 (:save-p :compute-only)
470 (note-this-location vop :internal-error)
471 ;; we should be able to do this better. what we
472 ;; really would like to do is use the target as the
473 ;; temp whenever it's not also the source
474 (unless (location= x y)
477 (frob (%negate/double-float %negate double-reg double-float)
478 (inst lea hex8 (make-ea :qword :disp 1))
479 (inst ror hex8 1) ; #x8000000000000000
482 (frob (%negate/single-float %negate single-reg single-float)
483 (inst lea hex8 (make-ea :qword :disp 1))
487 (frob (abs/double-float abs double-reg double-float)
492 (frob (abs/single-float abs single-reg single-float)
500 (define-vop (float-compare)
505 (:save-p :compute-only)
506 (:note "inline float comparison"))
508 ;;; comiss and comisd can cope with one or other arg in memory: we
509 ;;; could (should, indeed) extend these to cope with descriptor args
512 (define-vop (single-float-compare float-compare)
513 (:args (x :scs (single-reg)) (y :scs (single-reg)))
515 (:arg-types single-float single-float))
516 (define-vop (double-float-compare float-compare)
517 (:args (x :scs (double-reg)) (y :scs (double-reg)))
519 (:arg-types double-float double-float))
521 (define-vop (=/single-float single-float-compare)
526 (note-this-location vop :internal-error)
528 ;; if PF&CF, there was a NaN involved => not equal
529 ;; otherwise, ZF => equal
532 (inst jmp :ne target))
534 (let ((not-lab (gen-label)))
535 (inst jmp :p not-lab)
537 (emit-label not-lab))))))
539 (define-vop (=/double-float double-float-compare)
544 (note-this-location vop :internal-error)
548 (inst jmp :ne target))
550 (let ((not-lab (gen-label)))
551 (inst jmp :p not-lab)
553 (emit-label not-lab))))))
555 ;; XXX all of these probably have bad NaN behaviour
556 (define-vop (<double-float double-float-compare)
561 (inst jmp (if not-p :nc :c) target)))
563 (define-vop (<single-float single-float-compare)
568 (inst jmp (if not-p :nc :c) target)))
570 (define-vop (>double-float double-float-compare)
575 (inst jmp (if not-p :na :a) target)))
577 (define-vop (>single-float single-float-compare)
582 (inst jmp (if not-p :na :a) target)))
588 (macrolet ((frob (name translate inst to-sc to-type)
590 (:args (x :scs (signed-stack signed-reg) :target temp))
591 (:temporary (:sc signed-stack) temp)
592 (:results (y :scs (,to-sc)))
593 (:arg-types signed-num)
594 (:result-types ,to-type)
596 (:note "inline float coercion")
597 (:translate ,translate)
599 (:save-p :compute-only)
604 (note-this-location vop :internal-error)
607 (note-this-location vop :internal-error)
608 (inst ,inst y x)))))))
609 (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
610 (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
612 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
614 (:args (x :scs (,from-sc) :target y))
615 (:results (y :scs (,to-sc)))
616 (:arg-types ,from-type)
617 (:result-types ,to-type)
619 (:note "inline float coercion")
620 (:translate ,translate)
622 (:save-p :compute-only)
624 (note-this-location vop :internal-error)
626 (frob %single-float/double-float %single-float cvtsd2ss double-reg
627 double-float single-reg single-float)
629 (frob %double-float/single-float %double-float cvtss2sd
630 single-reg single-float double-reg double-float))
632 (macrolet ((frob (trans inst from-sc from-type round-p)
633 (declare (ignore round-p))
634 `(define-vop (,(symbolicate trans "/" from-type))
635 (:args (x :scs (,from-sc)))
636 (:temporary (:sc any-reg) temp-reg)
637 (:results (y :scs (signed-reg)))
638 (:arg-types ,from-type)
639 (:result-types signed-num)
642 (:note "inline float truncate")
644 (:save-p :compute-only)
648 (inst ,inst temp-reg x)
653 (frob %unary-truncate cvttss2si single-reg single-float nil)
654 (frob %unary-truncate cvttsd2si double-reg double-float nil)
656 (frob %unary-round cvtss2si single-reg single-float t)
657 (frob %unary-round cvtsd2si double-reg double-float t))
659 (define-vop (make-single-float)
660 (:args (bits :scs (signed-reg) :target res
661 :load-if (not (or (and (sc-is bits signed-stack)
662 (sc-is res single-reg))
663 (and (sc-is bits signed-stack)
664 (sc-is res single-stack)
665 (location= bits res))))))
666 (:results (res :scs (single-reg single-stack)))
667 (:arg-types signed-num)
668 (:result-types single-float)
669 (:translate make-single-float)
679 (aver (location= bits res)))))
683 (inst movd res bits))
685 (inst movd res bits)))))))
687 (define-vop (make-double-float)
688 (:args (hi-bits :scs (signed-reg))
689 (lo-bits :scs (unsigned-reg)))
690 (:results (res :scs (double-reg)))
691 (:temporary (:sc unsigned-reg) temp)
692 (:arg-types signed-num unsigned-num)
693 (:result-types double-float)
694 (:translate make-double-float)
700 (inst or temp lo-bits)
701 (inst movd res temp)))
703 (define-vop (single-float-bits)
704 (:args (float :scs (single-reg descriptor-reg)
705 :load-if (not (sc-is float single-stack))))
706 (:results (bits :scs (signed-reg)))
707 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
708 (:arg-types single-float)
709 (:result-types signed-num)
710 (:translate single-float-bits)
718 (inst movss stack-temp float)
719 (move bits stack-temp))
724 (inst shr bits 32))))
728 (inst movss bits float)))))
733 (define-vop (double-float-high-bits)
734 (:args (float :scs (double-reg descriptor-reg)
735 :load-if (not (sc-is float double-stack))))
736 (:results (hi-bits :scs (signed-reg)))
737 (:temporary (:sc signed-stack :from :argument :to :result) temp)
738 (:arg-types double-float)
739 (:result-types signed-num)
740 (:translate double-float-high-bits)
746 (inst movsd temp float)
749 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
751 (loadw hi-bits float double-float-value-slot
752 other-pointer-lowtag)))
753 (inst sar hi-bits 32)))
755 (define-vop (double-float-low-bits)
756 (:args (float :scs (double-reg descriptor-reg)
757 :load-if (not (sc-is float double-stack))))
758 (:results (lo-bits :scs (unsigned-reg)))
759 (:temporary (:sc signed-stack :from :argument :to :result) temp)
760 (:arg-types double-float)
761 (:result-types unsigned-num)
762 (:translate double-float-low-bits)
768 (inst movsd temp float)
771 (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
773 (loadw lo-bits float double-float-value-slot
774 other-pointer-lowtag)))
775 (inst shl lo-bits 32)
776 (inst shr lo-bits 32)))
780 ;;;; complex float VOPs
782 (define-vop (make-complex-single-float)
784 (:args (real :scs (single-reg) :to :result :target r
785 :load-if (not (location= real r)))
786 (imag :scs (single-reg) :to :save))
787 (:arg-types single-float single-float)
788 (:results (r :scs (complex-single-reg) :from (:argument 0)
789 :load-if (not (sc-is r complex-single-stack))))
790 (:result-types complex-single-float)
791 (:note "inline complex single-float creation")
796 (let ((r-real (complex-single-reg-real-tn r)))
797 (unless (location= real r-real)
798 (inst movss r-real real)))
799 (let ((r-imag (complex-single-reg-imag-tn r)))
800 (unless (location= imag r-imag)
801 (inst movss r-imag imag))))
802 (complex-single-stack
803 (unless (location= real r)
804 (inst movss (ea-for-csf-real-stack r) real))
805 (inst movss (ea-for-csf-imag-stack r) imag)))))
807 (define-vop (make-complex-double-float)
809 (:args (real :scs (double-reg) :target r
810 :load-if (not (location= real r)))
811 (imag :scs (double-reg) :to :save))
812 (:arg-types double-float double-float)
813 (:results (r :scs (complex-double-reg) :from (:argument 0)
814 :load-if (not (sc-is r complex-double-stack))))
815 (:result-types complex-double-float)
816 (:note "inline complex double-float creation")
821 (let ((r-real (complex-double-reg-real-tn r)))
822 (unless (location= real r-real)
823 (inst movsd r-real real)))
824 (let ((r-imag (complex-double-reg-imag-tn r)))
825 (unless (location= imag r-imag)
826 (inst movsd r-imag imag))))
827 (complex-double-stack
828 (unless (location= real r)
829 (inst movsd (ea-for-cdf-real-stack r) real))
830 (inst movsd (ea-for-cdf-imag-stack r) imag)))))
832 (define-vop (complex-float-value)
833 (:args (x :target r))
835 (:variant-vars offset)
838 (cond ((sc-is x complex-single-reg complex-double-reg)
840 (make-random-tn :kind :normal
841 :sc (sc-or-lose 'double-reg)
842 :offset (+ offset (tn-offset x)))))
843 (unless (location= value-tn r)
844 (if (sc-is x complex-single-reg)
845 (inst movss r value-tn)
846 (inst movsd r value-tn)))))
847 ((sc-is r single-reg)
849 (complex-single-stack
851 (0 (ea-for-csf-real-stack x))
852 (1 (ea-for-csf-imag-stack x))))
855 (0 (ea-for-csf-real-desc x))
856 (1 (ea-for-csf-imag-desc x)))))))
858 ((sc-is r double-reg)
860 (complex-double-stack
862 (0 (ea-for-cdf-real-stack x))
863 (1 (ea-for-cdf-imag-stack x))))
866 (0 (ea-for-cdf-real-desc x))
867 (1 (ea-for-cdf-imag-desc x)))))))
869 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
871 (define-vop (realpart/complex-single-float complex-float-value)
872 (:translate realpart)
873 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
875 (:arg-types complex-single-float)
876 (:results (r :scs (single-reg)))
877 (:result-types single-float)
878 (:note "complex float realpart")
881 (define-vop (realpart/complex-double-float complex-float-value)
882 (:translate realpart)
883 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
885 (:arg-types complex-double-float)
886 (:results (r :scs (double-reg)))
887 (:result-types double-float)
888 (:note "complex float realpart")
891 (define-vop (imagpart/complex-single-float complex-float-value)
892 (:translate imagpart)
893 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
895 (:arg-types complex-single-float)
896 (:results (r :scs (single-reg)))
897 (:result-types single-float)
898 (:note "complex float imagpart")
901 (define-vop (imagpart/complex-double-float complex-float-value)
902 (:translate imagpart)
903 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
905 (:arg-types complex-double-float)
906 (:results (r :scs (double-reg)))
907 (:result-types double-float)
908 (:note "complex float imagpart")
912 ;;; hack dummy VOPs to bias the representation selection of their
913 ;;; arguments towards a FP register, which can help avoid consing at
914 ;;; inappropriate locations
915 (defknown double-float-reg-bias (double-float) (values))
916 (define-vop (double-float-reg-bias)
917 (:translate double-float-reg-bias)
918 (:args (x :scs (double-reg double-stack) :load-if nil))
919 (:arg-types double-float)
921 (:note "inline dummy FP register bias")
924 (defknown single-float-reg-bias (single-float) (values))
925 (define-vop (single-float-reg-bias)
926 (:translate single-float-reg-bias)
927 (:args (x :scs (single-reg single-stack) :load-if nil))
928 (:arg-types single-float)
930 (:note "inline dummy FP register bias")