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)
36 :disp (- (* (+ (tn-offset ,tn)
37 (ecase ,kind (:single 1) (:double 2) (:long 3)))
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))
59 ;;; complex float stack EAs
60 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
63 :disp (- (* (+ (tn-offset ,tn)
68 (ecase ,slot (:real 1) (:imag 2))))
70 (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
71 (ea-for-cxf-stack tn :single :real base))
72 (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
73 (ea-for-cxf-stack tn :single :imag base))
74 (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
75 (ea-for-cxf-stack tn :double :real base))
76 (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
77 (ea-for-cxf-stack tn :double :imag base)))
79 ;;; Abstract out the copying of a FP register to the FP stack top, and
80 ;;; provide two alternatives for its implementation. Note: it's not
81 ;;; necessary to distinguish between a single or double register move
84 ;;; Using a Pop then load.
85 (defun copy-fp-reg-to-fr0 (reg)
86 (aver (not (zerop (tn-offset reg))))
88 (inst fld (make-random-tn :kind :normal
89 :sc (sc-or-lose 'double-reg)
90 :offset (1- (tn-offset reg)))))
91 ;;; Using Fxch then Fst to restore the original reg contents.
93 (defun copy-fp-reg-to-fr0 (reg)
94 (aver (not (zerop (tn-offset reg))))
101 ;;; X is source, Y is destination.
102 (define-move-fun (load-single 2) (vop x y)
103 ((single-stack) (single-reg))
104 (with-empty-tn@fp-top(y)
105 (inst fld (ea-for-sf-stack x))))
107 (define-move-fun (store-single 2) (vop x y)
108 ((single-reg) (single-stack))
109 (cond ((zerop (tn-offset x))
110 (inst fst (ea-for-sf-stack y)))
113 (inst fst (ea-for-sf-stack y))
114 ;; This may not be necessary as ST0 is likely invalid now.
117 (define-move-fun (load-double 2) (vop x y)
118 ((double-stack) (double-reg))
119 (with-empty-tn@fp-top(y)
120 (inst fldd (ea-for-df-stack x))))
122 (define-move-fun (store-double 2) (vop x y)
123 ((double-reg) (double-stack))
124 (cond ((zerop (tn-offset x))
125 (inst fstd (ea-for-df-stack y)))
128 (inst fstd (ea-for-df-stack y))
129 ;; This may not be necessary as ST0 is likely invalid now.
134 ;;; The i387 has instructions to load some useful constants. This
135 ;;; doesn't save much time but might cut down on memory access and
136 ;;; reduce the size of the constant vector (CV). Intel claims they are
137 ;;; stored in a more precise form on chip. Anyhow, might as well use
138 ;;; the feature. It can be turned off by hacking the
139 ;;; "immediate-constant-sc" in vm.lisp.
140 (eval-when (:compile-toplevel :execute)
141 (setf *read-default-float-format* 'double-float))
142 (define-move-fun (load-fp-constant 2) (vop x y)
143 ((fp-constant) (single-reg double-reg))
144 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
145 (with-empty-tn@fp-top(y)
150 ((= value (coerce pi *read-default-float-format*))
152 ((= value (log 10e0 2e0))
154 ((= value (log 2.718281828459045235360287471352662e0 2e0))
156 ((= value (log 2e0 10e0))
158 ((= value (log 2e0 2.718281828459045235360287471352662e0))
160 (t (warn "ignoring bogus i387 constant ~A" value))))))
161 (eval-when (:compile-toplevel :execute)
162 (setf *read-default-float-format* 'single-float))
164 ;;;; complex float move functions
166 (defun complex-single-reg-real-tn (x)
167 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
168 :offset (tn-offset x)))
169 (defun complex-single-reg-imag-tn (x)
170 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
171 :offset (1+ (tn-offset x))))
173 (defun complex-double-reg-real-tn (x)
174 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
175 :offset (tn-offset x)))
176 (defun complex-double-reg-imag-tn (x)
177 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
178 :offset (1+ (tn-offset x))))
180 ;;; X is source, Y is destination.
181 (define-move-fun (load-complex-single 2) (vop x y)
182 ((complex-single-stack) (complex-single-reg))
183 (let ((real-tn (complex-single-reg-real-tn y)))
184 (with-empty-tn@fp-top (real-tn)
185 (inst fld (ea-for-csf-real-stack x))))
186 (let ((imag-tn (complex-single-reg-imag-tn y)))
187 (with-empty-tn@fp-top (imag-tn)
188 (inst fld (ea-for-csf-imag-stack x)))))
190 (define-move-fun (store-complex-single 2) (vop x y)
191 ((complex-single-reg) (complex-single-stack))
192 (let ((real-tn (complex-single-reg-real-tn x)))
193 (cond ((zerop (tn-offset real-tn))
194 (inst fst (ea-for-csf-real-stack y)))
197 (inst fst (ea-for-csf-real-stack y))
198 (inst fxch real-tn))))
199 (let ((imag-tn (complex-single-reg-imag-tn x)))
201 (inst fst (ea-for-csf-imag-stack y))
202 (inst fxch imag-tn)))
204 (define-move-fun (load-complex-double 2) (vop x y)
205 ((complex-double-stack) (complex-double-reg))
206 (let ((real-tn (complex-double-reg-real-tn y)))
207 (with-empty-tn@fp-top(real-tn)
208 (inst fldd (ea-for-cdf-real-stack x))))
209 (let ((imag-tn (complex-double-reg-imag-tn y)))
210 (with-empty-tn@fp-top(imag-tn)
211 (inst fldd (ea-for-cdf-imag-stack x)))))
213 (define-move-fun (store-complex-double 2) (vop x y)
214 ((complex-double-reg) (complex-double-stack))
215 (let ((real-tn (complex-double-reg-real-tn x)))
216 (cond ((zerop (tn-offset real-tn))
217 (inst fstd (ea-for-cdf-real-stack y)))
220 (inst fstd (ea-for-cdf-real-stack y))
221 (inst fxch real-tn))))
222 (let ((imag-tn (complex-double-reg-imag-tn x)))
224 (inst fstd (ea-for-cdf-imag-stack y))
225 (inst fxch imag-tn)))
230 ;;; float register to register moves
231 (define-vop (float-move)
236 (unless (location= x y)
237 (cond ((zerop (tn-offset y))
238 (copy-fp-reg-to-fr0 x))
239 ((zerop (tn-offset x))
246 (define-vop (single-move float-move)
247 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
248 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
249 (define-move-vop single-move :move (single-reg) (single-reg))
251 (define-vop (double-move float-move)
252 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
253 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
254 (define-move-vop double-move :move (double-reg) (double-reg))
256 ;;; complex float register to register moves
257 (define-vop (complex-float-move)
258 (:args (x :target y :load-if (not (location= x y))))
259 (:results (y :load-if (not (location= x y))))
260 (:note "complex float move")
262 (unless (location= x y)
263 ;; Note the complex-float-regs are aligned to every second
264 ;; float register so there is not need to worry about overlap.
265 (let ((x-real (complex-double-reg-real-tn x))
266 (y-real (complex-double-reg-real-tn y)))
267 (cond ((zerop (tn-offset y-real))
268 (copy-fp-reg-to-fr0 x-real))
269 ((zerop (tn-offset x-real))
274 (inst fxch x-real))))
275 (let ((x-imag (complex-double-reg-imag-tn x))
276 (y-imag (complex-double-reg-imag-tn y)))
279 (inst fxch x-imag)))))
281 (define-vop (complex-single-move complex-float-move)
282 (:args (x :scs (complex-single-reg) :target y
283 :load-if (not (location= x y))))
284 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
285 (define-move-vop complex-single-move :move
286 (complex-single-reg) (complex-single-reg))
288 (define-vop (complex-double-move complex-float-move)
289 (:args (x :scs (complex-double-reg)
290 :target y :load-if (not (location= x y))))
291 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
292 (define-move-vop complex-double-move :move
293 (complex-double-reg) (complex-double-reg))
296 ;;; Move from float to a descriptor reg. allocating a new float
297 ;;; object in the process.
298 (define-vop (move-from-single)
299 (:args (x :scs (single-reg) :to :save))
300 (:results (y :scs (descriptor-reg)))
302 (:note "float to pointer coercion")
304 (with-fixed-allocation (y
306 single-float-size node)
308 (inst fst (ea-for-sf-desc y))))))
309 (define-move-vop move-from-single :move
310 (single-reg) (descriptor-reg))
312 (define-vop (move-from-double)
313 (:args (x :scs (double-reg) :to :save))
314 (:results (y :scs (descriptor-reg)))
316 (:note "float to pointer coercion")
318 (with-fixed-allocation (y
323 (inst fstd (ea-for-df-desc y))))))
324 (define-move-vop move-from-double :move
325 (double-reg) (descriptor-reg))
327 (define-vop (move-from-fp-constant)
328 (:args (x :scs (fp-constant)))
329 (:results (y :scs (descriptor-reg)))
331 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
332 (0f0 (load-symbol-value y *fp-constant-0f0*))
333 (1f0 (load-symbol-value y *fp-constant-1f0*))
334 (0d0 (load-symbol-value y *fp-constant-0d0*))
335 (1d0 (load-symbol-value y *fp-constant-1d0*)))))
336 (define-move-vop move-from-fp-constant :move
337 (fp-constant) (descriptor-reg))
339 ;;; Move from a descriptor to a float register.
340 (define-vop (move-to-single)
341 (:args (x :scs (descriptor-reg)))
342 (:results (y :scs (single-reg)))
343 (:note "pointer to float coercion")
345 (with-empty-tn@fp-top(y)
346 (inst fld (ea-for-sf-desc x)))))
347 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
349 (define-vop (move-to-double)
350 (:args (x :scs (descriptor-reg)))
351 (:results (y :scs (double-reg)))
352 (:note "pointer to float coercion")
354 (with-empty-tn@fp-top(y)
355 (inst fldd (ea-for-df-desc x)))))
356 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
359 ;;; Move from complex float to a descriptor reg. allocating a new
360 ;;; complex float object in the process.
361 (define-vop (move-from-complex-single)
362 (:args (x :scs (complex-single-reg) :to :save))
363 (:results (y :scs (descriptor-reg)))
365 (:note "complex float to pointer coercion")
367 (with-fixed-allocation (y
368 complex-single-float-widetag
369 complex-single-float-size
371 (let ((real-tn (complex-single-reg-real-tn x)))
372 (with-tn@fp-top(real-tn)
373 (inst fst (ea-for-csf-real-desc y))))
374 (let ((imag-tn (complex-single-reg-imag-tn x)))
375 (with-tn@fp-top(imag-tn)
376 (inst fst (ea-for-csf-imag-desc y)))))))
377 (define-move-vop move-from-complex-single :move
378 (complex-single-reg) (descriptor-reg))
380 (define-vop (move-from-complex-double)
381 (:args (x :scs (complex-double-reg) :to :save))
382 (:results (y :scs (descriptor-reg)))
384 (:note "complex float to pointer coercion")
386 (with-fixed-allocation (y
387 complex-double-float-widetag
388 complex-double-float-size
390 (let ((real-tn (complex-double-reg-real-tn x)))
391 (with-tn@fp-top(real-tn)
392 (inst fstd (ea-for-cdf-real-desc y))))
393 (let ((imag-tn (complex-double-reg-imag-tn x)))
394 (with-tn@fp-top(imag-tn)
395 (inst fstd (ea-for-cdf-imag-desc y)))))))
396 (define-move-vop move-from-complex-double :move
397 (complex-double-reg) (descriptor-reg))
399 ;;; Move from a descriptor to a complex float register.
400 (macrolet ((frob (name sc format)
403 (:args (x :scs (descriptor-reg)))
404 (:results (y :scs (,sc)))
405 (:note "pointer to complex float coercion")
407 (let ((real-tn (complex-double-reg-real-tn y)))
408 (with-empty-tn@fp-top(real-tn)
410 (:single '((inst fld (ea-for-csf-real-desc x))))
411 (:double '((inst fldd (ea-for-cdf-real-desc x)))))))
412 (let ((imag-tn (complex-double-reg-imag-tn y)))
413 (with-empty-tn@fp-top(imag-tn)
415 (:single '((inst fld (ea-for-csf-imag-desc x))))
416 (:double '((inst fldd (ea-for-cdf-imag-desc x)))))))))
417 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
418 (frob move-to-complex-single complex-single-reg :single)
419 (frob move-to-complex-double complex-double-reg :double))
421 ;;;; the move argument vops
423 ;;;; Note these are also used to stuff fp numbers onto the c-call
424 ;;;; stack so the order is different than the lisp-stack.
426 ;;; the general MOVE-ARG VOP
427 (macrolet ((frob (name sc stack-sc format)
430 (:args (x :scs (,sc) :target y)
432 :load-if (not (sc-is y ,sc))))
434 (:note "float argument move")
435 (:generator ,(case format (:single 2) (:double 3) (:long 4))
438 (unless (location= x y)
439 (cond ((zerop (tn-offset y))
440 (copy-fp-reg-to-fr0 x))
441 ((zerop (tn-offset x))
448 (if (= (tn-offset fp) esp-offset)
449 (let* ((offset (* (tn-offset y) n-word-bytes))
450 (ea (make-ea :dword :base fp :disp offset)))
453 (:single '((inst fst ea)))
454 (:double '((inst fstd ea))))))
457 :disp (- (* (+ (tn-offset y)
465 (:single '((inst fst ea)))
466 (:double '((inst fstd ea)))))))))))
467 (define-move-vop ,name :move-arg
468 (,sc descriptor-reg) (,sc)))))
469 (frob move-single-float-arg single-reg single-stack :single)
470 (frob move-double-float-arg double-reg double-stack :double))
472 ;;;; complex float MOVE-ARG VOP
473 (macrolet ((frob (name sc stack-sc format)
476 (:args (x :scs (,sc) :target y)
478 :load-if (not (sc-is y ,sc))))
480 (:note "complex float argument move")
481 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
484 (unless (location= x y)
485 (let ((x-real (complex-double-reg-real-tn x))
486 (y-real (complex-double-reg-real-tn y)))
487 (cond ((zerop (tn-offset y-real))
488 (copy-fp-reg-to-fr0 x-real))
489 ((zerop (tn-offset x-real))
494 (inst fxch x-real))))
495 (let ((x-imag (complex-double-reg-imag-tn x))
496 (y-imag (complex-double-reg-imag-tn y)))
499 (inst fxch x-imag))))
501 (let ((real-tn (complex-double-reg-real-tn x)))
502 (cond ((zerop (tn-offset real-tn))
506 (ea-for-csf-real-stack y fp))))
509 (ea-for-cdf-real-stack y fp))))))
515 (ea-for-csf-real-stack y fp))))
518 (ea-for-cdf-real-stack y fp)))))
519 (inst fxch real-tn))))
520 (let ((imag-tn (complex-double-reg-imag-tn x)))
524 '((inst fst (ea-for-csf-imag-stack y fp))))
526 '((inst fstd (ea-for-cdf-imag-stack y fp)))))
527 (inst fxch imag-tn))))))
528 (define-move-vop ,name :move-arg
529 (,sc descriptor-reg) (,sc)))))
530 (frob move-complex-single-float-arg
531 complex-single-reg complex-single-stack :single)
532 (frob move-complex-double-float-arg
533 complex-double-reg complex-double-stack :double))
535 (define-move-vop move-arg :move-arg
536 (single-reg double-reg
537 complex-single-reg complex-double-reg)
543 ;;; dtc: the floating point arithmetic vops
545 ;;; Note: Although these can accept x and y on the stack or pointed to
546 ;;; from a descriptor register, they will work with register loading
547 ;;; without these. Same deal with the result - it need only be a
548 ;;; register. When load-tns are needed they will probably be in ST0
549 ;;; and the code below should be able to correctly handle all cases.
551 ;;; However it seems to produce better code if all arg. and result
552 ;;; options are used; on the P86 there is no extra cost in using a
553 ;;; memory operand to the FP instructions - not so on the PPro.
555 ;;; It may also be useful to handle constant args?
557 ;;; 22-Jul-97: descriptor args lose in some simple cases when
558 ;;; a function result computed in a loop. Then Python insists
559 ;;; on consing the intermediate values! For example
562 (declare (type (simple-array double-float (*)) a)
565 (declare (type double-float sum))
567 (incf sum (* (aref a i)(aref a i))))
570 ;;; So, disabling descriptor args until this can be fixed elsewhere.
572 ((frob (op fop-sti fopr-sti
574 fopd foprd dname dcost
576 #!-long-float (declare (ignore lcost lname))
580 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
582 (y :scs (single-reg single-stack #+nil descriptor-reg)
584 (:temporary (:sc single-reg :offset fr0-offset
585 :from :eval :to :result) fr0)
586 (:results (r :scs (single-reg single-stack)))
587 (:arg-types single-float single-float)
588 (:result-types single-float)
590 (:note "inline float arithmetic")
592 (:save-p :compute-only)
595 ;; Handle a few special cases
597 ;; x, y, and r are the same register.
598 ((and (sc-is x single-reg) (location= x r) (location= y r))
599 (cond ((zerop (tn-offset r))
604 ;; XX the source register will not be valid.
605 (note-next-instruction vop :internal-error)
608 ;; x and r are the same register.
609 ((and (sc-is x single-reg) (location= x r))
610 (cond ((zerop (tn-offset r))
613 ;; ST(0) = ST(0) op ST(y)
616 ;; ST(0) = ST(0) op Mem
617 (inst ,fop (ea-for-sf-stack y)))
619 (inst ,fop (ea-for-sf-desc y)))))
624 (unless (zerop (tn-offset y))
625 (copy-fp-reg-to-fr0 y)))
626 ((single-stack descriptor-reg)
628 (if (sc-is y single-stack)
629 (inst fld (ea-for-sf-stack y))
630 (inst fld (ea-for-sf-desc y)))))
631 ;; ST(i) = ST(i) op ST0
633 (maybe-fp-wait node vop))
634 ;; y and r are the same register.
635 ((and (sc-is y single-reg) (location= y r))
636 (cond ((zerop (tn-offset r))
639 ;; ST(0) = ST(x) op ST(0)
642 ;; ST(0) = Mem op ST(0)
643 (inst ,fopr (ea-for-sf-stack x)))
645 (inst ,fopr (ea-for-sf-desc x)))))
650 (unless (zerop (tn-offset x))
651 (copy-fp-reg-to-fr0 x)))
652 ((single-stack descriptor-reg)
654 (if (sc-is x single-stack)
655 (inst fld (ea-for-sf-stack x))
656 (inst fld (ea-for-sf-desc x)))))
657 ;; ST(i) = ST(0) op ST(i)
659 (maybe-fp-wait node vop))
662 ;; Get the result to ST0.
664 ;; Special handling is needed if x or y are in ST0, and
665 ;; simpler code is generated.
668 ((and (sc-is x single-reg) (zerop (tn-offset x)))
674 (inst ,fop (ea-for-sf-stack y)))
676 (inst ,fop (ea-for-sf-desc y)))))
678 ((and (sc-is y single-reg) (zerop (tn-offset y)))
684 (inst ,fopr (ea-for-sf-stack x)))
686 (inst ,fopr (ea-for-sf-desc x)))))
691 (copy-fp-reg-to-fr0 x))
694 (inst fld (ea-for-sf-stack x)))
697 (inst fld (ea-for-sf-desc x))))
703 (inst ,fop (ea-for-sf-stack y)))
705 (inst ,fop (ea-for-sf-desc y))))))
707 (note-next-instruction vop :internal-error)
709 ;; Finally save the result.
712 (cond ((zerop (tn-offset r))
713 (maybe-fp-wait node))
717 (inst fst (ea-for-sf-stack r))))))))
721 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
723 (y :scs (double-reg double-stack #+nil descriptor-reg)
725 (:temporary (:sc double-reg :offset fr0-offset
726 :from :eval :to :result) fr0)
727 (:results (r :scs (double-reg double-stack)))
728 (:arg-types double-float double-float)
729 (:result-types double-float)
731 (:note "inline float arithmetic")
733 (:save-p :compute-only)
736 ;; Handle a few special cases.
738 ;; x, y, and r are the same register.
739 ((and (sc-is x double-reg) (location= x r) (location= y r))
740 (cond ((zerop (tn-offset r))
745 ;; XX the source register will not be valid.
746 (note-next-instruction vop :internal-error)
749 ;; x and r are the same register.
750 ((and (sc-is x double-reg) (location= x r))
751 (cond ((zerop (tn-offset r))
754 ;; ST(0) = ST(0) op ST(y)
757 ;; ST(0) = ST(0) op Mem
758 (inst ,fopd (ea-for-df-stack y)))
760 (inst ,fopd (ea-for-df-desc y)))))
765 (unless (zerop (tn-offset y))
766 (copy-fp-reg-to-fr0 y)))
767 ((double-stack descriptor-reg)
769 (if (sc-is y double-stack)
770 (inst fldd (ea-for-df-stack y))
771 (inst fldd (ea-for-df-desc y)))))
772 ;; ST(i) = ST(i) op ST0
774 (maybe-fp-wait node vop))
775 ;; y and r are the same register.
776 ((and (sc-is y double-reg) (location= y r))
777 (cond ((zerop (tn-offset r))
780 ;; ST(0) = ST(x) op ST(0)
783 ;; ST(0) = Mem op ST(0)
784 (inst ,foprd (ea-for-df-stack x)))
786 (inst ,foprd (ea-for-df-desc x)))))
791 (unless (zerop (tn-offset x))
792 (copy-fp-reg-to-fr0 x)))
793 ((double-stack descriptor-reg)
795 (if (sc-is x double-stack)
796 (inst fldd (ea-for-df-stack x))
797 (inst fldd (ea-for-df-desc x)))))
798 ;; ST(i) = ST(0) op ST(i)
800 (maybe-fp-wait node vop))
803 ;; Get the result to ST0.
805 ;; Special handling is needed if x or y are in ST0, and
806 ;; simpler code is generated.
809 ((and (sc-is x double-reg) (zerop (tn-offset x)))
815 (inst ,fopd (ea-for-df-stack y)))
817 (inst ,fopd (ea-for-df-desc y)))))
819 ((and (sc-is y double-reg) (zerop (tn-offset y)))
825 (inst ,foprd (ea-for-df-stack x)))
827 (inst ,foprd (ea-for-df-desc x)))))
832 (copy-fp-reg-to-fr0 x))
835 (inst fldd (ea-for-df-stack x)))
838 (inst fldd (ea-for-df-desc x))))
844 (inst ,fopd (ea-for-df-stack y)))
846 (inst ,fopd (ea-for-df-desc y))))))
848 (note-next-instruction vop :internal-error)
850 ;; Finally save the result.
853 (cond ((zerop (tn-offset r))
854 (maybe-fp-wait node))
858 (inst fstd (ea-for-df-stack r))))))))
861 (frob + fadd-sti fadd-sti
862 fadd fadd +/single-float 2
863 faddd faddd +/double-float 2
865 (frob - fsub-sti fsubr-sti
866 fsub fsubr -/single-float 2
867 fsubd fsubrd -/double-float 2
869 (frob * fmul-sti fmul-sti
870 fmul fmul */single-float 3
871 fmuld fmuld */double-float 3
873 (frob / fdiv-sti fdivr-sti
874 fdiv fdivr //single-float 12
875 fdivd fdivrd //double-float 12
878 (macrolet ((frob (name inst translate sc type)
880 (:args (x :scs (,sc) :target fr0))
881 (:results (y :scs (,sc)))
882 (:translate ,translate)
885 (:result-types ,type)
886 (:temporary (:sc double-reg :offset fr0-offset
887 :from :argument :to :result) fr0)
889 (:note "inline float arithmetic")
891 (:save-p :compute-only)
893 (note-this-location vop :internal-error)
894 (unless (zerop (tn-offset x))
895 (inst fxch x) ; x to top of stack
896 (unless (location= x y)
897 (inst fst x))) ; Maybe save it.
898 (inst ,inst) ; Clobber st0.
899 (unless (zerop (tn-offset y))
902 (frob abs/single-float fabs abs single-reg single-float)
903 (frob abs/double-float fabs abs double-reg double-float)
905 (frob %negate/single-float fchs %negate single-reg single-float)
906 (frob %negate/double-float fchs %negate double-reg double-float))
910 (define-vop (=/float)
912 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
917 (:save-p :compute-only)
918 (:note "inline float comparison")
921 (note-this-location vop :internal-error)
923 ;; x is in ST0; y is in any reg.
924 ((zerop (tn-offset x))
926 ;; y is in ST0; x is in another reg.
927 ((zerop (tn-offset y))
929 ;; x and y are the same register, not ST0
934 ;; x and y are different registers, neither ST0.
939 (inst fnstsw) ; status word to ax
940 (inst and ah-tn #x45) ; C3 C2 C0
941 (inst cmp ah-tn #x40)
942 (inst jmp (if not-p :ne :e) target)))
944 (define-vop (=/single-float =/float)
946 (:args (x :scs (single-reg))
947 (y :scs (single-reg)))
948 (:arg-types single-float single-float))
950 (define-vop (=/double-float =/float)
952 (:args (x :scs (double-reg))
953 (y :scs (double-reg)))
954 (:arg-types double-float double-float))
956 (define-vop (<single-float)
958 (:args (x :scs (single-reg single-stack descriptor-reg))
959 (y :scs (single-reg single-stack descriptor-reg)))
960 (:arg-types single-float single-float)
961 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
962 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
966 (:note "inline float comparison")
969 ;; Handle a few special cases.
972 ((and (sc-is y single-reg) (zerop (tn-offset y)))
976 ((single-stack descriptor-reg)
977 (if (sc-is x single-stack)
978 (inst fcom (ea-for-sf-stack x))
979 (inst fcom (ea-for-sf-desc x)))))
980 (inst fnstsw) ; status word to ax
981 (inst and ah-tn #x45))
983 ;; general case when y is not in ST0
988 (unless (zerop (tn-offset x))
989 (copy-fp-reg-to-fr0 x)))
990 ((single-stack descriptor-reg)
992 (if (sc-is x single-stack)
993 (inst fld (ea-for-sf-stack x))
994 (inst fld (ea-for-sf-desc x)))))
998 ((single-stack descriptor-reg)
999 (if (sc-is y single-stack)
1000 (inst fcom (ea-for-sf-stack y))
1001 (inst fcom (ea-for-sf-desc y)))))
1002 (inst fnstsw) ; status word to ax
1003 (inst and ah-tn #x45) ; C3 C2 C0
1004 (inst cmp ah-tn #x01)))
1005 (inst jmp (if not-p :ne :e) target)))
1007 (define-vop (<double-float)
1009 (:args (x :scs (double-reg double-stack descriptor-reg))
1010 (y :scs (double-reg double-stack descriptor-reg)))
1011 (:arg-types double-float double-float)
1012 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1013 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1015 (:info target not-p)
1016 (:policy :fast-safe)
1017 (:note "inline float comparison")
1020 ;; Handle a few special cases
1023 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1027 ((double-stack descriptor-reg)
1028 (if (sc-is x double-stack)
1029 (inst fcomd (ea-for-df-stack x))
1030 (inst fcomd (ea-for-df-desc x)))))
1031 (inst fnstsw) ; status word to ax
1032 (inst and ah-tn #x45))
1034 ;; General case when y is not in ST0.
1039 (unless (zerop (tn-offset x))
1040 (copy-fp-reg-to-fr0 x)))
1041 ((double-stack descriptor-reg)
1043 (if (sc-is x double-stack)
1044 (inst fldd (ea-for-df-stack x))
1045 (inst fldd (ea-for-df-desc x)))))
1049 ((double-stack descriptor-reg)
1050 (if (sc-is y double-stack)
1051 (inst fcomd (ea-for-df-stack y))
1052 (inst fcomd (ea-for-df-desc y)))))
1053 (inst fnstsw) ; status word to ax
1054 (inst and ah-tn #x45) ; C3 C2 C0
1055 (inst cmp ah-tn #x01)))
1056 (inst jmp (if not-p :ne :e) target)))
1058 (define-vop (>single-float)
1060 (:args (x :scs (single-reg single-stack descriptor-reg))
1061 (y :scs (single-reg single-stack descriptor-reg)))
1062 (:arg-types single-float single-float)
1063 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1064 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1066 (:info target not-p)
1067 (:policy :fast-safe)
1068 (:note "inline float comparison")
1071 ;; Handle a few special cases.
1074 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1078 ((single-stack descriptor-reg)
1079 (if (sc-is x single-stack)
1080 (inst fcom (ea-for-sf-stack x))
1081 (inst fcom (ea-for-sf-desc x)))))
1082 (inst fnstsw) ; status word to ax
1083 (inst and ah-tn #x45)
1084 (inst cmp ah-tn #x01))
1086 ;; general case when y is not in ST0
1091 (unless (zerop (tn-offset x))
1092 (copy-fp-reg-to-fr0 x)))
1093 ((single-stack descriptor-reg)
1095 (if (sc-is x single-stack)
1096 (inst fld (ea-for-sf-stack x))
1097 (inst fld (ea-for-sf-desc x)))))
1101 ((single-stack descriptor-reg)
1102 (if (sc-is y single-stack)
1103 (inst fcom (ea-for-sf-stack y))
1104 (inst fcom (ea-for-sf-desc y)))))
1105 (inst fnstsw) ; status word to ax
1106 (inst and ah-tn #x45)))
1107 (inst jmp (if not-p :ne :e) target)))
1109 (define-vop (>double-float)
1111 (:args (x :scs (double-reg double-stack descriptor-reg))
1112 (y :scs (double-reg double-stack descriptor-reg)))
1113 (:arg-types double-float double-float)
1114 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1115 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1117 (:info target not-p)
1118 (:policy :fast-safe)
1119 (:note "inline float comparison")
1122 ;; Handle a few special cases.
1125 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1129 ((double-stack descriptor-reg)
1130 (if (sc-is x double-stack)
1131 (inst fcomd (ea-for-df-stack x))
1132 (inst fcomd (ea-for-df-desc x)))))
1133 (inst fnstsw) ; status word to ax
1134 (inst and ah-tn #x45)
1135 (inst cmp ah-tn #x01))
1137 ;; general case when y is not in ST0
1142 (unless (zerop (tn-offset x))
1143 (copy-fp-reg-to-fr0 x)))
1144 ((double-stack descriptor-reg)
1146 (if (sc-is x double-stack)
1147 (inst fldd (ea-for-df-stack x))
1148 (inst fldd (ea-for-df-desc x)))))
1152 ((double-stack descriptor-reg)
1153 (if (sc-is y double-stack)
1154 (inst fcomd (ea-for-df-stack y))
1155 (inst fcomd (ea-for-df-desc y)))))
1156 (inst fnstsw) ; status word to ax
1157 (inst and ah-tn #x45)))
1158 (inst jmp (if not-p :ne :e) target)))
1160 ;;; Comparisons with 0 can use the FTST instruction.
1162 (define-vop (float-test)
1164 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1166 (:info target not-p y)
1167 (:variant-vars code)
1168 (:policy :fast-safe)
1170 (:save-p :compute-only)
1171 (:note "inline float comparison")
1174 (note-this-location vop :internal-error)
1177 ((zerop (tn-offset x))
1184 (inst fnstsw) ; status word to ax
1185 (inst and ah-tn #x45) ; C3 C2 C0
1186 (unless (zerop code)
1187 (inst cmp ah-tn code))
1188 (inst jmp (if not-p :ne :e) target)))
1190 (define-vop (=0/single-float float-test)
1192 (:args (x :scs (single-reg)))
1193 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1195 (define-vop (=0/double-float float-test)
1197 (:args (x :scs (double-reg)))
1198 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1201 (define-vop (<0/single-float float-test)
1203 (:args (x :scs (single-reg)))
1204 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1206 (define-vop (<0/double-float float-test)
1208 (:args (x :scs (double-reg)))
1209 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1212 (define-vop (>0/single-float float-test)
1214 (:args (x :scs (single-reg)))
1215 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1217 (define-vop (>0/double-float float-test)
1219 (:args (x :scs (double-reg)))
1220 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1226 (macrolet ((frob (name translate to-sc to-type)
1227 `(define-vop (,name)
1228 (:args (x :scs (signed-stack signed-reg) :target temp))
1229 (:temporary (:sc signed-stack) temp)
1230 (:results (y :scs (,to-sc)))
1231 (:arg-types signed-num)
1232 (:result-types ,to-type)
1233 (:policy :fast-safe)
1234 (:note "inline float coercion")
1235 (:translate ,translate)
1237 (:save-p :compute-only)
1242 (with-empty-tn@fp-top(y)
1243 (note-this-location vop :internal-error)
1246 (with-empty-tn@fp-top(y)
1247 (note-this-location vop :internal-error)
1248 (inst fild x))))))))
1249 (frob %single-float/signed %single-float single-reg single-float)
1250 (frob %double-float/signed %double-float double-reg double-float))
1252 (macrolet ((frob (name translate to-sc to-type)
1253 `(define-vop (,name)
1254 (:args (x :scs (unsigned-reg)))
1255 (:results (y :scs (,to-sc)))
1256 (:arg-types unsigned-num)
1257 (:result-types ,to-type)
1258 (:policy :fast-safe)
1259 (:note "inline float coercion")
1260 (:translate ,translate)
1262 (:save-p :compute-only)
1266 (with-empty-tn@fp-top(y)
1267 (note-this-location vop :internal-error)
1268 (inst fildl (make-ea :dword :base rsp-tn)))
1269 (inst add rsp-tn 16)))))
1270 (frob %single-float/unsigned %single-float single-reg single-float)
1271 (frob %double-float/unsigned %double-float double-reg double-float))
1273 ;;; These should be no-ops but the compiler might want to move some
1275 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1276 `(define-vop (,name)
1277 (:args (x :scs (,from-sc) :target y))
1278 (:results (y :scs (,to-sc)))
1279 (:arg-types ,from-type)
1280 (:result-types ,to-type)
1281 (:policy :fast-safe)
1282 (:note "inline float coercion")
1283 (:translate ,translate)
1285 (:save-p :compute-only)
1287 (note-this-location vop :internal-error)
1288 (unless (location= x y)
1290 ((zerop (tn-offset x))
1291 ;; x is in ST0, y is in another reg. not ST0
1293 ((zerop (tn-offset y))
1294 ;; y is in ST0, x is in another reg. not ST0
1295 (copy-fp-reg-to-fr0 x))
1297 ;; Neither x or y are in ST0, and they are not in
1301 (inst fxch x))))))))
1303 (frob %single-float/double-float %single-float double-reg
1304 double-float single-reg single-float)
1306 (frob %double-float/single-float %double-float single-reg single-float
1307 double-reg double-float))
1309 (macrolet ((frob (trans from-sc from-type round-p)
1310 `(define-vop (,(symbolicate trans "/" from-type))
1311 (:args (x :scs (,from-sc)))
1312 (:temporary (:sc signed-stack) stack-temp)
1314 '((:temporary (:sc unsigned-stack) scw)
1315 (:temporary (:sc any-reg) rcw)))
1316 (:results (y :scs (signed-reg)))
1317 (:arg-types ,from-type)
1318 (:result-types signed-num)
1320 (:policy :fast-safe)
1321 (:note "inline float truncate")
1323 (:save-p :compute-only)
1326 '((note-this-location vop :internal-error)
1327 ;; Catch any pending FPE exceptions.
1329 (,(if round-p 'progn 'pseudo-atomic)
1330 ;; Normal mode (for now) is "round to best".
1333 '((inst fnstcw scw) ; save current control word
1334 (move rcw scw) ; into 16-bit register
1335 (inst or rcw (ash #b11 10)) ; CHOP
1336 (move stack-temp rcw)
1337 (inst fldcw stack-temp)))
1342 (inst fist stack-temp)
1343 (inst mov y stack-temp)))
1345 '((inst fldcw scw)))))))))
1346 (frob %unary-truncate single-reg single-float nil)
1347 (frob %unary-truncate double-reg double-float nil)
1349 (frob %unary-round single-reg single-float t)
1350 (frob %unary-round double-reg double-float t))
1352 (macrolet ((frob (trans from-sc from-type round-p)
1353 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1354 (:args (x :scs (,from-sc) :target fr0))
1355 (:temporary (:sc double-reg :offset fr0-offset
1356 :from :argument :to :result) fr0)
1358 '((:temporary (:sc unsigned-stack) stack-temp)
1359 (:temporary (:sc unsigned-stack) scw)
1360 (:temporary (:sc any-reg) rcw)))
1361 (:results (y :scs (unsigned-reg)))
1362 (:arg-types ,from-type)
1363 (:result-types unsigned-num)
1365 (:policy :fast-safe)
1366 (:note "inline float truncate")
1368 (:save-p :compute-only)
1371 '((note-this-location vop :internal-error)
1372 ;; Catch any pending FPE exceptions.
1374 ;; Normal mode (for now) is "round to best".
1375 (unless (zerop (tn-offset x))
1376 (copy-fp-reg-to-fr0 x))
1378 '((inst fnstcw scw) ; save current control word
1379 (move rcw scw) ; into 16-bit register
1380 (inst or rcw (ash #b11 10)) ; CHOP
1381 (move stack-temp rcw)
1382 (inst fldcw stack-temp)))
1384 (inst fistpl (make-ea :dword :base rsp-tn))
1386 (inst fld fr0) ; copy fr0 to at least restore stack.
1389 '((inst fldcw scw)))))))
1390 (frob %unary-truncate single-reg single-float nil)
1391 (frob %unary-truncate double-reg double-float nil)
1392 (frob %unary-round single-reg single-float t)
1393 (frob %unary-round double-reg double-float t))
1395 (define-vop (make-single-float)
1396 (:args (bits :scs (signed-reg) :target res
1397 :load-if (not (or (and (sc-is bits signed-stack)
1398 (sc-is res single-reg))
1399 (and (sc-is bits signed-stack)
1400 (sc-is res single-stack)
1401 (location= bits res))))))
1402 (:results (res :scs (single-reg single-stack)))
1403 (:temporary (:sc signed-stack) stack-temp)
1404 (:arg-types signed-num)
1405 (:result-types single-float)
1406 (:translate make-single-float)
1407 (:policy :fast-safe)
1414 (inst mov res bits))
1416 (aver (location= bits res)))))
1420 ;; source must be in memory
1421 (inst mov stack-temp bits)
1422 (with-empty-tn@fp-top(res)
1423 (inst fld stack-temp)))
1425 (with-empty-tn@fp-top(res)
1426 (inst fld bits))))))))
1428 (define-vop (make-double-float)
1429 (:args (hi-bits :scs (signed-reg))
1430 (lo-bits :scs (unsigned-reg)))
1431 (:results (res :scs (double-reg)))
1432 (:temporary (:sc double-stack) temp)
1433 (:arg-types signed-num unsigned-num)
1434 (:result-types double-float)
1435 (:translate make-double-float)
1436 (:policy :fast-safe)
1439 (let ((offset (1+ (tn-offset temp))))
1440 (storew hi-bits rbp-tn (- offset))
1441 (storew lo-bits rbp-tn (- (1+ offset)))
1442 (with-empty-tn@fp-top(res)
1443 (inst fldd (make-ea :dword :base rbp-tn
1444 :disp (- (* (1+ offset) n-word-bytes))))))))
1446 (define-vop (single-float-bits)
1447 (:args (float :scs (single-reg descriptor-reg)
1448 :load-if (not (sc-is float single-stack))))
1449 (:results (bits :scs (signed-reg)))
1450 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1451 (:arg-types single-float)
1452 (:result-types signed-num)
1453 (:translate single-float-bits)
1454 (:policy :fast-safe)
1461 (with-tn@fp-top(float)
1462 (inst fst stack-temp)
1463 (inst mov bits stack-temp)))
1465 (inst mov bits float))
1468 bits float single-float-value-slot
1469 other-pointer-lowtag))))
1473 (with-tn@fp-top(float)
1474 (inst fst bits))))))))
1476 (define-vop (double-float-high-bits)
1477 (:args (float :scs (double-reg descriptor-reg)
1478 :load-if (not (sc-is float double-stack))))
1479 (:results (hi-bits :scs (signed-reg)))
1480 (:temporary (:sc double-stack) temp)
1481 (:arg-types double-float)
1482 (:result-types signed-num)
1483 (:translate double-float-high-bits)
1484 (:policy :fast-safe)
1489 (with-tn@fp-top(float)
1490 (let ((where (make-ea :dword :base rbp-tn
1491 :disp (- (* (+ 2 (tn-offset temp))
1494 (loadw hi-bits rbp-tn (- (1+ (tn-offset temp)))))
1496 (loadw hi-bits rbp-tn (- (1+ (tn-offset float)))))
1498 (loadw hi-bits float (1+ double-float-value-slot)
1499 other-pointer-lowtag)))))
1501 (define-vop (double-float-low-bits)
1502 (:args (float :scs (double-reg descriptor-reg)
1503 :load-if (not (sc-is float double-stack))))
1504 (:results (lo-bits :scs (unsigned-reg)))
1505 (:temporary (:sc double-stack) temp)
1506 (:arg-types double-float)
1507 (:result-types unsigned-num)
1508 (:translate double-float-low-bits)
1509 (:policy :fast-safe)
1514 (with-tn@fp-top(float)
1515 (let ((where (make-ea :dword :base rbp-tn
1516 :disp (- (* (+ 2 (tn-offset temp))
1519 (loadw lo-bits rbp-tn (- (+ 2 (tn-offset temp)))))
1521 (loadw lo-bits rbp-tn (- (+ 2 (tn-offset float)))))
1523 (loadw lo-bits float double-float-value-slot
1524 other-pointer-lowtag)))))
1527 ;;;; float mode hackery
1529 (sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
1530 (defknown floating-point-modes () float-modes (flushable))
1531 (defknown ((setf floating-point-modes)) (float-modes)
1534 (def!constant npx-env-size (* 7 n-word-bytes))
1535 (def!constant npx-cw-offset 0)
1536 (def!constant npx-sw-offset 4)
1538 (define-vop (floating-point-modes)
1539 (:results (res :scs (unsigned-reg)))
1540 (:result-types unsigned-num)
1541 (:translate floating-point-modes)
1542 (:policy :fast-safe)
1543 (:temporary (:sc unsigned-reg :offset eax-offset :target res
1546 (inst sub rsp-tn npx-env-size) ; Make space on stack.
1547 (inst wait) ; Catch any pending FPE exceptions
1548 (inst fstenv (make-ea :dword :base rsp-tn)) ; masks all exceptions
1549 (inst fldenv (make-ea :dword :base rsp-tn)) ; Restore previous state.
1550 ;; Move current status to high word.
1551 (inst movzxd eax (make-ea :dword :base rsp-tn :disp (- npx-sw-offset 2)))
1552 ;; Move exception mask to low word.
1553 (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset))
1554 (inst add rsp-tn npx-env-size) ; Pop stack.
1555 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
1559 (define-vop (set-floating-point-modes)
1560 (:args (new :scs (unsigned-reg) :to :result :target res))
1561 (:results (res :scs (unsigned-reg)))
1562 (:arg-types unsigned-num)
1563 (:result-types unsigned-num)
1564 (:translate (setf floating-point-modes))
1565 (:policy :fast-safe)
1566 (:temporary (:sc unsigned-reg :offset eax-offset
1567 :from :eval :to :result) eax)
1569 (inst sub rsp-tn npx-env-size) ; Make space on stack.
1570 (inst wait) ; Catch any pending FPE exceptions.
1571 (inst fstenv (make-ea :dword :base rsp-tn))
1573 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
1574 (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn)
1575 (inst shr eax 16) ; position status word
1576 (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn)
1577 (inst fldenv (make-ea :dword :base rsp-tn))
1578 (inst add rsp-tn npx-env-size) ; Pop stack.
1584 ;;; Let's use some of the 80387 special functions.
1586 ;;; These defs will not take effect unless code/irrat.lisp is modified
1587 ;;; to remove the inlined alien routine def.
1589 (macrolet ((frob (func trans op)
1590 `(define-vop (,func)
1591 (:args (x :scs (double-reg) :target fr0))
1592 (:temporary (:sc double-reg :offset fr0-offset
1593 :from :argument :to :result) fr0)
1595 (:results (y :scs (double-reg)))
1596 (:arg-types double-float)
1597 (:result-types double-float)
1599 (:policy :fast-safe)
1600 (:note "inline NPX function")
1602 (:save-p :compute-only)
1605 (note-this-location vop :internal-error)
1606 (unless (zerop (tn-offset x))
1607 (inst fxch x) ; x to top of stack
1608 (unless (location= x y)
1609 (inst fst x))) ; maybe save it
1610 (inst ,op) ; clobber st0
1611 (cond ((zerop (tn-offset y))
1612 (maybe-fp-wait node))
1616 ;; Quick versions of fsin and fcos that require the argument to be
1617 ;; within range 2^63.
1618 (frob fsin-quick %sin-quick fsin)
1619 (frob fcos-quick %cos-quick fcos)
1620 (frob fsqrt %sqrt fsqrt))
1622 ;;; Quick version of ftan that requires the argument to be within
1624 (define-vop (ftan-quick)
1625 (:translate %tan-quick)
1626 (:args (x :scs (double-reg) :target fr0))
1627 (:temporary (:sc double-reg :offset fr0-offset
1628 :from :argument :to :result) fr0)
1629 (:temporary (:sc double-reg :offset fr1-offset
1630 :from :argument :to :result) fr1)
1631 (:results (y :scs (double-reg)))
1632 (:arg-types double-float)
1633 (:result-types double-float)
1634 (:policy :fast-safe)
1635 (:note "inline tan function")
1637 (:save-p :compute-only)
1639 (note-this-location vop :internal-error)
1648 (inst fldd (make-random-tn :kind :normal
1649 :sc (sc-or-lose 'double-reg)
1650 :offset (- (tn-offset x) 2)))))
1661 ;;; These versions of fsin, fcos, and ftan try to use argument
1662 ;;; reduction but to do this accurately requires greater precision and
1663 ;;; it is hopelessly inaccurate.
1665 (macrolet ((frob (func trans op)
1666 `(define-vop (,func)
1668 (:args (x :scs (double-reg) :target fr0))
1669 (:temporary (:sc unsigned-reg :offset eax-offset
1670 :from :eval :to :result) eax)
1671 (:temporary (:sc unsigned-reg :offset fr0-offset
1672 :from :argument :to :result) fr0)
1673 (:temporary (:sc unsigned-reg :offset fr1-offset
1674 :from :argument :to :result) fr1)
1675 (:results (y :scs (double-reg)))
1676 (:arg-types double-float)
1677 (:result-types double-float)
1678 (:policy :fast-safe)
1679 (:note "inline sin/cos function")
1681 (:save-p :compute-only)
1684 (note-this-location vop :internal-error)
1685 (unless (zerop (tn-offset x))
1686 (inst fxch x) ; x to top of stack
1687 (unless (location= x y)
1688 (inst fst x))) ; maybe save it
1690 (inst fnstsw) ; status word to ax
1691 (inst and ah-tn #x04) ; C2
1693 ;; Else x was out of range so reduce it; ST0 is unchanged.
1694 (inst fstp fr1) ; Load 2*PI
1700 (inst fnstsw) ; status word to ax
1701 (inst and ah-tn #x04) ; C2
1705 (unless (zerop (tn-offset y))
1707 (frob fsin %sin fsin)
1708 (frob fcos %cos fcos))
1712 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
1713 ;;; the argument is out of range 2^63 and would thus be hopelessly
1715 (macrolet ((frob (func trans op)
1716 `(define-vop (,func)
1718 (:args (x :scs (double-reg) :target fr0))
1719 (:temporary (:sc double-reg :offset fr0-offset
1720 :from :argument :to :result) fr0)
1721 (:temporary (:sc unsigned-reg :offset eax-offset
1722 :from :argument :to :result) eax)
1723 (:results (y :scs (double-reg)))
1724 (:arg-types double-float)
1725 (:result-types double-float)
1726 (:policy :fast-safe)
1727 (:note "inline sin/cos function")
1729 (:save-p :compute-only)
1732 (note-this-location vop :internal-error)
1733 (unless (zerop (tn-offset x))
1734 (inst fxch x) ; x to top of stack
1735 (unless (location= x y)
1736 (inst fst x))) ; maybe save it
1738 (inst fnstsw) ; status word to ax
1739 (inst and ah-tn #x04) ; C2
1741 ;; Else x was out of range so reduce it; ST0 is unchanged.
1742 (inst fstp fr0) ; Load 0.0
1745 (unless (zerop (tn-offset y))
1747 (frob fsin %sin fsin)
1748 (frob fcos %cos fcos))
1752 (:args (x :scs (double-reg) :target fr0))
1753 (:temporary (:sc double-reg :offset fr0-offset
1754 :from :argument :to :result) fr0)
1755 (:temporary (:sc double-reg :offset fr1-offset
1756 :from :argument :to :result) fr1)
1757 (:temporary (:sc unsigned-reg :offset eax-offset
1758 :from :argument :to :result) eax)
1759 (:results (y :scs (double-reg)))
1760 (:arg-types double-float)
1761 (:result-types double-float)
1763 (:policy :fast-safe)
1764 (:note "inline tan function")
1766 (:save-p :compute-only)
1769 (note-this-location vop :internal-error)
1778 (inst fldd (make-random-tn :kind :normal
1779 :sc (sc-or-lose 'double-reg)
1780 :offset (- (tn-offset x) 2)))))
1782 (inst fnstsw) ; status word to ax
1783 (inst and ah-tn #x04) ; C2
1785 ;; Else x was out of range so reduce it; ST0 is unchanged.
1786 (inst fldz) ; Load 0.0
1801 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
1802 (:temporary (:sc double-reg :offset fr0-offset
1803 :from :argument :to :result) fr0)
1804 (:temporary (:sc double-reg :offset fr1-offset
1805 :from :argument :to :result) fr1)
1806 (:temporary (:sc double-reg :offset fr2-offset
1807 :from :argument :to :result) fr2)
1808 (:results (y :scs (double-reg)))
1809 (:arg-types double-float)
1810 (:result-types double-float)
1811 (:policy :fast-safe)
1812 (:note "inline exp function")
1814 (:save-p :compute-only)
1816 (note-this-location vop :internal-error)
1819 (cond ((zerop (tn-offset x))
1825 ;; x is in a FP reg, not fr0
1829 ((double-stack descriptor-reg)
1832 (if (sc-is x double-stack)
1833 (inst fmuld (ea-for-df-stack x))
1834 (inst fmuld (ea-for-df-desc x)))))
1835 ;; Now fr0=x log2(e)
1839 (inst fsubp-sti fr1)
1842 (inst faddp-sti fr1)
1847 (t (inst fstd y)))))
1849 ;;; Modified exp that handles the following special cases:
1850 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
1853 (:args (x :scs (double-reg) :target fr0))
1854 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
1855 (:temporary (:sc double-reg :offset fr0-offset
1856 :from :argument :to :result) fr0)
1857 (:temporary (:sc double-reg :offset fr1-offset
1858 :from :argument :to :result) fr1)
1859 (:temporary (:sc double-reg :offset fr2-offset
1860 :from :argument :to :result) fr2)
1861 (:results (y :scs (double-reg)))
1862 (:arg-types double-float)
1863 (:result-types double-float)
1864 (:policy :fast-safe)
1865 (:note "inline exp function")
1867 (:save-p :compute-only)
1870 (note-this-location vop :internal-error)
1871 (unless (zerop (tn-offset x))
1872 (inst fxch x) ; x to top of stack
1873 (unless (location= x y)
1874 (inst fst x))) ; maybe save it
1875 ;; Check for Inf or NaN
1879 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
1880 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
1881 (inst and ah-tn #x02) ; Test sign of Inf.
1882 (inst jmp :z DONE) ; +Inf gives +Inf.
1883 (inst fstp fr0) ; -Inf gives 0
1885 (inst jmp-short DONE)
1890 ;; Now fr0=x log2(e)
1894 (inst fsubp-sti fr1)
1897 (inst faddp-sti fr1)
1901 (unless (zerop (tn-offset y))
1904 ;;; Expm1 = exp(x) - 1.
1905 ;;; Handles the following special cases:
1906 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
1907 (define-vop (fexpm1)
1909 (:args (x :scs (double-reg) :target fr0))
1910 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
1911 (:temporary (:sc double-reg :offset fr0-offset
1912 :from :argument :to :result) fr0)
1913 (:temporary (:sc double-reg :offset fr1-offset
1914 :from :argument :to :result) fr1)
1915 (:temporary (:sc double-reg :offset fr2-offset
1916 :from :argument :to :result) fr2)
1917 (:results (y :scs (double-reg)))
1918 (:arg-types double-float)
1919 (:result-types double-float)
1920 (:policy :fast-safe)
1921 (:note "inline expm1 function")
1923 (:save-p :compute-only)
1926 (note-this-location vop :internal-error)
1927 (unless (zerop (tn-offset x))
1928 (inst fxch x) ; x to top of stack
1929 (unless (location= x y)
1930 (inst fst x))) ; maybe save it
1931 ;; Check for Inf or NaN
1935 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
1936 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
1937 (inst and ah-tn #x02) ; Test sign of Inf.
1938 (inst jmp :z DONE) ; +Inf gives +Inf.
1939 (inst fstp fr0) ; -Inf gives -1.0
1942 (inst jmp-short DONE)
1944 ;; Free two stack slots leaving the argument on top.
1948 (inst fmul fr1) ; Now fr0 = x log2(e)
1963 (unless (zerop (tn-offset y))
1968 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
1969 (:temporary (:sc double-reg :offset fr0-offset
1970 :from :argument :to :result) fr0)
1971 (:temporary (:sc double-reg :offset fr1-offset
1972 :from :argument :to :result) fr1)
1973 (:results (y :scs (double-reg)))
1974 (:arg-types double-float)
1975 (:result-types double-float)
1976 (:policy :fast-safe)
1977 (:note "inline log function")
1979 (:save-p :compute-only)
1981 (note-this-location vop :internal-error)
1996 ;; x is in a FP reg, not fr0 or fr1
2000 (inst fldd (make-random-tn :kind :normal
2001 :sc (sc-or-lose 'double-reg)
2002 :offset (1- (tn-offset x))))))
2004 ((double-stack descriptor-reg)
2008 (if (sc-is x double-stack)
2009 (inst fldd (ea-for-df-stack x))
2010 (inst fldd (ea-for-df-desc x)))
2015 (t (inst fstd y)))))
2017 (define-vop (flog10)
2019 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2020 (:temporary (:sc double-reg :offset fr0-offset
2021 :from :argument :to :result) fr0)
2022 (:temporary (:sc double-reg :offset fr1-offset
2023 :from :argument :to :result) fr1)
2024 (:results (y :scs (double-reg)))
2025 (:arg-types double-float)
2026 (:result-types double-float)
2027 (:policy :fast-safe)
2028 (:note "inline log10 function")
2030 (:save-p :compute-only)
2032 (note-this-location vop :internal-error)
2047 ;; x is in a FP reg, not fr0 or fr1
2051 (inst fldd (make-random-tn :kind :normal
2052 :sc (sc-or-lose 'double-reg)
2053 :offset (1- (tn-offset x))))))
2055 ((double-stack descriptor-reg)
2059 (if (sc-is x double-stack)
2060 (inst fldd (ea-for-df-stack x))
2061 (inst fldd (ea-for-df-desc x)))
2066 (t (inst fstd y)))))
2070 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2071 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2072 (:temporary (:sc double-reg :offset fr0-offset
2073 :from (:argument 0) :to :result) fr0)
2074 (:temporary (:sc double-reg :offset fr1-offset
2075 :from (:argument 1) :to :result) fr1)
2076 (:temporary (:sc double-reg :offset fr2-offset
2077 :from :load :to :result) fr2)
2078 (:results (r :scs (double-reg)))
2079 (:arg-types double-float double-float)
2080 (:result-types double-float)
2081 (:policy :fast-safe)
2082 (:note "inline pow function")
2084 (:save-p :compute-only)
2086 (note-this-location vop :internal-error)
2087 ;; Setup x in fr0 and y in fr1
2089 ;; x in fr0; y in fr1
2090 ((and (sc-is x double-reg) (zerop (tn-offset x))
2091 (sc-is y double-reg) (= 1 (tn-offset y))))
2092 ;; y in fr1; x not in fr0
2093 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2097 (copy-fp-reg-to-fr0 x))
2100 (inst fldd (ea-for-df-stack x)))
2103 (inst fldd (ea-for-df-desc x)))))
2104 ;; x in fr0; y not in fr1
2105 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2107 ;; Now load y to fr0
2110 (copy-fp-reg-to-fr0 y))
2113 (inst fldd (ea-for-df-stack y)))
2116 (inst fldd (ea-for-df-desc y))))
2118 ;; x in fr1; y not in fr1
2119 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2123 (copy-fp-reg-to-fr0 y))
2126 (inst fldd (ea-for-df-stack y)))
2129 (inst fldd (ea-for-df-desc y))))
2132 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2134 ;; Now load x to fr0
2137 (copy-fp-reg-to-fr0 x))
2140 (inst fldd (ea-for-df-stack x)))
2143 (inst fldd (ea-for-df-desc x)))))
2144 ;; Neither x or y are in either fr0 or fr1
2151 (inst fldd (make-random-tn :kind :normal
2152 :sc (sc-or-lose 'double-reg)
2153 :offset (- (tn-offset y) 2))))
2155 (inst fldd (ea-for-df-stack y)))
2157 (inst fldd (ea-for-df-desc y))))
2161 (inst fldd (make-random-tn :kind :normal
2162 :sc (sc-or-lose 'double-reg)
2163 :offset (1- (tn-offset x)))))
2165 (inst fldd (ea-for-df-stack x)))
2167 (inst fldd (ea-for-df-desc x))))))
2169 ;; Now have x at fr0; and y at fr1
2171 ;; Now fr0=y log2(x)
2175 (inst fsubp-sti fr1)
2178 (inst faddp-sti fr1)
2183 (t (inst fstd r)))))
2185 (define-vop (fscalen)
2186 (:translate %scalbn)
2187 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2188 (y :scs (signed-stack signed-reg) :target temp))
2189 (:temporary (:sc double-reg :offset fr0-offset
2190 :from (:argument 0) :to :result) fr0)
2191 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2192 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2193 (:results (r :scs (double-reg)))
2194 (:arg-types double-float signed-num)
2195 (:result-types double-float)
2196 (:policy :fast-safe)
2197 (:note "inline scalbn function")
2199 ;; Setup x in fr0 and y in fr1
2230 (inst fld (make-random-tn :kind :normal
2231 :sc (sc-or-lose 'double-reg)
2232 :offset (1- (tn-offset x)))))))
2233 ((double-stack descriptor-reg)
2242 (if (sc-is x double-stack)
2243 (inst fldd (ea-for-df-stack x))
2244 (inst fldd (ea-for-df-desc x)))))
2246 (unless (zerop (tn-offset r))
2249 (define-vop (fscale)
2251 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2252 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2253 (:temporary (:sc double-reg :offset fr0-offset
2254 :from (:argument 0) :to :result) fr0)
2255 (:temporary (:sc double-reg :offset fr1-offset
2256 :from (:argument 1) :to :result) fr1)
2257 (:results (r :scs (double-reg)))
2258 (:arg-types double-float double-float)
2259 (:result-types double-float)
2260 (:policy :fast-safe)
2261 (:note "inline scalb function")
2263 (:save-p :compute-only)
2265 (note-this-location vop :internal-error)
2266 ;; Setup x in fr0 and y in fr1
2268 ;; x in fr0; y in fr1
2269 ((and (sc-is x double-reg) (zerop (tn-offset x))
2270 (sc-is y double-reg) (= 1 (tn-offset y))))
2271 ;; y in fr1; x not in fr0
2272 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2276 (copy-fp-reg-to-fr0 x))
2279 (inst fldd (ea-for-df-stack x)))
2282 (inst fldd (ea-for-df-desc x)))))
2283 ;; x in fr0; y not in fr1
2284 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2286 ;; Now load y to fr0
2289 (copy-fp-reg-to-fr0 y))
2292 (inst fldd (ea-for-df-stack y)))
2295 (inst fldd (ea-for-df-desc y))))
2297 ;; x in fr1; y not in fr1
2298 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2302 (copy-fp-reg-to-fr0 y))
2305 (inst fldd (ea-for-df-stack y)))
2308 (inst fldd (ea-for-df-desc y))))
2311 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2313 ;; Now load x to fr0
2316 (copy-fp-reg-to-fr0 x))
2319 (inst fldd (ea-for-df-stack x)))
2322 (inst fldd (ea-for-df-desc x)))))
2323 ;; Neither x or y are in either fr0 or fr1
2330 (inst fldd (make-random-tn :kind :normal
2331 :sc (sc-or-lose 'double-reg)
2332 :offset (- (tn-offset y) 2))))
2334 (inst fldd (ea-for-df-stack y)))
2336 (inst fldd (ea-for-df-desc y))))
2340 (inst fldd (make-random-tn :kind :normal
2341 :sc (sc-or-lose 'double-reg)
2342 :offset (1- (tn-offset x)))))
2344 (inst fldd (ea-for-df-stack x)))
2346 (inst fldd (ea-for-df-desc x))))))
2348 ;; Now have x at fr0; and y at fr1
2350 (unless (zerop (tn-offset r))
2353 (define-vop (flog1p)
2355 (:args (x :scs (double-reg) :to :result))
2356 (:temporary (:sc double-reg :offset fr0-offset
2357 :from :argument :to :result) fr0)
2358 (:temporary (:sc double-reg :offset fr1-offset
2359 :from :argument :to :result) fr1)
2360 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2361 (:results (y :scs (double-reg)))
2362 (:arg-types double-float)
2363 (:result-types double-float)
2364 (:policy :fast-safe)
2365 (:note "inline log1p function")
2368 ;; x is in a FP reg, not fr0, fr1.
2371 (inst fldd (make-random-tn :kind :normal
2372 :sc (sc-or-lose 'double-reg)
2373 :offset (- (tn-offset x) 2)))
2375 (inst push #x3e947ae1) ; Constant 0.29
2377 (inst fld (make-ea :dword :base rsp-tn))
2380 (inst fnstsw) ; status word to ax
2381 (inst and ah-tn #x45)
2382 (inst jmp :z WITHIN-RANGE)
2383 ;; Out of range for fyl2xp1.
2385 (inst faddd (make-random-tn :kind :normal
2386 :sc (sc-or-lose 'double-reg)
2387 :offset (- (tn-offset x) 1)))
2395 (inst fldd (make-random-tn :kind :normal
2396 :sc (sc-or-lose 'double-reg)
2397 :offset (- (tn-offset x) 1)))
2403 (t (inst fstd y)))))
2405 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2406 ;;; instruction and a range check can be avoided.
2407 (define-vop (flog1p-pentium)
2409 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2410 (:temporary (:sc double-reg :offset fr0-offset
2411 :from :argument :to :result) fr0)
2412 (:temporary (:sc double-reg :offset fr1-offset
2413 :from :argument :to :result) fr1)
2414 (:results (y :scs (double-reg)))
2415 (:arg-types double-float)
2416 (:result-types double-float)
2417 (:policy :fast-safe)
2418 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2419 (:note "inline log1p with limited x range function")
2421 (:save-p :compute-only)
2423 (note-this-location vop :internal-error)
2438 ;; x is in a FP reg, not fr0 or fr1
2442 (inst fldd (make-random-tn :kind :normal
2443 :sc (sc-or-lose 'double-reg)
2444 :offset (1- (tn-offset x)))))))
2445 ((double-stack descriptor-reg)
2449 (if (sc-is x double-stack)
2450 (inst fldd (ea-for-df-stack x))
2451 (inst fldd (ea-for-df-desc x)))))
2456 (t (inst fstd y)))))
2460 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2461 (:temporary (:sc double-reg :offset fr0-offset
2462 :from :argument :to :result) fr0)
2463 (:temporary (:sc double-reg :offset fr1-offset
2464 :from :argument :to :result) fr1)
2465 (:results (y :scs (double-reg)))
2466 (:arg-types double-float)
2467 (:result-types double-float)
2468 (:policy :fast-safe)
2469 (:note "inline logb function")
2471 (:save-p :compute-only)
2473 (note-this-location vop :internal-error)
2484 ;; x is in a FP reg, not fr0 or fr1
2487 (inst fldd (make-random-tn :kind :normal
2488 :sc (sc-or-lose 'double-reg)
2489 :offset (- (tn-offset x) 2))))))
2490 ((double-stack descriptor-reg)
2493 (if (sc-is x double-stack)
2494 (inst fldd (ea-for-df-stack x))
2495 (inst fldd (ea-for-df-desc x)))))
2506 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2507 (:temporary (:sc double-reg :offset fr0-offset
2508 :from (:argument 0) :to :result) fr0)
2509 (:temporary (:sc double-reg :offset fr1-offset
2510 :from (:argument 0) :to :result) fr1)
2511 (:results (r :scs (double-reg)))
2512 (:arg-types double-float)
2513 (:result-types double-float)
2514 (:policy :fast-safe)
2515 (:note "inline atan function")
2517 (:save-p :compute-only)
2519 (note-this-location vop :internal-error)
2520 ;; Setup x in fr1 and 1.0 in fr0
2523 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2526 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2528 ;; x not in fr0 or fr1
2535 (inst fldd (make-random-tn :kind :normal
2536 :sc (sc-or-lose 'double-reg)
2537 :offset (- (tn-offset x) 2))))
2539 (inst fldd (ea-for-df-stack x)))
2541 (inst fldd (ea-for-df-desc x))))))
2543 ;; Now have x at fr1; and 1.0 at fr0
2548 (t (inst fstd r)))))
2550 (define-vop (fatan2)
2552 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
2553 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
2554 (:temporary (:sc double-reg :offset fr0-offset
2555 :from (:argument 1) :to :result) fr0)
2556 (:temporary (:sc double-reg :offset fr1-offset
2557 :from (:argument 0) :to :result) fr1)
2558 (:results (r :scs (double-reg)))
2559 (:arg-types double-float double-float)
2560 (:result-types double-float)
2561 (:policy :fast-safe)
2562 (:note "inline atan2 function")
2564 (:save-p :compute-only)
2566 (note-this-location vop :internal-error)
2567 ;; Setup x in fr1 and y in fr0
2569 ;; y in fr0; x in fr1
2570 ((and (sc-is y double-reg) (zerop (tn-offset y))
2571 (sc-is x double-reg) (= 1 (tn-offset x))))
2572 ;; x in fr1; y not in fr0
2573 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2577 (copy-fp-reg-to-fr0 y))
2580 (inst fldd (ea-for-df-stack y)))
2583 (inst fldd (ea-for-df-desc y)))))
2584 ((and (sc-is x double-reg) (zerop (tn-offset x))
2585 (sc-is y double-reg) (zerop (tn-offset x)))
2588 ;; y in fr0; x not in fr1
2589 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2591 ;; Now load x to fr0
2594 (copy-fp-reg-to-fr0 x))
2597 (inst fldd (ea-for-df-stack x)))
2600 (inst fldd (ea-for-df-desc x))))
2602 ;; y in fr1; x not in fr1
2603 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2607 (copy-fp-reg-to-fr0 x))
2610 (inst fldd (ea-for-df-stack x)))
2613 (inst fldd (ea-for-df-desc x))))
2616 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2618 ;; Now load y to fr0
2621 (copy-fp-reg-to-fr0 y))
2624 (inst fldd (ea-for-df-stack y)))
2627 (inst fldd (ea-for-df-desc y)))))
2628 ;; Neither y or x are in either fr0 or fr1
2635 (inst fldd (make-random-tn :kind :normal
2636 :sc (sc-or-lose 'double-reg)
2637 :offset (- (tn-offset x) 2))))
2639 (inst fldd (ea-for-df-stack x)))
2641 (inst fldd (ea-for-df-desc x))))
2645 (inst fldd (make-random-tn :kind :normal
2646 :sc (sc-or-lose 'double-reg)
2647 :offset (1- (tn-offset y)))))
2649 (inst fldd (ea-for-df-stack y)))
2651 (inst fldd (ea-for-df-desc y))))))
2653 ;; Now have y at fr0; and x at fr1
2658 (t (inst fstd r)))))
2659 ) ; PROGN #!-LONG-FLOAT
2662 ;;;; complex float VOPs
2664 (define-vop (make-complex-single-float)
2665 (:translate complex)
2666 (:args (real :scs (single-reg) :to :result :target r
2667 :load-if (not (location= real r)))
2668 (imag :scs (single-reg) :to :save))
2669 (:arg-types single-float single-float)
2670 (:results (r :scs (complex-single-reg) :from (:argument 0)
2671 :load-if (not (sc-is r complex-single-stack))))
2672 (:result-types complex-single-float)
2673 (:note "inline complex single-float creation")
2674 (:policy :fast-safe)
2678 (let ((r-real (complex-double-reg-real-tn r)))
2679 (unless (location= real r-real)
2680 (cond ((zerop (tn-offset r-real))
2681 (copy-fp-reg-to-fr0 real))
2682 ((zerop (tn-offset real))
2687 (inst fxch real)))))
2688 (let ((r-imag (complex-double-reg-imag-tn r)))
2689 (unless (location= imag r-imag)
2690 (cond ((zerop (tn-offset imag))
2695 (inst fxch imag))))))
2696 (complex-single-stack
2697 (unless (location= real r)
2698 (cond ((zerop (tn-offset real))
2699 (inst fst (ea-for-csf-real-stack r)))
2702 (inst fst (ea-for-csf-real-stack r))
2705 (inst fst (ea-for-csf-imag-stack r))
2706 (inst fxch imag)))))
2708 (define-vop (make-complex-double-float)
2709 (:translate complex)
2710 (:args (real :scs (double-reg) :target r
2711 :load-if (not (location= real r)))
2712 (imag :scs (double-reg) :to :save))
2713 (:arg-types double-float double-float)
2714 (:results (r :scs (complex-double-reg) :from (:argument 0)
2715 :load-if (not (sc-is r complex-double-stack))))
2716 (:result-types complex-double-float)
2717 (:note "inline complex double-float creation")
2718 (:policy :fast-safe)
2722 (let ((r-real (complex-double-reg-real-tn r)))
2723 (unless (location= real r-real)
2724 (cond ((zerop (tn-offset r-real))
2725 (copy-fp-reg-to-fr0 real))
2726 ((zerop (tn-offset real))
2731 (inst fxch real)))))
2732 (let ((r-imag (complex-double-reg-imag-tn r)))
2733 (unless (location= imag r-imag)
2734 (cond ((zerop (tn-offset imag))
2739 (inst fxch imag))))))
2740 (complex-double-stack
2741 (unless (location= real r)
2742 (cond ((zerop (tn-offset real))
2743 (inst fstd (ea-for-cdf-real-stack r)))
2746 (inst fstd (ea-for-cdf-real-stack r))
2749 (inst fstd (ea-for-cdf-imag-stack r))
2750 (inst fxch imag)))))
2752 (define-vop (complex-float-value)
2753 (:args (x :target r))
2755 (:variant-vars offset)
2756 (:policy :fast-safe)
2758 (cond ((sc-is x complex-single-reg complex-double-reg)
2760 (make-random-tn :kind :normal
2761 :sc (sc-or-lose 'double-reg)
2762 :offset (+ offset (tn-offset x)))))
2763 (unless (location= value-tn r)
2764 (cond ((zerop (tn-offset r))
2765 (copy-fp-reg-to-fr0 value-tn))
2766 ((zerop (tn-offset value-tn))
2769 (inst fxch value-tn)
2771 (inst fxch value-tn))))))
2772 ((sc-is r single-reg)
2773 (let ((ea (sc-case x
2774 (complex-single-stack
2776 (0 (ea-for-csf-real-stack x))
2777 (1 (ea-for-csf-imag-stack x))))
2780 (0 (ea-for-csf-real-desc x))
2781 (1 (ea-for-csf-imag-desc x)))))))
2782 (with-empty-tn@fp-top(r)
2784 ((sc-is r double-reg)
2785 (let ((ea (sc-case x
2786 (complex-double-stack
2788 (0 (ea-for-cdf-real-stack x))
2789 (1 (ea-for-cdf-imag-stack x))))
2792 (0 (ea-for-cdf-real-desc x))
2793 (1 (ea-for-cdf-imag-desc x)))))))
2794 (with-empty-tn@fp-top(r)
2796 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
2798 (define-vop (realpart/complex-single-float complex-float-value)
2799 (:translate realpart)
2800 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
2802 (:arg-types complex-single-float)
2803 (:results (r :scs (single-reg)))
2804 (:result-types single-float)
2805 (:note "complex float realpart")
2808 (define-vop (realpart/complex-double-float complex-float-value)
2809 (:translate realpart)
2810 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
2812 (:arg-types complex-double-float)
2813 (:results (r :scs (double-reg)))
2814 (:result-types double-float)
2815 (:note "complex float realpart")
2818 (define-vop (imagpart/complex-single-float complex-float-value)
2819 (:translate imagpart)
2820 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
2822 (:arg-types complex-single-float)
2823 (:results (r :scs (single-reg)))
2824 (:result-types single-float)
2825 (:note "complex float imagpart")
2828 (define-vop (imagpart/complex-double-float complex-float-value)
2829 (:translate imagpart)
2830 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
2832 (:arg-types complex-double-float)
2833 (:results (r :scs (double-reg)))
2834 (:result-types double-float)
2835 (:note "complex float imagpart")
2839 ;;; hack dummy VOPs to bias the representation selection of their
2840 ;;; arguments towards a FP register, which can help avoid consing at
2841 ;;; inappropriate locations
2842 (defknown double-float-reg-bias (double-float) (values))
2843 (define-vop (double-float-reg-bias)
2844 (:translate double-float-reg-bias)
2845 (:args (x :scs (double-reg double-stack) :load-if nil))
2846 (:arg-types double-float)
2847 (:policy :fast-safe)
2848 (:note "inline dummy FP register bias")
2851 (defknown single-float-reg-bias (single-float) (values))
2852 (define-vop (single-float-reg-bias)
2853 (:translate single-float-reg-bias)
2854 (:args (x :scs (single-reg single-stack) :load-if nil))
2855 (:arg-types single-float)
2856 (:policy :fast-safe)
2857 (:note "inline dummy FP register bias")