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-sf-desc (tn)
20 (ea-for-xf-desc tn single-float-value-slot))
21 (defun ea-for-df-desc (tn)
22 (ea-for-xf-desc tn double-float-value-slot))
24 (defun ea-for-csf-real-desc (tn)
25 (ea-for-xf-desc tn complex-single-float-real-slot))
26 (defun ea-for-csf-imag-desc (tn)
27 (ea-for-xf-desc tn complex-single-float-imag-slot))
28 (defun ea-for-cdf-real-desc (tn)
29 (ea-for-xf-desc tn complex-double-float-real-slot))
30 (defun ea-for-cdf-imag-desc (tn)
31 (ea-for-xf-desc tn complex-double-float-imag-slot)))
33 (macrolet ((ea-for-xf-stack (tn kind)
34 (declare (ignore kind))
37 :disp (- (* (+ (tn-offset ,tn) 1)
39 (defun ea-for-sf-stack (tn)
40 (ea-for-xf-stack tn :single))
41 (defun ea-for-df-stack (tn)
42 (ea-for-xf-stack tn :double)))
44 ;;; Telling the FPU to wait is required in order to make signals occur
45 ;;; at the expected place, but naturally slows things down.
47 ;;; NODE is the node whose compilation policy controls the decision
48 ;;; whether to just blast through carelessly or carefully emit wait
49 ;;; instructions and whatnot.
51 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
52 ;;; #'NOTE-NEXT-INSTRUCTION.
53 (defun maybe-fp-wait (node &optional note-next-instruction)
54 (when (policy node (or (= debug 3) (> safety speed))))
55 (when note-next-instruction
56 (note-next-instruction note-next-instruction :internal-error))
60 ;;; complex float stack EAs
61 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
62 (declare (ignore kind))
65 :disp (- (* (+ (tn-offset ,tn)
66 (* 1 (ecase ,slot (:real 1) (:imag 2))))
68 (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
69 (ea-for-cxf-stack tn :single :real base))
70 (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
71 (ea-for-cxf-stack tn :single :imag base))
72 (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
73 (ea-for-cxf-stack tn :double :real base))
74 (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
75 (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 (identity x) ; KLUDGE: IDENTITY as IGNORABLE...
86 (inst movq y fp-double-zero-tn))
88 (define-move-fun (load-single 2) (vop x y)
89 ((single-stack) (single-reg))
90 (inst movss y (ea-for-sf-stack x)))
92 (define-move-fun (store-single 2) (vop x y)
93 ((single-reg) (single-stack))
94 (inst movss (ea-for-sf-stack y) x))
96 (define-move-fun (load-double 2) (vop x y)
97 ((double-stack) (double-reg))
98 (inst movsd y (ea-for-df-stack x)))
100 (define-move-fun (store-double 2) (vop x y)
101 ((double-reg) (double-stack))
102 (inst movsd (ea-for-df-stack y) x))
104 (eval-when (:compile-toplevel :execute)
105 (setf *read-default-float-format* 'single-float))
107 ;;;; complex float move functions
109 (defun complex-single-reg-real-tn (x)
110 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
111 :offset (tn-offset x)))
112 (defun complex-single-reg-imag-tn (x)
113 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
114 :offset (1+ (tn-offset x))))
116 (defun complex-double-reg-real-tn (x)
117 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
118 :offset (tn-offset x)))
119 (defun complex-double-reg-imag-tn (x)
120 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
121 :offset (1+ (tn-offset x))))
123 ;;; X is source, Y is destination.
124 (define-move-fun (load-complex-single 2) (vop x y)
125 ((complex-single-stack) (complex-single-reg))
126 (let ((real-tn (complex-single-reg-real-tn y)))
127 (inst movss real-tn (ea-for-csf-real-stack x)))
128 (let ((imag-tn (complex-single-reg-imag-tn y)))
129 (inst movss imag-tn (ea-for-csf-imag-stack x))))
131 (define-move-fun (store-complex-single 2) (vop x y)
132 ((complex-single-reg) (complex-single-stack))
133 (let ((real-tn (complex-single-reg-real-tn x))
134 (imag-tn (complex-single-reg-imag-tn x)))
135 (inst movss (ea-for-csf-real-stack y) real-tn)
136 (inst movss (ea-for-csf-imag-stack y) imag-tn)))
138 (define-move-fun (load-complex-double 2) (vop x y)
139 ((complex-double-stack) (complex-double-reg))
140 (let ((real-tn (complex-double-reg-real-tn y)))
141 (inst movsd real-tn (ea-for-cdf-real-stack x)))
142 (let ((imag-tn (complex-double-reg-imag-tn y)))
143 (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
145 (define-move-fun (store-complex-double 2) (vop x y)
146 ((complex-double-reg) (complex-double-stack))
147 (let ((real-tn (complex-double-reg-real-tn x))
148 (imag-tn (complex-double-reg-imag-tn x)))
149 (inst movsd (ea-for-cdf-real-stack y) real-tn)
150 (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
155 ;;; float register to register moves
156 (macrolet ((frob (vop sc)
161 :load-if (not (location= x y))))
162 (:results (y :scs (,sc)
163 :load-if (not (location= x y))))
166 (unless (location= y x)
168 (define-move-vop ,vop :move (,sc) (,sc)))))
169 (frob single-move single-reg)
170 (frob double-move double-reg))
172 ;;; complex float register to register moves
173 (define-vop (complex-float-move)
174 (:args (x :target y :load-if (not (location= x y))))
175 (:results (y :load-if (not (location= x y))))
176 (:note "complex float move")
178 (unless (location= x y)
179 ;; Note the complex-float-regs are aligned to every second
180 ;; float register so there is not need to worry about overlap.
181 ;; (It would be better to put the imagpart in the top half of the
182 ;; register, or something, but let's worry about that later)
183 (let ((x-real (complex-single-reg-real-tn x))
184 (y-real (complex-single-reg-real-tn y)))
185 (inst movq y-real x-real))
186 (let ((x-imag (complex-single-reg-imag-tn x))
187 (y-imag (complex-single-reg-imag-tn y)))
188 (inst movq y-imag x-imag)))))
190 (define-vop (complex-single-move complex-float-move)
191 (:args (x :scs (complex-single-reg) :target y
192 :load-if (not (location= x y))))
193 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
194 (define-move-vop complex-single-move :move
195 (complex-single-reg) (complex-single-reg))
197 (define-vop (complex-double-move complex-float-move)
198 (:args (x :scs (complex-double-reg)
199 :target y :load-if (not (location= x y))))
200 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
201 (define-move-vop complex-double-move :move
202 (complex-double-reg) (complex-double-reg))
205 ;;; Move from float to a descriptor reg. allocating a new float
206 ;;; object in the process.
207 (define-vop (move-from-single)
208 (:args (x :scs (single-reg) :to :save))
209 (:results (y :scs (descriptor-reg)))
211 (:note "float to pointer coercion")
213 (with-fixed-allocation (y
215 single-float-size node)
216 (inst movss (ea-for-sf-desc y) x))))
217 (define-move-vop move-from-single :move
218 (single-reg) (descriptor-reg))
220 (define-vop (move-from-double)
221 (:args (x :scs (double-reg) :to :save))
222 (:results (y :scs (descriptor-reg)))
224 (:note "float to pointer coercion")
226 (with-fixed-allocation (y
230 (inst movsd (ea-for-df-desc y) x))))
231 (define-move-vop move-from-double :move
232 (double-reg) (descriptor-reg))
235 (define-vop (move-from-fp-constant)
236 (:args (x :scs (fp-constant)))
237 (:results (y :scs (descriptor-reg)))
239 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
240 (0f0 (load-symbol-value y *fp-constant-0f0*))
241 (1f0 (load-symbol-value y *fp-constant-1f0*))
242 (0d0 (load-symbol-value y *fp-constant-0d0*))
243 (1d0 (load-symbol-value y *fp-constant-1d0*)))))
245 (define-move-vop move-from-fp-constant :move
246 (fp-constant) (descriptor-reg))
248 ;;; Move from a descriptor to a float register.
249 (define-vop (move-to-single)
250 (:args (x :scs (descriptor-reg)))
251 (:results (y :scs (single-reg)))
252 (:note "pointer to float coercion")
254 (inst movss y (ea-for-sf-desc x))))
255 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
257 (define-vop (move-to-double)
258 (:args (x :scs (descriptor-reg)))
259 (:results (y :scs (double-reg)))
260 (:note "pointer to float coercion")
262 (inst movsd y (ea-for-df-desc x))))
263 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
266 ;;; Move from complex float to a descriptor reg. allocating a new
267 ;;; complex float object in the process.
268 (define-vop (move-from-complex-single)
269 (:args (x :scs (complex-single-reg) :to :save))
270 (:results (y :scs (descriptor-reg)))
272 (:note "complex float to pointer coercion")
274 (with-fixed-allocation (y
275 complex-single-float-widetag
276 complex-single-float-size
278 (let ((real-tn (complex-single-reg-real-tn x)))
279 (inst movss (ea-for-csf-real-desc y) real-tn))
280 (let ((imag-tn (complex-single-reg-imag-tn x)))
281 (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
282 (define-move-vop move-from-complex-single :move
283 (complex-single-reg) (descriptor-reg))
285 (define-vop (move-from-complex-double)
286 (:args (x :scs (complex-double-reg) :to :save))
287 (:results (y :scs (descriptor-reg)))
289 (:note "complex float to pointer coercion")
291 (with-fixed-allocation (y
292 complex-double-float-widetag
293 complex-double-float-size
295 (let ((real-tn (complex-double-reg-real-tn x)))
296 (inst movsd (ea-for-cdf-real-desc y) real-tn))
297 (let ((imag-tn (complex-double-reg-imag-tn x)))
298 (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
299 (define-move-vop move-from-complex-double :move
300 (complex-double-reg) (descriptor-reg))
302 ;;; Move from a descriptor to a complex float register.
303 (macrolet ((frob (name sc format)
306 (:args (x :scs (descriptor-reg)))
307 (:results (y :scs (,sc)))
308 (:note "pointer to complex float coercion")
310 (let ((real-tn (complex-double-reg-real-tn y)))
314 '((inst movss real-tn (ea-for-csf-real-desc x))))
316 '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
317 (let ((imag-tn (complex-double-reg-imag-tn y)))
321 '((inst movss imag-tn (ea-for-csf-imag-desc x))))
323 '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
324 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
325 (frob move-to-complex-single complex-single-reg :single)
326 (frob move-to-complex-double complex-double-reg :double))
328 ;;;; the move argument vops
330 ;;;; Note these are also used to stuff fp numbers onto the c-call
331 ;;;; stack so the order is different than the lisp-stack.
333 ;;; the general MOVE-ARG VOP
334 (macrolet ((frob (name sc stack-sc format)
337 (:args (x :scs (,sc) :target y)
339 :load-if (not (sc-is y ,sc))))
341 (:note "float argument move")
342 (:generator ,(case format (:single 2) (:double 3) )
345 (unless (location= x y)
348 (if (= (tn-offset fp) esp-offset)
349 (let* ((offset (* (tn-offset y) n-word-bytes))
350 (ea (make-ea :dword :base fp :disp offset)))
352 (:single '((inst movss ea x)))
353 (:double '((inst movsd ea x)))))
356 :disp (- (* (+ (tn-offset y)
363 (:single '((inst movss ea x)))
364 (:double '((inst movsd ea x)))))))))))
365 (define-move-vop ,name :move-arg
366 (,sc descriptor-reg) (,sc)))))
367 (frob move-single-float-arg single-reg single-stack :single)
368 (frob move-double-float-arg double-reg double-stack :double))
370 ;;;; complex float MOVE-ARG VOP
371 (macrolet ((frob (name sc stack-sc format)
374 (:args (x :scs (,sc) :target y)
376 :load-if (not (sc-is y ,sc))))
378 (:note "complex float argument move")
379 (:generator ,(ecase format (:single 2) (:double 3))
382 (unless (location= x y)
383 (let ((x-real (complex-double-reg-real-tn x))
384 (y-real (complex-double-reg-real-tn y)))
385 (inst movsd y-real x-real))
386 (let ((x-imag (complex-double-reg-imag-tn x))
387 (y-imag (complex-double-reg-imag-tn y)))
388 (inst movsd y-imag x-imag))))
390 (let ((real-tn (complex-double-reg-real-tn x)))
394 (ea-for-csf-real-stack y fp)
398 (ea-for-cdf-real-stack y fp)
400 (let ((imag-tn (complex-double-reg-imag-tn x)))
404 (ea-for-csf-imag-stack y fp) imag-tn)))
407 (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
408 (define-move-vop ,name :move-arg
409 (,sc descriptor-reg) (,sc)))))
410 (frob move-complex-single-float-arg
411 complex-single-reg complex-single-stack :single)
412 (frob move-complex-double-float-arg
413 complex-double-reg complex-double-stack :double))
415 (define-move-vop move-arg :move-arg
416 (single-reg double-reg
417 complex-single-reg complex-double-reg)
423 (define-vop (float-op)
427 (:note "inline float arithmetic")
429 (:save-p :compute-only))
431 (macrolet ((frob (name sc ptype)
432 `(define-vop (,name float-op)
433 (:args (x :scs (,sc))
435 (:results (r :scs (,sc)))
436 (:arg-types ,ptype ,ptype)
437 (:result-types ,ptype))))
438 (frob single-float-op single-reg single-float)
439 (frob double-float-op double-reg double-float))
441 (macrolet ((generate (movinst opinst commutative)
446 ((and ,commutative (location= y r))
448 ((not (location= r y))
452 (inst ,movinst tmp x)
454 (inst ,movinst r tmp)))))
455 (frob (op sinst sname scost dinst dname dcost commutative)
457 (define-vop (,sname single-float-op)
459 (:temporary (:sc single-reg) tmp)
461 (generate movss ,sinst ,commutative)))
462 (define-vop (,dname double-float-op)
464 (:temporary (:sc single-reg) tmp)
466 (generate movsd ,dinst ,commutative))))))
467 (frob + addss +/single-float 2 addsd +/double-float 2 t)
468 (frob - subss -/single-float 2 subsd -/double-float 2 nil)
469 (frob * mulss */single-float 4 mulsd */double-float 5 t)
470 (frob / divss //single-float 12 divsd //double-float 19 nil))
473 (macrolet ((frob ((name translate sc type) &body body)
475 (:args (x :scs (,sc)))
476 (:results (y :scs (,sc)))
477 (:translate ,translate)
480 (:result-types ,type)
481 (:temporary (:sc any-reg) hex8)
484 (:note "inline float arithmetic")
486 (:save-p :compute-only)
488 (note-this-location vop :internal-error)
489 ;; we should be able to do this better. what we
490 ;; really would like to do is use the target as the
491 ;; temp whenever it's not also the source
492 (unless (location= x y)
495 (frob (%negate/double-float %negate double-reg double-float)
496 (inst lea hex8 (make-ea :qword :disp 1))
497 (inst ror hex8 1) ; #x8000000000000000
500 (frob (%negate/single-float %negate single-reg single-float)
501 (inst lea hex8 (make-ea :qword :disp 1))
505 (frob (abs/double-float abs double-reg double-float)
510 (frob (abs/single-float abs single-reg single-float)
518 (define-vop (float-compare)
523 (:save-p :compute-only)
524 (:note "inline float comparison"))
526 ;;; comiss and comisd can cope with one or other arg in memory: we
527 ;;; could (should, indeed) extend these to cope with descriptor args
530 (define-vop (single-float-compare float-compare)
531 (:args (x :scs (single-reg)) (y :scs (single-reg)))
533 (:arg-types single-float single-float))
534 (define-vop (double-float-compare float-compare)
535 (:args (x :scs (double-reg)) (y :scs (double-reg)))
537 (:arg-types double-float double-float))
539 (define-vop (=/single-float single-float-compare)
544 (note-this-location vop :internal-error)
546 ;; if PF&CF, there was a NaN involved => not equal
547 ;; otherwise, ZF => equal
550 (inst jmp :ne target))
552 (let ((not-lab (gen-label)))
553 (inst jmp :p not-lab)
555 (emit-label not-lab))))))
557 (define-vop (=/double-float double-float-compare)
562 (note-this-location vop :internal-error)
566 (inst jmp :ne target))
568 (let ((not-lab (gen-label)))
569 (inst jmp :p not-lab)
571 (emit-label not-lab))))))
573 ;; XXX all of these probably have bad NaN behaviour
574 (define-vop (<double-float double-float-compare)
579 (inst jmp (if not-p :nc :c) target)))
581 (define-vop (<single-float single-float-compare)
586 (inst jmp (if not-p :nc :c) target)))
588 (define-vop (>double-float double-float-compare)
593 (inst jmp (if not-p :na :a) target)))
595 (define-vop (>single-float single-float-compare)
600 (inst jmp (if not-p :na :a) target)))
606 (macrolet ((frob (name translate inst to-sc to-type)
608 (:args (x :scs (signed-stack signed-reg) :target temp))
609 (:temporary (:sc signed-stack) temp)
610 (:results (y :scs (,to-sc)))
611 (:arg-types signed-num)
612 (:result-types ,to-type)
614 (:note "inline float coercion")
615 (:translate ,translate)
617 (:save-p :compute-only)
622 (note-this-location vop :internal-error)
625 (note-this-location vop :internal-error)
626 (inst ,inst y x)))))))
627 (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
628 (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
631 (macrolet ((frob (name translate inst to-sc to-type)
633 (:args (x :scs (unsigned-reg)))
634 (:results (y :scs (,to-sc)))
635 (:arg-types unsigned-num)
636 (:result-types ,to-type)
638 (:note "inline float coercion")
639 (:translate ,translate)
641 (:save-p :compute-only)
644 (frob %single-float/unsigned %single-float cvtsi2ss single-reg single-float)
645 (frob %double-float/unsigned %double-float cvtsi2sd double-reg double-float))
647 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
649 (:args (x :scs (,from-sc) :target y))
650 (:results (y :scs (,to-sc)))
651 (:arg-types ,from-type)
652 (:result-types ,to-type)
654 (:note "inline float coercion")
655 (:translate ,translate)
657 (:save-p :compute-only)
659 (note-this-location vop :internal-error)
661 (frob %single-float/double-float %single-float cvtsd2ss double-reg
662 double-float single-reg single-float)
664 (frob %double-float/single-float %double-float cvtss2sd
665 single-reg single-float double-reg double-float))
667 (macrolet ((frob (trans inst from-sc from-type round-p)
668 (declare (ignore round-p))
669 `(define-vop (,(symbolicate trans "/" from-type))
670 (:args (x :scs (,from-sc)))
671 (:temporary (:sc any-reg) temp-reg)
672 (:results (y :scs (signed-reg)))
673 (:arg-types ,from-type)
674 (:result-types signed-num)
677 (:note "inline float truncate")
679 (:save-p :compute-only)
683 (inst ,inst temp-reg x)
688 (frob %unary-truncate cvttss2si single-reg single-float nil)
689 (frob %unary-truncate cvttsd2si double-reg double-float nil)
691 (frob %unary-round cvtss2si single-reg single-float t)
692 (frob %unary-round cvtsd2si double-reg double-float t))
694 #+nil ;; will we need this?
695 (macrolet ((frob (trans from-sc from-type round-p)
696 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
697 (:args (x :scs (,from-sc) :target fr0))
698 (:temporary (:sc double-reg :offset fr0-offset
699 :from :argument :to :result) fr0)
701 '((:temporary (:sc unsigned-stack) stack-temp)
702 (:temporary (:sc unsigned-stack) scw)
703 (:temporary (:sc any-reg) rcw)))
704 (:results (y :scs (unsigned-reg)))
705 (:arg-types ,from-type)
706 (:result-types unsigned-num)
709 (:note "inline float truncate")
711 (:save-p :compute-only)
714 '((note-this-location vop :internal-error)
715 ;; Catch any pending FPE exceptions.
717 ;; Normal mode (for now) is "round to best".
718 (unless (zerop (tn-offset x))
719 (copy-fp-reg-to-fr0 x))
721 '((inst fnstcw scw) ; save current control word
722 (move rcw scw) ; into 16-bit register
723 (inst or rcw (ash #b11 10)) ; CHOP
724 (move stack-temp rcw)
725 (inst fldcw stack-temp)))
727 (inst fistpl (make-ea :dword :base rsp-tn))
729 (inst fld fr0) ; copy fr0 to at least restore stack.
732 '((inst fldcw scw)))))))
733 (frob %unary-truncate single-reg single-float nil)
734 (frob %unary-truncate double-reg double-float nil)
735 (frob %unary-round single-reg single-float t)
736 (frob %unary-round double-reg double-float t))
738 (define-vop (make-single-float)
739 (:args (bits :scs (signed-reg) :target res
740 :load-if (not (or (and (sc-is bits signed-stack)
741 (sc-is res single-reg))
742 (and (sc-is bits signed-stack)
743 (sc-is res single-stack)
744 (location= bits res))))))
745 (:results (res :scs (single-reg single-stack)))
746 ; (:temporary (:sc signed-stack) stack-temp)
747 (:arg-types signed-num)
748 (:result-types single-float)
749 (:translate make-single-float)
759 (aver (location= bits res)))))
763 (inst movd res bits))
765 (inst movd res bits)))))))
767 (define-vop (make-double-float)
768 (:args (hi-bits :scs (signed-reg))
769 (lo-bits :scs (unsigned-reg)))
770 (:results (res :scs (double-reg)))
771 (:temporary (:sc unsigned-reg) temp)
772 (:arg-types signed-num unsigned-num)
773 (:result-types double-float)
774 (:translate make-double-float)
780 (inst or temp lo-bits)
781 (inst movd res temp)))
783 (define-vop (single-float-bits)
784 (:args (float :scs (single-reg descriptor-reg)
785 :load-if (not (sc-is float single-stack))))
786 (:results (bits :scs (signed-reg)))
787 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
788 (:arg-types single-float)
789 (:result-types signed-num)
790 (:translate single-float-bits)
798 (inst movss stack-temp float)
799 (move bits stack-temp))
804 bits float single-float-value-slot
805 other-pointer-lowtag))))
809 (inst movss bits float)))))
814 (define-vop (double-float-high-bits)
815 (:args (float :scs (double-reg descriptor-reg)
816 :load-if (not (sc-is float double-stack))))
817 (:results (hi-bits :scs (signed-reg)))
818 (:temporary (:sc signed-stack :from :argument :to :result) temp)
819 (:arg-types double-float)
820 (:result-types signed-num)
821 (:translate double-float-high-bits)
827 (inst movsd temp float)
830 (loadw hi-bits ebp-tn (- (tn-offset float))))
832 (loadw hi-bits float double-float-value-slot
833 other-pointer-lowtag)))
834 (inst sar hi-bits 32)))
836 (define-vop (double-float-low-bits)
837 (:args (float :scs (double-reg descriptor-reg)
838 :load-if (not (sc-is float double-stack))))
839 (:results (lo-bits :scs (unsigned-reg)))
840 (:temporary (:sc signed-stack :from :argument :to :result) temp)
841 (:arg-types double-float)
842 (:result-types unsigned-num)
843 (:translate double-float-low-bits)
849 (inst movsd temp float)
852 (loadw lo-bits ebp-tn (- (tn-offset float))))
854 (loadw lo-bits float double-float-value-slot
855 other-pointer-lowtag)))
856 (inst shl lo-bits 32)
857 (inst shr lo-bits 32)))
860 ;;;; float mode hackery
862 (sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
863 (defknown floating-point-modes () float-modes (flushable))
864 (defknown ((setf floating-point-modes)) (float-modes)
867 (define-vop (floating-point-modes)
868 (:results (res :scs (unsigned-reg)))
869 (:result-types unsigned-num)
870 (:translate floating-point-modes)
872 (:temporary (:sc unsigned-stack :from :argument :to :result) temp)
876 ;; Extract status from bytes 0-5 to bytes 16-21
877 (inst and temp (1- (expt 2 6)))
879 ;; Extract mask from bytes 7-12 to bytes 0-5
881 (inst and res (1- (expt 2 6)))
882 ;; Flip the bits to convert from "1 means exception masked" to
883 ;; "1 means exception enabled".
884 (inst xor res (1- (expt 2 6)))
887 (define-vop (set-floating-point-modes)
888 (:args (new :scs (unsigned-reg) :to :result :target res))
889 (:results (res :scs (unsigned-reg)))
890 (:arg-types unsigned-num)
891 (:result-types unsigned-num)
892 (:translate (setf floating-point-modes))
894 (:temporary (:sc unsigned-reg :from :argument :to :result) temp1)
895 (:temporary (:sc unsigned-stack :from :argument :to :result) temp2)
899 ;; Clear status + masks
900 (inst and temp2 (lognot (logior (1- (expt 2 6))
901 (ash (1- (expt 2 6)) 7))))
902 ;; Replace current status
905 (inst and temp1 (1- (expt 2 6)))
906 (inst or temp2 temp1)
907 ;; Replace exception masks
909 (inst and temp1 (1- (expt 2 6)))
910 (inst xor temp1 (1- (expt 2 6)))
912 (inst or temp2 temp1)
913 (inst ldmxcsr temp2)))
916 ;;;; complex float VOPs
918 (define-vop (make-complex-single-float)
920 (:args (real :scs (single-reg) :to :result :target r
921 :load-if (not (location= real r)))
922 (imag :scs (single-reg) :to :save))
923 (:arg-types single-float single-float)
924 (:results (r :scs (complex-single-reg) :from (:argument 0)
925 :load-if (not (sc-is r complex-single-stack))))
926 (:result-types complex-single-float)
927 (:note "inline complex single-float creation")
932 (let ((r-real (complex-single-reg-real-tn r)))
933 (unless (location= real r-real)
934 (inst movss r-real real)))
935 (let ((r-imag (complex-single-reg-imag-tn r)))
936 (unless (location= imag r-imag)
937 (inst movss r-imag imag))))
938 (complex-single-stack
939 (inst movss (ea-for-csf-real-stack r) real)
940 (inst movss (ea-for-csf-imag-stack r) imag)))))
942 (define-vop (make-complex-double-float)
944 (:args (real :scs (double-reg) :target r
945 :load-if (not (location= real r)))
946 (imag :scs (double-reg) :to :save))
947 (:arg-types double-float double-float)
948 (:results (r :scs (complex-double-reg) :from (:argument 0)
949 :load-if (not (sc-is r complex-double-stack))))
950 (:result-types complex-double-float)
951 (:note "inline complex double-float creation")
956 (let ((r-real (complex-double-reg-real-tn r)))
957 (unless (location= real r-real)
958 (inst movsd r-real real)))
959 (let ((r-imag (complex-double-reg-imag-tn r)))
960 (unless (location= imag r-imag)
961 (inst movsd r-imag imag))))
962 (complex-double-stack
963 (inst movsd (ea-for-cdf-real-stack r) real)
964 (inst movsd (ea-for-cdf-imag-stack r) imag)))))
966 (define-vop (complex-float-value)
967 (:args (x :target r))
969 (:variant-vars offset)
972 (cond ((sc-is x complex-single-reg complex-double-reg)
974 (make-random-tn :kind :normal
975 :sc (sc-or-lose 'double-reg)
976 :offset (+ offset (tn-offset x)))))
977 (unless (location= value-tn r)
978 (if (sc-is x complex-single-reg)
979 (inst movss r value-tn)
980 (inst movsd r value-tn)))))
981 ((sc-is r single-reg)
983 (complex-single-stack
985 (0 (ea-for-csf-real-stack x))
986 (1 (ea-for-csf-imag-stack x))))
989 (0 (ea-for-csf-real-desc x))
990 (1 (ea-for-csf-imag-desc x)))))))
992 ((sc-is r double-reg)
994 (complex-double-stack
996 (0 (ea-for-cdf-real-stack x))
997 (1 (ea-for-cdf-imag-stack x))))
1000 (0 (ea-for-cdf-real-desc x))
1001 (1 (ea-for-cdf-imag-desc x)))))))
1003 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
1005 (define-vop (realpart/complex-single-float complex-float-value)
1006 (:translate realpart)
1007 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1009 (:arg-types complex-single-float)
1010 (:results (r :scs (single-reg)))
1011 (:result-types single-float)
1012 (:note "complex float realpart")
1015 (define-vop (realpart/complex-double-float complex-float-value)
1016 (:translate realpart)
1017 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1019 (:arg-types complex-double-float)
1020 (:results (r :scs (double-reg)))
1021 (:result-types double-float)
1022 (:note "complex float realpart")
1025 (define-vop (imagpart/complex-single-float complex-float-value)
1026 (:translate imagpart)
1027 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1029 (:arg-types complex-single-float)
1030 (:results (r :scs (single-reg)))
1031 (:result-types single-float)
1032 (:note "complex float imagpart")
1035 (define-vop (imagpart/complex-double-float complex-float-value)
1036 (:translate imagpart)
1037 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1039 (:arg-types complex-double-float)
1040 (:results (r :scs (double-reg)))
1041 (:result-types double-float)
1042 (:note "complex float imagpart")
1046 ;;; hack dummy VOPs to bias the representation selection of their
1047 ;;; arguments towards a FP register, which can help avoid consing at
1048 ;;; inappropriate locations
1049 (defknown double-float-reg-bias (double-float) (values))
1050 (define-vop (double-float-reg-bias)
1051 (:translate double-float-reg-bias)
1052 (:args (x :scs (double-reg double-stack) :load-if nil))
1053 (:arg-types double-float)
1054 (:policy :fast-safe)
1055 (:note "inline dummy FP register bias")
1058 (defknown single-float-reg-bias (single-float) (values))
1059 (define-vop (single-float-reg-bias)
1060 (:translate single-float-reg-bias)
1061 (:args (x :scs (single-reg single-stack) :load-if nil))
1062 (:arg-types single-float)
1063 (:policy :fast-safe)
1064 (:note "inline dummy FP register bias")