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 sb!vm:word-bytes)
18 sb!vm:other-pointer-lowtag))))
19 (defun ea-for-sf-desc (tn)
20 (ea-for-xf-desc tn sb!vm:single-float-value-slot))
21 (defun ea-for-df-desc (tn)
22 (ea-for-xf-desc tn sb!vm:double-float-value-slot))
24 (defun ea-for-lf-desc (tn)
25 (ea-for-xf-desc tn sb!vm:long-float-value-slot))
27 (defun ea-for-csf-real-desc (tn)
28 (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot))
29 (defun ea-for-csf-imag-desc (tn)
30 (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot))
31 (defun ea-for-cdf-real-desc (tn)
32 (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot))
33 (defun ea-for-cdf-imag-desc (tn)
34 (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot))
36 (defun ea-for-clf-real-desc (tn)
37 (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot))
39 (defun ea-for-clf-imag-desc (tn)
40 (ea-for-xf-desc tn sb!vm: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-function (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-function (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-function (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-function (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-function (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-function (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-function (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-function (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-function (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-function (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-function (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-function (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-function (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
391 sb!vm:single-float-type
392 sb!vm: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
405 sb!vm:double-float-type
406 sb!vm:double-float-size
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
421 sb!vm:long-float-type
422 sb!vm:long-float-size
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-0s0*))
436 (1f0 (load-symbol-value y *fp-constant-1s0*))
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 sb!vm:complex-single-float-type
498 sb!vm:complex-single-float-size node)
499 (let ((real-tn (complex-single-reg-real-tn x)))
500 (with-tn@fp-top(real-tn)
501 (inst fst (ea-for-csf-real-desc y))))
502 (let ((imag-tn (complex-single-reg-imag-tn x)))
503 (with-tn@fp-top(imag-tn)
504 (inst fst (ea-for-csf-imag-desc y)))))))
505 (define-move-vop move-from-complex-single :move
506 (complex-single-reg) (descriptor-reg))
508 (define-vop (move-from-complex-double)
509 (:args (x :scs (complex-double-reg) :to :save))
510 (:results (y :scs (descriptor-reg)))
512 (:note "complex float to pointer coercion")
514 (with-fixed-allocation (y
515 sb!vm:complex-double-float-type
516 sb!vm:complex-double-float-size
518 (let ((real-tn (complex-double-reg-real-tn x)))
519 (with-tn@fp-top(real-tn)
520 (inst fstd (ea-for-cdf-real-desc y))))
521 (let ((imag-tn (complex-double-reg-imag-tn x)))
522 (with-tn@fp-top(imag-tn)
523 (inst fstd (ea-for-cdf-imag-desc y)))))))
524 (define-move-vop move-from-complex-double :move
525 (complex-double-reg) (descriptor-reg))
528 (define-vop (move-from-complex-long)
529 (:args (x :scs (complex-long-reg) :to :save))
530 (:results (y :scs (descriptor-reg)))
532 (:note "complex float to pointer coercion")
534 (with-fixed-allocation (y
535 sb!vm:complex-long-float-type
536 sb!vm:complex-long-float-size
538 (let ((real-tn (complex-long-reg-real-tn x)))
539 (with-tn@fp-top(real-tn)
540 (store-long-float (ea-for-clf-real-desc y))))
541 (let ((imag-tn (complex-long-reg-imag-tn x)))
542 (with-tn@fp-top(imag-tn)
543 (store-long-float (ea-for-clf-imag-desc y)))))))
545 (define-move-vop move-from-complex-long :move
546 (complex-long-reg) (descriptor-reg))
548 ;;; Move from a descriptor to a complex float register.
549 (macrolet ((frob (name sc format)
552 (:args (x :scs (descriptor-reg)))
553 (:results (y :scs (,sc)))
554 (:note "pointer to complex float coercion")
556 (let ((real-tn (complex-double-reg-real-tn y)))
557 (with-empty-tn@fp-top(real-tn)
559 (:single '((inst fld (ea-for-csf-real-desc x))))
560 (:double '((inst fldd (ea-for-cdf-real-desc x))))
562 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
563 (let ((imag-tn (complex-double-reg-imag-tn y)))
564 (with-empty-tn@fp-top(imag-tn)
566 (:single '((inst fld (ea-for-csf-imag-desc x))))
567 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
569 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
570 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
571 (frob move-to-complex-single complex-single-reg :single)
572 (frob move-to-complex-double complex-double-reg :double)
574 (frob move-to-complex-double complex-long-reg :long))
576 ;;;; the move argument vops
578 ;;;; Note these are also used to stuff fp numbers onto the c-call
579 ;;;; stack so the order is different than the lisp-stack.
581 ;;; the general move-argument vop
582 (macrolet ((frob (name sc stack-sc format)
585 (:args (x :scs (,sc) :target y)
587 :load-if (not (sc-is y ,sc))))
589 (:note "float argument move")
590 (:generator ,(case format (:single 2) (:double 3) (:long 4))
593 (unless (location= x y)
594 (cond ((zerop (tn-offset y))
595 (copy-fp-reg-to-fr0 x))
596 ((zerop (tn-offset x))
603 (if (= (tn-offset fp) esp-offset)
604 (let* ((offset (* (tn-offset y) word-bytes))
605 (ea (make-ea :dword :base fp :disp offset)))
608 (:single '((inst fst ea)))
609 (:double '((inst fstd ea)))
611 (:long '((store-long-float ea))))))
614 :disp (- (* (+ (tn-offset y)
619 sb!vm:word-bytes)))))
622 (:single '((inst fst ea)))
623 (:double '((inst fstd ea)))
625 (:long '((store-long-float ea)))))))))))
626 (define-move-vop ,name :move-argument
627 (,sc descriptor-reg) (,sc)))))
628 (frob move-single-float-argument single-reg single-stack :single)
629 (frob move-double-float-argument double-reg double-stack :double)
631 (frob move-long-float-argument long-reg long-stack :long))
633 ;;;; complex float move-argument vop
634 (macrolet ((frob (name sc stack-sc format)
637 (:args (x :scs (,sc) :target y)
639 :load-if (not (sc-is y ,sc))))
641 (:note "complex float argument move")
642 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
645 (unless (location= x y)
646 (let ((x-real (complex-double-reg-real-tn x))
647 (y-real (complex-double-reg-real-tn y)))
648 (cond ((zerop (tn-offset y-real))
649 (copy-fp-reg-to-fr0 x-real))
650 ((zerop (tn-offset x-real))
655 (inst fxch x-real))))
656 (let ((x-imag (complex-double-reg-imag-tn x))
657 (y-imag (complex-double-reg-imag-tn y)))
660 (inst fxch x-imag))))
662 (let ((real-tn (complex-double-reg-real-tn x)))
663 (cond ((zerop (tn-offset real-tn))
667 (ea-for-csf-real-stack y fp))))
670 (ea-for-cdf-real-stack y fp))))
674 (ea-for-clf-real-stack y fp))))))
680 (ea-for-csf-real-stack y fp))))
683 (ea-for-cdf-real-stack y fp))))
687 (ea-for-clf-real-stack y fp)))))
688 (inst fxch real-tn))))
689 (let ((imag-tn (complex-double-reg-imag-tn x)))
693 '((inst fst (ea-for-csf-imag-stack y fp))))
695 '((inst fstd (ea-for-cdf-imag-stack y fp))))
699 (ea-for-clf-imag-stack y fp)))))
700 (inst fxch imag-tn))))))
701 (define-move-vop ,name :move-argument
702 (,sc descriptor-reg) (,sc)))))
703 (frob move-complex-single-float-argument
704 complex-single-reg complex-single-stack :single)
705 (frob move-complex-double-float-argument
706 complex-double-reg complex-double-stack :double)
708 (frob move-complex-long-float-argument
709 complex-long-reg complex-long-stack :long))
711 (define-move-vop move-argument :move-argument
712 (single-reg double-reg #!+long-float long-reg
713 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
719 ;;; dtc: the floating point arithmetic vops
721 ;;; Note: Although these can accept x and y on the stack or pointed to
722 ;;; from a descriptor register, they will work with register loading
723 ;;; without these. Same deal with the result - it need only be a
724 ;;; register. When load-tns are needed they will probably be in ST0
725 ;;; and the code below should be able to correctly handle all cases.
727 ;;; However it seems to produce better code if all arg. and result
728 ;;; options are used; on the P86 there is no extra cost in using a
729 ;;; memory operand to the FP instructions - not so on the PPro.
731 ;;; It may also be useful to handle constant args?
733 ;;; 22-Jul-97: descriptor args lose in some simple cases when
734 ;;; a function result computed in a loop. Then Python insists
735 ;;; on consing the intermediate values! For example
738 (declare (type (simple-array double-float (*)) a)
741 (declare (type double-float sum))
743 (incf sum (* (aref a i)(aref a i))))
746 ;;; So, disabling descriptor args until this can be fixed elsewhere.
748 ((frob (op fop-sti fopr-sti
750 fopd foprd dname dcost
752 #!-long-float (declare (ignore lcost lname))
756 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
758 (y :scs (single-reg single-stack #+nil descriptor-reg)
760 (:temporary (:sc single-reg :offset fr0-offset
761 :from :eval :to :result) fr0)
762 (:results (r :scs (single-reg single-stack)))
763 (:arg-types single-float single-float)
764 (:result-types single-float)
766 (:note "inline float arithmetic")
768 (:save-p :compute-only)
771 ;; Handle a few special cases
773 ;; x, y, and r are the same register.
774 ((and (sc-is x single-reg) (location= x r) (location= y r))
775 (cond ((zerop (tn-offset r))
780 ;; XX the source register will not be valid.
781 (note-next-instruction vop :internal-error)
784 ;; x and r are the same register.
785 ((and (sc-is x single-reg) (location= x r))
786 (cond ((zerop (tn-offset r))
789 ;; ST(0) = ST(0) op ST(y)
792 ;; ST(0) = ST(0) op Mem
793 (inst ,fop (ea-for-sf-stack y)))
795 (inst ,fop (ea-for-sf-desc y)))))
800 (unless (zerop (tn-offset y))
801 (copy-fp-reg-to-fr0 y)))
802 ((single-stack descriptor-reg)
804 (if (sc-is y single-stack)
805 (inst fld (ea-for-sf-stack y))
806 (inst fld (ea-for-sf-desc y)))))
807 ;; ST(i) = ST(i) op ST0
809 (maybe-fp-wait node vop))
810 ;; y and r are the same register.
811 ((and (sc-is y single-reg) (location= y r))
812 (cond ((zerop (tn-offset r))
815 ;; ST(0) = ST(x) op ST(0)
818 ;; ST(0) = Mem op ST(0)
819 (inst ,fopr (ea-for-sf-stack x)))
821 (inst ,fopr (ea-for-sf-desc x)))))
826 (unless (zerop (tn-offset x))
827 (copy-fp-reg-to-fr0 x)))
828 ((single-stack descriptor-reg)
830 (if (sc-is x single-stack)
831 (inst fld (ea-for-sf-stack x))
832 (inst fld (ea-for-sf-desc x)))))
833 ;; ST(i) = ST(0) op ST(i)
835 (maybe-fp-wait node vop))
838 ;; Get the result to ST0.
840 ;; Special handling is needed if x or y are in ST0, and
841 ;; simpler code is generated.
844 ((and (sc-is x single-reg) (zerop (tn-offset x)))
850 (inst ,fop (ea-for-sf-stack y)))
852 (inst ,fop (ea-for-sf-desc y)))))
854 ((and (sc-is y single-reg) (zerop (tn-offset y)))
860 (inst ,fopr (ea-for-sf-stack x)))
862 (inst ,fopr (ea-for-sf-desc x)))))
867 (copy-fp-reg-to-fr0 x))
870 (inst fld (ea-for-sf-stack x)))
873 (inst fld (ea-for-sf-desc x))))
879 (inst ,fop (ea-for-sf-stack y)))
881 (inst ,fop (ea-for-sf-desc y))))))
883 (note-next-instruction vop :internal-error)
885 ;; Finally save the result.
888 (cond ((zerop (tn-offset r))
889 (maybe-fp-wait node))
893 (inst fst (ea-for-sf-stack r))))))))
897 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
899 (y :scs (double-reg double-stack #+nil descriptor-reg)
901 (:temporary (:sc double-reg :offset fr0-offset
902 :from :eval :to :result) fr0)
903 (:results (r :scs (double-reg double-stack)))
904 (:arg-types double-float double-float)
905 (:result-types double-float)
907 (:note "inline float arithmetic")
909 (:save-p :compute-only)
912 ;; Handle a few special cases.
914 ;; x, y, and r are the same register.
915 ((and (sc-is x double-reg) (location= x r) (location= y r))
916 (cond ((zerop (tn-offset r))
921 ;; XX the source register will not be valid.
922 (note-next-instruction vop :internal-error)
925 ;; x and r are the same register.
926 ((and (sc-is x double-reg) (location= x r))
927 (cond ((zerop (tn-offset r))
930 ;; ST(0) = ST(0) op ST(y)
933 ;; ST(0) = ST(0) op Mem
934 (inst ,fopd (ea-for-df-stack y)))
936 (inst ,fopd (ea-for-df-desc y)))))
941 (unless (zerop (tn-offset y))
942 (copy-fp-reg-to-fr0 y)))
943 ((double-stack descriptor-reg)
945 (if (sc-is y double-stack)
946 (inst fldd (ea-for-df-stack y))
947 (inst fldd (ea-for-df-desc y)))))
948 ;; ST(i) = ST(i) op ST0
950 (maybe-fp-wait node vop))
951 ;; y and r are the same register.
952 ((and (sc-is y double-reg) (location= y r))
953 (cond ((zerop (tn-offset r))
956 ;; ST(0) = ST(x) op ST(0)
959 ;; ST(0) = Mem op ST(0)
960 (inst ,foprd (ea-for-df-stack x)))
962 (inst ,foprd (ea-for-df-desc x)))))
967 (unless (zerop (tn-offset x))
968 (copy-fp-reg-to-fr0 x)))
969 ((double-stack descriptor-reg)
971 (if (sc-is x double-stack)
972 (inst fldd (ea-for-df-stack x))
973 (inst fldd (ea-for-df-desc x)))))
974 ;; ST(i) = ST(0) op ST(i)
976 (maybe-fp-wait node vop))
979 ;; Get the result to ST0.
981 ;; Special handling is needed if x or y are in ST0, and
982 ;; simpler code is generated.
985 ((and (sc-is x double-reg) (zerop (tn-offset x)))
991 (inst ,fopd (ea-for-df-stack y)))
993 (inst ,fopd (ea-for-df-desc y)))))
995 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1001 (inst ,foprd (ea-for-df-stack x)))
1003 (inst ,foprd (ea-for-df-desc x)))))
1008 (copy-fp-reg-to-fr0 x))
1011 (inst fldd (ea-for-df-stack x)))
1014 (inst fldd (ea-for-df-desc x))))
1020 (inst ,fopd (ea-for-df-stack y)))
1022 (inst ,fopd (ea-for-df-desc y))))))
1024 (note-next-instruction vop :internal-error)
1026 ;; Finally save the result.
1029 (cond ((zerop (tn-offset r))
1030 (maybe-fp-wait node))
1034 (inst fstd (ea-for-df-stack r))))))))
1037 (define-vop (,lname)
1039 (:args (x :scs (long-reg) :to :eval)
1040 (y :scs (long-reg) :to :eval))
1041 (:temporary (:sc long-reg :offset fr0-offset
1042 :from :eval :to :result) fr0)
1043 (:results (r :scs (long-reg)))
1044 (:arg-types long-float long-float)
1045 (:result-types long-float)
1046 (:policy :fast-safe)
1047 (:note "inline float arithmetic")
1049 (:save-p :compute-only)
1052 ;; Handle a few special cases.
1054 ;; x, y, and r are the same register.
1055 ((and (location= x r) (location= y r))
1056 (cond ((zerop (tn-offset r))
1061 ;; XX the source register will not be valid.
1062 (note-next-instruction vop :internal-error)
1065 ;; x and r are the same register.
1067 (cond ((zerop (tn-offset r))
1068 ;; ST(0) = ST(0) op ST(y)
1072 (unless (zerop (tn-offset y))
1073 (copy-fp-reg-to-fr0 y))
1074 ;; ST(i) = ST(i) op ST0
1076 (maybe-fp-wait node vop))
1077 ;; y and r are the same register.
1079 (cond ((zerop (tn-offset r))
1080 ;; ST(0) = ST(x) op ST(0)
1084 (unless (zerop (tn-offset x))
1085 (copy-fp-reg-to-fr0 x))
1086 ;; ST(i) = ST(0) op ST(i)
1087 (inst ,fopr-sti r)))
1088 (maybe-fp-wait node vop))
1091 ;; Get the result to ST0.
1093 ;; Special handling is needed if x or y are in ST0, and
1094 ;; simpler code is generated.
1097 ((zerop (tn-offset x))
1101 ((zerop (tn-offset y))
1106 (copy-fp-reg-to-fr0 x)
1110 (note-next-instruction vop :internal-error)
1112 ;; Finally save the result.
1113 (cond ((zerop (tn-offset r))
1114 (maybe-fp-wait node))
1116 (inst fst r))))))))))
1118 (frob + fadd-sti fadd-sti
1119 fadd fadd +/single-float 2
1120 faddd faddd +/double-float 2
1122 (frob - fsub-sti fsubr-sti
1123 fsub fsubr -/single-float 2
1124 fsubd fsubrd -/double-float 2
1126 (frob * fmul-sti fmul-sti
1127 fmul fmul */single-float 3
1128 fmuld fmuld */double-float 3
1130 (frob / fdiv-sti fdivr-sti
1131 fdiv fdivr //single-float 12
1132 fdivd fdivrd //double-float 12
1135 (macrolet ((frob (name inst translate sc type)
1136 `(define-vop (,name)
1137 (:args (x :scs (,sc) :target fr0))
1138 (:results (y :scs (,sc)))
1139 (:translate ,translate)
1140 (:policy :fast-safe)
1142 (:result-types ,type)
1143 (:temporary (:sc double-reg :offset fr0-offset
1144 :from :argument :to :result) fr0)
1146 (:note "inline float arithmetic")
1148 (:save-p :compute-only)
1150 (note-this-location vop :internal-error)
1151 (unless (zerop (tn-offset x))
1152 (inst fxch x) ; x to top of stack
1153 (unless (location= x y)
1154 (inst fst x))) ; Maybe save it.
1155 (inst ,inst) ; Clobber st0.
1156 (unless (zerop (tn-offset y))
1159 (frob abs/single-float fabs abs single-reg single-float)
1160 (frob abs/double-float fabs abs double-reg double-float)
1162 (frob abs/long-float fabs abs long-reg long-float)
1163 (frob %negate/single-float fchs %negate single-reg single-float)
1164 (frob %negate/double-float fchs %negate double-reg double-float)
1166 (frob %negate/long-float fchs %negate long-reg long-float))
1170 (define-vop (=/float)
1172 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1174 (:info target not-p)
1175 (:policy :fast-safe)
1177 (:save-p :compute-only)
1178 (:note "inline float comparison")
1181 (note-this-location vop :internal-error)
1183 ;; x is in ST0; y is in any reg.
1184 ((zerop (tn-offset x))
1186 ;; y is in ST0; x is in another reg.
1187 ((zerop (tn-offset y))
1189 ;; x and y are the same register, not ST0
1194 ;; x and y are different registers, neither ST0.
1199 (inst fnstsw) ; status word to ax
1200 (inst and ah-tn #x45) ; C3 C2 C0
1201 (inst cmp ah-tn #x40)
1202 (inst jmp (if not-p :ne :e) target)))
1204 (define-vop (=/single-float =/float)
1206 (:args (x :scs (single-reg))
1207 (y :scs (single-reg)))
1208 (:arg-types single-float single-float))
1210 (define-vop (=/double-float =/float)
1212 (:args (x :scs (double-reg))
1213 (y :scs (double-reg)))
1214 (:arg-types double-float double-float))
1217 (define-vop (=/long-float =/float)
1219 (:args (x :scs (long-reg))
1220 (y :scs (long-reg)))
1221 (:arg-types long-float long-float))
1223 (define-vop (<single-float)
1225 (:args (x :scs (single-reg single-stack descriptor-reg))
1226 (y :scs (single-reg single-stack descriptor-reg)))
1227 (:arg-types single-float single-float)
1228 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1229 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1231 (:info target not-p)
1232 (:policy :fast-safe)
1233 (:note "inline float comparison")
1236 ;; Handle a few special cases.
1239 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1243 ((single-stack descriptor-reg)
1244 (if (sc-is x single-stack)
1245 (inst fcom (ea-for-sf-stack x))
1246 (inst fcom (ea-for-sf-desc x)))))
1247 (inst fnstsw) ; status word to ax
1248 (inst and ah-tn #x45))
1250 ;; general case when y is not in ST0
1255 (unless (zerop (tn-offset x))
1256 (copy-fp-reg-to-fr0 x)))
1257 ((single-stack descriptor-reg)
1259 (if (sc-is x single-stack)
1260 (inst fld (ea-for-sf-stack x))
1261 (inst fld (ea-for-sf-desc x)))))
1265 ((single-stack descriptor-reg)
1266 (if (sc-is y single-stack)
1267 (inst fcom (ea-for-sf-stack y))
1268 (inst fcom (ea-for-sf-desc y)))))
1269 (inst fnstsw) ; status word to ax
1270 (inst and ah-tn #x45) ; C3 C2 C0
1271 (inst cmp ah-tn #x01)))
1272 (inst jmp (if not-p :ne :e) target)))
1274 (define-vop (<double-float)
1276 (:args (x :scs (double-reg double-stack descriptor-reg))
1277 (y :scs (double-reg double-stack descriptor-reg)))
1278 (:arg-types double-float double-float)
1279 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1280 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1282 (:info target not-p)
1283 (:policy :fast-safe)
1284 (:note "inline float comparison")
1287 ;; Handle a few special cases
1290 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1294 ((double-stack descriptor-reg)
1295 (if (sc-is x double-stack)
1296 (inst fcomd (ea-for-df-stack x))
1297 (inst fcomd (ea-for-df-desc x)))))
1298 (inst fnstsw) ; status word to ax
1299 (inst and ah-tn #x45))
1301 ;; General case when y is not in ST0.
1306 (unless (zerop (tn-offset x))
1307 (copy-fp-reg-to-fr0 x)))
1308 ((double-stack descriptor-reg)
1310 (if (sc-is x double-stack)
1311 (inst fldd (ea-for-df-stack x))
1312 (inst fldd (ea-for-df-desc x)))))
1316 ((double-stack descriptor-reg)
1317 (if (sc-is y double-stack)
1318 (inst fcomd (ea-for-df-stack y))
1319 (inst fcomd (ea-for-df-desc y)))))
1320 (inst fnstsw) ; status word to ax
1321 (inst and ah-tn #x45) ; C3 C2 C0
1322 (inst cmp ah-tn #x01)))
1323 (inst jmp (if not-p :ne :e) target)))
1326 (define-vop (<long-float)
1328 (:args (x :scs (long-reg))
1329 (y :scs (long-reg)))
1330 (:arg-types long-float long-float)
1331 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1333 (:info target not-p)
1334 (:policy :fast-safe)
1335 (:note "inline float comparison")
1339 ;; x is in ST0; y is in any reg.
1340 ((zerop (tn-offset x))
1342 (inst fnstsw) ; status word to ax
1343 (inst and ah-tn #x45) ; C3 C2 C0
1344 (inst cmp ah-tn #x01))
1345 ;; y is in ST0; x is in another reg.
1346 ((zerop (tn-offset y))
1348 (inst fnstsw) ; status word to ax
1349 (inst and ah-tn #x45))
1350 ;; x and y are the same register, not ST0
1351 ;; x and y are different registers, neither ST0.
1356 (inst fnstsw) ; status word to ax
1357 (inst and ah-tn #x45))) ; C3 C2 C0
1358 (inst jmp (if not-p :ne :e) target)))
1360 (define-vop (>single-float)
1362 (:args (x :scs (single-reg single-stack descriptor-reg))
1363 (y :scs (single-reg single-stack descriptor-reg)))
1364 (:arg-types single-float single-float)
1365 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1366 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1368 (:info target not-p)
1369 (:policy :fast-safe)
1370 (:note "inline float comparison")
1373 ;; Handle a few special cases.
1376 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1380 ((single-stack descriptor-reg)
1381 (if (sc-is x single-stack)
1382 (inst fcom (ea-for-sf-stack x))
1383 (inst fcom (ea-for-sf-desc x)))))
1384 (inst fnstsw) ; status word to ax
1385 (inst and ah-tn #x45)
1386 (inst cmp ah-tn #x01))
1388 ;; general case when y is not in ST0
1393 (unless (zerop (tn-offset x))
1394 (copy-fp-reg-to-fr0 x)))
1395 ((single-stack descriptor-reg)
1397 (if (sc-is x single-stack)
1398 (inst fld (ea-for-sf-stack x))
1399 (inst fld (ea-for-sf-desc x)))))
1403 ((single-stack descriptor-reg)
1404 (if (sc-is y single-stack)
1405 (inst fcom (ea-for-sf-stack y))
1406 (inst fcom (ea-for-sf-desc y)))))
1407 (inst fnstsw) ; status word to ax
1408 (inst and ah-tn #x45)))
1409 (inst jmp (if not-p :ne :e) target)))
1411 (define-vop (>double-float)
1413 (:args (x :scs (double-reg double-stack descriptor-reg))
1414 (y :scs (double-reg double-stack descriptor-reg)))
1415 (:arg-types double-float double-float)
1416 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1417 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1419 (:info target not-p)
1420 (:policy :fast-safe)
1421 (:note "inline float comparison")
1424 ;; Handle a few special cases.
1427 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1431 ((double-stack descriptor-reg)
1432 (if (sc-is x double-stack)
1433 (inst fcomd (ea-for-df-stack x))
1434 (inst fcomd (ea-for-df-desc x)))))
1435 (inst fnstsw) ; status word to ax
1436 (inst and ah-tn #x45)
1437 (inst cmp ah-tn #x01))
1439 ;; general case when y is not in ST0
1444 (unless (zerop (tn-offset x))
1445 (copy-fp-reg-to-fr0 x)))
1446 ((double-stack descriptor-reg)
1448 (if (sc-is x double-stack)
1449 (inst fldd (ea-for-df-stack x))
1450 (inst fldd (ea-for-df-desc x)))))
1454 ((double-stack descriptor-reg)
1455 (if (sc-is y double-stack)
1456 (inst fcomd (ea-for-df-stack y))
1457 (inst fcomd (ea-for-df-desc y)))))
1458 (inst fnstsw) ; status word to ax
1459 (inst and ah-tn #x45)))
1460 (inst jmp (if not-p :ne :e) target)))
1463 (define-vop (>long-float)
1465 (:args (x :scs (long-reg))
1466 (y :scs (long-reg)))
1467 (:arg-types long-float long-float)
1468 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1470 (:info target not-p)
1471 (:policy :fast-safe)
1472 (:note "inline float comparison")
1476 ;; y is in ST0; x is in any reg.
1477 ((zerop (tn-offset y))
1479 (inst fnstsw) ; status word to ax
1480 (inst and ah-tn #x45)
1481 (inst cmp ah-tn #x01))
1482 ;; x is in ST0; y is in another reg.
1483 ((zerop (tn-offset x))
1485 (inst fnstsw) ; status word to ax
1486 (inst and ah-tn #x45))
1487 ;; y and x are the same register, not ST0
1488 ;; y and x are different registers, neither ST0.
1493 (inst fnstsw) ; status word to ax
1494 (inst and ah-tn #x45)))
1495 (inst jmp (if not-p :ne :e) target)))
1497 ;;; Comparisons with 0 can use the FTST instruction.
1499 (define-vop (float-test)
1501 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1503 (:info target not-p y)
1504 (:variant-vars code)
1505 (:policy :fast-safe)
1507 (:save-p :compute-only)
1508 (:note "inline float comparison")
1511 (note-this-location vop :internal-error)
1514 ((zerop (tn-offset x))
1521 (inst fnstsw) ; status word to ax
1522 (inst and ah-tn #x45) ; C3 C2 C0
1523 (unless (zerop code)
1524 (inst cmp ah-tn code))
1525 (inst jmp (if not-p :ne :e) target)))
1527 (define-vop (=0/single-float float-test)
1529 (:args (x :scs (single-reg)))
1530 #!-negative-zero-is-not-zero
1531 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1532 #!+negative-zero-is-not-zero
1533 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1535 (define-vop (=0/double-float float-test)
1537 (:args (x :scs (double-reg)))
1538 #!-negative-zero-is-not-zero
1539 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1540 #!+negative-zero-is-not-zero
1541 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1544 (define-vop (=0/long-float float-test)
1546 (:args (x :scs (long-reg)))
1547 #!-negative-zero-is-not-zero
1548 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1549 #!+negative-zero-is-not-zero
1550 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1553 (define-vop (<0/single-float float-test)
1555 (:args (x :scs (single-reg)))
1556 #!-negative-zero-is-not-zero
1557 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1558 #!+negative-zero-is-not-zero
1559 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1561 (define-vop (<0/double-float float-test)
1563 (:args (x :scs (double-reg)))
1564 #!-negative-zero-is-not-zero
1565 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1566 #!+negative-zero-is-not-zero
1567 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1570 (define-vop (<0/long-float float-test)
1572 (:args (x :scs (long-reg)))
1573 #!-negative-zero-is-not-zero
1574 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1575 #!+negative-zero-is-not-zero
1576 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1579 (define-vop (>0/single-float float-test)
1581 (:args (x :scs (single-reg)))
1582 #!-negative-zero-is-not-zero
1583 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1584 #!+negative-zero-is-not-zero
1585 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1587 (define-vop (>0/double-float float-test)
1589 (:args (x :scs (double-reg)))
1590 #!-negative-zero-is-not-zero
1591 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1592 #!+negative-zero-is-not-zero
1593 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1596 (define-vop (>0/long-float float-test)
1598 (:args (x :scs (long-reg)))
1599 #!-negative-zero-is-not-zero
1600 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1601 #!+negative-zero-is-not-zero
1602 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1606 (deftransform eql ((x y) (long-float long-float))
1607 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1608 (= (long-float-high-bits x) (long-float-high-bits y))
1609 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1613 (macrolet ((frob (name translate to-sc to-type)
1614 `(define-vop (,name)
1615 (:args (x :scs (signed-stack signed-reg) :target temp))
1616 (:temporary (:sc signed-stack) temp)
1617 (:results (y :scs (,to-sc)))
1618 (:arg-types signed-num)
1619 (:result-types ,to-type)
1620 (:policy :fast-safe)
1621 (:note "inline float coercion")
1622 (:translate ,translate)
1624 (:save-p :compute-only)
1629 (with-empty-tn@fp-top(y)
1630 (note-this-location vop :internal-error)
1633 (with-empty-tn@fp-top(y)
1634 (note-this-location vop :internal-error)
1635 (inst fild x))))))))
1636 (frob %single-float/signed %single-float single-reg single-float)
1637 (frob %double-float/signed %double-float double-reg double-float)
1639 (frob %long-float/signed %long-float long-reg long-float))
1641 (macrolet ((frob (name translate to-sc to-type)
1642 `(define-vop (,name)
1643 (:args (x :scs (unsigned-reg)))
1644 (:results (y :scs (,to-sc)))
1645 (:arg-types unsigned-num)
1646 (:result-types ,to-type)
1647 (:policy :fast-safe)
1648 (:note "inline float coercion")
1649 (:translate ,translate)
1651 (:save-p :compute-only)
1655 (with-empty-tn@fp-top(y)
1656 (note-this-location vop :internal-error)
1657 (inst fildl (make-ea :dword :base esp-tn)))
1658 (inst add esp-tn 8)))))
1659 (frob %single-float/unsigned %single-float single-reg single-float)
1660 (frob %double-float/unsigned %double-float double-reg double-float)
1662 (frob %long-float/unsigned %long-float long-reg long-float))
1664 ;;; These should be no-ops but the compiler might want to move some
1666 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1667 `(define-vop (,name)
1668 (:args (x :scs (,from-sc) :target y))
1669 (:results (y :scs (,to-sc)))
1670 (:arg-types ,from-type)
1671 (:result-types ,to-type)
1672 (:policy :fast-safe)
1673 (:note "inline float coercion")
1674 (:translate ,translate)
1676 (:save-p :compute-only)
1678 (note-this-location vop :internal-error)
1679 (unless (location= x y)
1681 ((zerop (tn-offset x))
1682 ;; x is in ST0, y is in another reg. not ST0
1684 ((zerop (tn-offset y))
1685 ;; y is in ST0, x is in another reg. not ST0
1686 (copy-fp-reg-to-fr0 x))
1688 ;; Neither x or y are in ST0, and they are not in
1692 (inst fxch x))))))))
1694 (frob %single-float/double-float %single-float double-reg
1695 double-float single-reg single-float)
1697 (frob %single-float/long-float %single-float long-reg
1698 long-float single-reg single-float)
1699 (frob %double-float/single-float %double-float single-reg single-float
1700 double-reg double-float)
1702 (frob %double-float/long-float %double-float long-reg long-float
1703 double-reg double-float)
1705 (frob %long-float/single-float %long-float single-reg single-float
1706 long-reg long-float)
1708 (frob %long-float/double-float %long-float double-reg double-float
1709 long-reg long-float))
1711 (macrolet ((frob (trans from-sc from-type round-p)
1712 `(define-vop (,(symbolicate trans "/" from-type))
1713 (:args (x :scs (,from-sc)))
1714 (:temporary (:sc signed-stack) stack-temp)
1716 '((:temporary (:sc unsigned-stack) scw)
1717 (:temporary (:sc any-reg) rcw)))
1718 (:results (y :scs (signed-reg)))
1719 (:arg-types ,from-type)
1720 (:result-types signed-num)
1722 (:policy :fast-safe)
1723 (:note "inline float truncate")
1725 (:save-p :compute-only)
1728 '((note-this-location vop :internal-error)
1729 ;; Catch any pending FPE exceptions.
1731 (,(if round-p 'progn 'pseudo-atomic)
1732 ;; Normal mode (for now) is "round to best".
1735 '((inst fnstcw scw) ; save current control word
1736 (move rcw scw) ; into 16-bit register
1737 (inst or rcw (ash #b11 10)) ; CHOP
1738 (move stack-temp rcw)
1739 (inst fldcw stack-temp)))
1744 (inst fist stack-temp)
1745 (inst mov y stack-temp)))
1747 '((inst fldcw scw)))))))))
1748 (frob %unary-truncate single-reg single-float nil)
1749 (frob %unary-truncate double-reg double-float nil)
1751 (frob %unary-truncate long-reg long-float nil)
1752 (frob %unary-round single-reg single-float t)
1753 (frob %unary-round double-reg double-float t)
1755 (frob %unary-round long-reg long-float t))
1757 (macrolet ((frob (trans from-sc from-type round-p)
1758 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1759 (:args (x :scs (,from-sc) :target fr0))
1760 (:temporary (:sc double-reg :offset fr0-offset
1761 :from :argument :to :result) fr0)
1763 '((:temporary (:sc unsigned-stack) stack-temp)
1764 (:temporary (:sc unsigned-stack) scw)
1765 (:temporary (:sc any-reg) rcw)))
1766 (:results (y :scs (unsigned-reg)))
1767 (:arg-types ,from-type)
1768 (:result-types unsigned-num)
1770 (:policy :fast-safe)
1771 (:note "inline float truncate")
1773 (:save-p :compute-only)
1776 '((note-this-location vop :internal-error)
1777 ;; Catch any pending FPE exceptions.
1779 ;; Normal mode (for now) is "round to best".
1780 (unless (zerop (tn-offset x))
1781 (copy-fp-reg-to-fr0 x))
1783 '((inst fnstcw scw) ; save current control word
1784 (move rcw scw) ; into 16-bit register
1785 (inst or rcw (ash #b11 10)) ; CHOP
1786 (move stack-temp rcw)
1787 (inst fldcw stack-temp)))
1789 (inst fistpl (make-ea :dword :base esp-tn))
1791 (inst fld fr0) ; copy fr0 to at least restore stack.
1794 '((inst fldcw scw)))))))
1795 (frob %unary-truncate single-reg single-float nil)
1796 (frob %unary-truncate double-reg double-float nil)
1798 (frob %unary-truncate long-reg long-float nil)
1799 (frob %unary-round single-reg single-float t)
1800 (frob %unary-round double-reg double-float t)
1802 (frob %unary-round long-reg long-float t))
1804 (define-vop (make-single-float)
1805 (:args (bits :scs (signed-reg) :target res
1806 :load-if (not (or (and (sc-is bits signed-stack)
1807 (sc-is res single-reg))
1808 (and (sc-is bits signed-stack)
1809 (sc-is res single-stack)
1810 (location= bits res))))))
1811 (:results (res :scs (single-reg single-stack)))
1812 (:temporary (:sc signed-stack) stack-temp)
1813 (:arg-types signed-num)
1814 (:result-types single-float)
1815 (:translate make-single-float)
1816 (:policy :fast-safe)
1823 (inst mov res bits))
1825 (aver (location= bits res)))))
1829 ;; source must be in memory
1830 (inst mov stack-temp bits)
1831 (with-empty-tn@fp-top(res)
1832 (inst fld stack-temp)))
1834 (with-empty-tn@fp-top(res)
1835 (inst fld bits))))))))
1837 (define-vop (make-double-float)
1838 (:args (hi-bits :scs (signed-reg))
1839 (lo-bits :scs (unsigned-reg)))
1840 (:results (res :scs (double-reg)))
1841 (:temporary (:sc double-stack) temp)
1842 (:arg-types signed-num unsigned-num)
1843 (:result-types double-float)
1844 (:translate make-double-float)
1845 (:policy :fast-safe)
1848 (let ((offset (1+ (tn-offset temp))))
1849 (storew hi-bits ebp-tn (- offset))
1850 (storew lo-bits ebp-tn (- (1+ offset)))
1851 (with-empty-tn@fp-top(res)
1852 (inst fldd (make-ea :dword :base ebp-tn
1853 :disp (- (* (1+ offset) word-bytes))))))))
1856 (define-vop (make-long-float)
1857 (:args (exp-bits :scs (signed-reg))
1858 (hi-bits :scs (unsigned-reg))
1859 (lo-bits :scs (unsigned-reg)))
1860 (:results (res :scs (long-reg)))
1861 (:temporary (:sc long-stack) temp)
1862 (:arg-types signed-num unsigned-num unsigned-num)
1863 (:result-types long-float)
1864 (:translate make-long-float)
1865 (:policy :fast-safe)
1868 (let ((offset (1+ (tn-offset temp))))
1869 (storew exp-bits ebp-tn (- offset))
1870 (storew hi-bits ebp-tn (- (1+ offset)))
1871 (storew lo-bits ebp-tn (- (+ offset 2)))
1872 (with-empty-tn@fp-top(res)
1873 (inst fldl (make-ea :dword :base ebp-tn
1874 :disp (- (* (+ offset 2) word-bytes))))))))
1876 (define-vop (single-float-bits)
1877 (:args (float :scs (single-reg descriptor-reg)
1878 :load-if (not (sc-is float single-stack))))
1879 (:results (bits :scs (signed-reg)))
1880 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1881 (:arg-types single-float)
1882 (:result-types signed-num)
1883 (:translate single-float-bits)
1884 (:policy :fast-safe)
1891 (with-tn@fp-top(float)
1892 (inst fst stack-temp)
1893 (inst mov bits stack-temp)))
1895 (inst mov bits float))
1898 bits float sb!vm:single-float-value-slot
1899 sb!vm:other-pointer-lowtag))))
1903 (with-tn@fp-top(float)
1904 (inst fst bits))))))))
1906 (define-vop (double-float-high-bits)
1907 (:args (float :scs (double-reg descriptor-reg)
1908 :load-if (not (sc-is float double-stack))))
1909 (:results (hi-bits :scs (signed-reg)))
1910 (:temporary (:sc double-stack) temp)
1911 (:arg-types double-float)
1912 (:result-types signed-num)
1913 (:translate double-float-high-bits)
1914 (:policy :fast-safe)
1919 (with-tn@fp-top(float)
1920 (let ((where (make-ea :dword :base ebp-tn
1921 :disp (- (* (+ 2 (tn-offset temp))
1924 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1926 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1928 (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
1929 sb!vm:other-pointer-lowtag)))))
1931 (define-vop (double-float-low-bits)
1932 (:args (float :scs (double-reg descriptor-reg)
1933 :load-if (not (sc-is float double-stack))))
1934 (:results (lo-bits :scs (unsigned-reg)))
1935 (:temporary (:sc double-stack) temp)
1936 (:arg-types double-float)
1937 (:result-types unsigned-num)
1938 (:translate double-float-low-bits)
1939 (:policy :fast-safe)
1944 (with-tn@fp-top(float)
1945 (let ((where (make-ea :dword :base ebp-tn
1946 :disp (- (* (+ 2 (tn-offset temp))
1949 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1951 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1953 (loadw lo-bits float sb!vm:double-float-value-slot
1954 sb!vm:other-pointer-lowtag)))))
1957 (define-vop (long-float-exp-bits)
1958 (:args (float :scs (long-reg descriptor-reg)
1959 :load-if (not (sc-is float long-stack))))
1960 (:results (exp-bits :scs (signed-reg)))
1961 (:temporary (:sc long-stack) temp)
1962 (:arg-types long-float)
1963 (:result-types signed-num)
1964 (:translate long-float-exp-bits)
1965 (:policy :fast-safe)
1970 (with-tn@fp-top(float)
1971 (let ((where (make-ea :dword :base ebp-tn
1972 :disp (- (* (+ 3 (tn-offset temp))
1974 (store-long-float where)))
1975 (inst movsx exp-bits
1976 (make-ea :word :base ebp-tn
1977 :disp (* (- (1+ (tn-offset temp))) word-bytes))))
1979 (inst movsx exp-bits
1980 (make-ea :word :base ebp-tn
1981 :disp (* (- (1+ (tn-offset float))) word-bytes))))
1983 (inst movsx exp-bits
1984 (make-ea :word :base float
1985 :disp (- (* (+ 2 sb!vm:long-float-value-slot)
1987 sb!vm:other-pointer-lowtag)))))))
1990 (define-vop (long-float-high-bits)
1991 (:args (float :scs (long-reg descriptor-reg)
1992 :load-if (not (sc-is float long-stack))))
1993 (:results (hi-bits :scs (unsigned-reg)))
1994 (:temporary (:sc long-stack) temp)
1995 (:arg-types long-float)
1996 (:result-types unsigned-num)
1997 (:translate long-float-high-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 hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
2010 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
2012 (loadw hi-bits float (1+ sb!vm:long-float-value-slot)
2013 sb!vm:other-pointer-lowtag)))))
2016 (define-vop (long-float-low-bits)
2017 (:args (float :scs (long-reg descriptor-reg)
2018 :load-if (not (sc-is float long-stack))))
2019 (:results (lo-bits :scs (unsigned-reg)))
2020 (:temporary (:sc long-stack) temp)
2021 (:arg-types long-float)
2022 (:result-types unsigned-num)
2023 (:translate long-float-low-bits)
2024 (:policy :fast-safe)
2029 (with-tn@fp-top(float)
2030 (let ((where (make-ea :dword :base ebp-tn
2031 :disp (- (* (+ 3 (tn-offset temp))
2033 (store-long-float where)))
2034 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2036 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2038 (loadw lo-bits float sb!vm:long-float-value-slot
2039 sb!vm:other-pointer-lowtag)))))
2041 ;;;; float mode hackery
2043 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2044 (defknown floating-point-modes () float-modes (flushable))
2045 (defknown ((setf floating-point-modes)) (float-modes)
2048 (defconstant npx-env-size (* 7 sb!vm:word-bytes))
2049 (defconstant npx-cw-offset 0)
2050 (defconstant npx-sw-offset 4)
2052 (define-vop (floating-point-modes)
2053 (:results (res :scs (unsigned-reg)))
2054 (:result-types unsigned-num)
2055 (:translate floating-point-modes)
2056 (:policy :fast-safe)
2057 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2060 (inst sub esp-tn npx-env-size) ; Make space on stack.
2061 (inst wait) ; Catch any pending FPE exceptions
2062 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2063 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2064 ;; Move current status to high word.
2065 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2066 ;; Move exception mask to low word.
2067 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2068 (inst add esp-tn npx-env-size) ; Pop stack.
2069 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2072 (define-vop (set-floating-point-modes)
2073 (:args (new :scs (unsigned-reg) :to :result :target res))
2074 (:results (res :scs (unsigned-reg)))
2075 (:arg-types unsigned-num)
2076 (:result-types unsigned-num)
2077 (:translate (setf floating-point-modes))
2078 (:policy :fast-safe)
2079 (:temporary (:sc unsigned-reg :offset eax-offset
2080 :from :eval :to :result) eax)
2082 (inst sub esp-tn npx-env-size) ; Make space on stack.
2083 (inst wait) ; Catch any pending FPE exceptions.
2084 (inst fstenv (make-ea :dword :base esp-tn))
2086 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2087 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2088 (inst shr eax 16) ; position status word
2089 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2090 (inst fldenv (make-ea :dword :base esp-tn))
2091 (inst add esp-tn npx-env-size) ; Pop stack.
2097 ;;; Let's use some of the 80387 special functions.
2099 ;;; These defs will not take effect unless code/irrat.lisp is modified
2100 ;;; to remove the inlined alien routine def.
2102 (macrolet ((frob (func trans op)
2103 `(define-vop (,func)
2104 (:args (x :scs (double-reg) :target fr0))
2105 (:temporary (:sc double-reg :offset fr0-offset
2106 :from :argument :to :result) fr0)
2108 (:results (y :scs (double-reg)))
2109 (:arg-types double-float)
2110 (:result-types double-float)
2112 (:policy :fast-safe)
2113 (:note "inline NPX function")
2115 (:save-p :compute-only)
2118 (note-this-location vop :internal-error)
2119 (unless (zerop (tn-offset x))
2120 (inst fxch x) ; x to top of stack
2121 (unless (location= x y)
2122 (inst fst x))) ; maybe save it
2123 (inst ,op) ; clobber st0
2124 (cond ((zerop (tn-offset y))
2125 (maybe-fp-wait node))
2129 ;; Quick versions of fsin and fcos that require the argument to be
2130 ;; within range 2^63.
2131 (frob fsin-quick %sin-quick fsin)
2132 (frob fcos-quick %cos-quick fcos)
2133 (frob fsqrt %sqrt fsqrt))
2135 ;;; Quick version of ftan that requires the argument to be within
2137 (define-vop (ftan-quick)
2138 (:translate %tan-quick)
2139 (:args (x :scs (double-reg) :target fr0))
2140 (:temporary (:sc double-reg :offset fr0-offset
2141 :from :argument :to :result) fr0)
2142 (:temporary (:sc double-reg :offset fr1-offset
2143 :from :argument :to :result) fr1)
2144 (:results (y :scs (double-reg)))
2145 (:arg-types double-float)
2146 (:result-types double-float)
2147 (:policy :fast-safe)
2148 (:note "inline tan function")
2150 (:save-p :compute-only)
2152 (note-this-location vop :internal-error)
2161 (inst fldd (make-random-tn :kind :normal
2162 :sc (sc-or-lose 'double-reg)
2163 :offset (- (tn-offset x) 2)))))
2174 ;;; These versions of fsin, fcos, and ftan try to use argument
2175 ;;; reduction but to do this accurately requires greater precision and
2176 ;;; it is hopelessly inaccurate.
2178 (macrolet ((frob (func trans op)
2179 `(define-vop (,func)
2181 (:args (x :scs (double-reg) :target fr0))
2182 (:temporary (:sc unsigned-reg :offset eax-offset
2183 :from :eval :to :result) eax)
2184 (:temporary (:sc unsigned-reg :offset fr0-offset
2185 :from :argument :to :result) fr0)
2186 (:temporary (:sc unsigned-reg :offset fr1-offset
2187 :from :argument :to :result) fr1)
2188 (:results (y :scs (double-reg)))
2189 (:arg-types double-float)
2190 (:result-types double-float)
2191 (:policy :fast-safe)
2192 (:note "inline sin/cos function")
2194 (:save-p :compute-only)
2197 (note-this-location vop :internal-error)
2198 (unless (zerop (tn-offset x))
2199 (inst fxch x) ; x to top of stack
2200 (unless (location= x y)
2201 (inst fst x))) ; maybe save it
2203 (inst fnstsw) ; status word to ax
2204 (inst and ah-tn #x04) ; C2
2206 ;; Else x was out of range so reduce it; ST0 is unchanged.
2207 (inst fstp fr1) ; Load 2*PI
2213 (inst fnstsw) ; status word to ax
2214 (inst and ah-tn #x04) ; C2
2218 (unless (zerop (tn-offset y))
2220 (frob fsin %sin fsin)
2221 (frob fcos %cos fcos))
2226 (:args (x :scs (double-reg) :target fr0))
2227 (:temporary (:sc unsigned-reg :offset eax-offset
2228 :from :argument :to :result) eax)
2229 (:temporary (:sc double-reg :offset fr0-offset
2230 :from :argument :to :result) fr0)
2231 (:temporary (:sc double-reg :offset fr1-offset
2232 :from :argument :to :result) fr1)
2233 (:results (y :scs (double-reg)))
2234 (:arg-types double-float)
2235 (:result-types double-float)
2236 (:policy :fast-safe)
2237 (:note "inline tan function")
2239 (:save-p :compute-only)
2242 (note-this-location vop :internal-error)
2251 (inst fldd (make-random-tn :kind :normal
2252 :sc (sc-or-lose 'double-reg)
2253 :offset (- (tn-offset x) 2)))))
2255 (inst fnstsw) ; status word to ax
2256 (inst and ah-tn #x04) ; C2
2258 ;; Else x was out of range so reduce it; ST0 is unchanged.
2259 (inst fldpi) ; Load 2*PI
2264 (inst fnstsw) ; status word to ax
2265 (inst and ah-tn #x04) ; C2
2279 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2280 ;;; the argument is out of range 2^63 and would thus be hopelessly
2282 (macrolet ((frob (func trans op)
2283 `(define-vop (,func)
2285 (:args (x :scs (double-reg) :target fr0))
2286 (:temporary (:sc double-reg :offset fr0-offset
2287 :from :argument :to :result) fr0)
2288 (:temporary (:sc unsigned-reg :offset eax-offset
2289 :from :argument :to :result) eax)
2290 (:results (y :scs (double-reg)))
2291 (:arg-types double-float)
2292 (:result-types double-float)
2293 (:policy :fast-safe)
2294 (:note "inline sin/cos function")
2296 (:save-p :compute-only)
2299 (note-this-location vop :internal-error)
2300 (unless (zerop (tn-offset x))
2301 (inst fxch x) ; x to top of stack
2302 (unless (location= x y)
2303 (inst fst x))) ; maybe save it
2305 (inst fnstsw) ; status word to ax
2306 (inst and ah-tn #x04) ; C2
2308 ;; Else x was out of range so reduce it; ST0 is unchanged.
2309 (inst fstp fr0) ; Load 0.0
2312 (unless (zerop (tn-offset y))
2314 (frob fsin %sin fsin)
2315 (frob fcos %cos fcos))
2319 (:args (x :scs (double-reg) :target fr0))
2320 (:temporary (:sc double-reg :offset fr0-offset
2321 :from :argument :to :result) fr0)
2322 (:temporary (:sc double-reg :offset fr1-offset
2323 :from :argument :to :result) fr1)
2324 (:temporary (:sc unsigned-reg :offset eax-offset
2325 :from :argument :to :result) eax)
2326 (:results (y :scs (double-reg)))
2327 (:arg-types double-float)
2328 (:result-types double-float)
2330 (:policy :fast-safe)
2331 (:note "inline tan function")
2333 (:save-p :compute-only)
2336 (note-this-location vop :internal-error)
2345 (inst fldd (make-random-tn :kind :normal
2346 :sc (sc-or-lose 'double-reg)
2347 :offset (- (tn-offset x) 2)))))
2349 (inst fnstsw) ; status word to ax
2350 (inst and ah-tn #x04) ; C2
2352 ;; Else x was out of range so reduce it; ST0 is unchanged.
2353 (inst fldz) ; Load 0.0
2368 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2369 (:temporary (:sc double-reg :offset fr0-offset
2370 :from :argument :to :result) fr0)
2371 (:temporary (:sc double-reg :offset fr1-offset
2372 :from :argument :to :result) fr1)
2373 (:temporary (:sc double-reg :offset fr2-offset
2374 :from :argument :to :result) fr2)
2375 (:results (y :scs (double-reg)))
2376 (:arg-types double-float)
2377 (:result-types double-float)
2378 (:policy :fast-safe)
2379 (:note "inline exp function")
2381 (:save-p :compute-only)
2383 (note-this-location vop :internal-error)
2386 (cond ((zerop (tn-offset x))
2392 ;; x is in a FP reg, not fr0
2396 ((double-stack descriptor-reg)
2399 (if (sc-is x double-stack)
2400 (inst fmuld (ea-for-df-stack x))
2401 (inst fmuld (ea-for-df-desc x)))))
2402 ;; Now fr0=x log2(e)
2406 (inst fsubp-sti fr1)
2409 (inst faddp-sti fr1)
2414 (t (inst fstd y)))))
2416 ;;; Modified exp that handles the following special cases:
2417 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2420 (:args (x :scs (double-reg) :target fr0))
2421 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2422 (:temporary (:sc double-reg :offset fr0-offset
2423 :from :argument :to :result) fr0)
2424 (:temporary (:sc double-reg :offset fr1-offset
2425 :from :argument :to :result) fr1)
2426 (:temporary (:sc double-reg :offset fr2-offset
2427 :from :argument :to :result) fr2)
2428 (:results (y :scs (double-reg)))
2429 (:arg-types double-float)
2430 (:result-types double-float)
2431 (:policy :fast-safe)
2432 (:note "inline exp function")
2434 (:save-p :compute-only)
2437 (note-this-location vop :internal-error)
2438 (unless (zerop (tn-offset x))
2439 (inst fxch x) ; x to top of stack
2440 (unless (location= x y)
2441 (inst fst x))) ; maybe save it
2442 ;; Check for Inf or NaN
2446 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2447 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2448 (inst and ah-tn #x02) ; Test sign of Inf.
2449 (inst jmp :z DONE) ; +Inf gives +Inf.
2450 (inst fstp fr0) ; -Inf gives 0
2452 (inst jmp-short DONE)
2457 ;; Now fr0=x log2(e)
2461 (inst fsubp-sti fr1)
2464 (inst faddp-sti fr1)
2468 (unless (zerop (tn-offset y))
2471 ;;; Expm1 = exp(x) - 1.
2472 ;;; Handles the following special cases:
2473 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2474 (define-vop (fexpm1)
2476 (:args (x :scs (double-reg) :target fr0))
2477 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2478 (:temporary (:sc double-reg :offset fr0-offset
2479 :from :argument :to :result) fr0)
2480 (:temporary (:sc double-reg :offset fr1-offset
2481 :from :argument :to :result) fr1)
2482 (:temporary (:sc double-reg :offset fr2-offset
2483 :from :argument :to :result) fr2)
2484 (:results (y :scs (double-reg)))
2485 (:arg-types double-float)
2486 (:result-types double-float)
2487 (:policy :fast-safe)
2488 (:note "inline expm1 function")
2490 (:save-p :compute-only)
2493 (note-this-location vop :internal-error)
2494 (unless (zerop (tn-offset x))
2495 (inst fxch x) ; x to top of stack
2496 (unless (location= x y)
2497 (inst fst x))) ; maybe save it
2498 ;; Check for Inf or NaN
2502 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2503 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2504 (inst and ah-tn #x02) ; Test sign of Inf.
2505 (inst jmp :z DONE) ; +Inf gives +Inf.
2506 (inst fstp fr0) ; -Inf gives -1.0
2509 (inst jmp-short DONE)
2511 ;; Free two stack slots leaving the argument on top.
2515 (inst fmul fr1) ; Now fr0 = x log2(e)
2530 (unless (zerop (tn-offset y))
2535 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2536 (:temporary (:sc double-reg :offset fr0-offset
2537 :from :argument :to :result) fr0)
2538 (:temporary (:sc double-reg :offset fr1-offset
2539 :from :argument :to :result) fr1)
2540 (:results (y :scs (double-reg)))
2541 (:arg-types double-float)
2542 (:result-types double-float)
2543 (:policy :fast-safe)
2544 (:note "inline log function")
2546 (:save-p :compute-only)
2548 (note-this-location vop :internal-error)
2563 ;; x is in a FP reg, not fr0 or fr1
2567 (inst fldd (make-random-tn :kind :normal
2568 :sc (sc-or-lose 'double-reg)
2569 :offset (1- (tn-offset x))))))
2571 ((double-stack descriptor-reg)
2575 (if (sc-is x double-stack)
2576 (inst fldd (ea-for-df-stack x))
2577 (inst fldd (ea-for-df-desc x)))
2582 (t (inst fstd y)))))
2584 (define-vop (flog10)
2586 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2587 (:temporary (:sc double-reg :offset fr0-offset
2588 :from :argument :to :result) fr0)
2589 (:temporary (:sc double-reg :offset fr1-offset
2590 :from :argument :to :result) fr1)
2591 (:results (y :scs (double-reg)))
2592 (:arg-types double-float)
2593 (:result-types double-float)
2594 (:policy :fast-safe)
2595 (:note "inline log10 function")
2597 (:save-p :compute-only)
2599 (note-this-location vop :internal-error)
2614 ;; x is in a FP reg, not fr0 or fr1
2618 (inst fldd (make-random-tn :kind :normal
2619 :sc (sc-or-lose 'double-reg)
2620 :offset (1- (tn-offset x))))))
2622 ((double-stack descriptor-reg)
2626 (if (sc-is x double-stack)
2627 (inst fldd (ea-for-df-stack x))
2628 (inst fldd (ea-for-df-desc x)))
2633 (t (inst fstd y)))))
2637 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2638 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2639 (:temporary (:sc double-reg :offset fr0-offset
2640 :from (:argument 0) :to :result) fr0)
2641 (:temporary (:sc double-reg :offset fr1-offset
2642 :from (:argument 1) :to :result) fr1)
2643 (:temporary (:sc double-reg :offset fr2-offset
2644 :from :load :to :result) fr2)
2645 (:results (r :scs (double-reg)))
2646 (:arg-types double-float double-float)
2647 (:result-types double-float)
2648 (:policy :fast-safe)
2649 (:note "inline pow function")
2651 (:save-p :compute-only)
2653 (note-this-location vop :internal-error)
2654 ;; Setup x in fr0 and y in fr1
2656 ;; x in fr0; y in fr1
2657 ((and (sc-is x double-reg) (zerop (tn-offset x))
2658 (sc-is y double-reg) (= 1 (tn-offset y))))
2659 ;; y in fr1; x not in fr0
2660 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2664 (copy-fp-reg-to-fr0 x))
2667 (inst fldd (ea-for-df-stack x)))
2670 (inst fldd (ea-for-df-desc x)))))
2671 ;; x in fr0; y not in fr1
2672 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2674 ;; Now load y to fr0
2677 (copy-fp-reg-to-fr0 y))
2680 (inst fldd (ea-for-df-stack y)))
2683 (inst fldd (ea-for-df-desc y))))
2685 ;; x in fr1; y not in fr1
2686 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2690 (copy-fp-reg-to-fr0 y))
2693 (inst fldd (ea-for-df-stack y)))
2696 (inst fldd (ea-for-df-desc y))))
2699 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2701 ;; Now load x to fr0
2704 (copy-fp-reg-to-fr0 x))
2707 (inst fldd (ea-for-df-stack x)))
2710 (inst fldd (ea-for-df-desc x)))))
2711 ;; Neither x or y are in either fr0 or fr1
2718 (inst fldd (make-random-tn :kind :normal
2719 :sc (sc-or-lose 'double-reg)
2720 :offset (- (tn-offset y) 2))))
2722 (inst fldd (ea-for-df-stack y)))
2724 (inst fldd (ea-for-df-desc y))))
2728 (inst fldd (make-random-tn :kind :normal
2729 :sc (sc-or-lose 'double-reg)
2730 :offset (1- (tn-offset x)))))
2732 (inst fldd (ea-for-df-stack x)))
2734 (inst fldd (ea-for-df-desc x))))))
2736 ;; Now have x at fr0; and y at fr1
2738 ;; Now fr0=y log2(x)
2742 (inst fsubp-sti fr1)
2745 (inst faddp-sti fr1)
2750 (t (inst fstd r)))))
2752 (define-vop (fscalen)
2753 (:translate %scalbn)
2754 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2755 (y :scs (signed-stack signed-reg) :target temp))
2756 (:temporary (:sc double-reg :offset fr0-offset
2757 :from (:argument 0) :to :result) fr0)
2758 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2759 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2760 (:results (r :scs (double-reg)))
2761 (:arg-types double-float signed-num)
2762 (:result-types double-float)
2763 (:policy :fast-safe)
2764 (:note "inline scalbn function")
2766 ;; Setup x in fr0 and y in fr1
2797 (inst fld (make-random-tn :kind :normal
2798 :sc (sc-or-lose 'double-reg)
2799 :offset (1- (tn-offset x)))))))
2800 ((double-stack descriptor-reg)
2809 (if (sc-is x double-stack)
2810 (inst fldd (ea-for-df-stack x))
2811 (inst fldd (ea-for-df-desc x)))))
2813 (unless (zerop (tn-offset r))
2816 (define-vop (fscale)
2818 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2819 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2820 (:temporary (:sc double-reg :offset fr0-offset
2821 :from (:argument 0) :to :result) fr0)
2822 (:temporary (:sc double-reg :offset fr1-offset
2823 :from (:argument 1) :to :result) fr1)
2824 (:results (r :scs (double-reg)))
2825 (:arg-types double-float double-float)
2826 (:result-types double-float)
2827 (:policy :fast-safe)
2828 (:note "inline scalb function")
2830 (:save-p :compute-only)
2832 (note-this-location vop :internal-error)
2833 ;; Setup x in fr0 and y in fr1
2835 ;; x in fr0; y in fr1
2836 ((and (sc-is x double-reg) (zerop (tn-offset x))
2837 (sc-is y double-reg) (= 1 (tn-offset y))))
2838 ;; y in fr1; x not in fr0
2839 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2843 (copy-fp-reg-to-fr0 x))
2846 (inst fldd (ea-for-df-stack x)))
2849 (inst fldd (ea-for-df-desc x)))))
2850 ;; x in fr0; y not in fr1
2851 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2853 ;; Now load y to fr0
2856 (copy-fp-reg-to-fr0 y))
2859 (inst fldd (ea-for-df-stack y)))
2862 (inst fldd (ea-for-df-desc y))))
2864 ;; x in fr1; y not in fr1
2865 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2869 (copy-fp-reg-to-fr0 y))
2872 (inst fldd (ea-for-df-stack y)))
2875 (inst fldd (ea-for-df-desc y))))
2878 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2880 ;; Now load x to fr0
2883 (copy-fp-reg-to-fr0 x))
2886 (inst fldd (ea-for-df-stack x)))
2889 (inst fldd (ea-for-df-desc x)))))
2890 ;; Neither x or y are in either fr0 or fr1
2897 (inst fldd (make-random-tn :kind :normal
2898 :sc (sc-or-lose 'double-reg)
2899 :offset (- (tn-offset y) 2))))
2901 (inst fldd (ea-for-df-stack y)))
2903 (inst fldd (ea-for-df-desc y))))
2907 (inst fldd (make-random-tn :kind :normal
2908 :sc (sc-or-lose 'double-reg)
2909 :offset (1- (tn-offset x)))))
2911 (inst fldd (ea-for-df-stack x)))
2913 (inst fldd (ea-for-df-desc x))))))
2915 ;; Now have x at fr0; and y at fr1
2917 (unless (zerop (tn-offset r))
2920 (define-vop (flog1p)
2922 (:args (x :scs (double-reg) :to :result))
2923 (:temporary (:sc double-reg :offset fr0-offset
2924 :from :argument :to :result) fr0)
2925 (:temporary (:sc double-reg :offset fr1-offset
2926 :from :argument :to :result) fr1)
2927 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2928 (:results (y :scs (double-reg)))
2929 (:arg-types double-float)
2930 (:result-types double-float)
2931 (:policy :fast-safe)
2932 (:note "inline log1p function")
2935 ;; x is in a FP reg, not fr0, fr1.
2938 (inst fldd (make-random-tn :kind :normal
2939 :sc (sc-or-lose 'double-reg)
2940 :offset (- (tn-offset x) 2)))
2942 (inst push #x3e947ae1) ; Constant 0.29
2944 (inst fld (make-ea :dword :base esp-tn))
2947 (inst fnstsw) ; status word to ax
2948 (inst and ah-tn #x45)
2949 (inst jmp :z WITHIN-RANGE)
2950 ;; Out of range for fyl2xp1.
2952 (inst faddd (make-random-tn :kind :normal
2953 :sc (sc-or-lose 'double-reg)
2954 :offset (- (tn-offset x) 1)))
2962 (inst fldd (make-random-tn :kind :normal
2963 :sc (sc-or-lose 'double-reg)
2964 :offset (- (tn-offset x) 1)))
2970 (t (inst fstd y)))))
2972 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2973 ;;; instruction and a range check can be avoided.
2974 (define-vop (flog1p-pentium)
2976 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2977 (:temporary (:sc double-reg :offset fr0-offset
2978 :from :argument :to :result) fr0)
2979 (:temporary (:sc double-reg :offset fr1-offset
2980 :from :argument :to :result) fr1)
2981 (:results (y :scs (double-reg)))
2982 (:arg-types double-float)
2983 (:result-types double-float)
2984 (:policy :fast-safe)
2985 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2986 (:note "inline log1p with limited x range function")
2988 (:save-p :compute-only)
2990 (note-this-location vop :internal-error)
3005 ;; x is in a FP reg, not fr0 or fr1
3009 (inst fldd (make-random-tn :kind :normal
3010 :sc (sc-or-lose 'double-reg)
3011 :offset (1- (tn-offset x)))))))
3012 ((double-stack descriptor-reg)
3016 (if (sc-is x double-stack)
3017 (inst fldd (ea-for-df-stack x))
3018 (inst fldd (ea-for-df-desc x)))))
3023 (t (inst fstd y)))))
3027 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3028 (:temporary (:sc double-reg :offset fr0-offset
3029 :from :argument :to :result) fr0)
3030 (:temporary (:sc double-reg :offset fr1-offset
3031 :from :argument :to :result) fr1)
3032 (:results (y :scs (double-reg)))
3033 (:arg-types double-float)
3034 (:result-types double-float)
3035 (:policy :fast-safe)
3036 (:note "inline logb function")
3038 (:save-p :compute-only)
3040 (note-this-location vop :internal-error)
3051 ;; x is in a FP reg, not fr0 or fr1
3054 (inst fldd (make-random-tn :kind :normal
3055 :sc (sc-or-lose 'double-reg)
3056 :offset (- (tn-offset x) 2))))))
3057 ((double-stack descriptor-reg)
3060 (if (sc-is x double-stack)
3061 (inst fldd (ea-for-df-stack x))
3062 (inst fldd (ea-for-df-desc x)))))
3073 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3074 (:temporary (:sc double-reg :offset fr0-offset
3075 :from (:argument 0) :to :result) fr0)
3076 (:temporary (:sc double-reg :offset fr1-offset
3077 :from (:argument 0) :to :result) fr1)
3078 (:results (r :scs (double-reg)))
3079 (:arg-types double-float)
3080 (:result-types double-float)
3081 (:policy :fast-safe)
3082 (:note "inline atan function")
3084 (:save-p :compute-only)
3086 (note-this-location vop :internal-error)
3087 ;; Setup x in fr1 and 1.0 in fr0
3090 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3093 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3095 ;; x not in fr0 or fr1
3102 (inst fldd (make-random-tn :kind :normal
3103 :sc (sc-or-lose 'double-reg)
3104 :offset (- (tn-offset x) 2))))
3106 (inst fldd (ea-for-df-stack x)))
3108 (inst fldd (ea-for-df-desc x))))))
3110 ;; Now have x at fr1; and 1.0 at fr0
3115 (t (inst fstd r)))))
3117 (define-vop (fatan2)
3119 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3120 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3121 (:temporary (:sc double-reg :offset fr0-offset
3122 :from (:argument 1) :to :result) fr0)
3123 (:temporary (:sc double-reg :offset fr1-offset
3124 :from (:argument 0) :to :result) fr1)
3125 (:results (r :scs (double-reg)))
3126 (:arg-types double-float double-float)
3127 (:result-types double-float)
3128 (:policy :fast-safe)
3129 (:note "inline atan2 function")
3131 (:save-p :compute-only)
3133 (note-this-location vop :internal-error)
3134 ;; Setup x in fr1 and y in fr0
3136 ;; y in fr0; x in fr1
3137 ((and (sc-is y double-reg) (zerop (tn-offset y))
3138 (sc-is x double-reg) (= 1 (tn-offset x))))
3139 ;; x in fr1; y not in fr0
3140 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3144 (copy-fp-reg-to-fr0 y))
3147 (inst fldd (ea-for-df-stack y)))
3150 (inst fldd (ea-for-df-desc y)))))
3151 ;; y in fr0; x not in fr1
3152 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3154 ;; Now load x to fr0
3157 (copy-fp-reg-to-fr0 x))
3160 (inst fldd (ea-for-df-stack x)))
3163 (inst fldd (ea-for-df-desc x))))
3165 ;; y in fr1; x not in fr1
3166 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3170 (copy-fp-reg-to-fr0 x))
3173 (inst fldd (ea-for-df-stack x)))
3176 (inst fldd (ea-for-df-desc x))))
3179 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3181 ;; Now load y to fr0
3184 (copy-fp-reg-to-fr0 y))
3187 (inst fldd (ea-for-df-stack y)))
3190 (inst fldd (ea-for-df-desc y)))))
3191 ;; Neither y or x are in either fr0 or fr1
3198 (inst fldd (make-random-tn :kind :normal
3199 :sc (sc-or-lose 'double-reg)
3200 :offset (- (tn-offset x) 2))))
3202 (inst fldd (ea-for-df-stack x)))
3204 (inst fldd (ea-for-df-desc x))))
3208 (inst fldd (make-random-tn :kind :normal
3209 :sc (sc-or-lose 'double-reg)
3210 :offset (1- (tn-offset y)))))
3212 (inst fldd (ea-for-df-stack y)))
3214 (inst fldd (ea-for-df-desc y))))))
3216 ;; Now have y at fr0; and x at fr1
3221 (t (inst fstd r)))))
3222 ) ; PROGN #!-LONG-FLOAT
3227 ;;; Lets use some of the 80387 special functions.
3229 ;;; These defs will not take effect unless code/irrat.lisp is modified
3230 ;;; to remove the inlined alien routine def.
3232 (macrolet ((frob (func trans op)
3233 `(define-vop (,func)
3234 (:args (x :scs (long-reg) :target fr0))
3235 (:temporary (:sc long-reg :offset fr0-offset
3236 :from :argument :to :result) fr0)
3238 (:results (y :scs (long-reg)))
3239 (:arg-types long-float)
3240 (:result-types long-float)
3242 (:policy :fast-safe)
3243 (:note "inline NPX function")
3245 (:save-p :compute-only)
3248 (note-this-location vop :internal-error)
3249 (unless (zerop (tn-offset x))
3250 (inst fxch x) ; x to top of stack
3251 (unless (location= x y)
3252 (inst fst x))) ; maybe save it
3253 (inst ,op) ; clobber st0
3254 (cond ((zerop (tn-offset y))
3255 (maybe-fp-wait node))
3259 ;; Quick versions of FSIN and FCOS that require the argument to be
3260 ;; within range 2^63.
3261 (frob fsin-quick %sin-quick fsin)
3262 (frob fcos-quick %cos-quick fcos)
3263 (frob fsqrt %sqrt fsqrt))
3265 ;;; Quick version of ftan that requires the argument to be within
3267 (define-vop (ftan-quick)
3268 (:translate %tan-quick)
3269 (:args (x :scs (long-reg) :target fr0))
3270 (:temporary (:sc long-reg :offset fr0-offset
3271 :from :argument :to :result) fr0)
3272 (:temporary (:sc long-reg :offset fr1-offset
3273 :from :argument :to :result) fr1)
3274 (:results (y :scs (long-reg)))
3275 (:arg-types long-float)
3276 (:result-types long-float)
3277 (:policy :fast-safe)
3278 (:note "inline tan function")
3280 (:save-p :compute-only)
3282 (note-this-location vop :internal-error)
3291 (inst fldd (make-random-tn :kind :normal
3292 :sc (sc-or-lose 'double-reg)
3293 :offset (- (tn-offset x) 2)))))
3304 ;;; These versions of fsin, fcos, and ftan try to use argument
3305 ;;; reduction but to do this accurately requires greater precision and
3306 ;;; it is hopelessly inaccurate.
3308 (macrolet ((frob (func trans op)
3309 `(define-vop (,func)
3311 (:args (x :scs (long-reg) :target fr0))
3312 (:temporary (:sc unsigned-reg :offset eax-offset
3313 :from :eval :to :result) eax)
3314 (:temporary (:sc long-reg :offset fr0-offset
3315 :from :argument :to :result) fr0)
3316 (:temporary (:sc long-reg :offset fr1-offset
3317 :from :argument :to :result) fr1)
3318 (:results (y :scs (long-reg)))
3319 (:arg-types long-float)
3320 (:result-types long-float)
3321 (:policy :fast-safe)
3322 (:note "inline sin/cos function")
3324 (:save-p :compute-only)
3327 (note-this-location vop :internal-error)
3328 (unless (zerop (tn-offset x))
3329 (inst fxch x) ; x to top of stack
3330 (unless (location= x y)
3331 (inst fst x))) ; maybe save it
3333 (inst fnstsw) ; status word to ax
3334 (inst and ah-tn #x04) ; C2
3336 ;; Else x was out of range so reduce it; ST0 is unchanged.
3337 (inst fstp fr1) ; Load 2*PI
3343 (inst fnstsw) ; status word to ax
3344 (inst and ah-tn #x04) ; C2
3348 (unless (zerop (tn-offset y))
3350 (frob fsin %sin fsin)
3351 (frob fcos %cos fcos))
3356 (:args (x :scs (long-reg) :target fr0))
3357 (:temporary (:sc unsigned-reg :offset eax-offset
3358 :from :argument :to :result) eax)
3359 (:temporary (:sc long-reg :offset fr0-offset
3360 :from :argument :to :result) fr0)
3361 (:temporary (:sc long-reg :offset fr1-offset
3362 :from :argument :to :result) fr1)
3363 (:results (y :scs (long-reg)))
3364 (:arg-types long-float)
3365 (:result-types long-float)
3366 (:policy :fast-safe)
3367 (:note "inline tan function")
3369 (:save-p :compute-only)
3372 (note-this-location vop :internal-error)
3381 (inst fldd (make-random-tn :kind :normal
3382 :sc (sc-or-lose 'double-reg)
3383 :offset (- (tn-offset x) 2)))))
3385 (inst fnstsw) ; status word to ax
3386 (inst and ah-tn #x04) ; C2
3388 ;; Else x was out of range so reduce it; ST0 is unchanged.
3389 (inst fldpi) ; Load 2*PI
3394 (inst fnstsw) ; status word to ax
3395 (inst and ah-tn #x04) ; C2
3409 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3410 ;;; the argument is out of range 2^63 and would thus be hopelessly
3412 (macrolet ((frob (func trans op)
3413 `(define-vop (,func)
3415 (:args (x :scs (long-reg) :target fr0))
3416 (:temporary (:sc long-reg :offset fr0-offset
3417 :from :argument :to :result) fr0)
3418 (:temporary (:sc unsigned-reg :offset eax-offset
3419 :from :argument :to :result) eax)
3420 (:results (y :scs (long-reg)))
3421 (:arg-types long-float)
3422 (:result-types long-float)
3423 (:policy :fast-safe)
3424 (:note "inline sin/cos function")
3426 (:save-p :compute-only)
3429 (note-this-location vop :internal-error)
3430 (unless (zerop (tn-offset x))
3431 (inst fxch x) ; x to top of stack
3432 (unless (location= x y)
3433 (inst fst x))) ; maybe save it
3435 (inst fnstsw) ; status word to ax
3436 (inst and ah-tn #x04) ; C2
3438 ;; Else x was out of range so reduce it; ST0 is unchanged.
3439 (inst fstp fr0) ; Load 0.0
3442 (unless (zerop (tn-offset y))
3444 (frob fsin %sin fsin)
3445 (frob fcos %cos fcos))
3449 (:args (x :scs (long-reg) :target fr0))
3450 (:temporary (:sc long-reg :offset fr0-offset
3451 :from :argument :to :result) fr0)
3452 (:temporary (:sc long-reg :offset fr1-offset
3453 :from :argument :to :result) fr1)
3454 (:temporary (:sc unsigned-reg :offset eax-offset
3455 :from :argument :to :result) eax)
3456 (:results (y :scs (long-reg)))
3457 (:arg-types long-float)
3458 (:result-types long-float)
3460 (:policy :fast-safe)
3461 (:note "inline tan function")
3463 (:save-p :compute-only)
3466 (note-this-location vop :internal-error)
3475 (inst fldd (make-random-tn :kind :normal
3476 :sc (sc-or-lose 'double-reg)
3477 :offset (- (tn-offset x) 2)))))
3479 (inst fnstsw) ; status word to ax
3480 (inst and ah-tn #x04) ; C2
3482 ;; Else x was out of range so reduce it; ST0 is unchanged.
3483 (inst fldz) ; Load 0.0
3495 ;;; Modified exp that handles the following special cases:
3496 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3499 (:args (x :scs (long-reg) :target fr0))
3500 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3501 (:temporary (:sc long-reg :offset fr0-offset
3502 :from :argument :to :result) fr0)
3503 (:temporary (:sc long-reg :offset fr1-offset
3504 :from :argument :to :result) fr1)
3505 (:temporary (:sc long-reg :offset fr2-offset
3506 :from :argument :to :result) fr2)
3507 (:results (y :scs (long-reg)))
3508 (:arg-types long-float)
3509 (:result-types long-float)
3510 (:policy :fast-safe)
3511 (:note "inline exp function")
3513 (:save-p :compute-only)
3516 (note-this-location vop :internal-error)
3517 (unless (zerop (tn-offset x))
3518 (inst fxch x) ; x to top of stack
3519 (unless (location= x y)
3520 (inst fst x))) ; maybe save it
3521 ;; Check for Inf or NaN
3525 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3526 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3527 (inst and ah-tn #x02) ; Test sign of Inf.
3528 (inst jmp :z DONE) ; +Inf gives +Inf.
3529 (inst fstp fr0) ; -Inf gives 0
3531 (inst jmp-short DONE)
3536 ;; Now fr0=x log2(e)
3540 (inst fsubp-sti fr1)
3543 (inst faddp-sti fr1)
3547 (unless (zerop (tn-offset y))
3550 ;;; Expm1 = exp(x) - 1.
3551 ;;; Handles the following special cases:
3552 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3553 (define-vop (fexpm1)
3555 (:args (x :scs (long-reg) :target fr0))
3556 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3557 (:temporary (:sc long-reg :offset fr0-offset
3558 :from :argument :to :result) fr0)
3559 (:temporary (:sc long-reg :offset fr1-offset
3560 :from :argument :to :result) fr1)
3561 (:temporary (:sc long-reg :offset fr2-offset
3562 :from :argument :to :result) fr2)
3563 (:results (y :scs (long-reg)))
3564 (:arg-types long-float)
3565 (:result-types long-float)
3566 (:policy :fast-safe)
3567 (:note "inline expm1 function")
3569 (:save-p :compute-only)
3572 (note-this-location vop :internal-error)
3573 (unless (zerop (tn-offset x))
3574 (inst fxch x) ; x to top of stack
3575 (unless (location= x y)
3576 (inst fst x))) ; maybe save it
3577 ;; Check for Inf or NaN
3581 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3582 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3583 (inst and ah-tn #x02) ; Test sign of Inf.
3584 (inst jmp :z DONE) ; +Inf gives +Inf.
3585 (inst fstp fr0) ; -Inf gives -1.0
3588 (inst jmp-short DONE)
3590 ;; Free two stack slots leaving the argument on top.
3594 (inst fmul fr1) ; Now fr0 = x log2(e)
3609 (unless (zerop (tn-offset y))
3614 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3615 (:temporary (:sc long-reg :offset fr0-offset
3616 :from :argument :to :result) fr0)
3617 (:temporary (:sc long-reg :offset fr1-offset
3618 :from :argument :to :result) fr1)
3619 (:results (y :scs (long-reg)))
3620 (:arg-types long-float)
3621 (:result-types long-float)
3622 (:policy :fast-safe)
3623 (:note "inline log function")
3625 (:save-p :compute-only)
3627 (note-this-location vop :internal-error)
3642 ;; x is in a FP reg, not fr0 or fr1
3646 (inst fldd (make-random-tn :kind :normal
3647 :sc (sc-or-lose 'double-reg)
3648 :offset (1- (tn-offset x))))))
3650 ((long-stack descriptor-reg)
3654 (if (sc-is x long-stack)
3655 (inst fldl (ea-for-lf-stack x))
3656 (inst fldl (ea-for-lf-desc x)))
3661 (t (inst fstd y)))))
3663 (define-vop (flog10)
3665 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3666 (:temporary (:sc long-reg :offset fr0-offset
3667 :from :argument :to :result) fr0)
3668 (:temporary (:sc long-reg :offset fr1-offset
3669 :from :argument :to :result) fr1)
3670 (:results (y :scs (long-reg)))
3671 (:arg-types long-float)
3672 (:result-types long-float)
3673 (:policy :fast-safe)
3674 (:note "inline log10 function")
3676 (:save-p :compute-only)
3678 (note-this-location vop :internal-error)
3693 ;; x is in a FP reg, not fr0 or fr1
3697 (inst fldd (make-random-tn :kind :normal
3698 :sc (sc-or-lose 'double-reg)
3699 :offset (1- (tn-offset x))))))
3701 ((long-stack descriptor-reg)
3705 (if (sc-is x long-stack)
3706 (inst fldl (ea-for-lf-stack x))
3707 (inst fldl (ea-for-lf-desc x)))
3712 (t (inst fstd y)))))
3716 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3717 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3718 (:temporary (:sc long-reg :offset fr0-offset
3719 :from (:argument 0) :to :result) fr0)
3720 (:temporary (:sc long-reg :offset fr1-offset
3721 :from (:argument 1) :to :result) fr1)
3722 (:temporary (:sc long-reg :offset fr2-offset
3723 :from :load :to :result) fr2)
3724 (:results (r :scs (long-reg)))
3725 (:arg-types long-float long-float)
3726 (:result-types long-float)
3727 (:policy :fast-safe)
3728 (:note "inline pow function")
3730 (:save-p :compute-only)
3732 (note-this-location vop :internal-error)
3733 ;; Setup x in fr0 and y in fr1
3735 ;; x in fr0; y in fr1
3736 ((and (sc-is x long-reg) (zerop (tn-offset x))
3737 (sc-is y long-reg) (= 1 (tn-offset y))))
3738 ;; y in fr1; x not in fr0
3739 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3743 (copy-fp-reg-to-fr0 x))
3746 (inst fldl (ea-for-lf-stack x)))
3749 (inst fldl (ea-for-lf-desc x)))))
3750 ;; x in fr0; y not in fr1
3751 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3753 ;; Now load y to fr0
3756 (copy-fp-reg-to-fr0 y))
3759 (inst fldl (ea-for-lf-stack y)))
3762 (inst fldl (ea-for-lf-desc y))))
3764 ;; x in fr1; y not in fr1
3765 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3769 (copy-fp-reg-to-fr0 y))
3772 (inst fldl (ea-for-lf-stack y)))
3775 (inst fldl (ea-for-lf-desc y))))
3778 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3780 ;; Now load x to fr0
3783 (copy-fp-reg-to-fr0 x))
3786 (inst fldl (ea-for-lf-stack x)))
3789 (inst fldl (ea-for-lf-desc x)))))
3790 ;; Neither x or y are in either fr0 or fr1
3797 (inst fldd (make-random-tn :kind :normal
3798 :sc (sc-or-lose 'double-reg)
3799 :offset (- (tn-offset y) 2))))
3801 (inst fldl (ea-for-lf-stack y)))
3803 (inst fldl (ea-for-lf-desc y))))
3807 (inst fldd (make-random-tn :kind :normal
3808 :sc (sc-or-lose 'double-reg)
3809 :offset (1- (tn-offset x)))))
3811 (inst fldl (ea-for-lf-stack x)))
3813 (inst fldl (ea-for-lf-desc x))))))
3815 ;; Now have x at fr0; and y at fr1
3817 ;; Now fr0=y log2(x)
3821 (inst fsubp-sti fr1)
3824 (inst faddp-sti fr1)
3829 (t (inst fstd r)))))
3831 (define-vop (fscalen)
3832 (:translate %scalbn)
3833 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3834 (y :scs (signed-stack signed-reg) :target temp))
3835 (:temporary (:sc long-reg :offset fr0-offset
3836 :from (:argument 0) :to :result) fr0)
3837 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3838 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3839 (:results (r :scs (long-reg)))
3840 (:arg-types long-float signed-num)
3841 (:result-types long-float)
3842 (:policy :fast-safe)
3843 (:note "inline scalbn function")
3845 ;; Setup x in fr0 and y in fr1
3876 (inst fld (make-random-tn :kind :normal
3877 :sc (sc-or-lose 'double-reg)
3878 :offset (1- (tn-offset x)))))))
3879 ((long-stack descriptor-reg)
3888 (if (sc-is x long-stack)
3889 (inst fldl (ea-for-lf-stack x))
3890 (inst fldl (ea-for-lf-desc x)))))
3892 (unless (zerop (tn-offset r))
3895 (define-vop (fscale)
3897 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3898 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3899 (:temporary (:sc long-reg :offset fr0-offset
3900 :from (:argument 0) :to :result) fr0)
3901 (:temporary (:sc long-reg :offset fr1-offset
3902 :from (:argument 1) :to :result) fr1)
3903 (:results (r :scs (long-reg)))
3904 (:arg-types long-float long-float)
3905 (:result-types long-float)
3906 (:policy :fast-safe)
3907 (:note "inline scalb function")
3909 (:save-p :compute-only)
3911 (note-this-location vop :internal-error)
3912 ;; Setup x in fr0 and y in fr1
3914 ;; x in fr0; y in fr1
3915 ((and (sc-is x long-reg) (zerop (tn-offset x))
3916 (sc-is y long-reg) (= 1 (tn-offset y))))
3917 ;; y in fr1; x not in fr0
3918 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3922 (copy-fp-reg-to-fr0 x))
3925 (inst fldl (ea-for-lf-stack x)))
3928 (inst fldl (ea-for-lf-desc x)))))
3929 ;; x in fr0; y not in fr1
3930 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3932 ;; Now load y to fr0
3935 (copy-fp-reg-to-fr0 y))
3938 (inst fldl (ea-for-lf-stack y)))
3941 (inst fldl (ea-for-lf-desc y))))
3943 ;; x in fr1; y not in fr1
3944 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3948 (copy-fp-reg-to-fr0 y))
3951 (inst fldl (ea-for-lf-stack y)))
3954 (inst fldl (ea-for-lf-desc y))))
3957 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3959 ;; Now load x to fr0
3962 (copy-fp-reg-to-fr0 x))
3965 (inst fldl (ea-for-lf-stack x)))
3968 (inst fldl (ea-for-lf-desc x)))))
3969 ;; Neither x or y are in either fr0 or fr1
3976 (inst fldd (make-random-tn :kind :normal
3977 :sc (sc-or-lose 'double-reg)
3978 :offset (- (tn-offset y) 2))))
3980 (inst fldl (ea-for-lf-stack y)))
3982 (inst fldl (ea-for-lf-desc y))))
3986 (inst fldd (make-random-tn :kind :normal
3987 :sc (sc-or-lose 'double-reg)
3988 :offset (1- (tn-offset x)))))
3990 (inst fldl (ea-for-lf-stack x)))
3992 (inst fldl (ea-for-lf-desc x))))))
3994 ;; Now have x at fr0; and y at fr1
3996 (unless (zerop (tn-offset r))
3999 (define-vop (flog1p)
4001 (:args (x :scs (long-reg) :to :result))
4002 (:temporary (:sc long-reg :offset fr0-offset
4003 :from :argument :to :result) fr0)
4004 (:temporary (:sc long-reg :offset fr1-offset
4005 :from :argument :to :result) fr1)
4006 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
4007 (:results (y :scs (long-reg)))
4008 (:arg-types long-float)
4009 (:result-types long-float)
4010 (:policy :fast-safe)
4011 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
4012 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
4013 ;; an enormous PROGN above. Still, it would be probably be good to
4014 ;; add some code to warn about redefining VOPs.
4015 ;; FIXME 2: See comments on DEFINE-VOP FLOG1P :GUARD above.
4016 (:guard #!+pentium nil #!-pentium t)
4017 (:note "inline log1p function")
4020 ;; x is in a FP reg, not fr0, fr1.
4023 (inst fldd (make-random-tn :kind :normal
4024 :sc (sc-or-lose 'double-reg)
4025 :offset (- (tn-offset x) 2)))
4027 (inst push #x3e947ae1) ; Constant 0.29
4029 (inst fld (make-ea :dword :base esp-tn))
4032 (inst fnstsw) ; status word to ax
4033 (inst and ah-tn #x45)
4034 (inst jmp :z WITHIN-RANGE)
4035 ;; Out of range for fyl2xp1.
4037 (inst faddd (make-random-tn :kind :normal
4038 :sc (sc-or-lose 'double-reg)
4039 :offset (- (tn-offset x) 1)))
4047 (inst fldd (make-random-tn :kind :normal
4048 :sc (sc-or-lose 'double-reg)
4049 :offset (- (tn-offset x) 1)))
4055 (t (inst fstd y)))))
4057 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4058 ;;; instruction and a range check can be avoided.
4059 (define-vop (flog1p-pentium)
4061 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4062 (:temporary (:sc long-reg :offset fr0-offset
4063 :from :argument :to :result) fr0)
4064 (:temporary (:sc long-reg :offset fr1-offset
4065 :from :argument :to :result) fr1)
4066 (:results (y :scs (long-reg)))
4067 (:arg-types long-float)
4068 (:result-types long-float)
4069 (:policy :fast-safe)
4070 ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
4071 (:guard #!+pentium t #!-pentium)
4072 (:note "inline log1p function")
4088 ;; x is in a FP reg, not fr0 or fr1
4092 (inst fldd (make-random-tn :kind :normal
4093 :sc (sc-or-lose 'double-reg)
4094 :offset (1- (tn-offset x)))))))
4095 ((long-stack descriptor-reg)
4099 (if (sc-is x long-stack)
4100 (inst fldl (ea-for-lf-stack x))
4101 (inst fldl (ea-for-lf-desc x)))))
4106 (t (inst fstd y)))))
4110 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4111 (:temporary (:sc long-reg :offset fr0-offset
4112 :from :argument :to :result) fr0)
4113 (:temporary (:sc long-reg :offset fr1-offset
4114 :from :argument :to :result) fr1)
4115 (:results (y :scs (long-reg)))
4116 (:arg-types long-float)
4117 (:result-types long-float)
4118 (:policy :fast-safe)
4119 (:note "inline logb function")
4121 (:save-p :compute-only)
4123 (note-this-location vop :internal-error)
4134 ;; x is in a FP reg, not fr0 or fr1
4137 (inst fldd (make-random-tn :kind :normal
4138 :sc (sc-or-lose 'double-reg)
4139 :offset (- (tn-offset x) 2))))))
4140 ((long-stack descriptor-reg)
4143 (if (sc-is x long-stack)
4144 (inst fldl (ea-for-lf-stack x))
4145 (inst fldl (ea-for-lf-desc x)))))
4156 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4157 (:temporary (:sc long-reg :offset fr0-offset
4158 :from (:argument 0) :to :result) fr0)
4159 (:temporary (:sc long-reg :offset fr1-offset
4160 :from (:argument 0) :to :result) fr1)
4161 (:results (r :scs (long-reg)))
4162 (:arg-types long-float)
4163 (:result-types long-float)
4164 (:policy :fast-safe)
4165 (:note "inline atan function")
4167 (:save-p :compute-only)
4169 (note-this-location vop :internal-error)
4170 ;; Setup x in fr1 and 1.0 in fr0
4173 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4176 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4178 ;; x not in fr0 or fr1
4185 (inst fldd (make-random-tn :kind :normal
4186 :sc (sc-or-lose 'double-reg)
4187 :offset (- (tn-offset x) 2))))
4189 (inst fldl (ea-for-lf-stack x)))
4191 (inst fldl (ea-for-lf-desc x))))))
4193 ;; Now have x at fr1; and 1.0 at fr0
4198 (t (inst fstd r)))))
4200 (define-vop (fatan2)
4202 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4203 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4204 (:temporary (:sc long-reg :offset fr0-offset
4205 :from (:argument 1) :to :result) fr0)
4206 (:temporary (:sc long-reg :offset fr1-offset
4207 :from (:argument 0) :to :result) fr1)
4208 (:results (r :scs (long-reg)))
4209 (:arg-types long-float long-float)
4210 (:result-types long-float)
4211 (:policy :fast-safe)
4212 (:note "inline atan2 function")
4214 (:save-p :compute-only)
4216 (note-this-location vop :internal-error)
4217 ;; Setup x in fr1 and y in fr0
4219 ;; y in fr0; x in fr1
4220 ((and (sc-is y long-reg) (zerop (tn-offset y))
4221 (sc-is x long-reg) (= 1 (tn-offset x))))
4222 ;; x in fr1; y not in fr0
4223 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4227 (copy-fp-reg-to-fr0 y))
4230 (inst fldl (ea-for-lf-stack y)))
4233 (inst fldl (ea-for-lf-desc y)))))
4234 ;; y in fr0; x not in fr1
4235 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4237 ;; Now load x to fr0
4240 (copy-fp-reg-to-fr0 x))
4243 (inst fldl (ea-for-lf-stack x)))
4246 (inst fldl (ea-for-lf-desc x))))
4248 ;; y in fr1; x not in fr1
4249 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4253 (copy-fp-reg-to-fr0 x))
4256 (inst fldl (ea-for-lf-stack x)))
4259 (inst fldl (ea-for-lf-desc x))))
4262 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4264 ;; Now load y to fr0
4267 (copy-fp-reg-to-fr0 y))
4270 (inst fldl (ea-for-lf-stack y)))
4273 (inst fldl (ea-for-lf-desc y)))))
4274 ;; Neither y or x are in either fr0 or fr1
4281 (inst fldd (make-random-tn :kind :normal
4282 :sc (sc-or-lose 'double-reg)
4283 :offset (- (tn-offset x) 2))))
4285 (inst fldl (ea-for-lf-stack x)))
4287 (inst fldl (ea-for-lf-desc x))))
4291 (inst fldd (make-random-tn :kind :normal
4292 :sc (sc-or-lose 'double-reg)
4293 :offset (1- (tn-offset y)))))
4295 (inst fldl (ea-for-lf-stack y)))
4297 (inst fldl (ea-for-lf-desc y))))))
4299 ;; Now have y at fr0; and x at fr1
4304 (t (inst fstd r)))))
4306 ) ; PROGN #!+LONG-FLOAT
4308 ;;;; complex float VOPs
4310 (define-vop (make-complex-single-float)
4311 (:translate complex)
4312 (:args (real :scs (single-reg) :to :result :target r
4313 :load-if (not (location= real r)))
4314 (imag :scs (single-reg) :to :save))
4315 (:arg-types single-float single-float)
4316 (:results (r :scs (complex-single-reg) :from (:argument 0)
4317 :load-if (not (sc-is r complex-single-stack))))
4318 (:result-types complex-single-float)
4319 (:note "inline complex single-float creation")
4320 (:policy :fast-safe)
4324 (let ((r-real (complex-double-reg-real-tn r)))
4325 (unless (location= real r-real)
4326 (cond ((zerop (tn-offset r-real))
4327 (copy-fp-reg-to-fr0 real))
4328 ((zerop (tn-offset real))
4333 (inst fxch real)))))
4334 (let ((r-imag (complex-double-reg-imag-tn r)))
4335 (unless (location= imag r-imag)
4336 (cond ((zerop (tn-offset imag))
4341 (inst fxch imag))))))
4342 (complex-single-stack
4343 (unless (location= real r)
4344 (cond ((zerop (tn-offset real))
4345 (inst fst (ea-for-csf-real-stack r)))
4348 (inst fst (ea-for-csf-real-stack r))
4351 (inst fst (ea-for-csf-imag-stack r))
4352 (inst fxch imag)))))
4354 (define-vop (make-complex-double-float)
4355 (:translate complex)
4356 (:args (real :scs (double-reg) :target r
4357 :load-if (not (location= real r)))
4358 (imag :scs (double-reg) :to :save))
4359 (:arg-types double-float double-float)
4360 (:results (r :scs (complex-double-reg) :from (:argument 0)
4361 :load-if (not (sc-is r complex-double-stack))))
4362 (:result-types complex-double-float)
4363 (:note "inline complex double-float creation")
4364 (:policy :fast-safe)
4368 (let ((r-real (complex-double-reg-real-tn r)))
4369 (unless (location= real r-real)
4370 (cond ((zerop (tn-offset r-real))
4371 (copy-fp-reg-to-fr0 real))
4372 ((zerop (tn-offset real))
4377 (inst fxch real)))))
4378 (let ((r-imag (complex-double-reg-imag-tn r)))
4379 (unless (location= imag r-imag)
4380 (cond ((zerop (tn-offset imag))
4385 (inst fxch imag))))))
4386 (complex-double-stack
4387 (unless (location= real r)
4388 (cond ((zerop (tn-offset real))
4389 (inst fstd (ea-for-cdf-real-stack r)))
4392 (inst fstd (ea-for-cdf-real-stack r))
4395 (inst fstd (ea-for-cdf-imag-stack r))
4396 (inst fxch imag)))))
4399 (define-vop (make-complex-long-float)
4400 (:translate complex)
4401 (:args (real :scs (long-reg) :target r
4402 :load-if (not (location= real r)))
4403 (imag :scs (long-reg) :to :save))
4404 (:arg-types long-float long-float)
4405 (:results (r :scs (complex-long-reg) :from (:argument 0)
4406 :load-if (not (sc-is r complex-long-stack))))
4407 (:result-types complex-long-float)
4408 (:note "inline complex long-float creation")
4409 (:policy :fast-safe)
4413 (let ((r-real (complex-double-reg-real-tn r)))
4414 (unless (location= real r-real)
4415 (cond ((zerop (tn-offset r-real))
4416 (copy-fp-reg-to-fr0 real))
4417 ((zerop (tn-offset real))
4422 (inst fxch real)))))
4423 (let ((r-imag (complex-double-reg-imag-tn r)))
4424 (unless (location= imag r-imag)
4425 (cond ((zerop (tn-offset imag))
4430 (inst fxch imag))))))
4432 (unless (location= real r)
4433 (cond ((zerop (tn-offset real))
4434 (store-long-float (ea-for-clf-real-stack r)))
4437 (store-long-float (ea-for-clf-real-stack r))
4440 (store-long-float (ea-for-clf-imag-stack r))
4441 (inst fxch imag)))))
4444 (define-vop (complex-float-value)
4445 (:args (x :target r))
4447 (:variant-vars offset)
4448 (:policy :fast-safe)
4450 (cond ((sc-is x complex-single-reg complex-double-reg
4451 #!+long-float complex-long-reg)
4453 (make-random-tn :kind :normal
4454 :sc (sc-or-lose 'double-reg)
4455 :offset (+ offset (tn-offset x)))))
4456 (unless (location= value-tn r)
4457 (cond ((zerop (tn-offset r))
4458 (copy-fp-reg-to-fr0 value-tn))
4459 ((zerop (tn-offset value-tn))
4462 (inst fxch value-tn)
4464 (inst fxch value-tn))))))
4465 ((sc-is r single-reg)
4466 (let ((ea (sc-case x
4467 (complex-single-stack
4469 (0 (ea-for-csf-real-stack x))
4470 (1 (ea-for-csf-imag-stack x))))
4473 (0 (ea-for-csf-real-desc x))
4474 (1 (ea-for-csf-imag-desc x)))))))
4475 (with-empty-tn@fp-top(r)
4477 ((sc-is r double-reg)
4478 (let ((ea (sc-case x
4479 (complex-double-stack
4481 (0 (ea-for-cdf-real-stack x))
4482 (1 (ea-for-cdf-imag-stack x))))
4485 (0 (ea-for-cdf-real-desc x))
4486 (1 (ea-for-cdf-imag-desc x)))))))
4487 (with-empty-tn@fp-top(r)
4491 (let ((ea (sc-case x
4494 (0 (ea-for-clf-real-stack x))
4495 (1 (ea-for-clf-imag-stack x))))
4498 (0 (ea-for-clf-real-desc x))
4499 (1 (ea-for-clf-imag-desc x)))))))
4500 (with-empty-tn@fp-top(r)
4502 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4504 (define-vop (realpart/complex-single-float complex-float-value)
4505 (:translate realpart)
4506 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4508 (:arg-types complex-single-float)
4509 (:results (r :scs (single-reg)))
4510 (:result-types single-float)
4511 (:note "complex float realpart")
4514 (define-vop (realpart/complex-double-float complex-float-value)
4515 (:translate realpart)
4516 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4518 (:arg-types complex-double-float)
4519 (:results (r :scs (double-reg)))
4520 (:result-types double-float)
4521 (:note "complex float realpart")
4525 (define-vop (realpart/complex-long-float complex-float-value)
4526 (:translate realpart)
4527 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4529 (:arg-types complex-long-float)
4530 (:results (r :scs (long-reg)))
4531 (:result-types long-float)
4532 (:note "complex float realpart")
4535 (define-vop (imagpart/complex-single-float complex-float-value)
4536 (:translate imagpart)
4537 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4539 (:arg-types complex-single-float)
4540 (:results (r :scs (single-reg)))
4541 (:result-types single-float)
4542 (:note "complex float imagpart")
4545 (define-vop (imagpart/complex-double-float complex-float-value)
4546 (:translate imagpart)
4547 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4549 (:arg-types complex-double-float)
4550 (:results (r :scs (double-reg)))
4551 (:result-types double-float)
4552 (:note "complex float imagpart")
4556 (define-vop (imagpart/complex-long-float complex-float-value)
4557 (:translate imagpart)
4558 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4560 (:arg-types complex-long-float)
4561 (:results (r :scs (long-reg)))
4562 (:result-types long-float)
4563 (:note "complex float imagpart")
4566 ;;; hack dummy VOPs to bias the representation selection of their
4567 ;;; arguments towards a FP register, which can help avoid consing at
4568 ;;; inappropriate locations
4569 (defknown double-float-reg-bias (double-float) (values))
4570 (define-vop (double-float-reg-bias)
4571 (:translate double-float-reg-bias)
4572 (:args (x :scs (double-reg double-stack) :load-if nil))
4573 (:arg-types double-float)
4574 (:policy :fast-safe)
4575 (:note "inline dummy FP register bias")
4578 (defknown single-float-reg-bias (single-float) (values))
4579 (define-vop (single-float-reg-bias)
4580 (:translate single-float-reg-bias)
4581 (:args (x :scs (single-reg single-stack) :load-if nil))
4582 (:arg-types single-float)
4583 (:policy :fast-safe)
4584 (:note "inline dummy FP register bias")