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 ((frob (op sinst sname scost dinst dname dcost)
443 (define-vop (,sname single-float-op)
445 (:results (r :scs (single-reg)))
446 (:temporary (:sc single-reg) tmp)
451 (define-vop (,dname double-float-op)
453 (:results (r :scs (double-reg)))
454 (:temporary (:sc single-reg) tmp)
458 (inst movsd r tmp))))))
459 (frob + addss +/single-float 2 addsd +/double-float 2)
460 (frob - subss -/single-float 2 subsd -/double-float 2)
461 (frob * mulss */single-float 4 mulsd */double-float 5)
462 (frob / divss //single-float 12 divsd //double-float 19))
466 (macrolet ((frob ((name translate sc type) &body body)
468 (:args (x :scs (,sc)))
469 (:results (y :scs (,sc)))
470 (:translate ,translate)
473 (:result-types ,type)
474 (:temporary (:sc any-reg) hex8)
477 (:note "inline float arithmetic")
479 (:save-p :compute-only)
481 (note-this-location vop :internal-error)
482 ;; we should be able to do this better. what we
483 ;; really would like to do is use the target as the
484 ;; temp whenever it's not also the source
485 (unless (location= x y)
488 (frob (%negate/double-float %negate double-reg double-float)
489 (inst lea hex8 (make-ea :qword :disp 1))
490 (inst ror hex8 1) ; #x8000000000000000
493 (frob (%negate/single-float %negate single-reg single-float)
494 (inst lea hex8 (make-ea :qword :disp 1))
498 (frob (abs/double-float abs double-reg double-float)
503 (frob (abs/single-float abs single-reg single-float)
511 (define-vop (float-compare)
516 (:save-p :compute-only)
517 (:note "inline float comparison"))
519 ;;; comiss and comisd can cope with one or other arg in memory: we
520 ;;; could (should, indeed) extend these to cope with descriptor args
523 (define-vop (single-float-compare float-compare)
524 (:args (x :scs (single-reg)) (y :scs (single-reg)))
526 (:arg-types single-float single-float))
527 (define-vop (double-float-compare float-compare)
528 (:args (x :scs (double-reg)) (y :scs (double-reg)))
530 (:arg-types double-float double-float))
532 (define-vop (=/single-float single-float-compare)
537 (note-this-location vop :internal-error)
539 ;; if PF&CF, there was a NaN involved => not equal
540 ;; otherwise, ZF => equal
543 (inst jmp :ne target))
545 (let ((not-lab (gen-label)))
546 (inst jmp :p not-lab)
548 (emit-label not-lab))))))
550 (define-vop (=/double-float double-float-compare)
555 (note-this-location vop :internal-error)
559 (inst jmp :ne target))
561 (let ((not-lab (gen-label)))
562 (inst jmp :p not-lab)
564 (emit-label not-lab))))))
566 ;; XXX all of these probably have bad NaN behaviour
567 (define-vop (<double-float double-float-compare)
572 (inst jmp (if not-p :nc :c) target)))
574 (define-vop (<single-float single-float-compare)
579 (inst jmp (if not-p :nc :c) target)))
581 (define-vop (>double-float double-float-compare)
586 (inst jmp (if not-p :na :a) target)))
588 (define-vop (>single-float single-float-compare)
593 (inst jmp (if not-p :na :a) target)))
599 (macrolet ((frob (name translate inst to-sc to-type)
601 (:args (x :scs (signed-stack signed-reg) :target temp))
602 (:temporary (:sc signed-stack) temp)
603 (:results (y :scs (,to-sc)))
604 (:arg-types signed-num)
605 (:result-types ,to-type)
607 (:note "inline float coercion")
608 (:translate ,translate)
610 (:save-p :compute-only)
615 (note-this-location vop :internal-error)
618 (note-this-location vop :internal-error)
619 (inst ,inst y x)))))))
620 (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
621 (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
624 (macrolet ((frob (name translate inst to-sc to-type)
626 (:args (x :scs (unsigned-reg)))
627 (:results (y :scs (,to-sc)))
628 (:arg-types unsigned-num)
629 (:result-types ,to-type)
631 (:note "inline float coercion")
632 (:translate ,translate)
634 (:save-p :compute-only)
637 (frob %single-float/unsigned %single-float cvtsi2ss single-reg single-float)
638 (frob %double-float/unsigned %double-float cvtsi2sd double-reg double-float))
640 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
642 (:args (x :scs (,from-sc) :target y))
643 (:results (y :scs (,to-sc)))
644 (:arg-types ,from-type)
645 (:result-types ,to-type)
647 (:note "inline float coercion")
648 (:translate ,translate)
650 (:save-p :compute-only)
652 (note-this-location vop :internal-error)
654 (frob %single-float/double-float %single-float cvtsd2ss double-reg
655 double-float single-reg single-float)
657 (frob %double-float/single-float %double-float cvtss2sd
658 single-reg single-float double-reg double-float))
660 (macrolet ((frob (trans inst from-sc from-type round-p)
661 (declare (ignore round-p))
662 `(define-vop (,(symbolicate trans "/" from-type))
663 (:args (x :scs (,from-sc)))
664 (:temporary (:sc any-reg) temp-reg)
665 (:results (y :scs (signed-reg)))
666 (:arg-types ,from-type)
667 (:result-types signed-num)
670 (:note "inline float truncate")
672 (:save-p :compute-only)
676 (inst ,inst temp-reg x)
681 (frob %unary-truncate cvttss2si single-reg single-float nil)
682 (frob %unary-truncate cvttsd2si double-reg double-float nil)
684 (frob %unary-round cvtss2si single-reg single-float t)
685 (frob %unary-round cvtsd2si double-reg double-float t))
687 #+nil ;; will we need this?
688 (macrolet ((frob (trans from-sc from-type round-p)
689 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
690 (:args (x :scs (,from-sc) :target fr0))
691 (:temporary (:sc double-reg :offset fr0-offset
692 :from :argument :to :result) fr0)
694 '((:temporary (:sc unsigned-stack) stack-temp)
695 (:temporary (:sc unsigned-stack) scw)
696 (:temporary (:sc any-reg) rcw)))
697 (:results (y :scs (unsigned-reg)))
698 (:arg-types ,from-type)
699 (:result-types unsigned-num)
702 (:note "inline float truncate")
704 (:save-p :compute-only)
707 '((note-this-location vop :internal-error)
708 ;; Catch any pending FPE exceptions.
710 ;; Normal mode (for now) is "round to best".
711 (unless (zerop (tn-offset x))
712 (copy-fp-reg-to-fr0 x))
714 '((inst fnstcw scw) ; save current control word
715 (move rcw scw) ; into 16-bit register
716 (inst or rcw (ash #b11 10)) ; CHOP
717 (move stack-temp rcw)
718 (inst fldcw stack-temp)))
720 (inst fistpl (make-ea :dword :base rsp-tn))
722 (inst fld fr0) ; copy fr0 to at least restore stack.
725 '((inst fldcw scw)))))))
726 (frob %unary-truncate single-reg single-float nil)
727 (frob %unary-truncate double-reg double-float nil)
728 (frob %unary-round single-reg single-float t)
729 (frob %unary-round double-reg double-float t))
731 (define-vop (make-single-float)
732 (:args (bits :scs (signed-reg) :target res
733 :load-if (not (or (and (sc-is bits signed-stack)
734 (sc-is res single-reg))
735 (and (sc-is bits signed-stack)
736 (sc-is res single-stack)
737 (location= bits res))))))
738 (:results (res :scs (single-reg single-stack)))
739 ; (:temporary (:sc signed-stack) stack-temp)
740 (:arg-types signed-num)
741 (:result-types single-float)
742 (:translate make-single-float)
752 (aver (location= bits res)))))
756 (inst movd res bits))
758 (inst movd res bits)))))))
760 (define-vop (make-double-float)
761 (:args (hi-bits :scs (signed-reg))
762 (lo-bits :scs (unsigned-reg)))
763 (:results (res :scs (double-reg)))
764 (:temporary (:sc unsigned-reg) temp)
765 (:arg-types signed-num unsigned-num)
766 (:result-types double-float)
767 (:translate make-double-float)
773 (inst or temp lo-bits)
774 (inst movd res temp)))
776 (define-vop (single-float-bits)
777 (:args (float :scs (single-reg descriptor-reg)
778 :load-if (not (sc-is float single-stack))))
779 (:results (bits :scs (signed-reg)))
780 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
781 (:arg-types single-float)
782 (:result-types signed-num)
783 (:translate single-float-bits)
791 (inst movss stack-temp float)
792 (move bits stack-temp))
797 bits float single-float-value-slot
798 other-pointer-lowtag))))
802 (inst movss bits float)))))
807 (define-vop (double-float-high-bits)
808 (:args (float :scs (double-reg descriptor-reg)
809 :load-if (not (sc-is float double-stack))))
810 (:results (hi-bits :scs (signed-reg)))
811 (:temporary (:sc signed-stack :from :argument :to :result) temp)
812 (:arg-types double-float)
813 (:result-types signed-num)
814 (:translate double-float-high-bits)
820 (inst movsd temp float)
823 (loadw hi-bits ebp-tn (- (tn-offset float))))
825 (loadw hi-bits float double-float-value-slot
826 other-pointer-lowtag)))
827 (inst sar hi-bits 32)))
829 (define-vop (double-float-low-bits)
830 (:args (float :scs (double-reg descriptor-reg)
831 :load-if (not (sc-is float double-stack))))
832 (:results (lo-bits :scs (unsigned-reg)))
833 (:temporary (:sc signed-stack :from :argument :to :result) temp)
834 (:arg-types double-float)
835 (:result-types unsigned-num)
836 (:translate double-float-low-bits)
842 (inst movsd temp float)
845 (loadw lo-bits ebp-tn (- (tn-offset float))))
847 (loadw lo-bits float double-float-value-slot
848 other-pointer-lowtag)))
849 (inst shl lo-bits 32)
850 (inst shr lo-bits 32)))
853 ;;;; float mode hackery
855 (sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
856 (defknown floating-point-modes () float-modes (flushable))
857 (defknown ((setf floating-point-modes)) (float-modes)
860 (def!constant npx-env-size (* 7 n-word-bytes))
861 (def!constant npx-cw-offset 0)
862 (def!constant npx-sw-offset 4)
864 (define-vop (floating-point-modes)
865 (:results (res :scs (unsigned-reg)))
866 (:result-types unsigned-num)
867 (:translate floating-point-modes)
869 (:temporary (:sc unsigned-reg :offset eax-offset :target res
872 (inst sub rsp-tn npx-env-size) ; Make space on stack.
873 (inst wait) ; Catch any pending FPE exceptions
874 (inst fstenv (make-ea :dword :base rsp-tn)) ; masks all exceptions
875 (inst fldenv (make-ea :dword :base rsp-tn)) ; Restore previous state.
876 ;; Move current status to high word.
877 (inst movzxd eax (make-ea :dword :base rsp-tn :disp (- npx-sw-offset 2)))
878 ;; Move exception mask to low word.
879 (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset))
880 (inst add rsp-tn npx-env-size) ; Pop stack.
881 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
885 (define-vop (set-floating-point-modes)
886 (:args (new :scs (unsigned-reg) :to :result :target res))
887 (:results (res :scs (unsigned-reg)))
888 (:arg-types unsigned-num)
889 (:result-types unsigned-num)
890 (:translate (setf floating-point-modes))
892 (:temporary (:sc unsigned-reg :offset eax-offset
893 :from :eval :to :result) eax)
895 (inst sub rsp-tn npx-env-size) ; Make space on stack.
896 (inst wait) ; Catch any pending FPE exceptions.
897 (inst fstenv (make-ea :dword :base rsp-tn))
899 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
900 (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn)
901 (inst shr eax 16) ; position status word
902 (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn)
903 (inst fldenv (make-ea :dword :base rsp-tn))
904 (inst add rsp-tn npx-env-size) ; Pop stack.
908 ;;;; complex float VOPs
910 (define-vop (make-complex-single-float)
912 (:args (real :scs (single-reg) :to :result :target r
913 :load-if (not (location= real r)))
914 (imag :scs (single-reg) :to :save))
915 (:arg-types single-float single-float)
916 (:results (r :scs (complex-single-reg) :from (:argument 0)
917 :load-if (not (sc-is r complex-single-stack))))
918 (:result-types complex-single-float)
919 (:note "inline complex single-float creation")
924 (let ((r-real (complex-single-reg-real-tn r)))
925 (unless (location= real r-real)
926 (inst movss r-real real)))
927 (let ((r-imag (complex-single-reg-imag-tn r)))
928 (unless (location= imag r-imag)
929 (inst movss r-imag imag))))
930 (complex-single-stack
931 (inst movss (ea-for-csf-real-stack r) real)
932 (inst movss (ea-for-csf-imag-stack r) imag)))))
934 (define-vop (make-complex-double-float)
936 (:args (real :scs (double-reg) :target r
937 :load-if (not (location= real r)))
938 (imag :scs (double-reg) :to :save))
939 (:arg-types double-float double-float)
940 (:results (r :scs (complex-double-reg) :from (:argument 0)
941 :load-if (not (sc-is r complex-double-stack))))
942 (:result-types complex-double-float)
943 (:note "inline complex double-float creation")
948 (let ((r-real (complex-double-reg-real-tn r)))
949 (unless (location= real r-real)
950 (inst movsd r-real real)))
951 (let ((r-imag (complex-double-reg-imag-tn r)))
952 (unless (location= imag r-imag)
953 (inst movsd r-imag imag))))
954 (complex-double-stack
955 (inst movsd (ea-for-cdf-real-stack r) real)
956 (inst movsd (ea-for-cdf-imag-stack r) imag)))))
958 (define-vop (complex-float-value)
959 (:args (x :target r))
961 (:variant-vars offset)
964 (cond ((sc-is x complex-single-reg complex-double-reg)
966 (make-random-tn :kind :normal
967 :sc (sc-or-lose 'double-reg)
968 :offset (+ offset (tn-offset x)))))
969 (unless (location= value-tn r)
970 (if (sc-is x complex-single-reg)
971 (inst movss r value-tn)
972 (inst movsd r value-tn)))))
973 ((sc-is r single-reg)
975 (complex-single-stack
977 (0 (ea-for-csf-real-stack x))
978 (1 (ea-for-csf-imag-stack x))))
981 (0 (ea-for-csf-real-desc x))
982 (1 (ea-for-csf-imag-desc x)))))))
984 ((sc-is r double-reg)
986 (complex-double-stack
988 (0 (ea-for-cdf-real-stack x))
989 (1 (ea-for-cdf-imag-stack x))))
992 (0 (ea-for-cdf-real-desc x))
993 (1 (ea-for-cdf-imag-desc x)))))))
995 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
997 (define-vop (realpart/complex-single-float complex-float-value)
998 (:translate realpart)
999 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1001 (:arg-types complex-single-float)
1002 (:results (r :scs (single-reg)))
1003 (:result-types single-float)
1004 (:note "complex float realpart")
1007 (define-vop (realpart/complex-double-float complex-float-value)
1008 (:translate realpart)
1009 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1011 (:arg-types complex-double-float)
1012 (:results (r :scs (double-reg)))
1013 (:result-types double-float)
1014 (:note "complex float realpart")
1017 (define-vop (imagpart/complex-single-float complex-float-value)
1018 (:translate imagpart)
1019 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1021 (:arg-types complex-single-float)
1022 (:results (r :scs (single-reg)))
1023 (:result-types single-float)
1024 (:note "complex float imagpart")
1027 (define-vop (imagpart/complex-double-float complex-float-value)
1028 (:translate imagpart)
1029 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1031 (:arg-types complex-double-float)
1032 (:results (r :scs (double-reg)))
1033 (:result-types double-float)
1034 (:note "complex float imagpart")
1038 ;;; hack dummy VOPs to bias the representation selection of their
1039 ;;; arguments towards a FP register, which can help avoid consing at
1040 ;;; inappropriate locations
1041 (defknown double-float-reg-bias (double-float) (values))
1042 (define-vop (double-float-reg-bias)
1043 (:translate double-float-reg-bias)
1044 (:args (x :scs (double-reg double-stack) :load-if nil))
1045 (:arg-types double-float)
1046 (:policy :fast-safe)
1047 (:note "inline dummy FP register bias")
1050 (defknown single-float-reg-bias (single-float) (values))
1051 (define-vop (single-float-reg-bias)
1052 (:translate single-float-reg-bias)
1053 (:args (x :scs (single-reg single-stack) :load-if nil))
1054 (:arg-types single-float)
1055 (:policy :fast-safe)
1056 (:note "inline dummy FP register bias")