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 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1533 (define-vop (=0/double-float float-test)
1535 (:args (x :scs (double-reg)))
1536 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1539 (define-vop (=0/long-float float-test)
1541 (:args (x :scs (long-reg)))
1542 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1545 (define-vop (<0/single-float float-test)
1547 (:args (x :scs (single-reg)))
1548 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1550 (define-vop (<0/double-float float-test)
1552 (:args (x :scs (double-reg)))
1553 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1556 (define-vop (<0/long-float float-test)
1558 (:args (x :scs (long-reg)))
1559 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1562 (define-vop (>0/single-float float-test)
1564 (:args (x :scs (single-reg)))
1565 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1567 (define-vop (>0/double-float float-test)
1569 (:args (x :scs (double-reg)))
1570 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1573 (define-vop (>0/long-float float-test)
1575 (:args (x :scs (long-reg)))
1576 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1580 (deftransform eql ((x y) (long-float long-float))
1581 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1582 (= (long-float-high-bits x) (long-float-high-bits y))
1583 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1587 (macrolet ((frob (name translate to-sc to-type)
1588 `(define-vop (,name)
1589 (:args (x :scs (signed-stack signed-reg) :target temp))
1590 (:temporary (:sc signed-stack) temp)
1591 (:results (y :scs (,to-sc)))
1592 (:arg-types signed-num)
1593 (:result-types ,to-type)
1594 (:policy :fast-safe)
1595 (:note "inline float coercion")
1596 (:translate ,translate)
1598 (:save-p :compute-only)
1603 (with-empty-tn@fp-top(y)
1604 (note-this-location vop :internal-error)
1607 (with-empty-tn@fp-top(y)
1608 (note-this-location vop :internal-error)
1609 (inst fild x))))))))
1610 (frob %single-float/signed %single-float single-reg single-float)
1611 (frob %double-float/signed %double-float double-reg double-float)
1613 (frob %long-float/signed %long-float long-reg long-float))
1615 (macrolet ((frob (name translate to-sc to-type)
1616 `(define-vop (,name)
1617 (:args (x :scs (unsigned-reg)))
1618 (:results (y :scs (,to-sc)))
1619 (:arg-types unsigned-num)
1620 (:result-types ,to-type)
1621 (:policy :fast-safe)
1622 (:note "inline float coercion")
1623 (:translate ,translate)
1625 (:save-p :compute-only)
1629 (with-empty-tn@fp-top(y)
1630 (note-this-location vop :internal-error)
1631 (inst fildl (make-ea :dword :base esp-tn)))
1632 (inst add esp-tn 8)))))
1633 (frob %single-float/unsigned %single-float single-reg single-float)
1634 (frob %double-float/unsigned %double-float double-reg double-float)
1636 (frob %long-float/unsigned %long-float long-reg long-float))
1638 ;;; These should be no-ops but the compiler might want to move some
1640 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1641 `(define-vop (,name)
1642 (:args (x :scs (,from-sc) :target y))
1643 (:results (y :scs (,to-sc)))
1644 (:arg-types ,from-type)
1645 (:result-types ,to-type)
1646 (:policy :fast-safe)
1647 (:note "inline float coercion")
1648 (:translate ,translate)
1650 (:save-p :compute-only)
1652 (note-this-location vop :internal-error)
1653 (unless (location= x y)
1655 ((zerop (tn-offset x))
1656 ;; x is in ST0, y is in another reg. not ST0
1658 ((zerop (tn-offset y))
1659 ;; y is in ST0, x is in another reg. not ST0
1660 (copy-fp-reg-to-fr0 x))
1662 ;; Neither x or y are in ST0, and they are not in
1666 (inst fxch x))))))))
1668 (frob %single-float/double-float %single-float double-reg
1669 double-float single-reg single-float)
1671 (frob %single-float/long-float %single-float long-reg
1672 long-float single-reg single-float)
1673 (frob %double-float/single-float %double-float single-reg single-float
1674 double-reg double-float)
1676 (frob %double-float/long-float %double-float long-reg long-float
1677 double-reg double-float)
1679 (frob %long-float/single-float %long-float single-reg single-float
1680 long-reg long-float)
1682 (frob %long-float/double-float %long-float double-reg double-float
1683 long-reg long-float))
1685 (macrolet ((frob (trans from-sc from-type round-p)
1686 `(define-vop (,(symbolicate trans "/" from-type))
1687 (:args (x :scs (,from-sc)))
1688 (:temporary (:sc signed-stack) stack-temp)
1690 '((:temporary (:sc unsigned-stack) scw)
1691 (:temporary (:sc any-reg) rcw)))
1692 (:results (y :scs (signed-reg)))
1693 (:arg-types ,from-type)
1694 (:result-types signed-num)
1696 (:policy :fast-safe)
1697 (:note "inline float truncate")
1699 (:save-p :compute-only)
1702 '((note-this-location vop :internal-error)
1703 ;; Catch any pending FPE exceptions.
1705 (,(if round-p 'progn 'pseudo-atomic)
1706 ;; Normal mode (for now) is "round to best".
1709 '((inst fnstcw scw) ; save current control word
1710 (move rcw scw) ; into 16-bit register
1711 (inst or rcw (ash #b11 10)) ; CHOP
1712 (move stack-temp rcw)
1713 (inst fldcw stack-temp)))
1718 (inst fist stack-temp)
1719 (inst mov y stack-temp)))
1721 '((inst fldcw scw)))))))))
1722 (frob %unary-truncate single-reg single-float nil)
1723 (frob %unary-truncate double-reg double-float nil)
1725 (frob %unary-truncate long-reg long-float nil)
1726 (frob %unary-round single-reg single-float t)
1727 (frob %unary-round double-reg double-float t)
1729 (frob %unary-round long-reg long-float t))
1731 (macrolet ((frob (trans from-sc from-type round-p)
1732 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1733 (:args (x :scs (,from-sc) :target fr0))
1734 (:temporary (:sc double-reg :offset fr0-offset
1735 :from :argument :to :result) fr0)
1737 '((:temporary (:sc unsigned-stack) stack-temp)
1738 (:temporary (:sc unsigned-stack) scw)
1739 (:temporary (:sc any-reg) rcw)))
1740 (:results (y :scs (unsigned-reg)))
1741 (:arg-types ,from-type)
1742 (:result-types unsigned-num)
1744 (:policy :fast-safe)
1745 (:note "inline float truncate")
1747 (:save-p :compute-only)
1750 '((note-this-location vop :internal-error)
1751 ;; Catch any pending FPE exceptions.
1753 ;; Normal mode (for now) is "round to best".
1754 (unless (zerop (tn-offset x))
1755 (copy-fp-reg-to-fr0 x))
1757 '((inst fnstcw scw) ; save current control word
1758 (move rcw scw) ; into 16-bit register
1759 (inst or rcw (ash #b11 10)) ; CHOP
1760 (move stack-temp rcw)
1761 (inst fldcw stack-temp)))
1763 (inst fistpl (make-ea :dword :base esp-tn))
1765 (inst fld fr0) ; copy fr0 to at least restore stack.
1768 '((inst fldcw scw)))))))
1769 (frob %unary-truncate single-reg single-float nil)
1770 (frob %unary-truncate double-reg double-float nil)
1772 (frob %unary-truncate long-reg long-float nil)
1773 (frob %unary-round single-reg single-float t)
1774 (frob %unary-round double-reg double-float t)
1776 (frob %unary-round long-reg long-float t))
1778 (define-vop (make-single-float)
1779 (:args (bits :scs (signed-reg) :target res
1780 :load-if (not (or (and (sc-is bits signed-stack)
1781 (sc-is res single-reg))
1782 (and (sc-is bits signed-stack)
1783 (sc-is res single-stack)
1784 (location= bits res))))))
1785 (:results (res :scs (single-reg single-stack)))
1786 (:temporary (:sc signed-stack) stack-temp)
1787 (:arg-types signed-num)
1788 (:result-types single-float)
1789 (:translate make-single-float)
1790 (:policy :fast-safe)
1797 (inst mov res bits))
1799 (aver (location= bits res)))))
1803 ;; source must be in memory
1804 (inst mov stack-temp bits)
1805 (with-empty-tn@fp-top(res)
1806 (inst fld stack-temp)))
1808 (with-empty-tn@fp-top(res)
1809 (inst fld bits))))))))
1811 (define-vop (make-double-float)
1812 (:args (hi-bits :scs (signed-reg))
1813 (lo-bits :scs (unsigned-reg)))
1814 (:results (res :scs (double-reg)))
1815 (:temporary (:sc double-stack) temp)
1816 (:arg-types signed-num unsigned-num)
1817 (:result-types double-float)
1818 (:translate make-double-float)
1819 (:policy :fast-safe)
1822 (let ((offset (1+ (tn-offset temp))))
1823 (storew hi-bits ebp-tn (- offset))
1824 (storew lo-bits ebp-tn (- (1+ offset)))
1825 (with-empty-tn@fp-top(res)
1826 (inst fldd (make-ea :dword :base ebp-tn
1827 :disp (- (* (1+ offset) n-word-bytes))))))))
1830 (define-vop (make-long-float)
1831 (:args (exp-bits :scs (signed-reg))
1832 (hi-bits :scs (unsigned-reg))
1833 (lo-bits :scs (unsigned-reg)))
1834 (:results (res :scs (long-reg)))
1835 (:temporary (:sc long-stack) temp)
1836 (:arg-types signed-num unsigned-num unsigned-num)
1837 (:result-types long-float)
1838 (:translate make-long-float)
1839 (:policy :fast-safe)
1842 (let ((offset (1+ (tn-offset temp))))
1843 (storew exp-bits ebp-tn (- offset))
1844 (storew hi-bits ebp-tn (- (1+ offset)))
1845 (storew lo-bits ebp-tn (- (+ offset 2)))
1846 (with-empty-tn@fp-top(res)
1847 (inst fldl (make-ea :dword :base ebp-tn
1848 :disp (- (* (+ offset 2) n-word-bytes))))))))
1850 (define-vop (single-float-bits)
1851 (:args (float :scs (single-reg descriptor-reg)
1852 :load-if (not (sc-is float single-stack))))
1853 (:results (bits :scs (signed-reg)))
1854 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1855 (:arg-types single-float)
1856 (:result-types signed-num)
1857 (:translate single-float-bits)
1858 (:policy :fast-safe)
1865 (with-tn@fp-top(float)
1866 (inst fst stack-temp)
1867 (inst mov bits stack-temp)))
1869 (inst mov bits float))
1872 bits float single-float-value-slot
1873 other-pointer-lowtag))))
1877 (with-tn@fp-top(float)
1878 (inst fst bits))))))))
1880 (define-vop (double-float-high-bits)
1881 (:args (float :scs (double-reg descriptor-reg)
1882 :load-if (not (sc-is float double-stack))))
1883 (:results (hi-bits :scs (signed-reg)))
1884 (:temporary (:sc double-stack) temp)
1885 (:arg-types double-float)
1886 (:result-types signed-num)
1887 (:translate double-float-high-bits)
1888 (:policy :fast-safe)
1893 (with-tn@fp-top(float)
1894 (let ((where (make-ea :dword :base ebp-tn
1895 :disp (- (* (+ 2 (tn-offset temp))
1898 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1900 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1902 (loadw hi-bits float (1+ double-float-value-slot)
1903 other-pointer-lowtag)))))
1905 (define-vop (double-float-low-bits)
1906 (:args (float :scs (double-reg descriptor-reg)
1907 :load-if (not (sc-is float double-stack))))
1908 (:results (lo-bits :scs (unsigned-reg)))
1909 (:temporary (:sc double-stack) temp)
1910 (:arg-types double-float)
1911 (:result-types unsigned-num)
1912 (:translate double-float-low-bits)
1913 (:policy :fast-safe)
1918 (with-tn@fp-top(float)
1919 (let ((where (make-ea :dword :base ebp-tn
1920 :disp (- (* (+ 2 (tn-offset temp))
1923 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1925 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1927 (loadw lo-bits float double-float-value-slot
1928 other-pointer-lowtag)))))
1931 (define-vop (long-float-exp-bits)
1932 (:args (float :scs (long-reg descriptor-reg)
1933 :load-if (not (sc-is float long-stack))))
1934 (:results (exp-bits :scs (signed-reg)))
1935 (:temporary (:sc long-stack) temp)
1936 (:arg-types long-float)
1937 (:result-types signed-num)
1938 (:translate long-float-exp-bits)
1939 (:policy :fast-safe)
1944 (with-tn@fp-top(float)
1945 (let ((where (make-ea :dword :base ebp-tn
1946 :disp (- (* (+ 3 (tn-offset temp))
1948 (store-long-float where)))
1949 (inst movsx exp-bits
1950 (make-ea :word :base ebp-tn
1951 :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
1953 (inst movsx exp-bits
1954 (make-ea :word :base ebp-tn
1955 :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
1957 (inst movsx exp-bits
1958 (make-ea :word :base float
1959 :disp (- (* (+ 2 long-float-value-slot)
1961 other-pointer-lowtag)))))))
1964 (define-vop (long-float-high-bits)
1965 (:args (float :scs (long-reg descriptor-reg)
1966 :load-if (not (sc-is float long-stack))))
1967 (:results (hi-bits :scs (unsigned-reg)))
1968 (:temporary (:sc long-stack) temp)
1969 (:arg-types long-float)
1970 (:result-types unsigned-num)
1971 (:translate long-float-high-bits)
1972 (:policy :fast-safe)
1977 (with-tn@fp-top(float)
1978 (let ((where (make-ea :dword :base ebp-tn
1979 :disp (- (* (+ 3 (tn-offset temp))
1981 (store-long-float where)))
1982 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
1984 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
1986 (loadw hi-bits float (1+ long-float-value-slot)
1987 other-pointer-lowtag)))))
1990 (define-vop (long-float-low-bits)
1991 (:args (float :scs (long-reg descriptor-reg)
1992 :load-if (not (sc-is float long-stack))))
1993 (:results (lo-bits :scs (unsigned-reg)))
1994 (:temporary (:sc long-stack) temp)
1995 (:arg-types long-float)
1996 (:result-types unsigned-num)
1997 (:translate long-float-low-bits)
1998 (:policy :fast-safe)
2003 (with-tn@fp-top(float)
2004 (let ((where (make-ea :dword :base ebp-tn
2005 :disp (- (* (+ 3 (tn-offset temp))
2007 (store-long-float where)))
2008 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2010 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2012 (loadw lo-bits float long-float-value-slot
2013 other-pointer-lowtag)))))
2015 ;;;; float mode hackery
2017 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2018 (defknown floating-point-modes () float-modes (flushable))
2019 (defknown ((setf floating-point-modes)) (float-modes)
2022 (def!constant npx-env-size (* 7 n-word-bytes))
2023 (def!constant npx-cw-offset 0)
2024 (def!constant npx-sw-offset 4)
2026 (define-vop (floating-point-modes)
2027 (:results (res :scs (unsigned-reg)))
2028 (:result-types unsigned-num)
2029 (:translate floating-point-modes)
2030 (:policy :fast-safe)
2031 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2034 (inst sub esp-tn npx-env-size) ; Make space on stack.
2035 (inst wait) ; Catch any pending FPE exceptions
2036 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2037 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2038 ;; Move current status to high word.
2039 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2040 ;; Move exception mask to low word.
2041 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2042 (inst add esp-tn npx-env-size) ; Pop stack.
2043 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2046 (define-vop (set-floating-point-modes)
2047 (:args (new :scs (unsigned-reg) :to :result :target res))
2048 (:results (res :scs (unsigned-reg)))
2049 (:arg-types unsigned-num)
2050 (:result-types unsigned-num)
2051 (:translate (setf floating-point-modes))
2052 (:policy :fast-safe)
2053 (:temporary (:sc unsigned-reg :offset eax-offset
2054 :from :eval :to :result) eax)
2056 (inst sub esp-tn npx-env-size) ; Make space on stack.
2057 (inst wait) ; Catch any pending FPE exceptions.
2058 (inst fstenv (make-ea :dword :base esp-tn))
2060 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2061 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2062 (inst shr eax 16) ; position status word
2063 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2064 (inst fldenv (make-ea :dword :base esp-tn))
2065 (inst add esp-tn npx-env-size) ; Pop stack.
2071 ;;; Let's use some of the 80387 special functions.
2073 ;;; These defs will not take effect unless code/irrat.lisp is modified
2074 ;;; to remove the inlined alien routine def.
2076 (macrolet ((frob (func trans op)
2077 `(define-vop (,func)
2078 (:args (x :scs (double-reg) :target fr0))
2079 (:temporary (:sc double-reg :offset fr0-offset
2080 :from :argument :to :result) fr0)
2082 (:results (y :scs (double-reg)))
2083 (:arg-types double-float)
2084 (:result-types double-float)
2086 (:policy :fast-safe)
2087 (:note "inline NPX function")
2089 (:save-p :compute-only)
2092 (note-this-location vop :internal-error)
2093 (unless (zerop (tn-offset x))
2094 (inst fxch x) ; x to top of stack
2095 (unless (location= x y)
2096 (inst fst x))) ; maybe save it
2097 (inst ,op) ; clobber st0
2098 (cond ((zerop (tn-offset y))
2099 (maybe-fp-wait node))
2103 ;; Quick versions of fsin and fcos that require the argument to be
2104 ;; within range 2^63.
2105 (frob fsin-quick %sin-quick fsin)
2106 (frob fcos-quick %cos-quick fcos)
2107 (frob fsqrt %sqrt fsqrt))
2109 ;;; Quick version of ftan that requires the argument to be within
2111 (define-vop (ftan-quick)
2112 (:translate %tan-quick)
2113 (:args (x :scs (double-reg) :target fr0))
2114 (:temporary (:sc double-reg :offset fr0-offset
2115 :from :argument :to :result) fr0)
2116 (:temporary (:sc double-reg :offset fr1-offset
2117 :from :argument :to :result) fr1)
2118 (:results (y :scs (double-reg)))
2119 (:arg-types double-float)
2120 (:result-types double-float)
2121 (:policy :fast-safe)
2122 (:note "inline tan function")
2124 (:save-p :compute-only)
2126 (note-this-location vop :internal-error)
2135 (inst fldd (make-random-tn :kind :normal
2136 :sc (sc-or-lose 'double-reg)
2137 :offset (- (tn-offset x) 2)))))
2148 ;;; These versions of fsin, fcos, and ftan try to use argument
2149 ;;; reduction but to do this accurately requires greater precision and
2150 ;;; it is hopelessly inaccurate.
2152 (macrolet ((frob (func trans op)
2153 `(define-vop (,func)
2155 (:args (x :scs (double-reg) :target fr0))
2156 (:temporary (:sc unsigned-reg :offset eax-offset
2157 :from :eval :to :result) eax)
2158 (:temporary (:sc unsigned-reg :offset fr0-offset
2159 :from :argument :to :result) fr0)
2160 (:temporary (:sc unsigned-reg :offset fr1-offset
2161 :from :argument :to :result) fr1)
2162 (:results (y :scs (double-reg)))
2163 (:arg-types double-float)
2164 (:result-types double-float)
2165 (:policy :fast-safe)
2166 (:note "inline sin/cos function")
2168 (:save-p :compute-only)
2171 (note-this-location vop :internal-error)
2172 (unless (zerop (tn-offset x))
2173 (inst fxch x) ; x to top of stack
2174 (unless (location= x y)
2175 (inst fst x))) ; maybe save it
2177 (inst fnstsw) ; status word to ax
2178 (inst and ah-tn #x04) ; C2
2180 ;; Else x was out of range so reduce it; ST0 is unchanged.
2181 (inst fstp fr1) ; Load 2*PI
2187 (inst fnstsw) ; status word to ax
2188 (inst and ah-tn #x04) ; C2
2192 (unless (zerop (tn-offset y))
2194 (frob fsin %sin fsin)
2195 (frob fcos %cos fcos))
2200 (:args (x :scs (double-reg) :target fr0))
2201 (:temporary (:sc unsigned-reg :offset eax-offset
2202 :from :argument :to :result) eax)
2203 (:temporary (:sc double-reg :offset fr0-offset
2204 :from :argument :to :result) fr0)
2205 (:temporary (:sc double-reg :offset fr1-offset
2206 :from :argument :to :result) fr1)
2207 (:results (y :scs (double-reg)))
2208 (:arg-types double-float)
2209 (:result-types double-float)
2210 (:policy :fast-safe)
2211 (:note "inline tan function")
2213 (:save-p :compute-only)
2216 (note-this-location vop :internal-error)
2225 (inst fldd (make-random-tn :kind :normal
2226 :sc (sc-or-lose 'double-reg)
2227 :offset (- (tn-offset x) 2)))))
2229 (inst fnstsw) ; status word to ax
2230 (inst and ah-tn #x04) ; C2
2232 ;; Else x was out of range so reduce it; ST0 is unchanged.
2233 (inst fldpi) ; Load 2*PI
2238 (inst fnstsw) ; status word to ax
2239 (inst and ah-tn #x04) ; C2
2253 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2254 ;;; the argument is out of range 2^63 and would thus be hopelessly
2256 (macrolet ((frob (func trans op)
2257 `(define-vop (,func)
2259 (:args (x :scs (double-reg) :target fr0))
2260 (:temporary (:sc double-reg :offset fr0-offset
2261 :from :argument :to :result) fr0)
2262 (:temporary (:sc unsigned-reg :offset eax-offset
2263 :from :argument :to :result) eax)
2264 (:results (y :scs (double-reg)))
2265 (:arg-types double-float)
2266 (:result-types double-float)
2267 (:policy :fast-safe)
2268 (:note "inline sin/cos function")
2270 (:save-p :compute-only)
2273 (note-this-location vop :internal-error)
2274 (unless (zerop (tn-offset x))
2275 (inst fxch x) ; x to top of stack
2276 (unless (location= x y)
2277 (inst fst x))) ; maybe save it
2279 (inst fnstsw) ; status word to ax
2280 (inst and ah-tn #x04) ; C2
2282 ;; Else x was out of range so reduce it; ST0 is unchanged.
2283 (inst fstp fr0) ; Load 0.0
2286 (unless (zerop (tn-offset y))
2288 (frob fsin %sin fsin)
2289 (frob fcos %cos fcos))
2293 (:args (x :scs (double-reg) :target fr0))
2294 (:temporary (:sc double-reg :offset fr0-offset
2295 :from :argument :to :result) fr0)
2296 (:temporary (:sc double-reg :offset fr1-offset
2297 :from :argument :to :result) fr1)
2298 (:temporary (:sc unsigned-reg :offset eax-offset
2299 :from :argument :to :result) eax)
2300 (:results (y :scs (double-reg)))
2301 (:arg-types double-float)
2302 (:result-types double-float)
2304 (:policy :fast-safe)
2305 (:note "inline tan function")
2307 (:save-p :compute-only)
2310 (note-this-location vop :internal-error)
2319 (inst fldd (make-random-tn :kind :normal
2320 :sc (sc-or-lose 'double-reg)
2321 :offset (- (tn-offset x) 2)))))
2323 (inst fnstsw) ; status word to ax
2324 (inst and ah-tn #x04) ; C2
2326 ;; Else x was out of range so reduce it; ST0 is unchanged.
2327 (inst fldz) ; Load 0.0
2342 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2343 (:temporary (:sc double-reg :offset fr0-offset
2344 :from :argument :to :result) fr0)
2345 (:temporary (:sc double-reg :offset fr1-offset
2346 :from :argument :to :result) fr1)
2347 (:temporary (:sc double-reg :offset fr2-offset
2348 :from :argument :to :result) fr2)
2349 (:results (y :scs (double-reg)))
2350 (:arg-types double-float)
2351 (:result-types double-float)
2352 (:policy :fast-safe)
2353 (:note "inline exp function")
2355 (:save-p :compute-only)
2357 (note-this-location vop :internal-error)
2360 (cond ((zerop (tn-offset x))
2366 ;; x is in a FP reg, not fr0
2370 ((double-stack descriptor-reg)
2373 (if (sc-is x double-stack)
2374 (inst fmuld (ea-for-df-stack x))
2375 (inst fmuld (ea-for-df-desc x)))))
2376 ;; Now fr0=x log2(e)
2380 (inst fsubp-sti fr1)
2383 (inst faddp-sti fr1)
2388 (t (inst fstd y)))))
2390 ;;; Modified exp that handles the following special cases:
2391 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2394 (:args (x :scs (double-reg) :target fr0))
2395 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2396 (:temporary (:sc double-reg :offset fr0-offset
2397 :from :argument :to :result) fr0)
2398 (:temporary (:sc double-reg :offset fr1-offset
2399 :from :argument :to :result) fr1)
2400 (:temporary (:sc double-reg :offset fr2-offset
2401 :from :argument :to :result) fr2)
2402 (:results (y :scs (double-reg)))
2403 (:arg-types double-float)
2404 (:result-types double-float)
2405 (:policy :fast-safe)
2406 (:note "inline exp function")
2408 (:save-p :compute-only)
2411 (note-this-location vop :internal-error)
2412 (unless (zerop (tn-offset x))
2413 (inst fxch x) ; x to top of stack
2414 (unless (location= x y)
2415 (inst fst x))) ; maybe save it
2416 ;; Check for Inf or NaN
2420 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2421 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2422 (inst and ah-tn #x02) ; Test sign of Inf.
2423 (inst jmp :z DONE) ; +Inf gives +Inf.
2424 (inst fstp fr0) ; -Inf gives 0
2426 (inst jmp-short DONE)
2431 ;; Now fr0=x log2(e)
2435 (inst fsubp-sti fr1)
2438 (inst faddp-sti fr1)
2442 (unless (zerop (tn-offset y))
2445 ;;; Expm1 = exp(x) - 1.
2446 ;;; Handles the following special cases:
2447 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2448 (define-vop (fexpm1)
2450 (:args (x :scs (double-reg) :target fr0))
2451 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2452 (:temporary (:sc double-reg :offset fr0-offset
2453 :from :argument :to :result) fr0)
2454 (:temporary (:sc double-reg :offset fr1-offset
2455 :from :argument :to :result) fr1)
2456 (:temporary (:sc double-reg :offset fr2-offset
2457 :from :argument :to :result) fr2)
2458 (:results (y :scs (double-reg)))
2459 (:arg-types double-float)
2460 (:result-types double-float)
2461 (:policy :fast-safe)
2462 (:note "inline expm1 function")
2464 (:save-p :compute-only)
2467 (note-this-location vop :internal-error)
2468 (unless (zerop (tn-offset x))
2469 (inst fxch x) ; x to top of stack
2470 (unless (location= x y)
2471 (inst fst x))) ; maybe save it
2472 ;; Check for Inf or NaN
2476 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2477 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2478 (inst and ah-tn #x02) ; Test sign of Inf.
2479 (inst jmp :z DONE) ; +Inf gives +Inf.
2480 (inst fstp fr0) ; -Inf gives -1.0
2483 (inst jmp-short DONE)
2485 ;; Free two stack slots leaving the argument on top.
2489 (inst fmul fr1) ; Now fr0 = x log2(e)
2504 (unless (zerop (tn-offset y))
2509 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2510 (:temporary (:sc double-reg :offset fr0-offset
2511 :from :argument :to :result) fr0)
2512 (:temporary (:sc double-reg :offset fr1-offset
2513 :from :argument :to :result) fr1)
2514 (:results (y :scs (double-reg)))
2515 (:arg-types double-float)
2516 (:result-types double-float)
2517 (:policy :fast-safe)
2518 (:note "inline log function")
2520 (:save-p :compute-only)
2522 (note-this-location vop :internal-error)
2537 ;; x is in a FP reg, not fr0 or fr1
2541 (inst fldd (make-random-tn :kind :normal
2542 :sc (sc-or-lose 'double-reg)
2543 :offset (1- (tn-offset x))))))
2545 ((double-stack descriptor-reg)
2549 (if (sc-is x double-stack)
2550 (inst fldd (ea-for-df-stack x))
2551 (inst fldd (ea-for-df-desc x)))
2556 (t (inst fstd y)))))
2558 (define-vop (flog10)
2560 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2561 (:temporary (:sc double-reg :offset fr0-offset
2562 :from :argument :to :result) fr0)
2563 (:temporary (:sc double-reg :offset fr1-offset
2564 :from :argument :to :result) fr1)
2565 (:results (y :scs (double-reg)))
2566 (:arg-types double-float)
2567 (:result-types double-float)
2568 (:policy :fast-safe)
2569 (:note "inline log10 function")
2571 (:save-p :compute-only)
2573 (note-this-location vop :internal-error)
2588 ;; x is in a FP reg, not fr0 or fr1
2592 (inst fldd (make-random-tn :kind :normal
2593 :sc (sc-or-lose 'double-reg)
2594 :offset (1- (tn-offset x))))))
2596 ((double-stack descriptor-reg)
2600 (if (sc-is x double-stack)
2601 (inst fldd (ea-for-df-stack x))
2602 (inst fldd (ea-for-df-desc x)))
2607 (t (inst fstd y)))))
2611 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2612 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2613 (:temporary (:sc double-reg :offset fr0-offset
2614 :from (:argument 0) :to :result) fr0)
2615 (:temporary (:sc double-reg :offset fr1-offset
2616 :from (:argument 1) :to :result) fr1)
2617 (:temporary (:sc double-reg :offset fr2-offset
2618 :from :load :to :result) fr2)
2619 (:results (r :scs (double-reg)))
2620 (:arg-types double-float double-float)
2621 (:result-types double-float)
2622 (:policy :fast-safe)
2623 (:note "inline pow function")
2625 (:save-p :compute-only)
2627 (note-this-location vop :internal-error)
2628 ;; Setup x in fr0 and y in fr1
2630 ;; x in fr0; y in fr1
2631 ((and (sc-is x double-reg) (zerop (tn-offset x))
2632 (sc-is y double-reg) (= 1 (tn-offset y))))
2633 ;; y in fr1; x not in fr0
2634 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2638 (copy-fp-reg-to-fr0 x))
2641 (inst fldd (ea-for-df-stack x)))
2644 (inst fldd (ea-for-df-desc x)))))
2645 ;; x in fr0; y not in fr1
2646 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2648 ;; Now load y to fr0
2651 (copy-fp-reg-to-fr0 y))
2654 (inst fldd (ea-for-df-stack y)))
2657 (inst fldd (ea-for-df-desc y))))
2659 ;; x in fr1; y not in fr1
2660 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2664 (copy-fp-reg-to-fr0 y))
2667 (inst fldd (ea-for-df-stack y)))
2670 (inst fldd (ea-for-df-desc y))))
2673 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2675 ;; Now load x to fr0
2678 (copy-fp-reg-to-fr0 x))
2681 (inst fldd (ea-for-df-stack x)))
2684 (inst fldd (ea-for-df-desc x)))))
2685 ;; Neither x or y are in either fr0 or fr1
2692 (inst fldd (make-random-tn :kind :normal
2693 :sc (sc-or-lose 'double-reg)
2694 :offset (- (tn-offset y) 2))))
2696 (inst fldd (ea-for-df-stack y)))
2698 (inst fldd (ea-for-df-desc y))))
2702 (inst fldd (make-random-tn :kind :normal
2703 :sc (sc-or-lose 'double-reg)
2704 :offset (1- (tn-offset x)))))
2706 (inst fldd (ea-for-df-stack x)))
2708 (inst fldd (ea-for-df-desc x))))))
2710 ;; Now have x at fr0; and y at fr1
2712 ;; Now fr0=y log2(x)
2716 (inst fsubp-sti fr1)
2719 (inst faddp-sti fr1)
2724 (t (inst fstd r)))))
2726 (define-vop (fscalen)
2727 (:translate %scalbn)
2728 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2729 (y :scs (signed-stack signed-reg) :target temp))
2730 (:temporary (:sc double-reg :offset fr0-offset
2731 :from (:argument 0) :to :result) fr0)
2732 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2733 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2734 (:results (r :scs (double-reg)))
2735 (:arg-types double-float signed-num)
2736 (:result-types double-float)
2737 (:policy :fast-safe)
2738 (:note "inline scalbn function")
2740 ;; Setup x in fr0 and y in fr1
2771 (inst fld (make-random-tn :kind :normal
2772 :sc (sc-or-lose 'double-reg)
2773 :offset (1- (tn-offset x)))))))
2774 ((double-stack descriptor-reg)
2783 (if (sc-is x double-stack)
2784 (inst fldd (ea-for-df-stack x))
2785 (inst fldd (ea-for-df-desc x)))))
2787 (unless (zerop (tn-offset r))
2790 (define-vop (fscale)
2792 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2793 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2794 (:temporary (:sc double-reg :offset fr0-offset
2795 :from (:argument 0) :to :result) fr0)
2796 (:temporary (:sc double-reg :offset fr1-offset
2797 :from (:argument 1) :to :result) fr1)
2798 (:results (r :scs (double-reg)))
2799 (:arg-types double-float double-float)
2800 (:result-types double-float)
2801 (:policy :fast-safe)
2802 (:note "inline scalb function")
2804 (:save-p :compute-only)
2806 (note-this-location vop :internal-error)
2807 ;; Setup x in fr0 and y in fr1
2809 ;; x in fr0; y in fr1
2810 ((and (sc-is x double-reg) (zerop (tn-offset x))
2811 (sc-is y double-reg) (= 1 (tn-offset y))))
2812 ;; y in fr1; x not in fr0
2813 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2817 (copy-fp-reg-to-fr0 x))
2820 (inst fldd (ea-for-df-stack x)))
2823 (inst fldd (ea-for-df-desc x)))))
2824 ;; x in fr0; y not in fr1
2825 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2827 ;; Now load y to fr0
2830 (copy-fp-reg-to-fr0 y))
2833 (inst fldd (ea-for-df-stack y)))
2836 (inst fldd (ea-for-df-desc y))))
2838 ;; x in fr1; y not in fr1
2839 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2843 (copy-fp-reg-to-fr0 y))
2846 (inst fldd (ea-for-df-stack y)))
2849 (inst fldd (ea-for-df-desc y))))
2852 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2854 ;; Now load x to fr0
2857 (copy-fp-reg-to-fr0 x))
2860 (inst fldd (ea-for-df-stack x)))
2863 (inst fldd (ea-for-df-desc x)))))
2864 ;; Neither x or y are in either fr0 or fr1
2871 (inst fldd (make-random-tn :kind :normal
2872 :sc (sc-or-lose 'double-reg)
2873 :offset (- (tn-offset y) 2))))
2875 (inst fldd (ea-for-df-stack y)))
2877 (inst fldd (ea-for-df-desc y))))
2881 (inst fldd (make-random-tn :kind :normal
2882 :sc (sc-or-lose 'double-reg)
2883 :offset (1- (tn-offset x)))))
2885 (inst fldd (ea-for-df-stack x)))
2887 (inst fldd (ea-for-df-desc x))))))
2889 ;; Now have x at fr0; and y at fr1
2891 (unless (zerop (tn-offset r))
2894 (define-vop (flog1p)
2896 (:args (x :scs (double-reg) :to :result))
2897 (:temporary (:sc double-reg :offset fr0-offset
2898 :from :argument :to :result) fr0)
2899 (:temporary (:sc double-reg :offset fr1-offset
2900 :from :argument :to :result) fr1)
2901 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2902 (:results (y :scs (double-reg)))
2903 (:arg-types double-float)
2904 (:result-types double-float)
2905 (:policy :fast-safe)
2906 (:note "inline log1p function")
2909 ;; x is in a FP reg, not fr0, fr1.
2912 (inst fldd (make-random-tn :kind :normal
2913 :sc (sc-or-lose 'double-reg)
2914 :offset (- (tn-offset x) 2)))
2916 (inst push #x3e947ae1) ; Constant 0.29
2918 (inst fld (make-ea :dword :base esp-tn))
2921 (inst fnstsw) ; status word to ax
2922 (inst and ah-tn #x45)
2923 (inst jmp :z WITHIN-RANGE)
2924 ;; Out of range for fyl2xp1.
2926 (inst faddd (make-random-tn :kind :normal
2927 :sc (sc-or-lose 'double-reg)
2928 :offset (- (tn-offset x) 1)))
2936 (inst fldd (make-random-tn :kind :normal
2937 :sc (sc-or-lose 'double-reg)
2938 :offset (- (tn-offset x) 1)))
2944 (t (inst fstd y)))))
2946 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2947 ;;; instruction and a range check can be avoided.
2948 (define-vop (flog1p-pentium)
2950 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2951 (:temporary (:sc double-reg :offset fr0-offset
2952 :from :argument :to :result) fr0)
2953 (:temporary (:sc double-reg :offset fr1-offset
2954 :from :argument :to :result) fr1)
2955 (:results (y :scs (double-reg)))
2956 (:arg-types double-float)
2957 (:result-types double-float)
2958 (:policy :fast-safe)
2959 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2960 (:note "inline log1p with limited x range function")
2962 (:save-p :compute-only)
2964 (note-this-location vop :internal-error)
2979 ;; x is in a FP reg, not fr0 or fr1
2983 (inst fldd (make-random-tn :kind :normal
2984 :sc (sc-or-lose 'double-reg)
2985 :offset (1- (tn-offset x)))))))
2986 ((double-stack descriptor-reg)
2990 (if (sc-is x double-stack)
2991 (inst fldd (ea-for-df-stack x))
2992 (inst fldd (ea-for-df-desc x)))))
2997 (t (inst fstd y)))))
3001 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3002 (:temporary (:sc double-reg :offset fr0-offset
3003 :from :argument :to :result) fr0)
3004 (:temporary (:sc double-reg :offset fr1-offset
3005 :from :argument :to :result) fr1)
3006 (:results (y :scs (double-reg)))
3007 (:arg-types double-float)
3008 (:result-types double-float)
3009 (:policy :fast-safe)
3010 (:note "inline logb function")
3012 (:save-p :compute-only)
3014 (note-this-location vop :internal-error)
3025 ;; x is in a FP reg, not fr0 or fr1
3028 (inst fldd (make-random-tn :kind :normal
3029 :sc (sc-or-lose 'double-reg)
3030 :offset (- (tn-offset x) 2))))))
3031 ((double-stack descriptor-reg)
3034 (if (sc-is x double-stack)
3035 (inst fldd (ea-for-df-stack x))
3036 (inst fldd (ea-for-df-desc x)))))
3047 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3048 (:temporary (:sc double-reg :offset fr0-offset
3049 :from (:argument 0) :to :result) fr0)
3050 (:temporary (:sc double-reg :offset fr1-offset
3051 :from (:argument 0) :to :result) fr1)
3052 (:results (r :scs (double-reg)))
3053 (:arg-types double-float)
3054 (:result-types double-float)
3055 (:policy :fast-safe)
3056 (:note "inline atan function")
3058 (:save-p :compute-only)
3060 (note-this-location vop :internal-error)
3061 ;; Setup x in fr1 and 1.0 in fr0
3064 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3067 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3069 ;; x not in fr0 or fr1
3076 (inst fldd (make-random-tn :kind :normal
3077 :sc (sc-or-lose 'double-reg)
3078 :offset (- (tn-offset x) 2))))
3080 (inst fldd (ea-for-df-stack x)))
3082 (inst fldd (ea-for-df-desc x))))))
3084 ;; Now have x at fr1; and 1.0 at fr0
3089 (t (inst fstd r)))))
3091 (define-vop (fatan2)
3093 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3094 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3095 (:temporary (:sc double-reg :offset fr0-offset
3096 :from (:argument 1) :to :result) fr0)
3097 (:temporary (:sc double-reg :offset fr1-offset
3098 :from (:argument 0) :to :result) fr1)
3099 (:results (r :scs (double-reg)))
3100 (:arg-types double-float double-float)
3101 (:result-types double-float)
3102 (:policy :fast-safe)
3103 (:note "inline atan2 function")
3105 (:save-p :compute-only)
3107 (note-this-location vop :internal-error)
3108 ;; Setup x in fr1 and y in fr0
3110 ;; y in fr0; x in fr1
3111 ((and (sc-is y double-reg) (zerop (tn-offset y))
3112 (sc-is x double-reg) (= 1 (tn-offset x))))
3113 ;; x in fr1; y not in fr0
3114 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3118 (copy-fp-reg-to-fr0 y))
3121 (inst fldd (ea-for-df-stack y)))
3124 (inst fldd (ea-for-df-desc y)))))
3125 ;; y in fr0; x not in fr1
3126 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3128 ;; Now load x to fr0
3131 (copy-fp-reg-to-fr0 x))
3134 (inst fldd (ea-for-df-stack x)))
3137 (inst fldd (ea-for-df-desc x))))
3139 ;; y in fr1; x not in fr1
3140 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3144 (copy-fp-reg-to-fr0 x))
3147 (inst fldd (ea-for-df-stack x)))
3150 (inst fldd (ea-for-df-desc x))))
3153 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3155 ;; Now load y to fr0
3158 (copy-fp-reg-to-fr0 y))
3161 (inst fldd (ea-for-df-stack y)))
3164 (inst fldd (ea-for-df-desc y)))))
3165 ;; Neither y or x are in either fr0 or fr1
3172 (inst fldd (make-random-tn :kind :normal
3173 :sc (sc-or-lose 'double-reg)
3174 :offset (- (tn-offset x) 2))))
3176 (inst fldd (ea-for-df-stack x)))
3178 (inst fldd (ea-for-df-desc x))))
3182 (inst fldd (make-random-tn :kind :normal
3183 :sc (sc-or-lose 'double-reg)
3184 :offset (1- (tn-offset y)))))
3186 (inst fldd (ea-for-df-stack y)))
3188 (inst fldd (ea-for-df-desc y))))))
3190 ;; Now have y at fr0; and x at fr1
3195 (t (inst fstd r)))))
3196 ) ; PROGN #!-LONG-FLOAT
3201 ;;; Lets use some of the 80387 special functions.
3203 ;;; These defs will not take effect unless code/irrat.lisp is modified
3204 ;;; to remove the inlined alien routine def.
3206 (macrolet ((frob (func trans op)
3207 `(define-vop (,func)
3208 (:args (x :scs (long-reg) :target fr0))
3209 (:temporary (:sc long-reg :offset fr0-offset
3210 :from :argument :to :result) fr0)
3212 (:results (y :scs (long-reg)))
3213 (:arg-types long-float)
3214 (:result-types long-float)
3216 (:policy :fast-safe)
3217 (:note "inline NPX function")
3219 (:save-p :compute-only)
3222 (note-this-location vop :internal-error)
3223 (unless (zerop (tn-offset x))
3224 (inst fxch x) ; x to top of stack
3225 (unless (location= x y)
3226 (inst fst x))) ; maybe save it
3227 (inst ,op) ; clobber st0
3228 (cond ((zerop (tn-offset y))
3229 (maybe-fp-wait node))
3233 ;; Quick versions of FSIN and FCOS that require the argument to be
3234 ;; within range 2^63.
3235 (frob fsin-quick %sin-quick fsin)
3236 (frob fcos-quick %cos-quick fcos)
3237 (frob fsqrt %sqrt fsqrt))
3239 ;;; Quick version of ftan that requires the argument to be within
3241 (define-vop (ftan-quick)
3242 (:translate %tan-quick)
3243 (:args (x :scs (long-reg) :target fr0))
3244 (:temporary (:sc long-reg :offset fr0-offset
3245 :from :argument :to :result) fr0)
3246 (:temporary (:sc long-reg :offset fr1-offset
3247 :from :argument :to :result) fr1)
3248 (:results (y :scs (long-reg)))
3249 (:arg-types long-float)
3250 (:result-types long-float)
3251 (:policy :fast-safe)
3252 (:note "inline tan function")
3254 (:save-p :compute-only)
3256 (note-this-location vop :internal-error)
3265 (inst fldd (make-random-tn :kind :normal
3266 :sc (sc-or-lose 'double-reg)
3267 :offset (- (tn-offset x) 2)))))
3278 ;;; These versions of fsin, fcos, and ftan try to use argument
3279 ;;; reduction but to do this accurately requires greater precision and
3280 ;;; it is hopelessly inaccurate.
3282 (macrolet ((frob (func trans op)
3283 `(define-vop (,func)
3285 (:args (x :scs (long-reg) :target fr0))
3286 (:temporary (:sc unsigned-reg :offset eax-offset
3287 :from :eval :to :result) eax)
3288 (:temporary (:sc long-reg :offset fr0-offset
3289 :from :argument :to :result) fr0)
3290 (:temporary (:sc long-reg :offset fr1-offset
3291 :from :argument :to :result) fr1)
3292 (:results (y :scs (long-reg)))
3293 (:arg-types long-float)
3294 (:result-types long-float)
3295 (:policy :fast-safe)
3296 (:note "inline sin/cos function")
3298 (:save-p :compute-only)
3301 (note-this-location vop :internal-error)
3302 (unless (zerop (tn-offset x))
3303 (inst fxch x) ; x to top of stack
3304 (unless (location= x y)
3305 (inst fst x))) ; maybe save it
3307 (inst fnstsw) ; status word to ax
3308 (inst and ah-tn #x04) ; C2
3310 ;; Else x was out of range so reduce it; ST0 is unchanged.
3311 (inst fstp fr1) ; Load 2*PI
3317 (inst fnstsw) ; status word to ax
3318 (inst and ah-tn #x04) ; C2
3322 (unless (zerop (tn-offset y))
3324 (frob fsin %sin fsin)
3325 (frob fcos %cos fcos))
3330 (:args (x :scs (long-reg) :target fr0))
3331 (:temporary (:sc unsigned-reg :offset eax-offset
3332 :from :argument :to :result) eax)
3333 (:temporary (:sc long-reg :offset fr0-offset
3334 :from :argument :to :result) fr0)
3335 (:temporary (:sc long-reg :offset fr1-offset
3336 :from :argument :to :result) fr1)
3337 (:results (y :scs (long-reg)))
3338 (:arg-types long-float)
3339 (:result-types long-float)
3340 (:policy :fast-safe)
3341 (:note "inline tan function")
3343 (:save-p :compute-only)
3346 (note-this-location vop :internal-error)
3355 (inst fldd (make-random-tn :kind :normal
3356 :sc (sc-or-lose 'double-reg)
3357 :offset (- (tn-offset x) 2)))))
3359 (inst fnstsw) ; status word to ax
3360 (inst and ah-tn #x04) ; C2
3362 ;; Else x was out of range so reduce it; ST0 is unchanged.
3363 (inst fldpi) ; Load 2*PI
3368 (inst fnstsw) ; status word to ax
3369 (inst and ah-tn #x04) ; C2
3383 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3384 ;;; the argument is out of range 2^63 and would thus be hopelessly
3386 (macrolet ((frob (func trans op)
3387 `(define-vop (,func)
3389 (:args (x :scs (long-reg) :target fr0))
3390 (:temporary (:sc long-reg :offset fr0-offset
3391 :from :argument :to :result) fr0)
3392 (:temporary (:sc unsigned-reg :offset eax-offset
3393 :from :argument :to :result) eax)
3394 (:results (y :scs (long-reg)))
3395 (:arg-types long-float)
3396 (:result-types long-float)
3397 (:policy :fast-safe)
3398 (:note "inline sin/cos function")
3400 (:save-p :compute-only)
3403 (note-this-location vop :internal-error)
3404 (unless (zerop (tn-offset x))
3405 (inst fxch x) ; x to top of stack
3406 (unless (location= x y)
3407 (inst fst x))) ; maybe save it
3409 (inst fnstsw) ; status word to ax
3410 (inst and ah-tn #x04) ; C2
3412 ;; Else x was out of range so reduce it; ST0 is unchanged.
3413 (inst fstp fr0) ; Load 0.0
3416 (unless (zerop (tn-offset y))
3418 (frob fsin %sin fsin)
3419 (frob fcos %cos fcos))
3423 (:args (x :scs (long-reg) :target fr0))
3424 (:temporary (:sc long-reg :offset fr0-offset
3425 :from :argument :to :result) fr0)
3426 (:temporary (:sc long-reg :offset fr1-offset
3427 :from :argument :to :result) fr1)
3428 (:temporary (:sc unsigned-reg :offset eax-offset
3429 :from :argument :to :result) eax)
3430 (:results (y :scs (long-reg)))
3431 (:arg-types long-float)
3432 (:result-types long-float)
3434 (:policy :fast-safe)
3435 (:note "inline tan function")
3437 (:save-p :compute-only)
3440 (note-this-location vop :internal-error)
3449 (inst fldd (make-random-tn :kind :normal
3450 :sc (sc-or-lose 'double-reg)
3451 :offset (- (tn-offset x) 2)))))
3453 (inst fnstsw) ; status word to ax
3454 (inst and ah-tn #x04) ; C2
3456 ;; Else x was out of range so reduce it; ST0 is unchanged.
3457 (inst fldz) ; Load 0.0
3469 ;;; Modified exp that handles the following special cases:
3470 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3473 (:args (x :scs (long-reg) :target fr0))
3474 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3475 (:temporary (:sc long-reg :offset fr0-offset
3476 :from :argument :to :result) fr0)
3477 (:temporary (:sc long-reg :offset fr1-offset
3478 :from :argument :to :result) fr1)
3479 (:temporary (:sc long-reg :offset fr2-offset
3480 :from :argument :to :result) fr2)
3481 (:results (y :scs (long-reg)))
3482 (:arg-types long-float)
3483 (:result-types long-float)
3484 (:policy :fast-safe)
3485 (:note "inline exp function")
3487 (:save-p :compute-only)
3490 (note-this-location vop :internal-error)
3491 (unless (zerop (tn-offset x))
3492 (inst fxch x) ; x to top of stack
3493 (unless (location= x y)
3494 (inst fst x))) ; maybe save it
3495 ;; Check for Inf or NaN
3499 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3500 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3501 (inst and ah-tn #x02) ; Test sign of Inf.
3502 (inst jmp :z DONE) ; +Inf gives +Inf.
3503 (inst fstp fr0) ; -Inf gives 0
3505 (inst jmp-short DONE)
3510 ;; Now fr0=x log2(e)
3514 (inst fsubp-sti fr1)
3517 (inst faddp-sti fr1)
3521 (unless (zerop (tn-offset y))
3524 ;;; Expm1 = exp(x) - 1.
3525 ;;; Handles the following special cases:
3526 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3527 (define-vop (fexpm1)
3529 (:args (x :scs (long-reg) :target fr0))
3530 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3531 (:temporary (:sc long-reg :offset fr0-offset
3532 :from :argument :to :result) fr0)
3533 (:temporary (:sc long-reg :offset fr1-offset
3534 :from :argument :to :result) fr1)
3535 (:temporary (:sc long-reg :offset fr2-offset
3536 :from :argument :to :result) fr2)
3537 (:results (y :scs (long-reg)))
3538 (:arg-types long-float)
3539 (:result-types long-float)
3540 (:policy :fast-safe)
3541 (:note "inline expm1 function")
3543 (:save-p :compute-only)
3546 (note-this-location vop :internal-error)
3547 (unless (zerop (tn-offset x))
3548 (inst fxch x) ; x to top of stack
3549 (unless (location= x y)
3550 (inst fst x))) ; maybe save it
3551 ;; Check for Inf or NaN
3555 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3556 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3557 (inst and ah-tn #x02) ; Test sign of Inf.
3558 (inst jmp :z DONE) ; +Inf gives +Inf.
3559 (inst fstp fr0) ; -Inf gives -1.0
3562 (inst jmp-short DONE)
3564 ;; Free two stack slots leaving the argument on top.
3568 (inst fmul fr1) ; Now fr0 = x log2(e)
3583 (unless (zerop (tn-offset y))
3588 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3589 (:temporary (:sc long-reg :offset fr0-offset
3590 :from :argument :to :result) fr0)
3591 (:temporary (:sc long-reg :offset fr1-offset
3592 :from :argument :to :result) fr1)
3593 (:results (y :scs (long-reg)))
3594 (:arg-types long-float)
3595 (:result-types long-float)
3596 (:policy :fast-safe)
3597 (:note "inline log function")
3599 (:save-p :compute-only)
3601 (note-this-location vop :internal-error)
3616 ;; x is in a FP reg, not fr0 or fr1
3620 (inst fldd (make-random-tn :kind :normal
3621 :sc (sc-or-lose 'double-reg)
3622 :offset (1- (tn-offset x))))))
3624 ((long-stack descriptor-reg)
3628 (if (sc-is x long-stack)
3629 (inst fldl (ea-for-lf-stack x))
3630 (inst fldl (ea-for-lf-desc x)))
3635 (t (inst fstd y)))))
3637 (define-vop (flog10)
3639 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3640 (:temporary (:sc long-reg :offset fr0-offset
3641 :from :argument :to :result) fr0)
3642 (:temporary (:sc long-reg :offset fr1-offset
3643 :from :argument :to :result) fr1)
3644 (:results (y :scs (long-reg)))
3645 (:arg-types long-float)
3646 (:result-types long-float)
3647 (:policy :fast-safe)
3648 (:note "inline log10 function")
3650 (:save-p :compute-only)
3652 (note-this-location vop :internal-error)
3667 ;; x is in a FP reg, not fr0 or fr1
3671 (inst fldd (make-random-tn :kind :normal
3672 :sc (sc-or-lose 'double-reg)
3673 :offset (1- (tn-offset x))))))
3675 ((long-stack descriptor-reg)
3679 (if (sc-is x long-stack)
3680 (inst fldl (ea-for-lf-stack x))
3681 (inst fldl (ea-for-lf-desc x)))
3686 (t (inst fstd y)))))
3690 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3691 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3692 (:temporary (:sc long-reg :offset fr0-offset
3693 :from (:argument 0) :to :result) fr0)
3694 (:temporary (:sc long-reg :offset fr1-offset
3695 :from (:argument 1) :to :result) fr1)
3696 (:temporary (:sc long-reg :offset fr2-offset
3697 :from :load :to :result) fr2)
3698 (:results (r :scs (long-reg)))
3699 (:arg-types long-float long-float)
3700 (:result-types long-float)
3701 (:policy :fast-safe)
3702 (:note "inline pow function")
3704 (:save-p :compute-only)
3706 (note-this-location vop :internal-error)
3707 ;; Setup x in fr0 and y in fr1
3709 ;; x in fr0; y in fr1
3710 ((and (sc-is x long-reg) (zerop (tn-offset x))
3711 (sc-is y long-reg) (= 1 (tn-offset y))))
3712 ;; y in fr1; x not in fr0
3713 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3717 (copy-fp-reg-to-fr0 x))
3720 (inst fldl (ea-for-lf-stack x)))
3723 (inst fldl (ea-for-lf-desc x)))))
3724 ;; x in fr0; y not in fr1
3725 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3727 ;; Now load y to fr0
3730 (copy-fp-reg-to-fr0 y))
3733 (inst fldl (ea-for-lf-stack y)))
3736 (inst fldl (ea-for-lf-desc y))))
3738 ;; x in fr1; y not in fr1
3739 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3743 (copy-fp-reg-to-fr0 y))
3746 (inst fldl (ea-for-lf-stack y)))
3749 (inst fldl (ea-for-lf-desc y))))
3752 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3754 ;; Now load x to fr0
3757 (copy-fp-reg-to-fr0 x))
3760 (inst fldl (ea-for-lf-stack x)))
3763 (inst fldl (ea-for-lf-desc x)))))
3764 ;; Neither x or y are in either fr0 or fr1
3771 (inst fldd (make-random-tn :kind :normal
3772 :sc (sc-or-lose 'double-reg)
3773 :offset (- (tn-offset y) 2))))
3775 (inst fldl (ea-for-lf-stack y)))
3777 (inst fldl (ea-for-lf-desc y))))
3781 (inst fldd (make-random-tn :kind :normal
3782 :sc (sc-or-lose 'double-reg)
3783 :offset (1- (tn-offset x)))))
3785 (inst fldl (ea-for-lf-stack x)))
3787 (inst fldl (ea-for-lf-desc x))))))
3789 ;; Now have x at fr0; and y at fr1
3791 ;; Now fr0=y log2(x)
3795 (inst fsubp-sti fr1)
3798 (inst faddp-sti fr1)
3803 (t (inst fstd r)))))
3805 (define-vop (fscalen)
3806 (:translate %scalbn)
3807 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3808 (y :scs (signed-stack signed-reg) :target temp))
3809 (:temporary (:sc long-reg :offset fr0-offset
3810 :from (:argument 0) :to :result) fr0)
3811 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3812 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3813 (:results (r :scs (long-reg)))
3814 (:arg-types long-float signed-num)
3815 (:result-types long-float)
3816 (:policy :fast-safe)
3817 (:note "inline scalbn function")
3819 ;; Setup x in fr0 and y in fr1
3850 (inst fld (make-random-tn :kind :normal
3851 :sc (sc-or-lose 'double-reg)
3852 :offset (1- (tn-offset x)))))))
3853 ((long-stack descriptor-reg)
3862 (if (sc-is x long-stack)
3863 (inst fldl (ea-for-lf-stack x))
3864 (inst fldl (ea-for-lf-desc x)))))
3866 (unless (zerop (tn-offset r))
3869 (define-vop (fscale)
3871 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3872 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3873 (:temporary (:sc long-reg :offset fr0-offset
3874 :from (:argument 0) :to :result) fr0)
3875 (:temporary (:sc long-reg :offset fr1-offset
3876 :from (:argument 1) :to :result) fr1)
3877 (:results (r :scs (long-reg)))
3878 (:arg-types long-float long-float)
3879 (:result-types long-float)
3880 (:policy :fast-safe)
3881 (:note "inline scalb function")
3883 (:save-p :compute-only)
3885 (note-this-location vop :internal-error)
3886 ;; Setup x in fr0 and y in fr1
3888 ;; x in fr0; y in fr1
3889 ((and (sc-is x long-reg) (zerop (tn-offset x))
3890 (sc-is y long-reg) (= 1 (tn-offset y))))
3891 ;; y in fr1; x not in fr0
3892 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3896 (copy-fp-reg-to-fr0 x))
3899 (inst fldl (ea-for-lf-stack x)))
3902 (inst fldl (ea-for-lf-desc x)))))
3903 ;; x in fr0; y not in fr1
3904 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3906 ;; Now load y to fr0
3909 (copy-fp-reg-to-fr0 y))
3912 (inst fldl (ea-for-lf-stack y)))
3915 (inst fldl (ea-for-lf-desc y))))
3917 ;; x in fr1; y not in fr1
3918 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3922 (copy-fp-reg-to-fr0 y))
3925 (inst fldl (ea-for-lf-stack y)))
3928 (inst fldl (ea-for-lf-desc y))))
3931 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3933 ;; Now load x to fr0
3936 (copy-fp-reg-to-fr0 x))
3939 (inst fldl (ea-for-lf-stack x)))
3942 (inst fldl (ea-for-lf-desc x)))))
3943 ;; Neither x or y are in either fr0 or fr1
3950 (inst fldd (make-random-tn :kind :normal
3951 :sc (sc-or-lose 'double-reg)
3952 :offset (- (tn-offset y) 2))))
3954 (inst fldl (ea-for-lf-stack y)))
3956 (inst fldl (ea-for-lf-desc y))))
3960 (inst fldd (make-random-tn :kind :normal
3961 :sc (sc-or-lose 'double-reg)
3962 :offset (1- (tn-offset x)))))
3964 (inst fldl (ea-for-lf-stack x)))
3966 (inst fldl (ea-for-lf-desc x))))))
3968 ;; Now have x at fr0; and y at fr1
3970 (unless (zerop (tn-offset r))
3973 (define-vop (flog1p)
3975 (:args (x :scs (long-reg) :to :result))
3976 (:temporary (:sc long-reg :offset fr0-offset
3977 :from :argument :to :result) fr0)
3978 (:temporary (:sc long-reg :offset fr1-offset
3979 :from :argument :to :result) fr1)
3980 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3981 (:results (y :scs (long-reg)))
3982 (:arg-types long-float)
3983 (:result-types long-float)
3984 (:policy :fast-safe)
3985 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3986 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3987 ;; an enormous PROGN above. Still, it would be probably be good to
3988 ;; add some code to warn about redefining VOPs.
3989 (:note "inline log1p function")
3992 ;; x is in a FP reg, not fr0, fr1.
3995 (inst fldd (make-random-tn :kind :normal
3996 :sc (sc-or-lose 'double-reg)
3997 :offset (- (tn-offset x) 2)))
3999 (inst push #x3e947ae1) ; Constant 0.29
4001 (inst fld (make-ea :dword :base esp-tn))
4004 (inst fnstsw) ; status word to ax
4005 (inst and ah-tn #x45)
4006 (inst jmp :z WITHIN-RANGE)
4007 ;; Out of range for fyl2xp1.
4009 (inst faddd (make-random-tn :kind :normal
4010 :sc (sc-or-lose 'double-reg)
4011 :offset (- (tn-offset x) 1)))
4019 (inst fldd (make-random-tn :kind :normal
4020 :sc (sc-or-lose 'double-reg)
4021 :offset (- (tn-offset x) 1)))
4027 (t (inst fstd y)))))
4029 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4030 ;;; instruction and a range check can be avoided.
4031 (define-vop (flog1p-pentium)
4033 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4034 (:temporary (:sc long-reg :offset fr0-offset
4035 :from :argument :to :result) fr0)
4036 (:temporary (:sc long-reg :offset fr1-offset
4037 :from :argument :to :result) fr1)
4038 (:results (y :scs (long-reg)))
4039 (:arg-types long-float)
4040 (:result-types long-float)
4041 (:policy :fast-safe)
4042 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
4043 (:note "inline log1p function")
4059 ;; x is in a FP reg, not fr0 or fr1
4063 (inst fldd (make-random-tn :kind :normal
4064 :sc (sc-or-lose 'double-reg)
4065 :offset (1- (tn-offset x)))))))
4066 ((long-stack descriptor-reg)
4070 (if (sc-is x long-stack)
4071 (inst fldl (ea-for-lf-stack x))
4072 (inst fldl (ea-for-lf-desc x)))))
4077 (t (inst fstd y)))))
4081 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4082 (:temporary (:sc long-reg :offset fr0-offset
4083 :from :argument :to :result) fr0)
4084 (:temporary (:sc long-reg :offset fr1-offset
4085 :from :argument :to :result) fr1)
4086 (:results (y :scs (long-reg)))
4087 (:arg-types long-float)
4088 (:result-types long-float)
4089 (:policy :fast-safe)
4090 (:note "inline logb function")
4092 (:save-p :compute-only)
4094 (note-this-location vop :internal-error)
4105 ;; x is in a FP reg, not fr0 or fr1
4108 (inst fldd (make-random-tn :kind :normal
4109 :sc (sc-or-lose 'double-reg)
4110 :offset (- (tn-offset x) 2))))))
4111 ((long-stack descriptor-reg)
4114 (if (sc-is x long-stack)
4115 (inst fldl (ea-for-lf-stack x))
4116 (inst fldl (ea-for-lf-desc x)))))
4127 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4128 (:temporary (:sc long-reg :offset fr0-offset
4129 :from (:argument 0) :to :result) fr0)
4130 (:temporary (:sc long-reg :offset fr1-offset
4131 :from (:argument 0) :to :result) fr1)
4132 (:results (r :scs (long-reg)))
4133 (:arg-types long-float)
4134 (:result-types long-float)
4135 (:policy :fast-safe)
4136 (:note "inline atan function")
4138 (:save-p :compute-only)
4140 (note-this-location vop :internal-error)
4141 ;; Setup x in fr1 and 1.0 in fr0
4144 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4147 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4149 ;; x not in fr0 or fr1
4156 (inst fldd (make-random-tn :kind :normal
4157 :sc (sc-or-lose 'double-reg)
4158 :offset (- (tn-offset x) 2))))
4160 (inst fldl (ea-for-lf-stack x)))
4162 (inst fldl (ea-for-lf-desc x))))))
4164 ;; Now have x at fr1; and 1.0 at fr0
4169 (t (inst fstd r)))))
4171 (define-vop (fatan2)
4173 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4174 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4175 (:temporary (:sc long-reg :offset fr0-offset
4176 :from (:argument 1) :to :result) fr0)
4177 (:temporary (:sc long-reg :offset fr1-offset
4178 :from (:argument 0) :to :result) fr1)
4179 (:results (r :scs (long-reg)))
4180 (:arg-types long-float long-float)
4181 (:result-types long-float)
4182 (:policy :fast-safe)
4183 (:note "inline atan2 function")
4185 (:save-p :compute-only)
4187 (note-this-location vop :internal-error)
4188 ;; Setup x in fr1 and y in fr0
4190 ;; y in fr0; x in fr1
4191 ((and (sc-is y long-reg) (zerop (tn-offset y))
4192 (sc-is x long-reg) (= 1 (tn-offset x))))
4193 ;; x in fr1; y not in fr0
4194 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4198 (copy-fp-reg-to-fr0 y))
4201 (inst fldl (ea-for-lf-stack y)))
4204 (inst fldl (ea-for-lf-desc y)))))
4205 ;; y in fr0; x not in fr1
4206 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4208 ;; Now load x to fr0
4211 (copy-fp-reg-to-fr0 x))
4214 (inst fldl (ea-for-lf-stack x)))
4217 (inst fldl (ea-for-lf-desc x))))
4219 ;; y in fr1; x not in fr1
4220 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4224 (copy-fp-reg-to-fr0 x))
4227 (inst fldl (ea-for-lf-stack x)))
4230 (inst fldl (ea-for-lf-desc x))))
4233 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4235 ;; Now load y to fr0
4238 (copy-fp-reg-to-fr0 y))
4241 (inst fldl (ea-for-lf-stack y)))
4244 (inst fldl (ea-for-lf-desc y)))))
4245 ;; Neither y or x are in either fr0 or fr1
4252 (inst fldd (make-random-tn :kind :normal
4253 :sc (sc-or-lose 'double-reg)
4254 :offset (- (tn-offset x) 2))))
4256 (inst fldl (ea-for-lf-stack x)))
4258 (inst fldl (ea-for-lf-desc x))))
4262 (inst fldd (make-random-tn :kind :normal
4263 :sc (sc-or-lose 'double-reg)
4264 :offset (1- (tn-offset y)))))
4266 (inst fldl (ea-for-lf-stack y)))
4268 (inst fldl (ea-for-lf-desc y))))))
4270 ;; Now have y at fr0; and x at fr1
4275 (t (inst fstd r)))))
4277 ) ; PROGN #!+LONG-FLOAT
4279 ;;;; complex float VOPs
4281 (define-vop (make-complex-single-float)
4282 (:translate complex)
4283 (:args (real :scs (single-reg) :to :result :target r
4284 :load-if (not (location= real r)))
4285 (imag :scs (single-reg) :to :save))
4286 (:arg-types single-float single-float)
4287 (:results (r :scs (complex-single-reg) :from (:argument 0)
4288 :load-if (not (sc-is r complex-single-stack))))
4289 (:result-types complex-single-float)
4290 (:note "inline complex single-float creation")
4291 (:policy :fast-safe)
4295 (let ((r-real (complex-double-reg-real-tn r)))
4296 (unless (location= real r-real)
4297 (cond ((zerop (tn-offset r-real))
4298 (copy-fp-reg-to-fr0 real))
4299 ((zerop (tn-offset real))
4304 (inst fxch real)))))
4305 (let ((r-imag (complex-double-reg-imag-tn r)))
4306 (unless (location= imag r-imag)
4307 (cond ((zerop (tn-offset imag))
4312 (inst fxch imag))))))
4313 (complex-single-stack
4314 (unless (location= real r)
4315 (cond ((zerop (tn-offset real))
4316 (inst fst (ea-for-csf-real-stack r)))
4319 (inst fst (ea-for-csf-real-stack r))
4322 (inst fst (ea-for-csf-imag-stack r))
4323 (inst fxch imag)))))
4325 (define-vop (make-complex-double-float)
4326 (:translate complex)
4327 (:args (real :scs (double-reg) :target r
4328 :load-if (not (location= real r)))
4329 (imag :scs (double-reg) :to :save))
4330 (:arg-types double-float double-float)
4331 (:results (r :scs (complex-double-reg) :from (:argument 0)
4332 :load-if (not (sc-is r complex-double-stack))))
4333 (:result-types complex-double-float)
4334 (:note "inline complex double-float creation")
4335 (:policy :fast-safe)
4339 (let ((r-real (complex-double-reg-real-tn r)))
4340 (unless (location= real r-real)
4341 (cond ((zerop (tn-offset r-real))
4342 (copy-fp-reg-to-fr0 real))
4343 ((zerop (tn-offset real))
4348 (inst fxch real)))))
4349 (let ((r-imag (complex-double-reg-imag-tn r)))
4350 (unless (location= imag r-imag)
4351 (cond ((zerop (tn-offset imag))
4356 (inst fxch imag))))))
4357 (complex-double-stack
4358 (unless (location= real r)
4359 (cond ((zerop (tn-offset real))
4360 (inst fstd (ea-for-cdf-real-stack r)))
4363 (inst fstd (ea-for-cdf-real-stack r))
4366 (inst fstd (ea-for-cdf-imag-stack r))
4367 (inst fxch imag)))))
4370 (define-vop (make-complex-long-float)
4371 (:translate complex)
4372 (:args (real :scs (long-reg) :target r
4373 :load-if (not (location= real r)))
4374 (imag :scs (long-reg) :to :save))
4375 (:arg-types long-float long-float)
4376 (:results (r :scs (complex-long-reg) :from (:argument 0)
4377 :load-if (not (sc-is r complex-long-stack))))
4378 (:result-types complex-long-float)
4379 (:note "inline complex long-float creation")
4380 (:policy :fast-safe)
4384 (let ((r-real (complex-double-reg-real-tn r)))
4385 (unless (location= real r-real)
4386 (cond ((zerop (tn-offset r-real))
4387 (copy-fp-reg-to-fr0 real))
4388 ((zerop (tn-offset real))
4393 (inst fxch real)))))
4394 (let ((r-imag (complex-double-reg-imag-tn r)))
4395 (unless (location= imag r-imag)
4396 (cond ((zerop (tn-offset imag))
4401 (inst fxch imag))))))
4403 (unless (location= real r)
4404 (cond ((zerop (tn-offset real))
4405 (store-long-float (ea-for-clf-real-stack r)))
4408 (store-long-float (ea-for-clf-real-stack r))
4411 (store-long-float (ea-for-clf-imag-stack r))
4412 (inst fxch imag)))))
4415 (define-vop (complex-float-value)
4416 (:args (x :target r))
4418 (:variant-vars offset)
4419 (:policy :fast-safe)
4421 (cond ((sc-is x complex-single-reg complex-double-reg
4422 #!+long-float complex-long-reg)
4424 (make-random-tn :kind :normal
4425 :sc (sc-or-lose 'double-reg)
4426 :offset (+ offset (tn-offset x)))))
4427 (unless (location= value-tn r)
4428 (cond ((zerop (tn-offset r))
4429 (copy-fp-reg-to-fr0 value-tn))
4430 ((zerop (tn-offset value-tn))
4433 (inst fxch value-tn)
4435 (inst fxch value-tn))))))
4436 ((sc-is r single-reg)
4437 (let ((ea (sc-case x
4438 (complex-single-stack
4440 (0 (ea-for-csf-real-stack x))
4441 (1 (ea-for-csf-imag-stack x))))
4444 (0 (ea-for-csf-real-desc x))
4445 (1 (ea-for-csf-imag-desc x)))))))
4446 (with-empty-tn@fp-top(r)
4448 ((sc-is r double-reg)
4449 (let ((ea (sc-case x
4450 (complex-double-stack
4452 (0 (ea-for-cdf-real-stack x))
4453 (1 (ea-for-cdf-imag-stack x))))
4456 (0 (ea-for-cdf-real-desc x))
4457 (1 (ea-for-cdf-imag-desc x)))))))
4458 (with-empty-tn@fp-top(r)
4462 (let ((ea (sc-case x
4465 (0 (ea-for-clf-real-stack x))
4466 (1 (ea-for-clf-imag-stack x))))
4469 (0 (ea-for-clf-real-desc x))
4470 (1 (ea-for-clf-imag-desc x)))))))
4471 (with-empty-tn@fp-top(r)
4473 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4475 (define-vop (realpart/complex-single-float complex-float-value)
4476 (:translate realpart)
4477 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4479 (:arg-types complex-single-float)
4480 (:results (r :scs (single-reg)))
4481 (:result-types single-float)
4482 (:note "complex float realpart")
4485 (define-vop (realpart/complex-double-float complex-float-value)
4486 (:translate realpart)
4487 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4489 (:arg-types complex-double-float)
4490 (:results (r :scs (double-reg)))
4491 (:result-types double-float)
4492 (:note "complex float realpart")
4496 (define-vop (realpart/complex-long-float complex-float-value)
4497 (:translate realpart)
4498 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4500 (:arg-types complex-long-float)
4501 (:results (r :scs (long-reg)))
4502 (:result-types long-float)
4503 (:note "complex float realpart")
4506 (define-vop (imagpart/complex-single-float complex-float-value)
4507 (:translate imagpart)
4508 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4510 (:arg-types complex-single-float)
4511 (:results (r :scs (single-reg)))
4512 (:result-types single-float)
4513 (:note "complex float imagpart")
4516 (define-vop (imagpart/complex-double-float complex-float-value)
4517 (:translate imagpart)
4518 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4520 (:arg-types complex-double-float)
4521 (:results (r :scs (double-reg)))
4522 (:result-types double-float)
4523 (:note "complex float imagpart")
4527 (define-vop (imagpart/complex-long-float complex-float-value)
4528 (:translate imagpart)
4529 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4531 (:arg-types complex-long-float)
4532 (:results (r :scs (long-reg)))
4533 (:result-types long-float)
4534 (:note "complex float imagpart")
4537 ;;; hack dummy VOPs to bias the representation selection of their
4538 ;;; arguments towards a FP register, which can help avoid consing at
4539 ;;; inappropriate locations
4540 (defknown double-float-reg-bias (double-float) (values))
4541 (define-vop (double-float-reg-bias)
4542 (:translate double-float-reg-bias)
4543 (:args (x :scs (double-reg double-stack) :load-if nil))
4544 (:arg-types double-float)
4545 (:policy :fast-safe)
4546 (:note "inline dummy FP register bias")
4549 (defknown single-float-reg-bias (single-float) (values))
4550 (define-vop (single-float-reg-bias)
4551 (:translate single-float-reg-bias)
4552 (:args (x :scs (single-reg single-stack) :load-if nil))
4553 (:arg-types single-float)
4554 (:policy :fast-safe)
4555 (:note "inline dummy FP register bias")