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))
67 (identity x) ; KLUDGE: IDENTITY as IGNORABLE...
68 (inst movq y fp-double-zero-tn))
70 (define-move-fun (load-single 2) (vop x y)
71 ((single-stack) (single-reg))
72 (inst movss y (ea-for-sf-stack x)))
74 (define-move-fun (store-single 2) (vop x y)
75 ((single-reg) (single-stack))
76 (inst movss (ea-for-sf-stack y) x))
78 (define-move-fun (load-double 2) (vop x y)
79 ((double-stack) (double-reg))
80 (inst movsd y (ea-for-df-stack x)))
82 (define-move-fun (store-double 2) (vop x y)
83 ((double-reg) (double-stack))
84 (inst movsd (ea-for-df-stack y) x))
86 (eval-when (:compile-toplevel :execute)
87 (setf *read-default-float-format* 'single-float))
89 ;;;; complex float move functions
91 (defun complex-single-reg-real-tn (x)
92 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
93 :offset (tn-offset x)))
94 (defun complex-single-reg-imag-tn (x)
95 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
96 :offset (1+ (tn-offset x))))
98 (defun complex-double-reg-real-tn (x)
99 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
100 :offset (tn-offset x)))
101 (defun complex-double-reg-imag-tn (x)
102 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
103 :offset (1+ (tn-offset x))))
105 ;;; X is source, Y is destination.
106 (define-move-fun (load-complex-single 2) (vop x y)
107 ((complex-single-stack) (complex-single-reg))
108 (let ((real-tn (complex-single-reg-real-tn y)))
109 (inst movss real-tn (ea-for-csf-real-stack x)))
110 (let ((imag-tn (complex-single-reg-imag-tn y)))
111 (inst movss imag-tn (ea-for-csf-imag-stack x))))
113 (define-move-fun (store-complex-single 2) (vop x y)
114 ((complex-single-reg) (complex-single-stack))
115 (let ((real-tn (complex-single-reg-real-tn x))
116 (imag-tn (complex-single-reg-imag-tn x)))
117 (inst movss (ea-for-csf-real-stack y) real-tn)
118 (inst movss (ea-for-csf-imag-stack y) imag-tn)))
120 (define-move-fun (load-complex-double 2) (vop x y)
121 ((complex-double-stack) (complex-double-reg))
122 (let ((real-tn (complex-double-reg-real-tn y)))
123 (inst movsd real-tn (ea-for-cdf-real-stack x)))
124 (let ((imag-tn (complex-double-reg-imag-tn y)))
125 (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
127 (define-move-fun (store-complex-double 2) (vop x y)
128 ((complex-double-reg) (complex-double-stack))
129 (let ((real-tn (complex-double-reg-real-tn x))
130 (imag-tn (complex-double-reg-imag-tn x)))
131 (inst movsd (ea-for-cdf-real-stack y) real-tn)
132 (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
137 ;;; float register to register moves
138 (macrolet ((frob (vop sc)
143 :load-if (not (location= x y))))
144 (:results (y :scs (,sc)
145 :load-if (not (location= x y))))
148 (unless (location= y x)
150 (define-move-vop ,vop :move (,sc) (,sc)))))
151 (frob single-move single-reg)
152 (frob double-move double-reg))
154 ;;; complex float register to register moves
155 (define-vop (complex-float-move)
156 (:args (x :target y :load-if (not (location= x y))))
157 (:results (y :load-if (not (location= x y))))
158 (:note "complex float move")
160 (unless (location= x y)
161 ;; Note the complex-float-regs are aligned to every second
162 ;; float register so there is not need to worry about overlap.
163 ;; (It would be better to put the imagpart in the top half of the
164 ;; register, or something, but let's worry about that later)
165 (let ((x-real (complex-single-reg-real-tn x))
166 (y-real (complex-single-reg-real-tn y)))
167 (inst movq y-real x-real))
168 (let ((x-imag (complex-single-reg-imag-tn x))
169 (y-imag (complex-single-reg-imag-tn y)))
170 (inst movq y-imag x-imag)))))
172 (define-vop (complex-single-move complex-float-move)
173 (:args (x :scs (complex-single-reg) :target y
174 :load-if (not (location= x y))))
175 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
176 (define-move-vop complex-single-move :move
177 (complex-single-reg) (complex-single-reg))
179 (define-vop (complex-double-move complex-float-move)
180 (:args (x :scs (complex-double-reg)
181 :target y :load-if (not (location= x y))))
182 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
183 (define-move-vop complex-double-move :move
184 (complex-double-reg) (complex-double-reg))
187 ;;; Move from float to a descriptor reg. allocating a new float
188 ;;; object in the process.
189 (define-vop (move-from-single)
190 (:args (x :scs (single-reg) :to :save))
191 (:results (y :scs (descriptor-reg)))
192 (:note "float to pointer coercion")
196 (inst or y single-float-widetag)))
198 (define-move-vop move-from-single :move
199 (single-reg) (descriptor-reg))
201 (define-vop (move-from-double)
202 (:args (x :scs (double-reg) :to :save))
203 (:results (y :scs (descriptor-reg)))
205 (:note "float to pointer coercion")
207 (with-fixed-allocation (y
211 (inst movsd (ea-for-df-desc y) x))))
212 (define-move-vop move-from-double :move
213 (double-reg) (descriptor-reg))
215 ;;; Move from a descriptor to a float register.
216 (define-vop (move-to-single)
217 (:args (x :scs (descriptor-reg) :target tmp))
218 (:temporary (:sc unsigned-reg) tmp)
219 (:results (y :scs (single-reg)))
220 (:note "pointer to float coercion")
226 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
228 (define-vop (move-to-double)
229 (:args (x :scs (descriptor-reg)))
230 (:results (y :scs (double-reg)))
231 (:note "pointer to float coercion")
233 (inst movsd y (ea-for-df-desc x))))
234 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
237 ;;; Move from complex float to a descriptor reg. allocating a new
238 ;;; complex float object in the process.
239 (define-vop (move-from-complex-single)
240 (:args (x :scs (complex-single-reg) :to :save))
241 (:results (y :scs (descriptor-reg)))
243 (:note "complex float to pointer coercion")
245 (with-fixed-allocation (y
246 complex-single-float-widetag
247 complex-single-float-size
249 (let ((real-tn (complex-single-reg-real-tn x)))
250 (inst movss (ea-for-csf-real-desc y) real-tn))
251 (let ((imag-tn (complex-single-reg-imag-tn x)))
252 (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
253 (define-move-vop move-from-complex-single :move
254 (complex-single-reg) (descriptor-reg))
256 (define-vop (move-from-complex-double)
257 (:args (x :scs (complex-double-reg) :to :save))
258 (:results (y :scs (descriptor-reg)))
260 (:note "complex float to pointer coercion")
262 (with-fixed-allocation (y
263 complex-double-float-widetag
264 complex-double-float-size
266 (let ((real-tn (complex-double-reg-real-tn x)))
267 (inst movsd (ea-for-cdf-real-desc y) real-tn))
268 (let ((imag-tn (complex-double-reg-imag-tn x)))
269 (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
270 (define-move-vop move-from-complex-double :move
271 (complex-double-reg) (descriptor-reg))
273 ;;; Move from a descriptor to a complex float register.
274 (macrolet ((frob (name sc format)
277 (:args (x :scs (descriptor-reg)))
278 (:results (y :scs (,sc)))
279 (:note "pointer to complex float coercion")
281 (let ((real-tn (complex-double-reg-real-tn y)))
285 '((inst movss real-tn (ea-for-csf-real-desc x))))
287 '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
288 (let ((imag-tn (complex-double-reg-imag-tn y)))
292 '((inst movss imag-tn (ea-for-csf-imag-desc x))))
294 '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
295 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
296 (frob move-to-complex-single complex-single-reg :single)
297 (frob move-to-complex-double complex-double-reg :double))
299 ;;;; the move argument vops
301 ;;;; Note these are also used to stuff fp numbers onto the c-call
302 ;;;; stack so the order is different than the lisp-stack.
304 ;;; the general MOVE-ARG VOP
305 (macrolet ((frob (name sc stack-sc format)
308 (:args (x :scs (,sc) :target y)
310 :load-if (not (sc-is y ,sc))))
312 (:note "float argument move")
313 (:generator ,(case format (:single 2) (:double 3) )
316 (unless (location= x y)
319 (if (= (tn-offset fp) esp-offset)
320 (let* ((offset (* (tn-offset y) n-word-bytes))
321 (ea (make-ea :dword :base fp :disp offset)))
323 (:single '((inst movss ea x)))
324 (:double '((inst movsd ea x)))))
327 :disp (- (* (1+ (tn-offset y))
330 (:single '((inst movss ea x)))
331 (:double '((inst movsd ea x))))))))))
332 (define-move-vop ,name :move-arg
333 (,sc descriptor-reg) (,sc)))))
334 (frob move-single-float-arg single-reg single-stack :single)
335 (frob move-double-float-arg double-reg double-stack :double))
337 ;;;; complex float MOVE-ARG VOP
338 (macrolet ((frob (name sc stack-sc format)
341 (:args (x :scs (,sc) :target y)
343 :load-if (not (sc-is y ,sc))))
345 (:note "complex float argument move")
346 (:generator ,(ecase format (:single 2) (:double 3))
349 (unless (location= x y)
350 (let ((x-real (complex-double-reg-real-tn x))
351 (y-real (complex-double-reg-real-tn y)))
352 (inst movsd y-real x-real))
353 (let ((x-imag (complex-double-reg-imag-tn x))
354 (y-imag (complex-double-reg-imag-tn y)))
355 (inst movsd y-imag x-imag))))
357 (let ((real-tn (complex-double-reg-real-tn x)))
361 (ea-for-csf-real-stack y fp)
365 (ea-for-cdf-real-stack y fp)
367 (let ((imag-tn (complex-double-reg-imag-tn x)))
371 (ea-for-csf-imag-stack y fp) imag-tn)))
374 (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
375 (define-move-vop ,name :move-arg
376 (,sc descriptor-reg) (,sc)))))
377 (frob move-complex-single-float-arg
378 complex-single-reg complex-single-stack :single)
379 (frob move-complex-double-float-arg
380 complex-double-reg complex-double-stack :double))
382 (define-move-vop move-arg :move-arg
383 (single-reg double-reg
384 complex-single-reg complex-double-reg)
390 (define-vop (float-op)
394 (:note "inline float arithmetic")
396 (:save-p :compute-only))
398 (macrolet ((frob (name sc ptype)
399 `(define-vop (,name float-op)
400 (:args (x :scs (,sc) :target r)
402 (:results (r :scs (,sc)))
403 (:arg-types ,ptype ,ptype)
404 (:result-types ,ptype))))
405 (frob single-float-op single-reg single-float)
406 (frob double-float-op double-reg double-float))
408 (macrolet ((generate (movinst opinst commutative)
413 ((and ,commutative (location= y r))
415 ((not (location= r y))
419 (inst ,movinst tmp x)
421 (inst ,movinst r tmp)))))
422 (frob (op sinst sname scost dinst dname dcost commutative)
424 (define-vop (,sname single-float-op)
426 (:temporary (:sc single-reg) tmp)
428 (generate movss ,sinst ,commutative)))
429 (define-vop (,dname double-float-op)
431 (:temporary (:sc single-reg) tmp)
433 (generate movsd ,dinst ,commutative))))))
434 (frob + addss +/single-float 2 addsd +/double-float 2 t)
435 (frob - subss -/single-float 2 subsd -/double-float 2 nil)
436 (frob * mulss */single-float 4 mulsd */double-float 5 t)
437 (frob / divss //single-float 12 divsd //double-float 19 nil))
441 (macrolet ((frob ((name translate sc type) &body body)
443 (:args (x :scs (,sc)))
444 (:results (y :scs (,sc)))
445 (:translate ,translate)
448 (:result-types ,type)
449 (:temporary (:sc any-reg) hex8)
452 (:note "inline float arithmetic")
454 (:save-p :compute-only)
456 (note-this-location vop :internal-error)
457 ;; we should be able to do this better. what we
458 ;; really would like to do is use the target as the
459 ;; temp whenever it's not also the source
460 (unless (location= x y)
463 (frob (%negate/double-float %negate double-reg double-float)
464 (inst lea hex8 (make-ea :qword :disp 1))
465 (inst ror hex8 1) ; #x8000000000000000
468 (frob (%negate/single-float %negate single-reg single-float)
469 (inst lea hex8 (make-ea :qword :disp 1))
473 (frob (abs/double-float abs double-reg double-float)
478 (frob (abs/single-float abs single-reg single-float)
486 (define-vop (float-compare)
491 (:save-p :compute-only)
492 (:note "inline float comparison"))
494 ;;; comiss and comisd can cope with one or other arg in memory: we
495 ;;; could (should, indeed) extend these to cope with descriptor args
498 (define-vop (single-float-compare float-compare)
499 (:args (x :scs (single-reg)) (y :scs (single-reg)))
501 (:arg-types single-float single-float))
502 (define-vop (double-float-compare float-compare)
503 (:args (x :scs (double-reg)) (y :scs (double-reg)))
505 (:arg-types double-float double-float))
507 (define-vop (=/single-float single-float-compare)
512 (note-this-location vop :internal-error)
514 ;; if PF&CF, there was a NaN involved => not equal
515 ;; otherwise, ZF => equal
518 (inst jmp :ne target))
520 (let ((not-lab (gen-label)))
521 (inst jmp :p not-lab)
523 (emit-label not-lab))))))
525 (define-vop (=/double-float double-float-compare)
530 (note-this-location vop :internal-error)
534 (inst jmp :ne target))
536 (let ((not-lab (gen-label)))
537 (inst jmp :p not-lab)
539 (emit-label not-lab))))))
541 ;; XXX all of these probably have bad NaN behaviour
542 (define-vop (<double-float double-float-compare)
547 (inst jmp (if not-p :nc :c) target)))
549 (define-vop (<single-float single-float-compare)
554 (inst jmp (if not-p :nc :c) target)))
556 (define-vop (>double-float double-float-compare)
561 (inst jmp (if not-p :na :a) target)))
563 (define-vop (>single-float single-float-compare)
568 (inst jmp (if not-p :na :a) target)))
574 (macrolet ((frob (name translate inst to-sc to-type)
576 (:args (x :scs (signed-stack signed-reg) :target temp))
577 (:temporary (:sc signed-stack) temp)
578 (:results (y :scs (,to-sc)))
579 (:arg-types signed-num)
580 (:result-types ,to-type)
582 (:note "inline float coercion")
583 (:translate ,translate)
585 (:save-p :compute-only)
590 (note-this-location vop :internal-error)
593 (note-this-location vop :internal-error)
594 (inst ,inst y x)))))))
595 (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
596 (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
598 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
600 (:args (x :scs (,from-sc) :target y))
601 (:results (y :scs (,to-sc)))
602 (:arg-types ,from-type)
603 (:result-types ,to-type)
605 (:note "inline float coercion")
606 (:translate ,translate)
608 (:save-p :compute-only)
610 (note-this-location vop :internal-error)
612 (frob %single-float/double-float %single-float cvtsd2ss double-reg
613 double-float single-reg single-float)
615 (frob %double-float/single-float %double-float cvtss2sd
616 single-reg single-float double-reg double-float))
618 (macrolet ((frob (trans inst from-sc from-type round-p)
619 (declare (ignore round-p))
620 `(define-vop (,(symbolicate trans "/" from-type))
621 (:args (x :scs (,from-sc)))
622 (:temporary (:sc any-reg) temp-reg)
623 (:results (y :scs (signed-reg)))
624 (:arg-types ,from-type)
625 (:result-types signed-num)
628 (:note "inline float truncate")
630 (:save-p :compute-only)
634 (inst ,inst temp-reg x)
639 (frob %unary-truncate cvttss2si single-reg single-float nil)
640 (frob %unary-truncate cvttsd2si double-reg double-float nil)
642 (frob %unary-round cvtss2si single-reg single-float t)
643 (frob %unary-round cvtsd2si double-reg double-float t))
645 (define-vop (make-single-float)
646 (:args (bits :scs (signed-reg) :target res
647 :load-if (not (or (and (sc-is bits signed-stack)
648 (sc-is res single-reg))
649 (and (sc-is bits signed-stack)
650 (sc-is res single-stack)
651 (location= bits res))))))
652 (:results (res :scs (single-reg single-stack)))
653 (:arg-types signed-num)
654 (:result-types single-float)
655 (:translate make-single-float)
665 (aver (location= bits res)))))
669 (inst movd res bits))
671 (inst movd res bits)))))))
673 (define-vop (make-double-float)
674 (:args (hi-bits :scs (signed-reg))
675 (lo-bits :scs (unsigned-reg)))
676 (:results (res :scs (double-reg)))
677 (:temporary (:sc unsigned-reg) temp)
678 (:arg-types signed-num unsigned-num)
679 (:result-types double-float)
680 (:translate make-double-float)
686 (inst or temp lo-bits)
687 (inst movd res temp)))
689 (define-vop (single-float-bits)
690 (:args (float :scs (single-reg descriptor-reg)
691 :load-if (not (sc-is float single-stack))))
692 (:results (bits :scs (signed-reg)))
693 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
694 (:arg-types single-float)
695 (:result-types signed-num)
696 (:translate single-float-bits)
704 (inst movss stack-temp float)
705 (move bits stack-temp))
710 (inst shr bits 32))))
714 (inst movss bits float)))))
719 (define-vop (double-float-high-bits)
720 (:args (float :scs (double-reg descriptor-reg)
721 :load-if (not (sc-is float double-stack))))
722 (:results (hi-bits :scs (signed-reg)))
723 (:temporary (:sc signed-stack :from :argument :to :result) temp)
724 (:arg-types double-float)
725 (:result-types signed-num)
726 (:translate double-float-high-bits)
732 (inst movsd temp float)
735 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
737 (loadw hi-bits float double-float-value-slot
738 other-pointer-lowtag)))
739 (inst sar hi-bits 32)))
741 (define-vop (double-float-low-bits)
742 (:args (float :scs (double-reg descriptor-reg)
743 :load-if (not (sc-is float double-stack))))
744 (:results (lo-bits :scs (unsigned-reg)))
745 (:temporary (:sc signed-stack :from :argument :to :result) temp)
746 (:arg-types double-float)
747 (:result-types unsigned-num)
748 (:translate double-float-low-bits)
754 (inst movsd temp float)
757 (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
759 (loadw lo-bits float double-float-value-slot
760 other-pointer-lowtag)))
761 (inst shl lo-bits 32)
762 (inst shr lo-bits 32)))
766 ;;;; complex float VOPs
768 (define-vop (make-complex-single-float)
770 (:args (real :scs (single-reg) :to :result :target r
771 :load-if (not (location= real r)))
772 (imag :scs (single-reg) :to :save))
773 (:arg-types single-float single-float)
774 (:results (r :scs (complex-single-reg) :from (:argument 0)
775 :load-if (not (sc-is r complex-single-stack))))
776 (:result-types complex-single-float)
777 (:note "inline complex single-float creation")
782 (let ((r-real (complex-single-reg-real-tn r)))
783 (unless (location= real r-real)
784 (inst movss r-real real)))
785 (let ((r-imag (complex-single-reg-imag-tn r)))
786 (unless (location= imag r-imag)
787 (inst movss r-imag imag))))
788 (complex-single-stack
789 (inst movss (ea-for-csf-real-stack r) real)
790 (inst movss (ea-for-csf-imag-stack r) imag)))))
792 (define-vop (make-complex-double-float)
794 (:args (real :scs (double-reg) :target r
795 :load-if (not (location= real r)))
796 (imag :scs (double-reg) :to :save))
797 (:arg-types double-float double-float)
798 (:results (r :scs (complex-double-reg) :from (:argument 0)
799 :load-if (not (sc-is r complex-double-stack))))
800 (:result-types complex-double-float)
801 (:note "inline complex double-float creation")
806 (let ((r-real (complex-double-reg-real-tn r)))
807 (unless (location= real r-real)
808 (inst movsd r-real real)))
809 (let ((r-imag (complex-double-reg-imag-tn r)))
810 (unless (location= imag r-imag)
811 (inst movsd r-imag imag))))
812 (complex-double-stack
813 (inst movsd (ea-for-cdf-real-stack r) real)
814 (inst movsd (ea-for-cdf-imag-stack r) imag)))))
816 (define-vop (complex-float-value)
817 (:args (x :target r))
819 (:variant-vars offset)
822 (cond ((sc-is x complex-single-reg complex-double-reg)
824 (make-random-tn :kind :normal
825 :sc (sc-or-lose 'double-reg)
826 :offset (+ offset (tn-offset x)))))
827 (unless (location= value-tn r)
828 (if (sc-is x complex-single-reg)
829 (inst movss r value-tn)
830 (inst movsd r value-tn)))))
831 ((sc-is r single-reg)
833 (complex-single-stack
835 (0 (ea-for-csf-real-stack x))
836 (1 (ea-for-csf-imag-stack x))))
839 (0 (ea-for-csf-real-desc x))
840 (1 (ea-for-csf-imag-desc x)))))))
842 ((sc-is r double-reg)
844 (complex-double-stack
846 (0 (ea-for-cdf-real-stack x))
847 (1 (ea-for-cdf-imag-stack x))))
850 (0 (ea-for-cdf-real-desc x))
851 (1 (ea-for-cdf-imag-desc x)))))))
853 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
855 (define-vop (realpart/complex-single-float complex-float-value)
856 (:translate realpart)
857 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
859 (:arg-types complex-single-float)
860 (:results (r :scs (single-reg)))
861 (:result-types single-float)
862 (:note "complex float realpart")
865 (define-vop (realpart/complex-double-float complex-float-value)
866 (:translate realpart)
867 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
869 (:arg-types complex-double-float)
870 (:results (r :scs (double-reg)))
871 (:result-types double-float)
872 (:note "complex float realpart")
875 (define-vop (imagpart/complex-single-float complex-float-value)
876 (:translate imagpart)
877 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
879 (:arg-types complex-single-float)
880 (:results (r :scs (single-reg)))
881 (:result-types single-float)
882 (:note "complex float imagpart")
885 (define-vop (imagpart/complex-double-float complex-float-value)
886 (:translate imagpart)
887 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
889 (:arg-types complex-double-float)
890 (:results (r :scs (double-reg)))
891 (:result-types double-float)
892 (:note "complex float imagpart")
896 ;;; hack dummy VOPs to bias the representation selection of their
897 ;;; arguments towards a FP register, which can help avoid consing at
898 ;;; inappropriate locations
899 (defknown double-float-reg-bias (double-float) (values))
900 (define-vop (double-float-reg-bias)
901 (:translate double-float-reg-bias)
902 (:args (x :scs (double-reg double-stack) :load-if nil))
903 (:arg-types double-float)
905 (:note "inline dummy FP register bias")
908 (defknown single-float-reg-bias (single-float) (values))
909 (define-vop (single-float-reg-bias)
910 (:translate single-float-reg-bias)
911 (:args (x :scs (single-reg single-stack) :load-if nil))
912 (:arg-types single-float)
914 (:note "inline dummy FP register bias")