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 ;;; Telling the FPU to wait is required in order to make signals occur
43 ;;; at the expected place, but naturally slows things down.
45 ;;; NODE is the node whose compilation policy controls the decision
46 ;;; whether to just blast through carelessly or carefully emit wait
47 ;;; instructions and whatnot.
49 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
50 ;;; #'NOTE-NEXT-INSTRUCTION.
51 (defun maybe-fp-wait (node &optional note-next-instruction)
52 (when (policy node (or (= debug 3) (> safety speed))))
53 (when note-next-instruction
54 (note-next-instruction note-next-instruction :internal-error))
58 ;;; complex float stack EAs
59 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
60 (declare (ignore kind))
63 :disp (- (* (+ (tn-offset ,tn)
64 (* 1 (ecase ,slot (:real 1) (:imag 2))))
66 (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
67 (ea-for-cxf-stack tn :single :real base))
68 (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
69 (ea-for-cxf-stack tn :single :imag base))
70 (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
71 (ea-for-cxf-stack tn :double :real base))
72 (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
73 (ea-for-cxf-stack tn :double :imag base)))
78 ;;; X is source, Y is destination.
80 (define-move-fun (load-fp-zero 1) (vop x y)
81 ((fp-single-zero) (single-reg)
82 (fp-double-zero) (double-reg))
83 (identity x) ; KLUDGE: IDENTITY as IGNORABLE...
84 (inst movq y fp-double-zero-tn))
86 (define-move-fun (load-single 2) (vop x y)
87 ((single-stack) (single-reg))
88 (inst movss y (ea-for-sf-stack x)))
90 (define-move-fun (store-single 2) (vop x y)
91 ((single-reg) (single-stack))
92 (inst movss (ea-for-sf-stack y) x))
94 (define-move-fun (load-double 2) (vop x y)
95 ((double-stack) (double-reg))
96 (inst movsd y (ea-for-df-stack x)))
98 (define-move-fun (store-double 2) (vop x y)
99 ((double-reg) (double-stack))
100 (inst movsd (ea-for-df-stack y) x))
102 (eval-when (:compile-toplevel :execute)
103 (setf *read-default-float-format* 'single-float))
105 ;;;; complex float move functions
107 (defun complex-single-reg-real-tn (x)
108 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
109 :offset (tn-offset x)))
110 (defun complex-single-reg-imag-tn (x)
111 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
112 :offset (1+ (tn-offset x))))
114 (defun complex-double-reg-real-tn (x)
115 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
116 :offset (tn-offset x)))
117 (defun complex-double-reg-imag-tn (x)
118 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
119 :offset (1+ (tn-offset x))))
121 ;;; X is source, Y is destination.
122 (define-move-fun (load-complex-single 2) (vop x y)
123 ((complex-single-stack) (complex-single-reg))
124 (let ((real-tn (complex-single-reg-real-tn y)))
125 (inst movss real-tn (ea-for-csf-real-stack x)))
126 (let ((imag-tn (complex-single-reg-imag-tn y)))
127 (inst movss imag-tn (ea-for-csf-imag-stack x))))
129 (define-move-fun (store-complex-single 2) (vop x y)
130 ((complex-single-reg) (complex-single-stack))
131 (let ((real-tn (complex-single-reg-real-tn x))
132 (imag-tn (complex-single-reg-imag-tn x)))
133 (inst movss (ea-for-csf-real-stack y) real-tn)
134 (inst movss (ea-for-csf-imag-stack y) imag-tn)))
136 (define-move-fun (load-complex-double 2) (vop x y)
137 ((complex-double-stack) (complex-double-reg))
138 (let ((real-tn (complex-double-reg-real-tn y)))
139 (inst movsd real-tn (ea-for-cdf-real-stack x)))
140 (let ((imag-tn (complex-double-reg-imag-tn y)))
141 (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
143 (define-move-fun (store-complex-double 2) (vop x y)
144 ((complex-double-reg) (complex-double-stack))
145 (let ((real-tn (complex-double-reg-real-tn x))
146 (imag-tn (complex-double-reg-imag-tn x)))
147 (inst movsd (ea-for-cdf-real-stack y) real-tn)
148 (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
153 ;;; float register to register moves
154 (macrolet ((frob (vop sc)
159 :load-if (not (location= x y))))
160 (:results (y :scs (,sc)
161 :load-if (not (location= x y))))
164 (unless (location= y x)
166 (define-move-vop ,vop :move (,sc) (,sc)))))
167 (frob single-move single-reg)
168 (frob double-move double-reg))
170 ;;; complex float register to register moves
171 (define-vop (complex-float-move)
172 (:args (x :target y :load-if (not (location= x y))))
173 (:results (y :load-if (not (location= x y))))
174 (:note "complex float move")
176 (unless (location= x y)
177 ;; Note the complex-float-regs are aligned to every second
178 ;; float register so there is not need to worry about overlap.
179 ;; (It would be better to put the imagpart in the top half of the
180 ;; register, or something, but let's worry about that later)
181 (let ((x-real (complex-single-reg-real-tn x))
182 (y-real (complex-single-reg-real-tn y)))
183 (inst movq y-real x-real))
184 (let ((x-imag (complex-single-reg-imag-tn x))
185 (y-imag (complex-single-reg-imag-tn y)))
186 (inst movq y-imag x-imag)))))
188 (define-vop (complex-single-move complex-float-move)
189 (:args (x :scs (complex-single-reg) :target y
190 :load-if (not (location= x y))))
191 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
192 (define-move-vop complex-single-move :move
193 (complex-single-reg) (complex-single-reg))
195 (define-vop (complex-double-move complex-float-move)
196 (:args (x :scs (complex-double-reg)
197 :target y :load-if (not (location= x y))))
198 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
199 (define-move-vop complex-double-move :move
200 (complex-double-reg) (complex-double-reg))
203 ;;; Move from float to a descriptor reg. allocating a new float
204 ;;; object in the process.
205 (define-vop (move-from-single)
206 (:args (x :scs (single-reg) :to :save))
207 (:results (y :scs (descriptor-reg)))
208 (:note "float to pointer coercion")
212 (inst or y single-float-widetag)))
214 (define-move-vop move-from-single :move
215 (single-reg) (descriptor-reg))
217 (define-vop (move-from-double)
218 (:args (x :scs (double-reg) :to :save))
219 (:results (y :scs (descriptor-reg)))
221 (:note "float to pointer coercion")
223 (with-fixed-allocation (y
227 (inst movsd (ea-for-df-desc y) x))))
228 (define-move-vop move-from-double :move
229 (double-reg) (descriptor-reg))
232 (define-vop (move-from-fp-constant)
233 (:args (x :scs (fp-constant)))
234 (:results (y :scs (descriptor-reg)))
236 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
237 (0f0 (load-symbol-value y *fp-constant-0f0*))
238 (1f0 (load-symbol-value y *fp-constant-1f0*))
239 (0d0 (load-symbol-value y *fp-constant-0d0*))
240 (1d0 (load-symbol-value y *fp-constant-1d0*)))))
242 (define-move-vop move-from-fp-constant :move
243 (fp-constant) (descriptor-reg))
245 ;;; Move from a descriptor to a float register.
246 (define-vop (move-to-single)
247 (:args (x :scs (descriptor-reg) :target tmp))
248 (:temporary (:sc unsigned-reg) tmp)
249 (:results (y :scs (single-reg)))
250 (:note "pointer to float coercion")
256 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
258 (define-vop (move-to-double)
259 (:args (x :scs (descriptor-reg)))
260 (:results (y :scs (double-reg)))
261 (:note "pointer to float coercion")
263 (inst movsd y (ea-for-df-desc x))))
264 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
267 ;;; Move from complex float to a descriptor reg. allocating a new
268 ;;; complex float object in the process.
269 (define-vop (move-from-complex-single)
270 (:args (x :scs (complex-single-reg) :to :save))
271 (:results (y :scs (descriptor-reg)))
273 (:note "complex float to pointer coercion")
275 (with-fixed-allocation (y
276 complex-single-float-widetag
277 complex-single-float-size
279 (let ((real-tn (complex-single-reg-real-tn x)))
280 (inst movss (ea-for-csf-real-desc y) real-tn))
281 (let ((imag-tn (complex-single-reg-imag-tn x)))
282 (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
283 (define-move-vop move-from-complex-single :move
284 (complex-single-reg) (descriptor-reg))
286 (define-vop (move-from-complex-double)
287 (:args (x :scs (complex-double-reg) :to :save))
288 (:results (y :scs (descriptor-reg)))
290 (:note "complex float to pointer coercion")
292 (with-fixed-allocation (y
293 complex-double-float-widetag
294 complex-double-float-size
296 (let ((real-tn (complex-double-reg-real-tn x)))
297 (inst movsd (ea-for-cdf-real-desc y) real-tn))
298 (let ((imag-tn (complex-double-reg-imag-tn x)))
299 (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
300 (define-move-vop move-from-complex-double :move
301 (complex-double-reg) (descriptor-reg))
303 ;;; Move from a descriptor to a complex float register.
304 (macrolet ((frob (name sc format)
307 (:args (x :scs (descriptor-reg)))
308 (:results (y :scs (,sc)))
309 (:note "pointer to complex float coercion")
311 (let ((real-tn (complex-double-reg-real-tn y)))
315 '((inst movss real-tn (ea-for-csf-real-desc x))))
317 '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
318 (let ((imag-tn (complex-double-reg-imag-tn y)))
322 '((inst movss imag-tn (ea-for-csf-imag-desc x))))
324 '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
325 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
326 (frob move-to-complex-single complex-single-reg :single)
327 (frob move-to-complex-double complex-double-reg :double))
329 ;;;; the move argument vops
331 ;;;; Note these are also used to stuff fp numbers onto the c-call
332 ;;;; stack so the order is different than the lisp-stack.
334 ;;; the general MOVE-ARG VOP
335 (macrolet ((frob (name sc stack-sc format)
338 (:args (x :scs (,sc) :target y)
340 :load-if (not (sc-is y ,sc))))
342 (:note "float argument move")
343 (:generator ,(case format (:single 2) (:double 3) )
346 (unless (location= x y)
349 (if (= (tn-offset fp) esp-offset)
350 (let* ((offset (* (tn-offset y) n-word-bytes))
351 (ea (make-ea :dword :base fp :disp offset)))
353 (:single '((inst movss ea x)))
354 (:double '((inst movsd ea x)))))
357 :disp (- (* (+ (tn-offset y)
364 (:single '((inst movss ea x)))
365 (:double '((inst movsd ea x)))))))))))
366 (define-move-vop ,name :move-arg
367 (,sc descriptor-reg) (,sc)))))
368 (frob move-single-float-arg single-reg single-stack :single)
369 (frob move-double-float-arg double-reg double-stack :double))
371 ;;;; complex float MOVE-ARG VOP
372 (macrolet ((frob (name sc stack-sc format)
375 (:args (x :scs (,sc) :target y)
377 :load-if (not (sc-is y ,sc))))
379 (:note "complex float argument move")
380 (:generator ,(ecase format (:single 2) (:double 3))
383 (unless (location= x y)
384 (let ((x-real (complex-double-reg-real-tn x))
385 (y-real (complex-double-reg-real-tn y)))
386 (inst movsd y-real x-real))
387 (let ((x-imag (complex-double-reg-imag-tn x))
388 (y-imag (complex-double-reg-imag-tn y)))
389 (inst movsd y-imag x-imag))))
391 (let ((real-tn (complex-double-reg-real-tn x)))
395 (ea-for-csf-real-stack y fp)
399 (ea-for-cdf-real-stack y fp)
401 (let ((imag-tn (complex-double-reg-imag-tn x)))
405 (ea-for-csf-imag-stack y fp) imag-tn)))
408 (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
409 (define-move-vop ,name :move-arg
410 (,sc descriptor-reg) (,sc)))))
411 (frob move-complex-single-float-arg
412 complex-single-reg complex-single-stack :single)
413 (frob move-complex-double-float-arg
414 complex-double-reg complex-double-stack :double))
416 (define-move-vop move-arg :move-arg
417 (single-reg double-reg
418 complex-single-reg complex-double-reg)
424 (define-vop (float-op)
428 (:note "inline float arithmetic")
430 (:save-p :compute-only))
432 (macrolet ((frob (name sc ptype)
433 `(define-vop (,name float-op)
434 (:args (x :scs (,sc) :target r)
436 (:results (r :scs (,sc)))
437 (:arg-types ,ptype ,ptype)
438 (:result-types ,ptype))))
439 (frob single-float-op single-reg single-float)
440 (frob double-float-op double-reg double-float))
442 (macrolet ((generate (movinst opinst commutative)
447 ((and ,commutative (location= y r))
449 ((not (location= r y))
453 (inst ,movinst tmp x)
455 (inst ,movinst r tmp)))))
456 (frob (op sinst sname scost dinst dname dcost commutative)
458 (define-vop (,sname single-float-op)
460 (:temporary (:sc single-reg) tmp)
462 (generate movss ,sinst ,commutative)))
463 (define-vop (,dname double-float-op)
465 (:temporary (:sc single-reg) tmp)
467 (generate movsd ,dinst ,commutative))))))
468 (frob + addss +/single-float 2 addsd +/double-float 2 t)
469 (frob - subss -/single-float 2 subsd -/double-float 2 nil)
470 (frob * mulss */single-float 4 mulsd */double-float 5 t)
471 (frob / divss //single-float 12 divsd //double-float 19 nil))
475 (macrolet ((frob ((name translate sc type) &body body)
477 (:args (x :scs (,sc)))
478 (:results (y :scs (,sc)))
479 (:translate ,translate)
482 (:result-types ,type)
483 (:temporary (:sc any-reg) hex8)
486 (:note "inline float arithmetic")
488 (:save-p :compute-only)
490 (note-this-location vop :internal-error)
491 ;; we should be able to do this better. what we
492 ;; really would like to do is use the target as the
493 ;; temp whenever it's not also the source
494 (unless (location= x y)
497 (frob (%negate/double-float %negate double-reg double-float)
498 (inst lea hex8 (make-ea :qword :disp 1))
499 (inst ror hex8 1) ; #x8000000000000000
502 (frob (%negate/single-float %negate single-reg single-float)
503 (inst lea hex8 (make-ea :qword :disp 1))
507 (frob (abs/double-float abs double-reg double-float)
512 (frob (abs/single-float abs single-reg single-float)
520 (define-vop (float-compare)
525 (:save-p :compute-only)
526 (:note "inline float comparison"))
528 ;;; comiss and comisd can cope with one or other arg in memory: we
529 ;;; could (should, indeed) extend these to cope with descriptor args
532 (define-vop (single-float-compare float-compare)
533 (:args (x :scs (single-reg)) (y :scs (single-reg)))
535 (:arg-types single-float single-float))
536 (define-vop (double-float-compare float-compare)
537 (:args (x :scs (double-reg)) (y :scs (double-reg)))
539 (:arg-types double-float double-float))
541 (define-vop (=/single-float single-float-compare)
546 (note-this-location vop :internal-error)
548 ;; if PF&CF, there was a NaN involved => not equal
549 ;; otherwise, ZF => equal
552 (inst jmp :ne target))
554 (let ((not-lab (gen-label)))
555 (inst jmp :p not-lab)
557 (emit-label not-lab))))))
559 (define-vop (=/double-float double-float-compare)
564 (note-this-location vop :internal-error)
568 (inst jmp :ne target))
570 (let ((not-lab (gen-label)))
571 (inst jmp :p not-lab)
573 (emit-label not-lab))))))
575 ;; XXX all of these probably have bad NaN behaviour
576 (define-vop (<double-float double-float-compare)
581 (inst jmp (if not-p :nc :c) target)))
583 (define-vop (<single-float single-float-compare)
588 (inst jmp (if not-p :nc :c) target)))
590 (define-vop (>double-float double-float-compare)
595 (inst jmp (if not-p :na :a) target)))
597 (define-vop (>single-float single-float-compare)
602 (inst jmp (if not-p :na :a) target)))
608 (macrolet ((frob (name translate inst to-sc to-type)
610 (:args (x :scs (signed-stack signed-reg) :target temp))
611 (:temporary (:sc signed-stack) temp)
612 (:results (y :scs (,to-sc)))
613 (:arg-types signed-num)
614 (:result-types ,to-type)
616 (:note "inline float coercion")
617 (:translate ,translate)
619 (:save-p :compute-only)
624 (note-this-location vop :internal-error)
627 (note-this-location vop :internal-error)
628 (inst ,inst y x)))))))
629 (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
630 (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
633 (macrolet ((frob (name translate inst to-sc to-type)
635 (:args (x :scs (unsigned-reg)))
636 (:results (y :scs (,to-sc)))
637 (:arg-types unsigned-num)
638 (:result-types ,to-type)
640 (:note "inline float coercion")
641 (:translate ,translate)
643 (:save-p :compute-only)
646 (frob %single-float/unsigned %single-float cvtsi2ss single-reg single-float)
647 (frob %double-float/unsigned %double-float cvtsi2sd double-reg double-float))
649 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
651 (:args (x :scs (,from-sc) :target y))
652 (:results (y :scs (,to-sc)))
653 (:arg-types ,from-type)
654 (:result-types ,to-type)
656 (:note "inline float coercion")
657 (:translate ,translate)
659 (:save-p :compute-only)
661 (note-this-location vop :internal-error)
663 (frob %single-float/double-float %single-float cvtsd2ss double-reg
664 double-float single-reg single-float)
666 (frob %double-float/single-float %double-float cvtss2sd
667 single-reg single-float double-reg double-float))
669 (macrolet ((frob (trans inst from-sc from-type round-p)
670 (declare (ignore round-p))
671 `(define-vop (,(symbolicate trans "/" from-type))
672 (:args (x :scs (,from-sc)))
673 (:temporary (:sc any-reg) temp-reg)
674 (:results (y :scs (signed-reg)))
675 (:arg-types ,from-type)
676 (:result-types signed-num)
679 (:note "inline float truncate")
681 (:save-p :compute-only)
685 (inst ,inst temp-reg x)
690 (frob %unary-truncate cvttss2si single-reg single-float nil)
691 (frob %unary-truncate cvttsd2si double-reg double-float nil)
693 (frob %unary-round cvtss2si single-reg single-float t)
694 (frob %unary-round cvtsd2si double-reg double-float t))
696 #+nil ;; will we need this?
697 (macrolet ((frob (trans from-sc from-type round-p)
698 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
699 (:args (x :scs (,from-sc) :target fr0))
700 (:temporary (:sc double-reg :offset fr0-offset
701 :from :argument :to :result) fr0)
703 '((:temporary (:sc unsigned-stack) stack-temp)
704 (:temporary (:sc unsigned-stack) scw)
705 (:temporary (:sc any-reg) rcw)))
706 (:results (y :scs (unsigned-reg)))
707 (:arg-types ,from-type)
708 (:result-types unsigned-num)
711 (:note "inline float truncate")
713 (:save-p :compute-only)
716 '((note-this-location vop :internal-error)
717 ;; Catch any pending FPE exceptions.
719 ;; Normal mode (for now) is "round to best".
720 (unless (zerop (tn-offset x))
721 (copy-fp-reg-to-fr0 x))
723 '((inst fnstcw scw) ; save current control word
724 (move rcw scw) ; into 16-bit register
725 (inst or rcw (ash #b11 10)) ; CHOP
726 (move stack-temp rcw)
727 (inst fldcw stack-temp)))
729 (inst fistpl (make-ea :dword :base rsp-tn))
731 (inst fld fr0) ; copy fr0 to at least restore stack.
734 '((inst fldcw scw)))))))
735 (frob %unary-truncate single-reg single-float nil)
736 (frob %unary-truncate double-reg double-float nil)
737 (frob %unary-round single-reg single-float t)
738 (frob %unary-round double-reg double-float t))
740 (define-vop (make-single-float)
741 (:args (bits :scs (signed-reg) :target res
742 :load-if (not (or (and (sc-is bits signed-stack)
743 (sc-is res single-reg))
744 (and (sc-is bits signed-stack)
745 (sc-is res single-stack)
746 (location= bits res))))))
747 (:results (res :scs (single-reg single-stack)))
748 ; (:temporary (:sc signed-stack) stack-temp)
749 (:arg-types signed-num)
750 (:result-types single-float)
751 (:translate make-single-float)
761 (aver (location= bits res)))))
765 (inst movd res bits))
767 (inst movd res bits)))))))
769 (define-vop (make-double-float)
770 (:args (hi-bits :scs (signed-reg))
771 (lo-bits :scs (unsigned-reg)))
772 (:results (res :scs (double-reg)))
773 (:temporary (:sc unsigned-reg) temp)
774 (:arg-types signed-num unsigned-num)
775 (:result-types double-float)
776 (:translate make-double-float)
782 (inst or temp lo-bits)
783 (inst movd res temp)))
785 (define-vop (single-float-bits)
786 (:args (float :scs (single-reg descriptor-reg)
787 :load-if (not (sc-is float single-stack))))
788 (:results (bits :scs (signed-reg)))
789 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
790 (:arg-types single-float)
791 (:result-types signed-num)
792 (:translate single-float-bits)
800 (inst movss stack-temp float)
801 (move bits stack-temp))
806 (inst shr bits 32))))
810 (inst movss bits float)))))
815 (define-vop (double-float-high-bits)
816 (:args (float :scs (double-reg descriptor-reg)
817 :load-if (not (sc-is float double-stack))))
818 (:results (hi-bits :scs (signed-reg)))
819 (:temporary (:sc signed-stack :from :argument :to :result) temp)
820 (:arg-types double-float)
821 (:result-types signed-num)
822 (:translate double-float-high-bits)
828 (inst movsd temp float)
831 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
833 (loadw hi-bits float double-float-value-slot
834 other-pointer-lowtag)))
835 (inst sar hi-bits 32)))
837 (define-vop (double-float-low-bits)
838 (:args (float :scs (double-reg descriptor-reg)
839 :load-if (not (sc-is float double-stack))))
840 (:results (lo-bits :scs (unsigned-reg)))
841 (:temporary (:sc signed-stack :from :argument :to :result) temp)
842 (:arg-types double-float)
843 (:result-types unsigned-num)
844 (:translate double-float-low-bits)
850 (inst movsd temp float)
853 (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
855 (loadw lo-bits float double-float-value-slot
856 other-pointer-lowtag)))
857 (inst shl lo-bits 32)
858 (inst shr lo-bits 32)))
861 ;;;; float mode hackery
863 (sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
864 (defknown floating-point-modes () float-modes (flushable))
865 (defknown ((setf floating-point-modes)) (float-modes)
868 (define-vop (floating-point-modes)
869 (:results (res :scs (unsigned-reg)))
870 (:result-types unsigned-num)
871 (:translate floating-point-modes)
873 (:temporary (:sc unsigned-stack :from :argument :to :result) temp)
877 ;; Extract status from bytes 0-5 to bytes 16-21
878 (inst and temp (1- (expt 2 6)))
880 ;; Extract mask from bytes 7-12 to bytes 0-5
882 (inst and res (1- (expt 2 6)))
883 ;; Flip the bits to convert from "1 means exception masked" to
884 ;; "1 means exception enabled".
885 (inst xor res (1- (expt 2 6)))
888 (define-vop (set-floating-point-modes)
889 (:args (new :scs (unsigned-reg) :to :result :target res))
890 (:results (res :scs (unsigned-reg)))
891 (:arg-types unsigned-num)
892 (:result-types unsigned-num)
893 (:translate (setf floating-point-modes))
895 (:temporary (:sc unsigned-reg :from :argument :to :result) temp1)
896 (:temporary (:sc unsigned-stack :from :argument :to :result) temp2)
900 ;; Clear status + masks
901 (inst and temp2 (lognot (logior (1- (expt 2 6))
902 (ash (1- (expt 2 6)) 7))))
903 ;; Replace current status
906 (inst and temp1 (1- (expt 2 6)))
907 (inst or temp2 temp1)
908 ;; Replace exception masks
910 (inst and temp1 (1- (expt 2 6)))
911 (inst xor temp1 (1- (expt 2 6)))
913 (inst or temp2 temp1)
914 (inst ldmxcsr temp2)))
917 ;;;; complex float VOPs
919 (define-vop (make-complex-single-float)
921 (:args (real :scs (single-reg) :to :result :target r
922 :load-if (not (location= real r)))
923 (imag :scs (single-reg) :to :save))
924 (:arg-types single-float single-float)
925 (:results (r :scs (complex-single-reg) :from (:argument 0)
926 :load-if (not (sc-is r complex-single-stack))))
927 (:result-types complex-single-float)
928 (:note "inline complex single-float creation")
933 (let ((r-real (complex-single-reg-real-tn r)))
934 (unless (location= real r-real)
935 (inst movss r-real real)))
936 (let ((r-imag (complex-single-reg-imag-tn r)))
937 (unless (location= imag r-imag)
938 (inst movss r-imag imag))))
939 (complex-single-stack
940 (inst movss (ea-for-csf-real-stack r) real)
941 (inst movss (ea-for-csf-imag-stack r) imag)))))
943 (define-vop (make-complex-double-float)
945 (:args (real :scs (double-reg) :target r
946 :load-if (not (location= real r)))
947 (imag :scs (double-reg) :to :save))
948 (:arg-types double-float double-float)
949 (:results (r :scs (complex-double-reg) :from (:argument 0)
950 :load-if (not (sc-is r complex-double-stack))))
951 (:result-types complex-double-float)
952 (:note "inline complex double-float creation")
957 (let ((r-real (complex-double-reg-real-tn r)))
958 (unless (location= real r-real)
959 (inst movsd r-real real)))
960 (let ((r-imag (complex-double-reg-imag-tn r)))
961 (unless (location= imag r-imag)
962 (inst movsd r-imag imag))))
963 (complex-double-stack
964 (inst movsd (ea-for-cdf-real-stack r) real)
965 (inst movsd (ea-for-cdf-imag-stack r) imag)))))
967 (define-vop (complex-float-value)
968 (:args (x :target r))
970 (:variant-vars offset)
973 (cond ((sc-is x complex-single-reg complex-double-reg)
975 (make-random-tn :kind :normal
976 :sc (sc-or-lose 'double-reg)
977 :offset (+ offset (tn-offset x)))))
978 (unless (location= value-tn r)
979 (if (sc-is x complex-single-reg)
980 (inst movss r value-tn)
981 (inst movsd r value-tn)))))
982 ((sc-is r single-reg)
984 (complex-single-stack
986 (0 (ea-for-csf-real-stack x))
987 (1 (ea-for-csf-imag-stack x))))
990 (0 (ea-for-csf-real-desc x))
991 (1 (ea-for-csf-imag-desc x)))))))
993 ((sc-is r double-reg)
995 (complex-double-stack
997 (0 (ea-for-cdf-real-stack x))
998 (1 (ea-for-cdf-imag-stack x))))
1001 (0 (ea-for-cdf-real-desc x))
1002 (1 (ea-for-cdf-imag-desc x)))))))
1004 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
1006 (define-vop (realpart/complex-single-float complex-float-value)
1007 (:translate realpart)
1008 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1010 (:arg-types complex-single-float)
1011 (:results (r :scs (single-reg)))
1012 (:result-types single-float)
1013 (:note "complex float realpart")
1016 (define-vop (realpart/complex-double-float complex-float-value)
1017 (:translate realpart)
1018 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1020 (:arg-types complex-double-float)
1021 (:results (r :scs (double-reg)))
1022 (:result-types double-float)
1023 (:note "complex float realpart")
1026 (define-vop (imagpart/complex-single-float complex-float-value)
1027 (:translate imagpart)
1028 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1030 (:arg-types complex-single-float)
1031 (:results (r :scs (single-reg)))
1032 (:result-types single-float)
1033 (:note "complex float imagpart")
1036 (define-vop (imagpart/complex-double-float complex-float-value)
1037 (:translate imagpart)
1038 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1040 (:arg-types complex-double-float)
1041 (:results (r :scs (double-reg)))
1042 (:result-types double-float)
1043 (:note "complex float imagpart")
1047 ;;; hack dummy VOPs to bias the representation selection of their
1048 ;;; arguments towards a FP register, which can help avoid consing at
1049 ;;; inappropriate locations
1050 (defknown double-float-reg-bias (double-float) (values))
1051 (define-vop (double-float-reg-bias)
1052 (:translate double-float-reg-bias)
1053 (:args (x :scs (double-reg double-stack) :load-if nil))
1054 (:arg-types double-float)
1055 (:policy :fast-safe)
1056 (:note "inline dummy FP register bias")
1059 (defknown single-float-reg-bias (single-float) (values))
1060 (define-vop (single-float-reg-bias)
1061 (:translate single-float-reg-bias)
1062 (:args (x :scs (single-reg single-stack) :load-if nil))
1063 (:arg-types single-float)
1064 (:policy :fast-safe)
1065 (:note "inline dummy FP register bias")