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-lf-desc (tn)
25 (ea-for-xf-desc tn long-float-value-slot))
27 (defun ea-for-csf-real-desc (tn)
28 (ea-for-xf-desc tn complex-single-float-real-slot))
29 (defun ea-for-csf-imag-desc (tn)
30 (ea-for-xf-desc tn complex-single-float-imag-slot))
31 (defun ea-for-cdf-real-desc (tn)
32 (ea-for-xf-desc tn complex-double-float-real-slot))
33 (defun ea-for-cdf-imag-desc (tn)
34 (ea-for-xf-desc tn complex-double-float-imag-slot))
36 (defun ea-for-clf-real-desc (tn)
37 (ea-for-xf-desc tn complex-long-float-real-slot))
39 (defun ea-for-clf-imag-desc (tn)
40 (ea-for-xf-desc tn complex-long-float-imag-slot)))
42 (macrolet ((ea-for-xf-stack (tn kind)
45 :disp (- (* (+ (tn-offset ,tn)
46 (ecase ,kind (:single 1) (:double 2) (:long 3)))
48 (defun ea-for-sf-stack (tn)
49 (ea-for-xf-stack tn :single))
50 (defun ea-for-df-stack (tn)
51 (ea-for-xf-stack tn :double))
53 (defun ea-for-lf-stack (tn)
54 (ea-for-xf-stack tn :long)))
56 ;;; Telling the FPU to wait is required in order to make signals occur
57 ;;; at the expected place, but naturally slows things down.
59 ;;; NODE is the node whose compilation policy controls the decision
60 ;;; whether to just blast through carelessly or carefully emit wait
61 ;;; instructions and whatnot.
63 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
64 ;;; #'NOTE-NEXT-INSTRUCTION.
65 (defun maybe-fp-wait (node &optional note-next-instruction)
66 (when (policy node (or (= debug 3) (> safety speed))))
67 (when note-next-instruction
68 (note-next-instruction note-next-instruction :internal-error))
71 ;;; complex float stack EAs
72 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
75 :disp (- (* (+ (tn-offset ,tn)
80 (ecase ,slot (:real 1) (:imag 2))))
82 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
83 (ea-for-cxf-stack tn :single :real base))
84 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
85 (ea-for-cxf-stack tn :single :imag base))
86 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
87 (ea-for-cxf-stack tn :double :real base))
88 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
89 (ea-for-cxf-stack tn :double :imag base))
91 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
92 (ea-for-cxf-stack tn :long :real base))
94 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
95 (ea-for-cxf-stack tn :long :imag base)))
97 ;;; Abstract out the copying of a FP register to the FP stack top, and
98 ;;; provide two alternatives for its implementation. Note: it's not
99 ;;; necessary to distinguish between a single or double register move
102 ;;; Using a Pop then load.
103 (defun copy-fp-reg-to-fr0 (reg)
104 (aver (not (zerop (tn-offset reg))))
106 (inst fld (make-random-tn :kind :normal
107 :sc (sc-or-lose 'double-reg)
108 :offset (1- (tn-offset reg)))))
109 ;;; Using Fxch then Fst to restore the original reg contents.
111 (defun copy-fp-reg-to-fr0 (reg)
112 (aver (not (zerop (tn-offset reg))))
116 ;;; The x86 can't store a long-float to memory without popping the
117 ;;; stack and marking a register as empty, so it is necessary to
118 ;;; restore the register from memory.
120 (defun store-long-float (ea)
126 ;;; X is source, Y is destination.
127 (define-move-fun (load-single 2) (vop x y)
128 ((single-stack) (single-reg))
129 (with-empty-tn@fp-top(y)
130 (inst fld (ea-for-sf-stack x))))
132 (define-move-fun (store-single 2) (vop x y)
133 ((single-reg) (single-stack))
134 (cond ((zerop (tn-offset x))
135 (inst fst (ea-for-sf-stack y)))
138 (inst fst (ea-for-sf-stack y))
139 ;; This may not be necessary as ST0 is likely invalid now.
142 (define-move-fun (load-double 2) (vop x y)
143 ((double-stack) (double-reg))
144 (with-empty-tn@fp-top(y)
145 (inst fldd (ea-for-df-stack x))))
147 (define-move-fun (store-double 2) (vop x y)
148 ((double-reg) (double-stack))
149 (cond ((zerop (tn-offset x))
150 (inst fstd (ea-for-df-stack y)))
153 (inst fstd (ea-for-df-stack y))
154 ;; This may not be necessary as ST0 is likely invalid now.
158 (define-move-fun (load-long 2) (vop x y)
159 ((long-stack) (long-reg))
160 (with-empty-tn@fp-top(y)
161 (inst fldl (ea-for-lf-stack x))))
164 (define-move-fun (store-long 2) (vop x y)
165 ((long-reg) (long-stack))
166 (cond ((zerop (tn-offset x))
167 (store-long-float (ea-for-lf-stack y)))
170 (store-long-float (ea-for-lf-stack y))
171 ;; This may not be necessary as ST0 is likely invalid now.
174 ;;; The i387 has instructions to load some useful constants. This
175 ;;; doesn't save much time but might cut down on memory access and
176 ;;; reduce the size of the constant vector (CV). Intel claims they are
177 ;;; stored in a more precise form on chip. Anyhow, might as well use
178 ;;; the feature. It can be turned off by hacking the
179 ;;; "immediate-constant-sc" in vm.lisp.
180 (define-move-fun (load-fp-constant 2) (vop x y)
181 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
182 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
183 (with-empty-tn@fp-top(y)
190 ((= value (log 10l0 2l0))
192 ((= value (log 2.718281828459045235360287471352662L0 2l0))
194 ((= value (log 2l0 10l0))
196 ((= value (log 2l0 2.718281828459045235360287471352662L0))
198 (t (warn "ignoring bogus i387 constant ~A" value))))))
201 ;;;; complex float move functions
203 (defun complex-single-reg-real-tn (x)
204 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
205 :offset (tn-offset x)))
206 (defun complex-single-reg-imag-tn (x)
207 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
208 :offset (1+ (tn-offset x))))
210 (defun complex-double-reg-real-tn (x)
211 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
212 :offset (tn-offset x)))
213 (defun complex-double-reg-imag-tn (x)
214 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
215 :offset (1+ (tn-offset x))))
218 (defun complex-long-reg-real-tn (x)
219 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
220 :offset (tn-offset x)))
222 (defun complex-long-reg-imag-tn (x)
223 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
224 :offset (1+ (tn-offset x))))
226 ;;; X is source, Y is destination.
227 (define-move-fun (load-complex-single 2) (vop x y)
228 ((complex-single-stack) (complex-single-reg))
229 (let ((real-tn (complex-single-reg-real-tn y)))
230 (with-empty-tn@fp-top (real-tn)
231 (inst fld (ea-for-csf-real-stack x))))
232 (let ((imag-tn (complex-single-reg-imag-tn y)))
233 (with-empty-tn@fp-top (imag-tn)
234 (inst fld (ea-for-csf-imag-stack x)))))
236 (define-move-fun (store-complex-single 2) (vop x y)
237 ((complex-single-reg) (complex-single-stack))
238 (let ((real-tn (complex-single-reg-real-tn x)))
239 (cond ((zerop (tn-offset real-tn))
240 (inst fst (ea-for-csf-real-stack y)))
243 (inst fst (ea-for-csf-real-stack y))
244 (inst fxch real-tn))))
245 (let ((imag-tn (complex-single-reg-imag-tn x)))
247 (inst fst (ea-for-csf-imag-stack y))
248 (inst fxch imag-tn)))
250 (define-move-fun (load-complex-double 2) (vop x y)
251 ((complex-double-stack) (complex-double-reg))
252 (let ((real-tn (complex-double-reg-real-tn y)))
253 (with-empty-tn@fp-top(real-tn)
254 (inst fldd (ea-for-cdf-real-stack x))))
255 (let ((imag-tn (complex-double-reg-imag-tn y)))
256 (with-empty-tn@fp-top(imag-tn)
257 (inst fldd (ea-for-cdf-imag-stack x)))))
259 (define-move-fun (store-complex-double 2) (vop x y)
260 ((complex-double-reg) (complex-double-stack))
261 (let ((real-tn (complex-double-reg-real-tn x)))
262 (cond ((zerop (tn-offset real-tn))
263 (inst fstd (ea-for-cdf-real-stack y)))
266 (inst fstd (ea-for-cdf-real-stack y))
267 (inst fxch real-tn))))
268 (let ((imag-tn (complex-double-reg-imag-tn x)))
270 (inst fstd (ea-for-cdf-imag-stack y))
271 (inst fxch imag-tn)))
274 (define-move-fun (load-complex-long 2) (vop x y)
275 ((complex-long-stack) (complex-long-reg))
276 (let ((real-tn (complex-long-reg-real-tn y)))
277 (with-empty-tn@fp-top(real-tn)
278 (inst fldl (ea-for-clf-real-stack x))))
279 (let ((imag-tn (complex-long-reg-imag-tn y)))
280 (with-empty-tn@fp-top(imag-tn)
281 (inst fldl (ea-for-clf-imag-stack x)))))
284 (define-move-fun (store-complex-long 2) (vop x y)
285 ((complex-long-reg) (complex-long-stack))
286 (let ((real-tn (complex-long-reg-real-tn x)))
287 (cond ((zerop (tn-offset real-tn))
288 (store-long-float (ea-for-clf-real-stack y)))
291 (store-long-float (ea-for-clf-real-stack y))
292 (inst fxch real-tn))))
293 (let ((imag-tn (complex-long-reg-imag-tn x)))
295 (store-long-float (ea-for-clf-imag-stack y))
296 (inst fxch imag-tn)))
301 ;;; float register to register moves
302 (define-vop (float-move)
307 (unless (location= x y)
308 (cond ((zerop (tn-offset y))
309 (copy-fp-reg-to-fr0 x))
310 ((zerop (tn-offset x))
317 (define-vop (single-move float-move)
318 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
319 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
320 (define-move-vop single-move :move (single-reg) (single-reg))
322 (define-vop (double-move float-move)
323 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
324 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
325 (define-move-vop double-move :move (double-reg) (double-reg))
328 (define-vop (long-move float-move)
329 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
330 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
332 (define-move-vop long-move :move (long-reg) (long-reg))
334 ;;; complex float register to register moves
335 (define-vop (complex-float-move)
336 (:args (x :target y :load-if (not (location= x y))))
337 (:results (y :load-if (not (location= x y))))
338 (:note "complex float move")
340 (unless (location= x y)
341 ;; Note the complex-float-regs are aligned to every second
342 ;; float register so there is not need to worry about overlap.
343 (let ((x-real (complex-double-reg-real-tn x))
344 (y-real (complex-double-reg-real-tn y)))
345 (cond ((zerop (tn-offset y-real))
346 (copy-fp-reg-to-fr0 x-real))
347 ((zerop (tn-offset x-real))
352 (inst fxch x-real))))
353 (let ((x-imag (complex-double-reg-imag-tn x))
354 (y-imag (complex-double-reg-imag-tn y)))
357 (inst fxch x-imag)))))
359 (define-vop (complex-single-move complex-float-move)
360 (:args (x :scs (complex-single-reg) :target y
361 :load-if (not (location= x y))))
362 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
363 (define-move-vop complex-single-move :move
364 (complex-single-reg) (complex-single-reg))
366 (define-vop (complex-double-move complex-float-move)
367 (:args (x :scs (complex-double-reg)
368 :target y :load-if (not (location= x y))))
369 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
370 (define-move-vop complex-double-move :move
371 (complex-double-reg) (complex-double-reg))
374 (define-vop (complex-long-move complex-float-move)
375 (:args (x :scs (complex-long-reg)
376 :target y :load-if (not (location= x y))))
377 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
379 (define-move-vop complex-long-move :move
380 (complex-long-reg) (complex-long-reg))
382 ;;; Move from float to a descriptor reg. allocating a new float
383 ;;; object in the process.
384 (define-vop (move-from-single)
385 (:args (x :scs (single-reg) :to :save))
386 (:results (y :scs (descriptor-reg)))
388 (:note "float to pointer coercion")
390 (with-fixed-allocation (y
392 single-float-size node)
394 (inst fst (ea-for-sf-desc y))))))
395 (define-move-vop move-from-single :move
396 (single-reg) (descriptor-reg))
398 (define-vop (move-from-double)
399 (:args (x :scs (double-reg) :to :save))
400 (:results (y :scs (descriptor-reg)))
402 (:note "float to pointer coercion")
404 (with-fixed-allocation (y
409 (inst fstd (ea-for-df-desc y))))))
410 (define-move-vop move-from-double :move
411 (double-reg) (descriptor-reg))
414 (define-vop (move-from-long)
415 (:args (x :scs (long-reg) :to :save))
416 (:results (y :scs (descriptor-reg)))
418 (:note "float to pointer coercion")
420 (with-fixed-allocation (y
425 (store-long-float (ea-for-lf-desc y))))))
427 (define-move-vop move-from-long :move
428 (long-reg) (descriptor-reg))
430 (define-vop (move-from-fp-constant)
431 (:args (x :scs (fp-constant)))
432 (:results (y :scs (descriptor-reg)))
434 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
435 (0f0 (load-symbol-value y *fp-constant-0f0*))
436 (1f0 (load-symbol-value y *fp-constant-1f0*))
437 (0d0 (load-symbol-value y *fp-constant-0d0*))
438 (1d0 (load-symbol-value y *fp-constant-1d0*))
440 (0l0 (load-symbol-value y *fp-constant-0l0*))
442 (1l0 (load-symbol-value y *fp-constant-1l0*))
444 (#.pi (load-symbol-value y *fp-constant-pi*))
446 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
448 (#.(log 2.718281828459045235360287471352662L0 2l0)
449 (load-symbol-value y *fp-constant-l2e*))
451 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
453 (#.(log 2l0 2.718281828459045235360287471352662L0)
454 (load-symbol-value y *fp-constant-ln2*)))))
455 (define-move-vop move-from-fp-constant :move
456 (fp-constant) (descriptor-reg))
458 ;;; Move from a descriptor to a float register.
459 (define-vop (move-to-single)
460 (:args (x :scs (descriptor-reg)))
461 (:results (y :scs (single-reg)))
462 (:note "pointer to float coercion")
464 (with-empty-tn@fp-top(y)
465 (inst fld (ea-for-sf-desc x)))))
466 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
468 (define-vop (move-to-double)
469 (:args (x :scs (descriptor-reg)))
470 (:results (y :scs (double-reg)))
471 (:note "pointer to float coercion")
473 (with-empty-tn@fp-top(y)
474 (inst fldd (ea-for-df-desc x)))))
475 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
478 (define-vop (move-to-long)
479 (:args (x :scs (descriptor-reg)))
480 (:results (y :scs (long-reg)))
481 (:note "pointer to float coercion")
483 (with-empty-tn@fp-top(y)
484 (inst fldl (ea-for-lf-desc x)))))
486 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
488 ;;; Move from complex float to a descriptor reg. allocating a new
489 ;;; complex float object in the process.
490 (define-vop (move-from-complex-single)
491 (:args (x :scs (complex-single-reg) :to :save))
492 (:results (y :scs (descriptor-reg)))
494 (:note "complex float to pointer coercion")
496 (with-fixed-allocation (y
497 complex-single-float-widetag
498 complex-single-float-size
500 (let ((real-tn (complex-single-reg-real-tn x)))
501 (with-tn@fp-top(real-tn)
502 (inst fst (ea-for-csf-real-desc y))))
503 (let ((imag-tn (complex-single-reg-imag-tn x)))
504 (with-tn@fp-top(imag-tn)
505 (inst fst (ea-for-csf-imag-desc y)))))))
506 (define-move-vop move-from-complex-single :move
507 (complex-single-reg) (descriptor-reg))
509 (define-vop (move-from-complex-double)
510 (:args (x :scs (complex-double-reg) :to :save))
511 (:results (y :scs (descriptor-reg)))
513 (:note "complex float to pointer coercion")
515 (with-fixed-allocation (y
516 complex-double-float-widetag
517 complex-double-float-size
519 (let ((real-tn (complex-double-reg-real-tn x)))
520 (with-tn@fp-top(real-tn)
521 (inst fstd (ea-for-cdf-real-desc y))))
522 (let ((imag-tn (complex-double-reg-imag-tn x)))
523 (with-tn@fp-top(imag-tn)
524 (inst fstd (ea-for-cdf-imag-desc y)))))))
525 (define-move-vop move-from-complex-double :move
526 (complex-double-reg) (descriptor-reg))
529 (define-vop (move-from-complex-long)
530 (:args (x :scs (complex-long-reg) :to :save))
531 (:results (y :scs (descriptor-reg)))
533 (:note "complex float to pointer coercion")
535 (with-fixed-allocation (y
536 complex-long-float-widetag
537 complex-long-float-size
539 (let ((real-tn (complex-long-reg-real-tn x)))
540 (with-tn@fp-top(real-tn)
541 (store-long-float (ea-for-clf-real-desc y))))
542 (let ((imag-tn (complex-long-reg-imag-tn x)))
543 (with-tn@fp-top(imag-tn)
544 (store-long-float (ea-for-clf-imag-desc y)))))))
546 (define-move-vop move-from-complex-long :move
547 (complex-long-reg) (descriptor-reg))
549 ;;; Move from a descriptor to a complex float register.
550 (macrolet ((frob (name sc format)
553 (:args (x :scs (descriptor-reg)))
554 (:results (y :scs (,sc)))
555 (:note "pointer to complex float coercion")
557 (let ((real-tn (complex-double-reg-real-tn y)))
558 (with-empty-tn@fp-top(real-tn)
560 (:single '((inst fld (ea-for-csf-real-desc x))))
561 (:double '((inst fldd (ea-for-cdf-real-desc x))))
563 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
564 (let ((imag-tn (complex-double-reg-imag-tn y)))
565 (with-empty-tn@fp-top(imag-tn)
567 (:single '((inst fld (ea-for-csf-imag-desc x))))
568 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
570 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
571 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
572 (frob move-to-complex-single complex-single-reg :single)
573 (frob move-to-complex-double complex-double-reg :double)
575 (frob move-to-complex-double complex-long-reg :long))
577 ;;;; the move argument vops
579 ;;;; Note these are also used to stuff fp numbers onto the c-call
580 ;;;; stack so the order is different than the lisp-stack.
582 ;;; the general MOVE-ARG VOP
583 (macrolet ((frob (name sc stack-sc format)
586 (:args (x :scs (,sc) :target y)
588 :load-if (not (sc-is y ,sc))))
590 (:note "float argument move")
591 (:generator ,(case format (:single 2) (:double 3) (:long 4))
594 (unless (location= x y)
595 (cond ((zerop (tn-offset y))
596 (copy-fp-reg-to-fr0 x))
597 ((zerop (tn-offset x))
604 (if (= (tn-offset fp) esp-offset)
605 (let* ((offset (* (tn-offset y) n-word-bytes))
606 (ea (make-ea :dword :base fp :disp offset)))
609 (:single '((inst fst ea)))
610 (:double '((inst fstd ea)))
612 (:long '((store-long-float ea))))))
615 :disp (- (* (+ (tn-offset y)
623 (:single '((inst fst ea)))
624 (:double '((inst fstd ea)))
626 (:long '((store-long-float ea)))))))))))
627 (define-move-vop ,name :move-arg
628 (,sc descriptor-reg) (,sc)))))
629 (frob move-single-float-arg single-reg single-stack :single)
630 (frob move-double-float-arg double-reg double-stack :double)
632 (frob move-long-float-arg long-reg long-stack :long))
634 ;;;; complex float MOVE-ARG VOP
635 (macrolet ((frob (name sc stack-sc format)
638 (:args (x :scs (,sc) :target y)
640 :load-if (not (sc-is y ,sc))))
642 (:note "complex float argument move")
643 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
646 (unless (location= x y)
647 (let ((x-real (complex-double-reg-real-tn x))
648 (y-real (complex-double-reg-real-tn y)))
649 (cond ((zerop (tn-offset y-real))
650 (copy-fp-reg-to-fr0 x-real))
651 ((zerop (tn-offset x-real))
656 (inst fxch x-real))))
657 (let ((x-imag (complex-double-reg-imag-tn x))
658 (y-imag (complex-double-reg-imag-tn y)))
661 (inst fxch x-imag))))
663 (let ((real-tn (complex-double-reg-real-tn x)))
664 (cond ((zerop (tn-offset real-tn))
668 (ea-for-csf-real-stack y fp))))
671 (ea-for-cdf-real-stack y fp))))
675 (ea-for-clf-real-stack y fp))))))
681 (ea-for-csf-real-stack y fp))))
684 (ea-for-cdf-real-stack y fp))))
688 (ea-for-clf-real-stack y fp)))))
689 (inst fxch real-tn))))
690 (let ((imag-tn (complex-double-reg-imag-tn x)))
694 '((inst fst (ea-for-csf-imag-stack y fp))))
696 '((inst fstd (ea-for-cdf-imag-stack y fp))))
700 (ea-for-clf-imag-stack y fp)))))
701 (inst fxch imag-tn))))))
702 (define-move-vop ,name :move-arg
703 (,sc descriptor-reg) (,sc)))))
704 (frob move-complex-single-float-arg
705 complex-single-reg complex-single-stack :single)
706 (frob move-complex-double-float-arg
707 complex-double-reg complex-double-stack :double)
709 (frob move-complex-long-float-arg
710 complex-long-reg complex-long-stack :long))
712 (define-move-vop move-arg :move-arg
713 (single-reg double-reg #!+long-float long-reg
714 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
720 ;;; dtc: the floating point arithmetic vops
722 ;;; Note: Although these can accept x and y on the stack or pointed to
723 ;;; from a descriptor register, they will work with register loading
724 ;;; without these. Same deal with the result - it need only be a
725 ;;; register. When load-tns are needed they will probably be in ST0
726 ;;; and the code below should be able to correctly handle all cases.
728 ;;; However it seems to produce better code if all arg. and result
729 ;;; options are used; on the P86 there is no extra cost in using a
730 ;;; memory operand to the FP instructions - not so on the PPro.
732 ;;; It may also be useful to handle constant args?
734 ;;; 22-Jul-97: descriptor args lose in some simple cases when
735 ;;; a function result computed in a loop. Then Python insists
736 ;;; on consing the intermediate values! For example
739 (declare (type (simple-array double-float (*)) a)
742 (declare (type double-float sum))
744 (incf sum (* (aref a i)(aref a i))))
747 ;;; So, disabling descriptor args until this can be fixed elsewhere.
749 ((frob (op fop-sti fopr-sti
751 fopd foprd dname dcost
753 #!-long-float (declare (ignore lcost lname))
757 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
759 (y :scs (single-reg single-stack #+nil descriptor-reg)
761 (:temporary (:sc single-reg :offset fr0-offset
762 :from :eval :to :result) fr0)
763 (:results (r :scs (single-reg single-stack)))
764 (:arg-types single-float single-float)
765 (:result-types single-float)
767 (:note "inline float arithmetic")
769 (:save-p :compute-only)
772 ;; Handle a few special cases
774 ;; x, y, and r are the same register.
775 ((and (sc-is x single-reg) (location= x r) (location= y r))
776 (cond ((zerop (tn-offset r))
781 ;; XX the source register will not be valid.
782 (note-next-instruction vop :internal-error)
785 ;; x and r are the same register.
786 ((and (sc-is x single-reg) (location= x r))
787 (cond ((zerop (tn-offset r))
790 ;; ST(0) = ST(0) op ST(y)
793 ;; ST(0) = ST(0) op Mem
794 (inst ,fop (ea-for-sf-stack y)))
796 (inst ,fop (ea-for-sf-desc y)))))
801 (unless (zerop (tn-offset y))
802 (copy-fp-reg-to-fr0 y)))
803 ((single-stack descriptor-reg)
805 (if (sc-is y single-stack)
806 (inst fld (ea-for-sf-stack y))
807 (inst fld (ea-for-sf-desc y)))))
808 ;; ST(i) = ST(i) op ST0
810 (maybe-fp-wait node vop))
811 ;; y and r are the same register.
812 ((and (sc-is y single-reg) (location= y r))
813 (cond ((zerop (tn-offset r))
816 ;; ST(0) = ST(x) op ST(0)
819 ;; ST(0) = Mem op ST(0)
820 (inst ,fopr (ea-for-sf-stack x)))
822 (inst ,fopr (ea-for-sf-desc x)))))
827 (unless (zerop (tn-offset x))
828 (copy-fp-reg-to-fr0 x)))
829 ((single-stack descriptor-reg)
831 (if (sc-is x single-stack)
832 (inst fld (ea-for-sf-stack x))
833 (inst fld (ea-for-sf-desc x)))))
834 ;; ST(i) = ST(0) op ST(i)
836 (maybe-fp-wait node vop))
839 ;; Get the result to ST0.
841 ;; Special handling is needed if x or y are in ST0, and
842 ;; simpler code is generated.
845 ((and (sc-is x single-reg) (zerop (tn-offset x)))
851 (inst ,fop (ea-for-sf-stack y)))
853 (inst ,fop (ea-for-sf-desc y)))))
855 ((and (sc-is y single-reg) (zerop (tn-offset y)))
861 (inst ,fopr (ea-for-sf-stack x)))
863 (inst ,fopr (ea-for-sf-desc x)))))
868 (copy-fp-reg-to-fr0 x))
871 (inst fld (ea-for-sf-stack x)))
874 (inst fld (ea-for-sf-desc x))))
880 (inst ,fop (ea-for-sf-stack y)))
882 (inst ,fop (ea-for-sf-desc y))))))
884 (note-next-instruction vop :internal-error)
886 ;; Finally save the result.
889 (cond ((zerop (tn-offset r))
890 (maybe-fp-wait node))
894 (inst fst (ea-for-sf-stack r))))))))
898 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
900 (y :scs (double-reg double-stack #+nil descriptor-reg)
902 (:temporary (:sc double-reg :offset fr0-offset
903 :from :eval :to :result) fr0)
904 (:results (r :scs (double-reg double-stack)))
905 (:arg-types double-float double-float)
906 (:result-types double-float)
908 (:note "inline float arithmetic")
910 (:save-p :compute-only)
913 ;; Handle a few special cases.
915 ;; x, y, and r are the same register.
916 ((and (sc-is x double-reg) (location= x r) (location= y r))
917 (cond ((zerop (tn-offset r))
922 ;; XX the source register will not be valid.
923 (note-next-instruction vop :internal-error)
926 ;; x and r are the same register.
927 ((and (sc-is x double-reg) (location= x r))
928 (cond ((zerop (tn-offset r))
931 ;; ST(0) = ST(0) op ST(y)
934 ;; ST(0) = ST(0) op Mem
935 (inst ,fopd (ea-for-df-stack y)))
937 (inst ,fopd (ea-for-df-desc y)))))
942 (unless (zerop (tn-offset y))
943 (copy-fp-reg-to-fr0 y)))
944 ((double-stack descriptor-reg)
946 (if (sc-is y double-stack)
947 (inst fldd (ea-for-df-stack y))
948 (inst fldd (ea-for-df-desc y)))))
949 ;; ST(i) = ST(i) op ST0
951 (maybe-fp-wait node vop))
952 ;; y and r are the same register.
953 ((and (sc-is y double-reg) (location= y r))
954 (cond ((zerop (tn-offset r))
957 ;; ST(0) = ST(x) op ST(0)
960 ;; ST(0) = Mem op ST(0)
961 (inst ,foprd (ea-for-df-stack x)))
963 (inst ,foprd (ea-for-df-desc x)))))
968 (unless (zerop (tn-offset x))
969 (copy-fp-reg-to-fr0 x)))
970 ((double-stack descriptor-reg)
972 (if (sc-is x double-stack)
973 (inst fldd (ea-for-df-stack x))
974 (inst fldd (ea-for-df-desc x)))))
975 ;; ST(i) = ST(0) op ST(i)
977 (maybe-fp-wait node vop))
980 ;; Get the result to ST0.
982 ;; Special handling is needed if x or y are in ST0, and
983 ;; simpler code is generated.
986 ((and (sc-is x double-reg) (zerop (tn-offset x)))
992 (inst ,fopd (ea-for-df-stack y)))
994 (inst ,fopd (ea-for-df-desc y)))))
996 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1002 (inst ,foprd (ea-for-df-stack x)))
1004 (inst ,foprd (ea-for-df-desc x)))))
1009 (copy-fp-reg-to-fr0 x))
1012 (inst fldd (ea-for-df-stack x)))
1015 (inst fldd (ea-for-df-desc x))))
1021 (inst ,fopd (ea-for-df-stack y)))
1023 (inst ,fopd (ea-for-df-desc y))))))
1025 (note-next-instruction vop :internal-error)
1027 ;; Finally save the result.
1030 (cond ((zerop (tn-offset r))
1031 (maybe-fp-wait node))
1035 (inst fstd (ea-for-df-stack r))))))))
1038 (define-vop (,lname)
1040 (:args (x :scs (long-reg) :to :eval)
1041 (y :scs (long-reg) :to :eval))
1042 (:temporary (:sc long-reg :offset fr0-offset
1043 :from :eval :to :result) fr0)
1044 (:results (r :scs (long-reg)))
1045 (:arg-types long-float long-float)
1046 (:result-types long-float)
1047 (:policy :fast-safe)
1048 (:note "inline float arithmetic")
1050 (:save-p :compute-only)
1053 ;; Handle a few special cases.
1055 ;; x, y, and r are the same register.
1056 ((and (location= x r) (location= y r))
1057 (cond ((zerop (tn-offset r))
1062 ;; XX the source register will not be valid.
1063 (note-next-instruction vop :internal-error)
1066 ;; x and r are the same register.
1068 (cond ((zerop (tn-offset r))
1069 ;; ST(0) = ST(0) op ST(y)
1073 (unless (zerop (tn-offset y))
1074 (copy-fp-reg-to-fr0 y))
1075 ;; ST(i) = ST(i) op ST0
1077 (maybe-fp-wait node vop))
1078 ;; y and r are the same register.
1080 (cond ((zerop (tn-offset r))
1081 ;; ST(0) = ST(x) op ST(0)
1085 (unless (zerop (tn-offset x))
1086 (copy-fp-reg-to-fr0 x))
1087 ;; ST(i) = ST(0) op ST(i)
1088 (inst ,fopr-sti r)))
1089 (maybe-fp-wait node vop))
1092 ;; Get the result to ST0.
1094 ;; Special handling is needed if x or y are in ST0, and
1095 ;; simpler code is generated.
1098 ((zerop (tn-offset x))
1102 ((zerop (tn-offset y))
1107 (copy-fp-reg-to-fr0 x)
1111 (note-next-instruction vop :internal-error)
1113 ;; Finally save the result.
1114 (cond ((zerop (tn-offset r))
1115 (maybe-fp-wait node))
1117 (inst fst r))))))))))
1119 (frob + fadd-sti fadd-sti
1120 fadd fadd +/single-float 2
1121 faddd faddd +/double-float 2
1123 (frob - fsub-sti fsubr-sti
1124 fsub fsubr -/single-float 2
1125 fsubd fsubrd -/double-float 2
1127 (frob * fmul-sti fmul-sti
1128 fmul fmul */single-float 3
1129 fmuld fmuld */double-float 3
1131 (frob / fdiv-sti fdivr-sti
1132 fdiv fdivr //single-float 12
1133 fdivd fdivrd //double-float 12
1136 (macrolet ((frob (name inst translate sc type)
1137 `(define-vop (,name)
1138 (:args (x :scs (,sc) :target fr0))
1139 (:results (y :scs (,sc)))
1140 (:translate ,translate)
1141 (:policy :fast-safe)
1143 (:result-types ,type)
1144 (:temporary (:sc double-reg :offset fr0-offset
1145 :from :argument :to :result) fr0)
1147 (:note "inline float arithmetic")
1149 (:save-p :compute-only)
1151 (note-this-location vop :internal-error)
1152 (unless (zerop (tn-offset x))
1153 (inst fxch x) ; x to top of stack
1154 (unless (location= x y)
1155 (inst fst x))) ; Maybe save it.
1156 (inst ,inst) ; Clobber st0.
1157 (unless (zerop (tn-offset y))
1160 (frob abs/single-float fabs abs single-reg single-float)
1161 (frob abs/double-float fabs abs double-reg double-float)
1163 (frob abs/long-float fabs abs long-reg long-float)
1164 (frob %negate/single-float fchs %negate single-reg single-float)
1165 (frob %negate/double-float fchs %negate double-reg double-float)
1167 (frob %negate/long-float fchs %negate long-reg long-float))
1171 (define-vop (=/float)
1173 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1175 (:info target not-p)
1176 (:policy :fast-safe)
1178 (:save-p :compute-only)
1179 (:note "inline float comparison")
1182 (note-this-location vop :internal-error)
1184 ;; x is in ST0; y is in any reg.
1185 ((zerop (tn-offset x))
1187 ;; y is in ST0; x is in another reg.
1188 ((zerop (tn-offset y))
1190 ;; x and y are the same register, not ST0
1195 ;; x and y are different registers, neither ST0.
1200 (inst fnstsw) ; status word to ax
1201 (inst and ah-tn #x45) ; C3 C2 C0
1202 (inst cmp ah-tn #x40)
1203 (inst jmp (if not-p :ne :e) target)))
1205 (define-vop (=/single-float =/float)
1207 (:args (x :scs (single-reg))
1208 (y :scs (single-reg)))
1209 (:arg-types single-float single-float))
1211 (define-vop (=/double-float =/float)
1213 (:args (x :scs (double-reg))
1214 (y :scs (double-reg)))
1215 (:arg-types double-float double-float))
1218 (define-vop (=/long-float =/float)
1220 (:args (x :scs (long-reg))
1221 (y :scs (long-reg)))
1222 (:arg-types long-float long-float))
1224 (define-vop (<single-float)
1226 (:args (x :scs (single-reg single-stack descriptor-reg))
1227 (y :scs (single-reg single-stack descriptor-reg)))
1228 (:arg-types single-float single-float)
1229 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1230 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1232 (:info target not-p)
1233 (:policy :fast-safe)
1234 (:note "inline float comparison")
1237 ;; Handle a few special cases.
1240 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1244 ((single-stack descriptor-reg)
1245 (if (sc-is x single-stack)
1246 (inst fcom (ea-for-sf-stack x))
1247 (inst fcom (ea-for-sf-desc x)))))
1248 (inst fnstsw) ; status word to ax
1249 (inst and ah-tn #x45))
1251 ;; general case when y is not in ST0
1256 (unless (zerop (tn-offset x))
1257 (copy-fp-reg-to-fr0 x)))
1258 ((single-stack descriptor-reg)
1260 (if (sc-is x single-stack)
1261 (inst fld (ea-for-sf-stack x))
1262 (inst fld (ea-for-sf-desc x)))))
1266 ((single-stack descriptor-reg)
1267 (if (sc-is y single-stack)
1268 (inst fcom (ea-for-sf-stack y))
1269 (inst fcom (ea-for-sf-desc y)))))
1270 (inst fnstsw) ; status word to ax
1271 (inst and ah-tn #x45) ; C3 C2 C0
1272 (inst cmp ah-tn #x01)))
1273 (inst jmp (if not-p :ne :e) target)))
1275 (define-vop (<double-float)
1277 (:args (x :scs (double-reg double-stack descriptor-reg))
1278 (y :scs (double-reg double-stack descriptor-reg)))
1279 (:arg-types double-float double-float)
1280 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1281 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1283 (:info target not-p)
1284 (:policy :fast-safe)
1285 (:note "inline float comparison")
1288 ;; Handle a few special cases
1291 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1295 ((double-stack descriptor-reg)
1296 (if (sc-is x double-stack)
1297 (inst fcomd (ea-for-df-stack x))
1298 (inst fcomd (ea-for-df-desc x)))))
1299 (inst fnstsw) ; status word to ax
1300 (inst and ah-tn #x45))
1302 ;; General case when y is not in ST0.
1307 (unless (zerop (tn-offset x))
1308 (copy-fp-reg-to-fr0 x)))
1309 ((double-stack descriptor-reg)
1311 (if (sc-is x double-stack)
1312 (inst fldd (ea-for-df-stack x))
1313 (inst fldd (ea-for-df-desc x)))))
1317 ((double-stack descriptor-reg)
1318 (if (sc-is y double-stack)
1319 (inst fcomd (ea-for-df-stack y))
1320 (inst fcomd (ea-for-df-desc y)))))
1321 (inst fnstsw) ; status word to ax
1322 (inst and ah-tn #x45) ; C3 C2 C0
1323 (inst cmp ah-tn #x01)))
1324 (inst jmp (if not-p :ne :e) target)))
1327 (define-vop (<long-float)
1329 (:args (x :scs (long-reg))
1330 (y :scs (long-reg)))
1331 (:arg-types long-float long-float)
1332 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1334 (:info target not-p)
1335 (:policy :fast-safe)
1336 (:note "inline float comparison")
1340 ;; x is in ST0; y is in any reg.
1341 ((zerop (tn-offset x))
1343 (inst fnstsw) ; status word to ax
1344 (inst and ah-tn #x45) ; C3 C2 C0
1345 (inst cmp ah-tn #x01))
1346 ;; y is in ST0; x is in another reg.
1347 ((zerop (tn-offset y))
1349 (inst fnstsw) ; status word to ax
1350 (inst and ah-tn #x45))
1351 ;; x and y are the same register, not ST0
1352 ;; x and y are different registers, neither ST0.
1357 (inst fnstsw) ; status word to ax
1358 (inst and ah-tn #x45))) ; C3 C2 C0
1359 (inst jmp (if not-p :ne :e) target)))
1361 (define-vop (>single-float)
1363 (:args (x :scs (single-reg single-stack descriptor-reg))
1364 (y :scs (single-reg single-stack descriptor-reg)))
1365 (:arg-types single-float single-float)
1366 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1367 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1369 (:info target not-p)
1370 (:policy :fast-safe)
1371 (:note "inline float comparison")
1374 ;; Handle a few special cases.
1377 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1381 ((single-stack descriptor-reg)
1382 (if (sc-is x single-stack)
1383 (inst fcom (ea-for-sf-stack x))
1384 (inst fcom (ea-for-sf-desc x)))))
1385 (inst fnstsw) ; status word to ax
1386 (inst and ah-tn #x45)
1387 (inst cmp ah-tn #x01))
1389 ;; general case when y is not in ST0
1394 (unless (zerop (tn-offset x))
1395 (copy-fp-reg-to-fr0 x)))
1396 ((single-stack descriptor-reg)
1398 (if (sc-is x single-stack)
1399 (inst fld (ea-for-sf-stack x))
1400 (inst fld (ea-for-sf-desc x)))))
1404 ((single-stack descriptor-reg)
1405 (if (sc-is y single-stack)
1406 (inst fcom (ea-for-sf-stack y))
1407 (inst fcom (ea-for-sf-desc y)))))
1408 (inst fnstsw) ; status word to ax
1409 (inst and ah-tn #x45)))
1410 (inst jmp (if not-p :ne :e) target)))
1412 (define-vop (>double-float)
1414 (:args (x :scs (double-reg double-stack descriptor-reg))
1415 (y :scs (double-reg double-stack descriptor-reg)))
1416 (:arg-types double-float double-float)
1417 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1418 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1420 (:info target not-p)
1421 (:policy :fast-safe)
1422 (:note "inline float comparison")
1425 ;; Handle a few special cases.
1428 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1432 ((double-stack descriptor-reg)
1433 (if (sc-is x double-stack)
1434 (inst fcomd (ea-for-df-stack x))
1435 (inst fcomd (ea-for-df-desc x)))))
1436 (inst fnstsw) ; status word to ax
1437 (inst and ah-tn #x45)
1438 (inst cmp ah-tn #x01))
1440 ;; general case when y is not in ST0
1445 (unless (zerop (tn-offset x))
1446 (copy-fp-reg-to-fr0 x)))
1447 ((double-stack descriptor-reg)
1449 (if (sc-is x double-stack)
1450 (inst fldd (ea-for-df-stack x))
1451 (inst fldd (ea-for-df-desc x)))))
1455 ((double-stack descriptor-reg)
1456 (if (sc-is y double-stack)
1457 (inst fcomd (ea-for-df-stack y))
1458 (inst fcomd (ea-for-df-desc y)))))
1459 (inst fnstsw) ; status word to ax
1460 (inst and ah-tn #x45)))
1461 (inst jmp (if not-p :ne :e) target)))
1464 (define-vop (>long-float)
1466 (:args (x :scs (long-reg))
1467 (y :scs (long-reg)))
1468 (:arg-types long-float long-float)
1469 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1471 (:info target not-p)
1472 (:policy :fast-safe)
1473 (:note "inline float comparison")
1477 ;; y is in ST0; x is in any reg.
1478 ((zerop (tn-offset y))
1480 (inst fnstsw) ; status word to ax
1481 (inst and ah-tn #x45)
1482 (inst cmp ah-tn #x01))
1483 ;; x is in ST0; y is in another reg.
1484 ((zerop (tn-offset x))
1486 (inst fnstsw) ; status word to ax
1487 (inst and ah-tn #x45))
1488 ;; y and x are the same register, not ST0
1489 ;; y and x are different registers, neither ST0.
1494 (inst fnstsw) ; status word to ax
1495 (inst and ah-tn #x45)))
1496 (inst jmp (if not-p :ne :e) target)))
1498 ;;; Comparisons with 0 can use the FTST instruction.
1500 (define-vop (float-test)
1502 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1504 (:info target not-p y)
1505 (:variant-vars code)
1506 (:policy :fast-safe)
1508 (:save-p :compute-only)
1509 (:note "inline float comparison")
1512 (note-this-location vop :internal-error)
1515 ((zerop (tn-offset x))
1522 (inst fnstsw) ; status word to ax
1523 (inst and ah-tn #x45) ; C3 C2 C0
1524 (unless (zerop code)
1525 (inst cmp ah-tn code))
1526 (inst jmp (if not-p :ne :e) target)))
1528 (define-vop (=0/single-float float-test)
1530 (:args (x :scs (single-reg)))
1531 #!-negative-zero-is-not-zero
1532 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1533 #!+negative-zero-is-not-zero
1534 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1536 (define-vop (=0/double-float float-test)
1538 (:args (x :scs (double-reg)))
1539 #!-negative-zero-is-not-zero
1540 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1541 #!+negative-zero-is-not-zero
1542 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1545 (define-vop (=0/long-float float-test)
1547 (:args (x :scs (long-reg)))
1548 #!-negative-zero-is-not-zero
1549 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1550 #!+negative-zero-is-not-zero
1551 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1554 (define-vop (<0/single-float float-test)
1556 (:args (x :scs (single-reg)))
1557 #!-negative-zero-is-not-zero
1558 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1559 #!+negative-zero-is-not-zero
1560 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1562 (define-vop (<0/double-float float-test)
1564 (:args (x :scs (double-reg)))
1565 #!-negative-zero-is-not-zero
1566 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1567 #!+negative-zero-is-not-zero
1568 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1571 (define-vop (<0/long-float float-test)
1573 (:args (x :scs (long-reg)))
1574 #!-negative-zero-is-not-zero
1575 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1576 #!+negative-zero-is-not-zero
1577 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1580 (define-vop (>0/single-float float-test)
1582 (:args (x :scs (single-reg)))
1583 #!-negative-zero-is-not-zero
1584 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1585 #!+negative-zero-is-not-zero
1586 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1588 (define-vop (>0/double-float float-test)
1590 (:args (x :scs (double-reg)))
1591 #!-negative-zero-is-not-zero
1592 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1593 #!+negative-zero-is-not-zero
1594 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1597 (define-vop (>0/long-float float-test)
1599 (:args (x :scs (long-reg)))
1600 #!-negative-zero-is-not-zero
1601 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1602 #!+negative-zero-is-not-zero
1603 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1607 (deftransform eql ((x y) (long-float long-float))
1608 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1609 (= (long-float-high-bits x) (long-float-high-bits y))
1610 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1614 (macrolet ((frob (name translate to-sc to-type)
1615 `(define-vop (,name)
1616 (:args (x :scs (signed-stack signed-reg) :target temp))
1617 (:temporary (:sc signed-stack) temp)
1618 (:results (y :scs (,to-sc)))
1619 (:arg-types signed-num)
1620 (:result-types ,to-type)
1621 (:policy :fast-safe)
1622 (:note "inline float coercion")
1623 (:translate ,translate)
1625 (:save-p :compute-only)
1630 (with-empty-tn@fp-top(y)
1631 (note-this-location vop :internal-error)
1634 (with-empty-tn@fp-top(y)
1635 (note-this-location vop :internal-error)
1636 (inst fild x))))))))
1637 (frob %single-float/signed %single-float single-reg single-float)
1638 (frob %double-float/signed %double-float double-reg double-float)
1640 (frob %long-float/signed %long-float long-reg long-float))
1642 (macrolet ((frob (name translate to-sc to-type)
1643 `(define-vop (,name)
1644 (:args (x :scs (unsigned-reg)))
1645 (:results (y :scs (,to-sc)))
1646 (:arg-types unsigned-num)
1647 (:result-types ,to-type)
1648 (:policy :fast-safe)
1649 (:note "inline float coercion")
1650 (:translate ,translate)
1652 (:save-p :compute-only)
1656 (with-empty-tn@fp-top(y)
1657 (note-this-location vop :internal-error)
1658 (inst fildl (make-ea :dword :base esp-tn)))
1659 (inst add esp-tn 8)))))
1660 (frob %single-float/unsigned %single-float single-reg single-float)
1661 (frob %double-float/unsigned %double-float double-reg double-float)
1663 (frob %long-float/unsigned %long-float long-reg long-float))
1665 ;;; These should be no-ops but the compiler might want to move some
1667 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1668 `(define-vop (,name)
1669 (:args (x :scs (,from-sc) :target y))
1670 (:results (y :scs (,to-sc)))
1671 (:arg-types ,from-type)
1672 (:result-types ,to-type)
1673 (:policy :fast-safe)
1674 (:note "inline float coercion")
1675 (:translate ,translate)
1677 (:save-p :compute-only)
1679 (note-this-location vop :internal-error)
1680 (unless (location= x y)
1682 ((zerop (tn-offset x))
1683 ;; x is in ST0, y is in another reg. not ST0
1685 ((zerop (tn-offset y))
1686 ;; y is in ST0, x is in another reg. not ST0
1687 (copy-fp-reg-to-fr0 x))
1689 ;; Neither x or y are in ST0, and they are not in
1693 (inst fxch x))))))))
1695 (frob %single-float/double-float %single-float double-reg
1696 double-float single-reg single-float)
1698 (frob %single-float/long-float %single-float long-reg
1699 long-float single-reg single-float)
1700 (frob %double-float/single-float %double-float single-reg single-float
1701 double-reg double-float)
1703 (frob %double-float/long-float %double-float long-reg long-float
1704 double-reg double-float)
1706 (frob %long-float/single-float %long-float single-reg single-float
1707 long-reg long-float)
1709 (frob %long-float/double-float %long-float double-reg double-float
1710 long-reg long-float))
1712 (macrolet ((frob (trans from-sc from-type round-p)
1713 `(define-vop (,(symbolicate trans "/" from-type))
1714 (:args (x :scs (,from-sc)))
1715 (:temporary (:sc signed-stack) stack-temp)
1717 '((:temporary (:sc unsigned-stack) scw)
1718 (:temporary (:sc any-reg) rcw)))
1719 (:results (y :scs (signed-reg)))
1720 (:arg-types ,from-type)
1721 (:result-types signed-num)
1723 (:policy :fast-safe)
1724 (:note "inline float truncate")
1726 (:save-p :compute-only)
1729 '((note-this-location vop :internal-error)
1730 ;; Catch any pending FPE exceptions.
1732 (,(if round-p 'progn 'pseudo-atomic)
1733 ;; Normal mode (for now) is "round to best".
1736 '((inst fnstcw scw) ; save current control word
1737 (move rcw scw) ; into 16-bit register
1738 (inst or rcw (ash #b11 10)) ; CHOP
1739 (move stack-temp rcw)
1740 (inst fldcw stack-temp)))
1745 (inst fist stack-temp)
1746 (inst mov y stack-temp)))
1748 '((inst fldcw scw)))))))))
1749 (frob %unary-truncate single-reg single-float nil)
1750 (frob %unary-truncate double-reg double-float nil)
1752 (frob %unary-truncate long-reg long-float nil)
1753 (frob %unary-round single-reg single-float t)
1754 (frob %unary-round double-reg double-float t)
1756 (frob %unary-round long-reg long-float t))
1758 (macrolet ((frob (trans from-sc from-type round-p)
1759 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1760 (:args (x :scs (,from-sc) :target fr0))
1761 (:temporary (:sc double-reg :offset fr0-offset
1762 :from :argument :to :result) fr0)
1764 '((:temporary (:sc unsigned-stack) stack-temp)
1765 (:temporary (:sc unsigned-stack) scw)
1766 (:temporary (:sc any-reg) rcw)))
1767 (:results (y :scs (unsigned-reg)))
1768 (:arg-types ,from-type)
1769 (:result-types unsigned-num)
1771 (:policy :fast-safe)
1772 (:note "inline float truncate")
1774 (:save-p :compute-only)
1777 '((note-this-location vop :internal-error)
1778 ;; Catch any pending FPE exceptions.
1780 ;; Normal mode (for now) is "round to best".
1781 (unless (zerop (tn-offset x))
1782 (copy-fp-reg-to-fr0 x))
1784 '((inst fnstcw scw) ; save current control word
1785 (move rcw scw) ; into 16-bit register
1786 (inst or rcw (ash #b11 10)) ; CHOP
1787 (move stack-temp rcw)
1788 (inst fldcw stack-temp)))
1790 (inst fistpl (make-ea :dword :base esp-tn))
1792 (inst fld fr0) ; copy fr0 to at least restore stack.
1795 '((inst fldcw scw)))))))
1796 (frob %unary-truncate single-reg single-float nil)
1797 (frob %unary-truncate double-reg double-float nil)
1799 (frob %unary-truncate long-reg long-float nil)
1800 (frob %unary-round single-reg single-float t)
1801 (frob %unary-round double-reg double-float t)
1803 (frob %unary-round long-reg long-float t))
1805 (define-vop (make-single-float)
1806 (:args (bits :scs (signed-reg) :target res
1807 :load-if (not (or (and (sc-is bits signed-stack)
1808 (sc-is res single-reg))
1809 (and (sc-is bits signed-stack)
1810 (sc-is res single-stack)
1811 (location= bits res))))))
1812 (:results (res :scs (single-reg single-stack)))
1813 (:temporary (:sc signed-stack) stack-temp)
1814 (:arg-types signed-num)
1815 (:result-types single-float)
1816 (:translate make-single-float)
1817 (:policy :fast-safe)
1824 (inst mov res bits))
1826 (aver (location= bits res)))))
1830 ;; source must be in memory
1831 (inst mov stack-temp bits)
1832 (with-empty-tn@fp-top(res)
1833 (inst fld stack-temp)))
1835 (with-empty-tn@fp-top(res)
1836 (inst fld bits))))))))
1838 (define-vop (make-double-float)
1839 (:args (hi-bits :scs (signed-reg))
1840 (lo-bits :scs (unsigned-reg)))
1841 (:results (res :scs (double-reg)))
1842 (:temporary (:sc double-stack) temp)
1843 (:arg-types signed-num unsigned-num)
1844 (:result-types double-float)
1845 (:translate make-double-float)
1846 (:policy :fast-safe)
1849 (let ((offset (1+ (tn-offset temp))))
1850 (storew hi-bits ebp-tn (- offset))
1851 (storew lo-bits ebp-tn (- (1+ offset)))
1852 (with-empty-tn@fp-top(res)
1853 (inst fldd (make-ea :dword :base ebp-tn
1854 :disp (- (* (1+ offset) n-word-bytes))))))))
1857 (define-vop (make-long-float)
1858 (:args (exp-bits :scs (signed-reg))
1859 (hi-bits :scs (unsigned-reg))
1860 (lo-bits :scs (unsigned-reg)))
1861 (:results (res :scs (long-reg)))
1862 (:temporary (:sc long-stack) temp)
1863 (:arg-types signed-num unsigned-num unsigned-num)
1864 (:result-types long-float)
1865 (:translate make-long-float)
1866 (:policy :fast-safe)
1869 (let ((offset (1+ (tn-offset temp))))
1870 (storew exp-bits ebp-tn (- offset))
1871 (storew hi-bits ebp-tn (- (1+ offset)))
1872 (storew lo-bits ebp-tn (- (+ offset 2)))
1873 (with-empty-tn@fp-top(res)
1874 (inst fldl (make-ea :dword :base ebp-tn
1875 :disp (- (* (+ offset 2) n-word-bytes))))))))
1877 (define-vop (single-float-bits)
1878 (:args (float :scs (single-reg descriptor-reg)
1879 :load-if (not (sc-is float single-stack))))
1880 (:results (bits :scs (signed-reg)))
1881 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1882 (:arg-types single-float)
1883 (:result-types signed-num)
1884 (:translate single-float-bits)
1885 (:policy :fast-safe)
1892 (with-tn@fp-top(float)
1893 (inst fst stack-temp)
1894 (inst mov bits stack-temp)))
1896 (inst mov bits float))
1899 bits float single-float-value-slot
1900 other-pointer-lowtag))))
1904 (with-tn@fp-top(float)
1905 (inst fst bits))))))))
1907 (define-vop (double-float-high-bits)
1908 (:args (float :scs (double-reg descriptor-reg)
1909 :load-if (not (sc-is float double-stack))))
1910 (:results (hi-bits :scs (signed-reg)))
1911 (:temporary (:sc double-stack) temp)
1912 (:arg-types double-float)
1913 (:result-types signed-num)
1914 (:translate double-float-high-bits)
1915 (:policy :fast-safe)
1920 (with-tn@fp-top(float)
1921 (let ((where (make-ea :dword :base ebp-tn
1922 :disp (- (* (+ 2 (tn-offset temp))
1925 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1927 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1929 (loadw hi-bits float (1+ double-float-value-slot)
1930 other-pointer-lowtag)))))
1932 (define-vop (double-float-low-bits)
1933 (:args (float :scs (double-reg descriptor-reg)
1934 :load-if (not (sc-is float double-stack))))
1935 (:results (lo-bits :scs (unsigned-reg)))
1936 (:temporary (:sc double-stack) temp)
1937 (:arg-types double-float)
1938 (:result-types unsigned-num)
1939 (:translate double-float-low-bits)
1940 (:policy :fast-safe)
1945 (with-tn@fp-top(float)
1946 (let ((where (make-ea :dword :base ebp-tn
1947 :disp (- (* (+ 2 (tn-offset temp))
1950 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1952 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1954 (loadw lo-bits float double-float-value-slot
1955 other-pointer-lowtag)))))
1958 (define-vop (long-float-exp-bits)
1959 (:args (float :scs (long-reg descriptor-reg)
1960 :load-if (not (sc-is float long-stack))))
1961 (:results (exp-bits :scs (signed-reg)))
1962 (:temporary (:sc long-stack) temp)
1963 (:arg-types long-float)
1964 (:result-types signed-num)
1965 (:translate long-float-exp-bits)
1966 (:policy :fast-safe)
1971 (with-tn@fp-top(float)
1972 (let ((where (make-ea :dword :base ebp-tn
1973 :disp (- (* (+ 3 (tn-offset temp))
1975 (store-long-float where)))
1976 (inst movsx exp-bits
1977 (make-ea :word :base ebp-tn
1978 :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
1980 (inst movsx exp-bits
1981 (make-ea :word :base ebp-tn
1982 :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
1984 (inst movsx exp-bits
1985 (make-ea :word :base float
1986 :disp (- (* (+ 2 long-float-value-slot)
1988 other-pointer-lowtag)))))))
1991 (define-vop (long-float-high-bits)
1992 (:args (float :scs (long-reg descriptor-reg)
1993 :load-if (not (sc-is float long-stack))))
1994 (:results (hi-bits :scs (unsigned-reg)))
1995 (:temporary (:sc long-stack) temp)
1996 (:arg-types long-float)
1997 (:result-types unsigned-num)
1998 (:translate long-float-high-bits)
1999 (:policy :fast-safe)
2004 (with-tn@fp-top(float)
2005 (let ((where (make-ea :dword :base ebp-tn
2006 :disp (- (* (+ 3 (tn-offset temp))
2008 (store-long-float where)))
2009 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
2011 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
2013 (loadw hi-bits float (1+ long-float-value-slot)
2014 other-pointer-lowtag)))))
2017 (define-vop (long-float-low-bits)
2018 (:args (float :scs (long-reg descriptor-reg)
2019 :load-if (not (sc-is float long-stack))))
2020 (:results (lo-bits :scs (unsigned-reg)))
2021 (:temporary (:sc long-stack) temp)
2022 (:arg-types long-float)
2023 (:result-types unsigned-num)
2024 (:translate long-float-low-bits)
2025 (:policy :fast-safe)
2030 (with-tn@fp-top(float)
2031 (let ((where (make-ea :dword :base ebp-tn
2032 :disp (- (* (+ 3 (tn-offset temp))
2034 (store-long-float where)))
2035 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2037 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2039 (loadw lo-bits float long-float-value-slot
2040 other-pointer-lowtag)))))
2042 ;;;; float mode hackery
2044 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2045 (defknown floating-point-modes () float-modes (flushable))
2046 (defknown ((setf floating-point-modes)) (float-modes)
2049 (def!constant npx-env-size (* 7 n-word-bytes))
2050 (def!constant npx-cw-offset 0)
2051 (def!constant npx-sw-offset 4)
2053 (define-vop (floating-point-modes)
2054 (:results (res :scs (unsigned-reg)))
2055 (:result-types unsigned-num)
2056 (:translate floating-point-modes)
2057 (:policy :fast-safe)
2058 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2061 (inst sub esp-tn npx-env-size) ; Make space on stack.
2062 (inst wait) ; Catch any pending FPE exceptions
2063 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2064 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2065 ;; Move current status to high word.
2066 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2067 ;; Move exception mask to low word.
2068 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2069 (inst add esp-tn npx-env-size) ; Pop stack.
2070 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2073 (define-vop (set-floating-point-modes)
2074 (:args (new :scs (unsigned-reg) :to :result :target res))
2075 (:results (res :scs (unsigned-reg)))
2076 (:arg-types unsigned-num)
2077 (:result-types unsigned-num)
2078 (:translate (setf floating-point-modes))
2079 (:policy :fast-safe)
2080 (:temporary (:sc unsigned-reg :offset eax-offset
2081 :from :eval :to :result) eax)
2083 (inst sub esp-tn npx-env-size) ; Make space on stack.
2084 (inst wait) ; Catch any pending FPE exceptions.
2085 (inst fstenv (make-ea :dword :base esp-tn))
2087 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2088 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2089 (inst shr eax 16) ; position status word
2090 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2091 (inst fldenv (make-ea :dword :base esp-tn))
2092 (inst add esp-tn npx-env-size) ; Pop stack.
2098 ;;; Let's use some of the 80387 special functions.
2100 ;;; These defs will not take effect unless code/irrat.lisp is modified
2101 ;;; to remove the inlined alien routine def.
2103 (macrolet ((frob (func trans op)
2104 `(define-vop (,func)
2105 (:args (x :scs (double-reg) :target fr0))
2106 (:temporary (:sc double-reg :offset fr0-offset
2107 :from :argument :to :result) fr0)
2109 (:results (y :scs (double-reg)))
2110 (:arg-types double-float)
2111 (:result-types double-float)
2113 (:policy :fast-safe)
2114 (:note "inline NPX function")
2116 (:save-p :compute-only)
2119 (note-this-location vop :internal-error)
2120 (unless (zerop (tn-offset x))
2121 (inst fxch x) ; x to top of stack
2122 (unless (location= x y)
2123 (inst fst x))) ; maybe save it
2124 (inst ,op) ; clobber st0
2125 (cond ((zerop (tn-offset y))
2126 (maybe-fp-wait node))
2130 ;; Quick versions of fsin and fcos that require the argument to be
2131 ;; within range 2^63.
2132 (frob fsin-quick %sin-quick fsin)
2133 (frob fcos-quick %cos-quick fcos)
2134 (frob fsqrt %sqrt fsqrt))
2136 ;;; Quick version of ftan that requires the argument to be within
2138 (define-vop (ftan-quick)
2139 (:translate %tan-quick)
2140 (:args (x :scs (double-reg) :target fr0))
2141 (:temporary (:sc double-reg :offset fr0-offset
2142 :from :argument :to :result) fr0)
2143 (:temporary (:sc double-reg :offset fr1-offset
2144 :from :argument :to :result) fr1)
2145 (:results (y :scs (double-reg)))
2146 (:arg-types double-float)
2147 (:result-types double-float)
2148 (:policy :fast-safe)
2149 (:note "inline tan function")
2151 (:save-p :compute-only)
2153 (note-this-location vop :internal-error)
2162 (inst fldd (make-random-tn :kind :normal
2163 :sc (sc-or-lose 'double-reg)
2164 :offset (- (tn-offset x) 2)))))
2175 ;;; These versions of fsin, fcos, and ftan try to use argument
2176 ;;; reduction but to do this accurately requires greater precision and
2177 ;;; it is hopelessly inaccurate.
2179 (macrolet ((frob (func trans op)
2180 `(define-vop (,func)
2182 (:args (x :scs (double-reg) :target fr0))
2183 (:temporary (:sc unsigned-reg :offset eax-offset
2184 :from :eval :to :result) eax)
2185 (:temporary (:sc unsigned-reg :offset fr0-offset
2186 :from :argument :to :result) fr0)
2187 (:temporary (:sc unsigned-reg :offset fr1-offset
2188 :from :argument :to :result) fr1)
2189 (:results (y :scs (double-reg)))
2190 (:arg-types double-float)
2191 (:result-types double-float)
2192 (:policy :fast-safe)
2193 (:note "inline sin/cos function")
2195 (:save-p :compute-only)
2198 (note-this-location vop :internal-error)
2199 (unless (zerop (tn-offset x))
2200 (inst fxch x) ; x to top of stack
2201 (unless (location= x y)
2202 (inst fst x))) ; maybe save it
2204 (inst fnstsw) ; status word to ax
2205 (inst and ah-tn #x04) ; C2
2207 ;; Else x was out of range so reduce it; ST0 is unchanged.
2208 (inst fstp fr1) ; Load 2*PI
2214 (inst fnstsw) ; status word to ax
2215 (inst and ah-tn #x04) ; C2
2219 (unless (zerop (tn-offset y))
2221 (frob fsin %sin fsin)
2222 (frob fcos %cos fcos))
2227 (:args (x :scs (double-reg) :target fr0))
2228 (:temporary (:sc unsigned-reg :offset eax-offset
2229 :from :argument :to :result) eax)
2230 (:temporary (:sc double-reg :offset fr0-offset
2231 :from :argument :to :result) fr0)
2232 (:temporary (:sc double-reg :offset fr1-offset
2233 :from :argument :to :result) fr1)
2234 (:results (y :scs (double-reg)))
2235 (:arg-types double-float)
2236 (:result-types double-float)
2237 (:policy :fast-safe)
2238 (:note "inline tan function")
2240 (:save-p :compute-only)
2243 (note-this-location vop :internal-error)
2252 (inst fldd (make-random-tn :kind :normal
2253 :sc (sc-or-lose 'double-reg)
2254 :offset (- (tn-offset x) 2)))))
2256 (inst fnstsw) ; status word to ax
2257 (inst and ah-tn #x04) ; C2
2259 ;; Else x was out of range so reduce it; ST0 is unchanged.
2260 (inst fldpi) ; Load 2*PI
2265 (inst fnstsw) ; status word to ax
2266 (inst and ah-tn #x04) ; C2
2280 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2281 ;;; the argument is out of range 2^63 and would thus be hopelessly
2283 (macrolet ((frob (func trans op)
2284 `(define-vop (,func)
2286 (:args (x :scs (double-reg) :target fr0))
2287 (:temporary (:sc double-reg :offset fr0-offset
2288 :from :argument :to :result) fr0)
2289 (:temporary (:sc unsigned-reg :offset eax-offset
2290 :from :argument :to :result) eax)
2291 (:results (y :scs (double-reg)))
2292 (:arg-types double-float)
2293 (:result-types double-float)
2294 (:policy :fast-safe)
2295 (:note "inline sin/cos function")
2297 (:save-p :compute-only)
2300 (note-this-location vop :internal-error)
2301 (unless (zerop (tn-offset x))
2302 (inst fxch x) ; x to top of stack
2303 (unless (location= x y)
2304 (inst fst x))) ; maybe save it
2306 (inst fnstsw) ; status word to ax
2307 (inst and ah-tn #x04) ; C2
2309 ;; Else x was out of range so reduce it; ST0 is unchanged.
2310 (inst fstp fr0) ; Load 0.0
2313 (unless (zerop (tn-offset y))
2315 (frob fsin %sin fsin)
2316 (frob fcos %cos fcos))
2320 (:args (x :scs (double-reg) :target fr0))
2321 (:temporary (:sc double-reg :offset fr0-offset
2322 :from :argument :to :result) fr0)
2323 (:temporary (:sc double-reg :offset fr1-offset
2324 :from :argument :to :result) fr1)
2325 (:temporary (:sc unsigned-reg :offset eax-offset
2326 :from :argument :to :result) eax)
2327 (:results (y :scs (double-reg)))
2328 (:arg-types double-float)
2329 (:result-types double-float)
2331 (:policy :fast-safe)
2332 (:note "inline tan function")
2334 (:save-p :compute-only)
2337 (note-this-location vop :internal-error)
2346 (inst fldd (make-random-tn :kind :normal
2347 :sc (sc-or-lose 'double-reg)
2348 :offset (- (tn-offset x) 2)))))
2350 (inst fnstsw) ; status word to ax
2351 (inst and ah-tn #x04) ; C2
2353 ;; Else x was out of range so reduce it; ST0 is unchanged.
2354 (inst fldz) ; Load 0.0
2369 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2370 (:temporary (:sc double-reg :offset fr0-offset
2371 :from :argument :to :result) fr0)
2372 (:temporary (:sc double-reg :offset fr1-offset
2373 :from :argument :to :result) fr1)
2374 (:temporary (:sc double-reg :offset fr2-offset
2375 :from :argument :to :result) fr2)
2376 (:results (y :scs (double-reg)))
2377 (:arg-types double-float)
2378 (:result-types double-float)
2379 (:policy :fast-safe)
2380 (:note "inline exp function")
2382 (:save-p :compute-only)
2384 (note-this-location vop :internal-error)
2387 (cond ((zerop (tn-offset x))
2393 ;; x is in a FP reg, not fr0
2397 ((double-stack descriptor-reg)
2400 (if (sc-is x double-stack)
2401 (inst fmuld (ea-for-df-stack x))
2402 (inst fmuld (ea-for-df-desc x)))))
2403 ;; Now fr0=x log2(e)
2407 (inst fsubp-sti fr1)
2410 (inst faddp-sti fr1)
2415 (t (inst fstd y)))))
2417 ;;; Modified exp that handles the following special cases:
2418 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2421 (:args (x :scs (double-reg) :target fr0))
2422 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2423 (:temporary (:sc double-reg :offset fr0-offset
2424 :from :argument :to :result) fr0)
2425 (:temporary (:sc double-reg :offset fr1-offset
2426 :from :argument :to :result) fr1)
2427 (:temporary (:sc double-reg :offset fr2-offset
2428 :from :argument :to :result) fr2)
2429 (:results (y :scs (double-reg)))
2430 (:arg-types double-float)
2431 (:result-types double-float)
2432 (:policy :fast-safe)
2433 (:note "inline exp function")
2435 (:save-p :compute-only)
2438 (note-this-location vop :internal-error)
2439 (unless (zerop (tn-offset x))
2440 (inst fxch x) ; x to top of stack
2441 (unless (location= x y)
2442 (inst fst x))) ; maybe save it
2443 ;; Check for Inf or NaN
2447 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2448 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2449 (inst and ah-tn #x02) ; Test sign of Inf.
2450 (inst jmp :z DONE) ; +Inf gives +Inf.
2451 (inst fstp fr0) ; -Inf gives 0
2453 (inst jmp-short DONE)
2458 ;; Now fr0=x log2(e)
2462 (inst fsubp-sti fr1)
2465 (inst faddp-sti fr1)
2469 (unless (zerop (tn-offset y))
2472 ;;; Expm1 = exp(x) - 1.
2473 ;;; Handles the following special cases:
2474 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2475 (define-vop (fexpm1)
2477 (:args (x :scs (double-reg) :target fr0))
2478 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2479 (:temporary (:sc double-reg :offset fr0-offset
2480 :from :argument :to :result) fr0)
2481 (:temporary (:sc double-reg :offset fr1-offset
2482 :from :argument :to :result) fr1)
2483 (:temporary (:sc double-reg :offset fr2-offset
2484 :from :argument :to :result) fr2)
2485 (:results (y :scs (double-reg)))
2486 (:arg-types double-float)
2487 (:result-types double-float)
2488 (:policy :fast-safe)
2489 (:note "inline expm1 function")
2491 (:save-p :compute-only)
2494 (note-this-location vop :internal-error)
2495 (unless (zerop (tn-offset x))
2496 (inst fxch x) ; x to top of stack
2497 (unless (location= x y)
2498 (inst fst x))) ; maybe save it
2499 ;; Check for Inf or NaN
2503 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2504 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2505 (inst and ah-tn #x02) ; Test sign of Inf.
2506 (inst jmp :z DONE) ; +Inf gives +Inf.
2507 (inst fstp fr0) ; -Inf gives -1.0
2510 (inst jmp-short DONE)
2512 ;; Free two stack slots leaving the argument on top.
2516 (inst fmul fr1) ; Now fr0 = x log2(e)
2531 (unless (zerop (tn-offset y))
2536 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2537 (:temporary (:sc double-reg :offset fr0-offset
2538 :from :argument :to :result) fr0)
2539 (:temporary (:sc double-reg :offset fr1-offset
2540 :from :argument :to :result) fr1)
2541 (:results (y :scs (double-reg)))
2542 (:arg-types double-float)
2543 (:result-types double-float)
2544 (:policy :fast-safe)
2545 (:note "inline log function")
2547 (:save-p :compute-only)
2549 (note-this-location vop :internal-error)
2564 ;; x is in a FP reg, not fr0 or fr1
2568 (inst fldd (make-random-tn :kind :normal
2569 :sc (sc-or-lose 'double-reg)
2570 :offset (1- (tn-offset x))))))
2572 ((double-stack descriptor-reg)
2576 (if (sc-is x double-stack)
2577 (inst fldd (ea-for-df-stack x))
2578 (inst fldd (ea-for-df-desc x)))
2583 (t (inst fstd y)))))
2585 (define-vop (flog10)
2587 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2588 (:temporary (:sc double-reg :offset fr0-offset
2589 :from :argument :to :result) fr0)
2590 (:temporary (:sc double-reg :offset fr1-offset
2591 :from :argument :to :result) fr1)
2592 (:results (y :scs (double-reg)))
2593 (:arg-types double-float)
2594 (:result-types double-float)
2595 (:policy :fast-safe)
2596 (:note "inline log10 function")
2598 (:save-p :compute-only)
2600 (note-this-location vop :internal-error)
2615 ;; x is in a FP reg, not fr0 or fr1
2619 (inst fldd (make-random-tn :kind :normal
2620 :sc (sc-or-lose 'double-reg)
2621 :offset (1- (tn-offset x))))))
2623 ((double-stack descriptor-reg)
2627 (if (sc-is x double-stack)
2628 (inst fldd (ea-for-df-stack x))
2629 (inst fldd (ea-for-df-desc x)))
2634 (t (inst fstd y)))))
2638 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2639 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2640 (:temporary (:sc double-reg :offset fr0-offset
2641 :from (:argument 0) :to :result) fr0)
2642 (:temporary (:sc double-reg :offset fr1-offset
2643 :from (:argument 1) :to :result) fr1)
2644 (:temporary (:sc double-reg :offset fr2-offset
2645 :from :load :to :result) fr2)
2646 (:results (r :scs (double-reg)))
2647 (:arg-types double-float double-float)
2648 (:result-types double-float)
2649 (:policy :fast-safe)
2650 (:note "inline pow function")
2652 (:save-p :compute-only)
2654 (note-this-location vop :internal-error)
2655 ;; Setup x in fr0 and y in fr1
2657 ;; x in fr0; y in fr1
2658 ((and (sc-is x double-reg) (zerop (tn-offset x))
2659 (sc-is y double-reg) (= 1 (tn-offset y))))
2660 ;; y in fr1; x not in fr0
2661 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2665 (copy-fp-reg-to-fr0 x))
2668 (inst fldd (ea-for-df-stack x)))
2671 (inst fldd (ea-for-df-desc x)))))
2672 ;; x in fr0; y not in fr1
2673 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2675 ;; Now load y to fr0
2678 (copy-fp-reg-to-fr0 y))
2681 (inst fldd (ea-for-df-stack y)))
2684 (inst fldd (ea-for-df-desc y))))
2686 ;; x in fr1; y not in fr1
2687 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2691 (copy-fp-reg-to-fr0 y))
2694 (inst fldd (ea-for-df-stack y)))
2697 (inst fldd (ea-for-df-desc y))))
2700 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2702 ;; Now load x to fr0
2705 (copy-fp-reg-to-fr0 x))
2708 (inst fldd (ea-for-df-stack x)))
2711 (inst fldd (ea-for-df-desc x)))))
2712 ;; Neither x or y are in either fr0 or fr1
2719 (inst fldd (make-random-tn :kind :normal
2720 :sc (sc-or-lose 'double-reg)
2721 :offset (- (tn-offset y) 2))))
2723 (inst fldd (ea-for-df-stack y)))
2725 (inst fldd (ea-for-df-desc y))))
2729 (inst fldd (make-random-tn :kind :normal
2730 :sc (sc-or-lose 'double-reg)
2731 :offset (1- (tn-offset x)))))
2733 (inst fldd (ea-for-df-stack x)))
2735 (inst fldd (ea-for-df-desc x))))))
2737 ;; Now have x at fr0; and y at fr1
2739 ;; Now fr0=y log2(x)
2743 (inst fsubp-sti fr1)
2746 (inst faddp-sti fr1)
2751 (t (inst fstd r)))))
2753 (define-vop (fscalen)
2754 (:translate %scalbn)
2755 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2756 (y :scs (signed-stack signed-reg) :target temp))
2757 (:temporary (:sc double-reg :offset fr0-offset
2758 :from (:argument 0) :to :result) fr0)
2759 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2760 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2761 (:results (r :scs (double-reg)))
2762 (:arg-types double-float signed-num)
2763 (:result-types double-float)
2764 (:policy :fast-safe)
2765 (:note "inline scalbn function")
2767 ;; Setup x in fr0 and y in fr1
2798 (inst fld (make-random-tn :kind :normal
2799 :sc (sc-or-lose 'double-reg)
2800 :offset (1- (tn-offset x)))))))
2801 ((double-stack descriptor-reg)
2810 (if (sc-is x double-stack)
2811 (inst fldd (ea-for-df-stack x))
2812 (inst fldd (ea-for-df-desc x)))))
2814 (unless (zerop (tn-offset r))
2817 (define-vop (fscale)
2819 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2820 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2821 (:temporary (:sc double-reg :offset fr0-offset
2822 :from (:argument 0) :to :result) fr0)
2823 (:temporary (:sc double-reg :offset fr1-offset
2824 :from (:argument 1) :to :result) fr1)
2825 (:results (r :scs (double-reg)))
2826 (:arg-types double-float double-float)
2827 (:result-types double-float)
2828 (:policy :fast-safe)
2829 (:note "inline scalb function")
2831 (:save-p :compute-only)
2833 (note-this-location vop :internal-error)
2834 ;; Setup x in fr0 and y in fr1
2836 ;; x in fr0; y in fr1
2837 ((and (sc-is x double-reg) (zerop (tn-offset x))
2838 (sc-is y double-reg) (= 1 (tn-offset y))))
2839 ;; y in fr1; x not in fr0
2840 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2844 (copy-fp-reg-to-fr0 x))
2847 (inst fldd (ea-for-df-stack x)))
2850 (inst fldd (ea-for-df-desc x)))))
2851 ;; x in fr0; y not in fr1
2852 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2854 ;; Now load y to fr0
2857 (copy-fp-reg-to-fr0 y))
2860 (inst fldd (ea-for-df-stack y)))
2863 (inst fldd (ea-for-df-desc y))))
2865 ;; x in fr1; y not in fr1
2866 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2870 (copy-fp-reg-to-fr0 y))
2873 (inst fldd (ea-for-df-stack y)))
2876 (inst fldd (ea-for-df-desc y))))
2879 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2881 ;; Now load x to fr0
2884 (copy-fp-reg-to-fr0 x))
2887 (inst fldd (ea-for-df-stack x)))
2890 (inst fldd (ea-for-df-desc x)))))
2891 ;; Neither x or y are in either fr0 or fr1
2898 (inst fldd (make-random-tn :kind :normal
2899 :sc (sc-or-lose 'double-reg)
2900 :offset (- (tn-offset y) 2))))
2902 (inst fldd (ea-for-df-stack y)))
2904 (inst fldd (ea-for-df-desc y))))
2908 (inst fldd (make-random-tn :kind :normal
2909 :sc (sc-or-lose 'double-reg)
2910 :offset (1- (tn-offset x)))))
2912 (inst fldd (ea-for-df-stack x)))
2914 (inst fldd (ea-for-df-desc x))))))
2916 ;; Now have x at fr0; and y at fr1
2918 (unless (zerop (tn-offset r))
2921 (define-vop (flog1p)
2923 (:args (x :scs (double-reg) :to :result))
2924 (:temporary (:sc double-reg :offset fr0-offset
2925 :from :argument :to :result) fr0)
2926 (:temporary (:sc double-reg :offset fr1-offset
2927 :from :argument :to :result) fr1)
2928 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2929 (:results (y :scs (double-reg)))
2930 (:arg-types double-float)
2931 (:result-types double-float)
2932 (:policy :fast-safe)
2933 (:note "inline log1p function")
2936 ;; x is in a FP reg, not fr0, fr1.
2939 (inst fldd (make-random-tn :kind :normal
2940 :sc (sc-or-lose 'double-reg)
2941 :offset (- (tn-offset x) 2)))
2943 (inst push #x3e947ae1) ; Constant 0.29
2945 (inst fld (make-ea :dword :base esp-tn))
2948 (inst fnstsw) ; status word to ax
2949 (inst and ah-tn #x45)
2950 (inst jmp :z WITHIN-RANGE)
2951 ;; Out of range for fyl2xp1.
2953 (inst faddd (make-random-tn :kind :normal
2954 :sc (sc-or-lose 'double-reg)
2955 :offset (- (tn-offset x) 1)))
2963 (inst fldd (make-random-tn :kind :normal
2964 :sc (sc-or-lose 'double-reg)
2965 :offset (- (tn-offset x) 1)))
2971 (t (inst fstd y)))))
2973 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2974 ;;; instruction and a range check can be avoided.
2975 (define-vop (flog1p-pentium)
2977 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2978 (:temporary (:sc double-reg :offset fr0-offset
2979 :from :argument :to :result) fr0)
2980 (:temporary (:sc double-reg :offset fr1-offset
2981 :from :argument :to :result) fr1)
2982 (:results (y :scs (double-reg)))
2983 (:arg-types double-float)
2984 (:result-types double-float)
2985 (:policy :fast-safe)
2986 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2987 (:note "inline log1p with limited x range function")
2989 (:save-p :compute-only)
2991 (note-this-location vop :internal-error)
3006 ;; x is in a FP reg, not fr0 or fr1
3010 (inst fldd (make-random-tn :kind :normal
3011 :sc (sc-or-lose 'double-reg)
3012 :offset (1- (tn-offset x)))))))
3013 ((double-stack descriptor-reg)
3017 (if (sc-is x double-stack)
3018 (inst fldd (ea-for-df-stack x))
3019 (inst fldd (ea-for-df-desc x)))))
3024 (t (inst fstd y)))))
3028 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3029 (:temporary (:sc double-reg :offset fr0-offset
3030 :from :argument :to :result) fr0)
3031 (:temporary (:sc double-reg :offset fr1-offset
3032 :from :argument :to :result) fr1)
3033 (:results (y :scs (double-reg)))
3034 (:arg-types double-float)
3035 (:result-types double-float)
3036 (:policy :fast-safe)
3037 (:note "inline logb function")
3039 (:save-p :compute-only)
3041 (note-this-location vop :internal-error)
3052 ;; x is in a FP reg, not fr0 or fr1
3055 (inst fldd (make-random-tn :kind :normal
3056 :sc (sc-or-lose 'double-reg)
3057 :offset (- (tn-offset x) 2))))))
3058 ((double-stack descriptor-reg)
3061 (if (sc-is x double-stack)
3062 (inst fldd (ea-for-df-stack x))
3063 (inst fldd (ea-for-df-desc x)))))
3074 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3075 (:temporary (:sc double-reg :offset fr0-offset
3076 :from (:argument 0) :to :result) fr0)
3077 (:temporary (:sc double-reg :offset fr1-offset
3078 :from (:argument 0) :to :result) fr1)
3079 (:results (r :scs (double-reg)))
3080 (:arg-types double-float)
3081 (:result-types double-float)
3082 (:policy :fast-safe)
3083 (:note "inline atan function")
3085 (:save-p :compute-only)
3087 (note-this-location vop :internal-error)
3088 ;; Setup x in fr1 and 1.0 in fr0
3091 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3094 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3096 ;; x not in fr0 or fr1
3103 (inst fldd (make-random-tn :kind :normal
3104 :sc (sc-or-lose 'double-reg)
3105 :offset (- (tn-offset x) 2))))
3107 (inst fldd (ea-for-df-stack x)))
3109 (inst fldd (ea-for-df-desc x))))))
3111 ;; Now have x at fr1; and 1.0 at fr0
3116 (t (inst fstd r)))))
3118 (define-vop (fatan2)
3120 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3121 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3122 (:temporary (:sc double-reg :offset fr0-offset
3123 :from (:argument 1) :to :result) fr0)
3124 (:temporary (:sc double-reg :offset fr1-offset
3125 :from (:argument 0) :to :result) fr1)
3126 (:results (r :scs (double-reg)))
3127 (:arg-types double-float double-float)
3128 (:result-types double-float)
3129 (:policy :fast-safe)
3130 (:note "inline atan2 function")
3132 (:save-p :compute-only)
3134 (note-this-location vop :internal-error)
3135 ;; Setup x in fr1 and y in fr0
3137 ;; y in fr0; x in fr1
3138 ((and (sc-is y double-reg) (zerop (tn-offset y))
3139 (sc-is x double-reg) (= 1 (tn-offset x))))
3140 ;; x in fr1; y not in fr0
3141 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3145 (copy-fp-reg-to-fr0 y))
3148 (inst fldd (ea-for-df-stack y)))
3151 (inst fldd (ea-for-df-desc y)))))
3152 ;; y in fr0; x not in fr1
3153 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3155 ;; Now load x to fr0
3158 (copy-fp-reg-to-fr0 x))
3161 (inst fldd (ea-for-df-stack x)))
3164 (inst fldd (ea-for-df-desc x))))
3166 ;; y in fr1; x not in fr1
3167 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3171 (copy-fp-reg-to-fr0 x))
3174 (inst fldd (ea-for-df-stack x)))
3177 (inst fldd (ea-for-df-desc x))))
3180 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3182 ;; Now load y to fr0
3185 (copy-fp-reg-to-fr0 y))
3188 (inst fldd (ea-for-df-stack y)))
3191 (inst fldd (ea-for-df-desc y)))))
3192 ;; Neither y or x are in either fr0 or fr1
3199 (inst fldd (make-random-tn :kind :normal
3200 :sc (sc-or-lose 'double-reg)
3201 :offset (- (tn-offset x) 2))))
3203 (inst fldd (ea-for-df-stack x)))
3205 (inst fldd (ea-for-df-desc x))))
3209 (inst fldd (make-random-tn :kind :normal
3210 :sc (sc-or-lose 'double-reg)
3211 :offset (1- (tn-offset y)))))
3213 (inst fldd (ea-for-df-stack y)))
3215 (inst fldd (ea-for-df-desc y))))))
3217 ;; Now have y at fr0; and x at fr1
3222 (t (inst fstd r)))))
3223 ) ; PROGN #!-LONG-FLOAT
3228 ;;; Lets use some of the 80387 special functions.
3230 ;;; These defs will not take effect unless code/irrat.lisp is modified
3231 ;;; to remove the inlined alien routine def.
3233 (macrolet ((frob (func trans op)
3234 `(define-vop (,func)
3235 (:args (x :scs (long-reg) :target fr0))
3236 (:temporary (:sc long-reg :offset fr0-offset
3237 :from :argument :to :result) fr0)
3239 (:results (y :scs (long-reg)))
3240 (:arg-types long-float)
3241 (:result-types long-float)
3243 (:policy :fast-safe)
3244 (:note "inline NPX function")
3246 (:save-p :compute-only)
3249 (note-this-location vop :internal-error)
3250 (unless (zerop (tn-offset x))
3251 (inst fxch x) ; x to top of stack
3252 (unless (location= x y)
3253 (inst fst x))) ; maybe save it
3254 (inst ,op) ; clobber st0
3255 (cond ((zerop (tn-offset y))
3256 (maybe-fp-wait node))
3260 ;; Quick versions of FSIN and FCOS that require the argument to be
3261 ;; within range 2^63.
3262 (frob fsin-quick %sin-quick fsin)
3263 (frob fcos-quick %cos-quick fcos)
3264 (frob fsqrt %sqrt fsqrt))
3266 ;;; Quick version of ftan that requires the argument to be within
3268 (define-vop (ftan-quick)
3269 (:translate %tan-quick)
3270 (:args (x :scs (long-reg) :target fr0))
3271 (:temporary (:sc long-reg :offset fr0-offset
3272 :from :argument :to :result) fr0)
3273 (:temporary (:sc long-reg :offset fr1-offset
3274 :from :argument :to :result) fr1)
3275 (:results (y :scs (long-reg)))
3276 (:arg-types long-float)
3277 (:result-types long-float)
3278 (:policy :fast-safe)
3279 (:note "inline tan function")
3281 (:save-p :compute-only)
3283 (note-this-location vop :internal-error)
3292 (inst fldd (make-random-tn :kind :normal
3293 :sc (sc-or-lose 'double-reg)
3294 :offset (- (tn-offset x) 2)))))
3305 ;;; These versions of fsin, fcos, and ftan try to use argument
3306 ;;; reduction but to do this accurately requires greater precision and
3307 ;;; it is hopelessly inaccurate.
3309 (macrolet ((frob (func trans op)
3310 `(define-vop (,func)
3312 (:args (x :scs (long-reg) :target fr0))
3313 (:temporary (:sc unsigned-reg :offset eax-offset
3314 :from :eval :to :result) eax)
3315 (:temporary (:sc long-reg :offset fr0-offset
3316 :from :argument :to :result) fr0)
3317 (:temporary (:sc long-reg :offset fr1-offset
3318 :from :argument :to :result) fr1)
3319 (:results (y :scs (long-reg)))
3320 (:arg-types long-float)
3321 (:result-types long-float)
3322 (:policy :fast-safe)
3323 (:note "inline sin/cos function")
3325 (:save-p :compute-only)
3328 (note-this-location vop :internal-error)
3329 (unless (zerop (tn-offset x))
3330 (inst fxch x) ; x to top of stack
3331 (unless (location= x y)
3332 (inst fst x))) ; maybe save it
3334 (inst fnstsw) ; status word to ax
3335 (inst and ah-tn #x04) ; C2
3337 ;; Else x was out of range so reduce it; ST0 is unchanged.
3338 (inst fstp fr1) ; Load 2*PI
3344 (inst fnstsw) ; status word to ax
3345 (inst and ah-tn #x04) ; C2
3349 (unless (zerop (tn-offset y))
3351 (frob fsin %sin fsin)
3352 (frob fcos %cos fcos))
3357 (:args (x :scs (long-reg) :target fr0))
3358 (:temporary (:sc unsigned-reg :offset eax-offset
3359 :from :argument :to :result) eax)
3360 (:temporary (:sc long-reg :offset fr0-offset
3361 :from :argument :to :result) fr0)
3362 (:temporary (:sc long-reg :offset fr1-offset
3363 :from :argument :to :result) fr1)
3364 (:results (y :scs (long-reg)))
3365 (:arg-types long-float)
3366 (:result-types long-float)
3367 (:policy :fast-safe)
3368 (:note "inline tan function")
3370 (:save-p :compute-only)
3373 (note-this-location vop :internal-error)
3382 (inst fldd (make-random-tn :kind :normal
3383 :sc (sc-or-lose 'double-reg)
3384 :offset (- (tn-offset x) 2)))))
3386 (inst fnstsw) ; status word to ax
3387 (inst and ah-tn #x04) ; C2
3389 ;; Else x was out of range so reduce it; ST0 is unchanged.
3390 (inst fldpi) ; Load 2*PI
3395 (inst fnstsw) ; status word to ax
3396 (inst and ah-tn #x04) ; C2
3410 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3411 ;;; the argument is out of range 2^63 and would thus be hopelessly
3413 (macrolet ((frob (func trans op)
3414 `(define-vop (,func)
3416 (:args (x :scs (long-reg) :target fr0))
3417 (:temporary (:sc long-reg :offset fr0-offset
3418 :from :argument :to :result) fr0)
3419 (:temporary (:sc unsigned-reg :offset eax-offset
3420 :from :argument :to :result) eax)
3421 (:results (y :scs (long-reg)))
3422 (:arg-types long-float)
3423 (:result-types long-float)
3424 (:policy :fast-safe)
3425 (:note "inline sin/cos function")
3427 (:save-p :compute-only)
3430 (note-this-location vop :internal-error)
3431 (unless (zerop (tn-offset x))
3432 (inst fxch x) ; x to top of stack
3433 (unless (location= x y)
3434 (inst fst x))) ; maybe save it
3436 (inst fnstsw) ; status word to ax
3437 (inst and ah-tn #x04) ; C2
3439 ;; Else x was out of range so reduce it; ST0 is unchanged.
3440 (inst fstp fr0) ; Load 0.0
3443 (unless (zerop (tn-offset y))
3445 (frob fsin %sin fsin)
3446 (frob fcos %cos fcos))
3450 (:args (x :scs (long-reg) :target fr0))
3451 (:temporary (:sc long-reg :offset fr0-offset
3452 :from :argument :to :result) fr0)
3453 (:temporary (:sc long-reg :offset fr1-offset
3454 :from :argument :to :result) fr1)
3455 (:temporary (:sc unsigned-reg :offset eax-offset
3456 :from :argument :to :result) eax)
3457 (:results (y :scs (long-reg)))
3458 (:arg-types long-float)
3459 (:result-types long-float)
3461 (:policy :fast-safe)
3462 (:note "inline tan function")
3464 (:save-p :compute-only)
3467 (note-this-location vop :internal-error)
3476 (inst fldd (make-random-tn :kind :normal
3477 :sc (sc-or-lose 'double-reg)
3478 :offset (- (tn-offset x) 2)))))
3480 (inst fnstsw) ; status word to ax
3481 (inst and ah-tn #x04) ; C2
3483 ;; Else x was out of range so reduce it; ST0 is unchanged.
3484 (inst fldz) ; Load 0.0
3496 ;;; Modified exp that handles the following special cases:
3497 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3500 (:args (x :scs (long-reg) :target fr0))
3501 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3502 (:temporary (:sc long-reg :offset fr0-offset
3503 :from :argument :to :result) fr0)
3504 (:temporary (:sc long-reg :offset fr1-offset
3505 :from :argument :to :result) fr1)
3506 (:temporary (:sc long-reg :offset fr2-offset
3507 :from :argument :to :result) fr2)
3508 (:results (y :scs (long-reg)))
3509 (:arg-types long-float)
3510 (:result-types long-float)
3511 (:policy :fast-safe)
3512 (:note "inline exp function")
3514 (:save-p :compute-only)
3517 (note-this-location vop :internal-error)
3518 (unless (zerop (tn-offset x))
3519 (inst fxch x) ; x to top of stack
3520 (unless (location= x y)
3521 (inst fst x))) ; maybe save it
3522 ;; Check for Inf or NaN
3526 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3527 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3528 (inst and ah-tn #x02) ; Test sign of Inf.
3529 (inst jmp :z DONE) ; +Inf gives +Inf.
3530 (inst fstp fr0) ; -Inf gives 0
3532 (inst jmp-short DONE)
3537 ;; Now fr0=x log2(e)
3541 (inst fsubp-sti fr1)
3544 (inst faddp-sti fr1)
3548 (unless (zerop (tn-offset y))
3551 ;;; Expm1 = exp(x) - 1.
3552 ;;; Handles the following special cases:
3553 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3554 (define-vop (fexpm1)
3556 (:args (x :scs (long-reg) :target fr0))
3557 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3558 (:temporary (:sc long-reg :offset fr0-offset
3559 :from :argument :to :result) fr0)
3560 (:temporary (:sc long-reg :offset fr1-offset
3561 :from :argument :to :result) fr1)
3562 (:temporary (:sc long-reg :offset fr2-offset
3563 :from :argument :to :result) fr2)
3564 (:results (y :scs (long-reg)))
3565 (:arg-types long-float)
3566 (:result-types long-float)
3567 (:policy :fast-safe)
3568 (:note "inline expm1 function")
3570 (:save-p :compute-only)
3573 (note-this-location vop :internal-error)
3574 (unless (zerop (tn-offset x))
3575 (inst fxch x) ; x to top of stack
3576 (unless (location= x y)
3577 (inst fst x))) ; maybe save it
3578 ;; Check for Inf or NaN
3582 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3583 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3584 (inst and ah-tn #x02) ; Test sign of Inf.
3585 (inst jmp :z DONE) ; +Inf gives +Inf.
3586 (inst fstp fr0) ; -Inf gives -1.0
3589 (inst jmp-short DONE)
3591 ;; Free two stack slots leaving the argument on top.
3595 (inst fmul fr1) ; Now fr0 = x log2(e)
3610 (unless (zerop (tn-offset y))
3615 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3616 (:temporary (:sc long-reg :offset fr0-offset
3617 :from :argument :to :result) fr0)
3618 (:temporary (:sc long-reg :offset fr1-offset
3619 :from :argument :to :result) fr1)
3620 (:results (y :scs (long-reg)))
3621 (:arg-types long-float)
3622 (:result-types long-float)
3623 (:policy :fast-safe)
3624 (:note "inline log function")
3626 (:save-p :compute-only)
3628 (note-this-location vop :internal-error)
3643 ;; x is in a FP reg, not fr0 or fr1
3647 (inst fldd (make-random-tn :kind :normal
3648 :sc (sc-or-lose 'double-reg)
3649 :offset (1- (tn-offset x))))))
3651 ((long-stack descriptor-reg)
3655 (if (sc-is x long-stack)
3656 (inst fldl (ea-for-lf-stack x))
3657 (inst fldl (ea-for-lf-desc x)))
3662 (t (inst fstd y)))))
3664 (define-vop (flog10)
3666 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3667 (:temporary (:sc long-reg :offset fr0-offset
3668 :from :argument :to :result) fr0)
3669 (:temporary (:sc long-reg :offset fr1-offset
3670 :from :argument :to :result) fr1)
3671 (:results (y :scs (long-reg)))
3672 (:arg-types long-float)
3673 (:result-types long-float)
3674 (:policy :fast-safe)
3675 (:note "inline log10 function")
3677 (:save-p :compute-only)
3679 (note-this-location vop :internal-error)
3694 ;; x is in a FP reg, not fr0 or fr1
3698 (inst fldd (make-random-tn :kind :normal
3699 :sc (sc-or-lose 'double-reg)
3700 :offset (1- (tn-offset x))))))
3702 ((long-stack descriptor-reg)
3706 (if (sc-is x long-stack)
3707 (inst fldl (ea-for-lf-stack x))
3708 (inst fldl (ea-for-lf-desc x)))
3713 (t (inst fstd y)))))
3717 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3718 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3719 (:temporary (:sc long-reg :offset fr0-offset
3720 :from (:argument 0) :to :result) fr0)
3721 (:temporary (:sc long-reg :offset fr1-offset
3722 :from (:argument 1) :to :result) fr1)
3723 (:temporary (:sc long-reg :offset fr2-offset
3724 :from :load :to :result) fr2)
3725 (:results (r :scs (long-reg)))
3726 (:arg-types long-float long-float)
3727 (:result-types long-float)
3728 (:policy :fast-safe)
3729 (:note "inline pow function")
3731 (:save-p :compute-only)
3733 (note-this-location vop :internal-error)
3734 ;; Setup x in fr0 and y in fr1
3736 ;; x in fr0; y in fr1
3737 ((and (sc-is x long-reg) (zerop (tn-offset x))
3738 (sc-is y long-reg) (= 1 (tn-offset y))))
3739 ;; y in fr1; x not in fr0
3740 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3744 (copy-fp-reg-to-fr0 x))
3747 (inst fldl (ea-for-lf-stack x)))
3750 (inst fldl (ea-for-lf-desc x)))))
3751 ;; x in fr0; y not in fr1
3752 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3754 ;; Now load y to fr0
3757 (copy-fp-reg-to-fr0 y))
3760 (inst fldl (ea-for-lf-stack y)))
3763 (inst fldl (ea-for-lf-desc y))))
3765 ;; x in fr1; y not in fr1
3766 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3770 (copy-fp-reg-to-fr0 y))
3773 (inst fldl (ea-for-lf-stack y)))
3776 (inst fldl (ea-for-lf-desc y))))
3779 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3781 ;; Now load x to fr0
3784 (copy-fp-reg-to-fr0 x))
3787 (inst fldl (ea-for-lf-stack x)))
3790 (inst fldl (ea-for-lf-desc x)))))
3791 ;; Neither x or y are in either fr0 or fr1
3798 (inst fldd (make-random-tn :kind :normal
3799 :sc (sc-or-lose 'double-reg)
3800 :offset (- (tn-offset y) 2))))
3802 (inst fldl (ea-for-lf-stack y)))
3804 (inst fldl (ea-for-lf-desc y))))
3808 (inst fldd (make-random-tn :kind :normal
3809 :sc (sc-or-lose 'double-reg)
3810 :offset (1- (tn-offset x)))))
3812 (inst fldl (ea-for-lf-stack x)))
3814 (inst fldl (ea-for-lf-desc x))))))
3816 ;; Now have x at fr0; and y at fr1
3818 ;; Now fr0=y log2(x)
3822 (inst fsubp-sti fr1)
3825 (inst faddp-sti fr1)
3830 (t (inst fstd r)))))
3832 (define-vop (fscalen)
3833 (:translate %scalbn)
3834 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3835 (y :scs (signed-stack signed-reg) :target temp))
3836 (:temporary (:sc long-reg :offset fr0-offset
3837 :from (:argument 0) :to :result) fr0)
3838 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3839 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3840 (:results (r :scs (long-reg)))
3841 (:arg-types long-float signed-num)
3842 (:result-types long-float)
3843 (:policy :fast-safe)
3844 (:note "inline scalbn function")
3846 ;; Setup x in fr0 and y in fr1
3877 (inst fld (make-random-tn :kind :normal
3878 :sc (sc-or-lose 'double-reg)
3879 :offset (1- (tn-offset x)))))))
3880 ((long-stack descriptor-reg)
3889 (if (sc-is x long-stack)
3890 (inst fldl (ea-for-lf-stack x))
3891 (inst fldl (ea-for-lf-desc x)))))
3893 (unless (zerop (tn-offset r))
3896 (define-vop (fscale)
3898 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3899 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3900 (:temporary (:sc long-reg :offset fr0-offset
3901 :from (:argument 0) :to :result) fr0)
3902 (:temporary (:sc long-reg :offset fr1-offset
3903 :from (:argument 1) :to :result) fr1)
3904 (:results (r :scs (long-reg)))
3905 (:arg-types long-float long-float)
3906 (:result-types long-float)
3907 (:policy :fast-safe)
3908 (:note "inline scalb function")
3910 (:save-p :compute-only)
3912 (note-this-location vop :internal-error)
3913 ;; Setup x in fr0 and y in fr1
3915 ;; x in fr0; y in fr1
3916 ((and (sc-is x long-reg) (zerop (tn-offset x))
3917 (sc-is y long-reg) (= 1 (tn-offset y))))
3918 ;; y in fr1; x not in fr0
3919 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3923 (copy-fp-reg-to-fr0 x))
3926 (inst fldl (ea-for-lf-stack x)))
3929 (inst fldl (ea-for-lf-desc x)))))
3930 ;; x in fr0; y not in fr1
3931 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3933 ;; Now load y to fr0
3936 (copy-fp-reg-to-fr0 y))
3939 (inst fldl (ea-for-lf-stack y)))
3942 (inst fldl (ea-for-lf-desc y))))
3944 ;; x in fr1; y not in fr1
3945 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3949 (copy-fp-reg-to-fr0 y))
3952 (inst fldl (ea-for-lf-stack y)))
3955 (inst fldl (ea-for-lf-desc y))))
3958 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3960 ;; Now load x to fr0
3963 (copy-fp-reg-to-fr0 x))
3966 (inst fldl (ea-for-lf-stack x)))
3969 (inst fldl (ea-for-lf-desc x)))))
3970 ;; Neither x or y are in either fr0 or fr1
3977 (inst fldd (make-random-tn :kind :normal
3978 :sc (sc-or-lose 'double-reg)
3979 :offset (- (tn-offset y) 2))))
3981 (inst fldl (ea-for-lf-stack y)))
3983 (inst fldl (ea-for-lf-desc y))))
3987 (inst fldd (make-random-tn :kind :normal
3988 :sc (sc-or-lose 'double-reg)
3989 :offset (1- (tn-offset x)))))
3991 (inst fldl (ea-for-lf-stack x)))
3993 (inst fldl (ea-for-lf-desc x))))))
3995 ;; Now have x at fr0; and y at fr1
3997 (unless (zerop (tn-offset r))
4000 (define-vop (flog1p)
4002 (:args (x :scs (long-reg) :to :result))
4003 (:temporary (:sc long-reg :offset fr0-offset
4004 :from :argument :to :result) fr0)
4005 (:temporary (:sc long-reg :offset fr1-offset
4006 :from :argument :to :result) fr1)
4007 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
4008 (:results (y :scs (long-reg)))
4009 (:arg-types long-float)
4010 (:result-types long-float)
4011 (:policy :fast-safe)
4012 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
4013 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
4014 ;; an enormous PROGN above. Still, it would be probably be good to
4015 ;; add some code to warn about redefining VOPs.
4016 (:note "inline log1p function")
4019 ;; x is in a FP reg, not fr0, fr1.
4022 (inst fldd (make-random-tn :kind :normal
4023 :sc (sc-or-lose 'double-reg)
4024 :offset (- (tn-offset x) 2)))
4026 (inst push #x3e947ae1) ; Constant 0.29
4028 (inst fld (make-ea :dword :base esp-tn))
4031 (inst fnstsw) ; status word to ax
4032 (inst and ah-tn #x45)
4033 (inst jmp :z WITHIN-RANGE)
4034 ;; Out of range for fyl2xp1.
4036 (inst faddd (make-random-tn :kind :normal
4037 :sc (sc-or-lose 'double-reg)
4038 :offset (- (tn-offset x) 1)))
4046 (inst fldd (make-random-tn :kind :normal
4047 :sc (sc-or-lose 'double-reg)
4048 :offset (- (tn-offset x) 1)))
4054 (t (inst fstd y)))))
4056 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4057 ;;; instruction and a range check can be avoided.
4058 (define-vop (flog1p-pentium)
4060 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4061 (:temporary (:sc long-reg :offset fr0-offset
4062 :from :argument :to :result) fr0)
4063 (:temporary (:sc long-reg :offset fr1-offset
4064 :from :argument :to :result) fr1)
4065 (:results (y :scs (long-reg)))
4066 (:arg-types long-float)
4067 (:result-types long-float)
4068 (:policy :fast-safe)
4069 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
4070 (:note "inline log1p function")
4086 ;; x is in a FP reg, not fr0 or fr1
4090 (inst fldd (make-random-tn :kind :normal
4091 :sc (sc-or-lose 'double-reg)
4092 :offset (1- (tn-offset x)))))))
4093 ((long-stack descriptor-reg)
4097 (if (sc-is x long-stack)
4098 (inst fldl (ea-for-lf-stack x))
4099 (inst fldl (ea-for-lf-desc x)))))
4104 (t (inst fstd y)))))
4108 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4109 (:temporary (:sc long-reg :offset fr0-offset
4110 :from :argument :to :result) fr0)
4111 (:temporary (:sc long-reg :offset fr1-offset
4112 :from :argument :to :result) fr1)
4113 (:results (y :scs (long-reg)))
4114 (:arg-types long-float)
4115 (:result-types long-float)
4116 (:policy :fast-safe)
4117 (:note "inline logb function")
4119 (:save-p :compute-only)
4121 (note-this-location vop :internal-error)
4132 ;; x is in a FP reg, not fr0 or fr1
4135 (inst fldd (make-random-tn :kind :normal
4136 :sc (sc-or-lose 'double-reg)
4137 :offset (- (tn-offset x) 2))))))
4138 ((long-stack descriptor-reg)
4141 (if (sc-is x long-stack)
4142 (inst fldl (ea-for-lf-stack x))
4143 (inst fldl (ea-for-lf-desc x)))))
4154 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4155 (:temporary (:sc long-reg :offset fr0-offset
4156 :from (:argument 0) :to :result) fr0)
4157 (:temporary (:sc long-reg :offset fr1-offset
4158 :from (:argument 0) :to :result) fr1)
4159 (:results (r :scs (long-reg)))
4160 (:arg-types long-float)
4161 (:result-types long-float)
4162 (:policy :fast-safe)
4163 (:note "inline atan function")
4165 (:save-p :compute-only)
4167 (note-this-location vop :internal-error)
4168 ;; Setup x in fr1 and 1.0 in fr0
4171 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4174 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4176 ;; x not in fr0 or fr1
4183 (inst fldd (make-random-tn :kind :normal
4184 :sc (sc-or-lose 'double-reg)
4185 :offset (- (tn-offset x) 2))))
4187 (inst fldl (ea-for-lf-stack x)))
4189 (inst fldl (ea-for-lf-desc x))))))
4191 ;; Now have x at fr1; and 1.0 at fr0
4196 (t (inst fstd r)))))
4198 (define-vop (fatan2)
4200 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4201 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4202 (:temporary (:sc long-reg :offset fr0-offset
4203 :from (:argument 1) :to :result) fr0)
4204 (:temporary (:sc long-reg :offset fr1-offset
4205 :from (:argument 0) :to :result) fr1)
4206 (:results (r :scs (long-reg)))
4207 (:arg-types long-float long-float)
4208 (:result-types long-float)
4209 (:policy :fast-safe)
4210 (:note "inline atan2 function")
4212 (:save-p :compute-only)
4214 (note-this-location vop :internal-error)
4215 ;; Setup x in fr1 and y in fr0
4217 ;; y in fr0; x in fr1
4218 ((and (sc-is y long-reg) (zerop (tn-offset y))
4219 (sc-is x long-reg) (= 1 (tn-offset x))))
4220 ;; x in fr1; y not in fr0
4221 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4225 (copy-fp-reg-to-fr0 y))
4228 (inst fldl (ea-for-lf-stack y)))
4231 (inst fldl (ea-for-lf-desc y)))))
4232 ;; y in fr0; x not in fr1
4233 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4235 ;; Now load x to fr0
4238 (copy-fp-reg-to-fr0 x))
4241 (inst fldl (ea-for-lf-stack x)))
4244 (inst fldl (ea-for-lf-desc x))))
4246 ;; y in fr1; x not in fr1
4247 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4251 (copy-fp-reg-to-fr0 x))
4254 (inst fldl (ea-for-lf-stack x)))
4257 (inst fldl (ea-for-lf-desc x))))
4260 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4262 ;; Now load y to fr0
4265 (copy-fp-reg-to-fr0 y))
4268 (inst fldl (ea-for-lf-stack y)))
4271 (inst fldl (ea-for-lf-desc y)))))
4272 ;; Neither y or x are in either fr0 or fr1
4279 (inst fldd (make-random-tn :kind :normal
4280 :sc (sc-or-lose 'double-reg)
4281 :offset (- (tn-offset x) 2))))
4283 (inst fldl (ea-for-lf-stack x)))
4285 (inst fldl (ea-for-lf-desc x))))
4289 (inst fldd (make-random-tn :kind :normal
4290 :sc (sc-or-lose 'double-reg)
4291 :offset (1- (tn-offset y)))))
4293 (inst fldl (ea-for-lf-stack y)))
4295 (inst fldl (ea-for-lf-desc y))))))
4297 ;; Now have y at fr0; and x at fr1
4302 (t (inst fstd r)))))
4304 ) ; PROGN #!+LONG-FLOAT
4306 ;;;; complex float VOPs
4308 (define-vop (make-complex-single-float)
4309 (:translate complex)
4310 (:args (real :scs (single-reg) :to :result :target r
4311 :load-if (not (location= real r)))
4312 (imag :scs (single-reg) :to :save))
4313 (:arg-types single-float single-float)
4314 (:results (r :scs (complex-single-reg) :from (:argument 0)
4315 :load-if (not (sc-is r complex-single-stack))))
4316 (:result-types complex-single-float)
4317 (:note "inline complex single-float creation")
4318 (:policy :fast-safe)
4322 (let ((r-real (complex-double-reg-real-tn r)))
4323 (unless (location= real r-real)
4324 (cond ((zerop (tn-offset r-real))
4325 (copy-fp-reg-to-fr0 real))
4326 ((zerop (tn-offset real))
4331 (inst fxch real)))))
4332 (let ((r-imag (complex-double-reg-imag-tn r)))
4333 (unless (location= imag r-imag)
4334 (cond ((zerop (tn-offset imag))
4339 (inst fxch imag))))))
4340 (complex-single-stack
4341 (unless (location= real r)
4342 (cond ((zerop (tn-offset real))
4343 (inst fst (ea-for-csf-real-stack r)))
4346 (inst fst (ea-for-csf-real-stack r))
4349 (inst fst (ea-for-csf-imag-stack r))
4350 (inst fxch imag)))))
4352 (define-vop (make-complex-double-float)
4353 (:translate complex)
4354 (:args (real :scs (double-reg) :target r
4355 :load-if (not (location= real r)))
4356 (imag :scs (double-reg) :to :save))
4357 (:arg-types double-float double-float)
4358 (:results (r :scs (complex-double-reg) :from (:argument 0)
4359 :load-if (not (sc-is r complex-double-stack))))
4360 (:result-types complex-double-float)
4361 (:note "inline complex double-float creation")
4362 (:policy :fast-safe)
4366 (let ((r-real (complex-double-reg-real-tn r)))
4367 (unless (location= real r-real)
4368 (cond ((zerop (tn-offset r-real))
4369 (copy-fp-reg-to-fr0 real))
4370 ((zerop (tn-offset real))
4375 (inst fxch real)))))
4376 (let ((r-imag (complex-double-reg-imag-tn r)))
4377 (unless (location= imag r-imag)
4378 (cond ((zerop (tn-offset imag))
4383 (inst fxch imag))))))
4384 (complex-double-stack
4385 (unless (location= real r)
4386 (cond ((zerop (tn-offset real))
4387 (inst fstd (ea-for-cdf-real-stack r)))
4390 (inst fstd (ea-for-cdf-real-stack r))
4393 (inst fstd (ea-for-cdf-imag-stack r))
4394 (inst fxch imag)))))
4397 (define-vop (make-complex-long-float)
4398 (:translate complex)
4399 (:args (real :scs (long-reg) :target r
4400 :load-if (not (location= real r)))
4401 (imag :scs (long-reg) :to :save))
4402 (:arg-types long-float long-float)
4403 (:results (r :scs (complex-long-reg) :from (:argument 0)
4404 :load-if (not (sc-is r complex-long-stack))))
4405 (:result-types complex-long-float)
4406 (:note "inline complex long-float creation")
4407 (:policy :fast-safe)
4411 (let ((r-real (complex-double-reg-real-tn r)))
4412 (unless (location= real r-real)
4413 (cond ((zerop (tn-offset r-real))
4414 (copy-fp-reg-to-fr0 real))
4415 ((zerop (tn-offset real))
4420 (inst fxch real)))))
4421 (let ((r-imag (complex-double-reg-imag-tn r)))
4422 (unless (location= imag r-imag)
4423 (cond ((zerop (tn-offset imag))
4428 (inst fxch imag))))))
4430 (unless (location= real r)
4431 (cond ((zerop (tn-offset real))
4432 (store-long-float (ea-for-clf-real-stack r)))
4435 (store-long-float (ea-for-clf-real-stack r))
4438 (store-long-float (ea-for-clf-imag-stack r))
4439 (inst fxch imag)))))
4442 (define-vop (complex-float-value)
4443 (:args (x :target r))
4445 (:variant-vars offset)
4446 (:policy :fast-safe)
4448 (cond ((sc-is x complex-single-reg complex-double-reg
4449 #!+long-float complex-long-reg)
4451 (make-random-tn :kind :normal
4452 :sc (sc-or-lose 'double-reg)
4453 :offset (+ offset (tn-offset x)))))
4454 (unless (location= value-tn r)
4455 (cond ((zerop (tn-offset r))
4456 (copy-fp-reg-to-fr0 value-tn))
4457 ((zerop (tn-offset value-tn))
4460 (inst fxch value-tn)
4462 (inst fxch value-tn))))))
4463 ((sc-is r single-reg)
4464 (let ((ea (sc-case x
4465 (complex-single-stack
4467 (0 (ea-for-csf-real-stack x))
4468 (1 (ea-for-csf-imag-stack x))))
4471 (0 (ea-for-csf-real-desc x))
4472 (1 (ea-for-csf-imag-desc x)))))))
4473 (with-empty-tn@fp-top(r)
4475 ((sc-is r double-reg)
4476 (let ((ea (sc-case x
4477 (complex-double-stack
4479 (0 (ea-for-cdf-real-stack x))
4480 (1 (ea-for-cdf-imag-stack x))))
4483 (0 (ea-for-cdf-real-desc x))
4484 (1 (ea-for-cdf-imag-desc x)))))))
4485 (with-empty-tn@fp-top(r)
4489 (let ((ea (sc-case x
4492 (0 (ea-for-clf-real-stack x))
4493 (1 (ea-for-clf-imag-stack x))))
4496 (0 (ea-for-clf-real-desc x))
4497 (1 (ea-for-clf-imag-desc x)))))))
4498 (with-empty-tn@fp-top(r)
4500 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4502 (define-vop (realpart/complex-single-float complex-float-value)
4503 (:translate realpart)
4504 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4506 (:arg-types complex-single-float)
4507 (:results (r :scs (single-reg)))
4508 (:result-types single-float)
4509 (:note "complex float realpart")
4512 (define-vop (realpart/complex-double-float complex-float-value)
4513 (:translate realpart)
4514 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4516 (:arg-types complex-double-float)
4517 (:results (r :scs (double-reg)))
4518 (:result-types double-float)
4519 (:note "complex float realpart")
4523 (define-vop (realpart/complex-long-float complex-float-value)
4524 (:translate realpart)
4525 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4527 (:arg-types complex-long-float)
4528 (:results (r :scs (long-reg)))
4529 (:result-types long-float)
4530 (:note "complex float realpart")
4533 (define-vop (imagpart/complex-single-float complex-float-value)
4534 (:translate imagpart)
4535 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4537 (:arg-types complex-single-float)
4538 (:results (r :scs (single-reg)))
4539 (:result-types single-float)
4540 (:note "complex float imagpart")
4543 (define-vop (imagpart/complex-double-float complex-float-value)
4544 (:translate imagpart)
4545 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4547 (:arg-types complex-double-float)
4548 (:results (r :scs (double-reg)))
4549 (:result-types double-float)
4550 (:note "complex float imagpart")
4554 (define-vop (imagpart/complex-long-float complex-float-value)
4555 (:translate imagpart)
4556 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4558 (:arg-types complex-long-float)
4559 (:results (r :scs (long-reg)))
4560 (:result-types long-float)
4561 (:note "complex float imagpart")
4564 ;;; hack dummy VOPs to bias the representation selection of their
4565 ;;; arguments towards a FP register, which can help avoid consing at
4566 ;;; inappropriate locations
4567 (defknown double-float-reg-bias (double-float) (values))
4568 (define-vop (double-float-reg-bias)
4569 (:translate double-float-reg-bias)
4570 (:args (x :scs (double-reg double-stack) :load-if nil))
4571 (:arg-types double-float)
4572 (:policy :fast-safe)
4573 (:note "inline dummy FP register bias")
4576 (defknown single-float-reg-bias (single-float) (values))
4577 (define-vop (single-float-reg-bias)
4578 (:translate single-float-reg-bias)
4579 (:args (x :scs (single-reg single-stack) :load-if nil))
4580 (:arg-types single-float)
4581 (:policy :fast-safe)
4582 (:note "inline dummy FP register bias")