1 ;;;; floating point support for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (macrolet ((ea-for-xf-desc (tn slot)
17 :disp (- (* ,slot n-word-bytes)
18 other-pointer-lowtag))))
19 (defun ea-for-sf-desc (tn)
20 (ea-for-xf-desc tn single-float-value-slot))
21 (defun ea-for-df-desc (tn)
22 (ea-for-xf-desc tn double-float-value-slot))
24 (defun ea-for-lf-desc (tn)
25 (ea-for-xf-desc tn long-float-value-slot))
27 (defun ea-for-csf-real-desc (tn)
28 (ea-for-xf-desc tn complex-single-float-real-slot))
29 (defun ea-for-csf-imag-desc (tn)
30 (ea-for-xf-desc tn complex-single-float-imag-slot))
31 (defun ea-for-cdf-real-desc (tn)
32 (ea-for-xf-desc tn complex-double-float-real-slot))
33 (defun ea-for-cdf-imag-desc (tn)
34 (ea-for-xf-desc tn complex-double-float-imag-slot))
36 (defun ea-for-clf-real-desc (tn)
37 (ea-for-xf-desc tn complex-long-float-real-slot))
39 (defun ea-for-clf-imag-desc (tn)
40 (ea-for-xf-desc tn complex-long-float-imag-slot)))
42 (macrolet ((ea-for-xf-stack (tn kind)
45 :disp (- (* (+ (tn-offset ,tn)
46 (ecase ,kind (:single 1) (:double 2) (:long 3)))
48 (defun ea-for-sf-stack (tn)
49 (ea-for-xf-stack tn :single))
50 (defun ea-for-df-stack (tn)
51 (ea-for-xf-stack tn :double))
53 (defun ea-for-lf-stack (tn)
54 (ea-for-xf-stack tn :long)))
56 ;;; Telling the FPU to wait is required in order to make signals occur
57 ;;; at the expected place, but naturally slows things down.
59 ;;; NODE is the node whose compilation policy controls the decision
60 ;;; whether to just blast through carelessly or carefully emit wait
61 ;;; instructions and whatnot.
63 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
64 ;;; #'NOTE-NEXT-INSTRUCTION.
66 ;;; Until 2004-03-15, the implementation of this was buggy; it
67 ;;; unconditionally emitted the WAIT instruction. It turns out that
68 ;;; this is the right thing to do anyway; omitting them can lead to
69 ;;; system corruption on conforming code. -- CSR
70 (defun maybe-fp-wait (node &optional note-next-instruction)
71 (declare (ignore node))
73 (when (policy node (or (= debug 3) (> safety speed))))
74 (when note-next-instruction
75 (note-next-instruction note-next-instruction :internal-error))
78 ;;; complex float stack EAs
79 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
82 :disp (- (* (+ (tn-offset ,tn)
87 (ecase ,slot (:real 1) (:imag 2))))
89 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
90 (ea-for-cxf-stack tn :single :real base))
91 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
92 (ea-for-cxf-stack tn :single :imag base))
93 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
94 (ea-for-cxf-stack tn :double :real base))
95 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
96 (ea-for-cxf-stack tn :double :imag base))
98 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
99 (ea-for-cxf-stack tn :long :real base))
101 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
102 (ea-for-cxf-stack tn :long :imag base)))
104 ;;; Abstract out the copying of a FP register to the FP stack top, and
105 ;;; provide two alternatives for its implementation. Note: it's not
106 ;;; necessary to distinguish between a single or double register move
109 ;;; Using a Pop then load.
110 (defun copy-fp-reg-to-fr0 (reg)
111 (aver (not (zerop (tn-offset reg))))
113 (inst fld (make-random-tn :kind :normal
114 :sc (sc-or-lose 'double-reg)
115 :offset (1- (tn-offset reg)))))
116 ;;; Using Fxch then Fst to restore the original reg contents.
118 (defun copy-fp-reg-to-fr0 (reg)
119 (aver (not (zerop (tn-offset reg))))
123 ;;; The x86 can't store a long-float to memory without popping the
124 ;;; stack and marking a register as empty, so it is necessary to
125 ;;; restore the register from memory.
127 (defun store-long-float (ea)
133 ;;; X is source, Y is destination.
134 (define-move-fun (load-single 2) (vop x y)
135 ((single-stack) (single-reg))
136 (with-empty-tn@fp-top(y)
137 (inst fld (ea-for-sf-stack x))))
139 (define-move-fun (store-single 2) (vop x y)
140 ((single-reg) (single-stack))
141 (cond ((zerop (tn-offset x))
142 (inst fst (ea-for-sf-stack y)))
145 (inst fst (ea-for-sf-stack y))
146 ;; This may not be necessary as ST0 is likely invalid now.
149 (define-move-fun (load-double 2) (vop x y)
150 ((double-stack) (double-reg))
151 (with-empty-tn@fp-top(y)
152 (inst fldd (ea-for-df-stack x))))
154 (define-move-fun (store-double 2) (vop x y)
155 ((double-reg) (double-stack))
156 (cond ((zerop (tn-offset x))
157 (inst fstd (ea-for-df-stack y)))
160 (inst fstd (ea-for-df-stack y))
161 ;; This may not be necessary as ST0 is likely invalid now.
165 (define-move-fun (load-long 2) (vop x y)
166 ((long-stack) (long-reg))
167 (with-empty-tn@fp-top(y)
168 (inst fldl (ea-for-lf-stack x))))
171 (define-move-fun (store-long 2) (vop x y)
172 ((long-reg) (long-stack))
173 (cond ((zerop (tn-offset x))
174 (store-long-float (ea-for-lf-stack y)))
177 (store-long-float (ea-for-lf-stack y))
178 ;; This may not be necessary as ST0 is likely invalid now.
181 ;;; The i387 has instructions to load some useful constants. This
182 ;;; doesn't save much time but might cut down on memory access and
183 ;;; reduce the size of the constant vector (CV). Intel claims they are
184 ;;; stored in a more precise form on chip. Anyhow, might as well use
185 ;;; the feature. It can be turned off by hacking the
186 ;;; "immediate-constant-sc" in vm.lisp.
187 (eval-when (:compile-toplevel :execute)
188 (setf *read-default-float-format*
189 #!+long-float 'long-float #!-long-float 'double-float))
190 (define-move-fun (load-fp-constant 2) (vop x y)
191 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
192 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
193 (with-empty-tn@fp-top(y)
198 ((= value (coerce pi *read-default-float-format*))
200 ((= value (log 10e0 2e0))
202 ((= value (log 2.718281828459045235360287471352662e0 2e0))
204 ((= value (log 2e0 10e0))
206 ((= value (log 2e0 2.718281828459045235360287471352662e0))
208 (t (warn "ignoring bogus i387 constant ~A" value))))))
209 (eval-when (:compile-toplevel :execute)
210 (setf *read-default-float-format* 'single-float))
212 ;;;; complex float move functions
214 (defun complex-single-reg-real-tn (x)
215 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
216 :offset (tn-offset x)))
217 (defun complex-single-reg-imag-tn (x)
218 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
219 :offset (1+ (tn-offset x))))
221 (defun complex-double-reg-real-tn (x)
222 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
223 :offset (tn-offset x)))
224 (defun complex-double-reg-imag-tn (x)
225 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
226 :offset (1+ (tn-offset x))))
229 (defun complex-long-reg-real-tn (x)
230 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
231 :offset (tn-offset x)))
233 (defun complex-long-reg-imag-tn (x)
234 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
235 :offset (1+ (tn-offset x))))
237 ;;; X is source, Y is destination.
238 (define-move-fun (load-complex-single 2) (vop x y)
239 ((complex-single-stack) (complex-single-reg))
240 (let ((real-tn (complex-single-reg-real-tn y)))
241 (with-empty-tn@fp-top (real-tn)
242 (inst fld (ea-for-csf-real-stack x))))
243 (let ((imag-tn (complex-single-reg-imag-tn y)))
244 (with-empty-tn@fp-top (imag-tn)
245 (inst fld (ea-for-csf-imag-stack x)))))
247 (define-move-fun (store-complex-single 2) (vop x y)
248 ((complex-single-reg) (complex-single-stack))
249 (let ((real-tn (complex-single-reg-real-tn x)))
250 (cond ((zerop (tn-offset real-tn))
251 (inst fst (ea-for-csf-real-stack y)))
254 (inst fst (ea-for-csf-real-stack y))
255 (inst fxch real-tn))))
256 (let ((imag-tn (complex-single-reg-imag-tn x)))
258 (inst fst (ea-for-csf-imag-stack y))
259 (inst fxch imag-tn)))
261 (define-move-fun (load-complex-double 2) (vop x y)
262 ((complex-double-stack) (complex-double-reg))
263 (let ((real-tn (complex-double-reg-real-tn y)))
264 (with-empty-tn@fp-top(real-tn)
265 (inst fldd (ea-for-cdf-real-stack x))))
266 (let ((imag-tn (complex-double-reg-imag-tn y)))
267 (with-empty-tn@fp-top(imag-tn)
268 (inst fldd (ea-for-cdf-imag-stack x)))))
270 (define-move-fun (store-complex-double 2) (vop x y)
271 ((complex-double-reg) (complex-double-stack))
272 (let ((real-tn (complex-double-reg-real-tn x)))
273 (cond ((zerop (tn-offset real-tn))
274 (inst fstd (ea-for-cdf-real-stack y)))
277 (inst fstd (ea-for-cdf-real-stack y))
278 (inst fxch real-tn))))
279 (let ((imag-tn (complex-double-reg-imag-tn x)))
281 (inst fstd (ea-for-cdf-imag-stack y))
282 (inst fxch imag-tn)))
285 (define-move-fun (load-complex-long 2) (vop x y)
286 ((complex-long-stack) (complex-long-reg))
287 (let ((real-tn (complex-long-reg-real-tn y)))
288 (with-empty-tn@fp-top(real-tn)
289 (inst fldl (ea-for-clf-real-stack x))))
290 (let ((imag-tn (complex-long-reg-imag-tn y)))
291 (with-empty-tn@fp-top(imag-tn)
292 (inst fldl (ea-for-clf-imag-stack x)))))
295 (define-move-fun (store-complex-long 2) (vop x y)
296 ((complex-long-reg) (complex-long-stack))
297 (let ((real-tn (complex-long-reg-real-tn x)))
298 (cond ((zerop (tn-offset real-tn))
299 (store-long-float (ea-for-clf-real-stack y)))
302 (store-long-float (ea-for-clf-real-stack y))
303 (inst fxch real-tn))))
304 (let ((imag-tn (complex-long-reg-imag-tn x)))
306 (store-long-float (ea-for-clf-imag-stack y))
307 (inst fxch imag-tn)))
312 ;;; float register to register moves
313 (define-vop (float-move)
318 (unless (location= x y)
319 (cond ((zerop (tn-offset y))
320 (copy-fp-reg-to-fr0 x))
321 ((zerop (tn-offset x))
328 (define-vop (single-move float-move)
329 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
330 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
331 (define-move-vop single-move :move (single-reg) (single-reg))
333 (define-vop (double-move float-move)
334 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
335 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
336 (define-move-vop double-move :move (double-reg) (double-reg))
339 (define-vop (long-move float-move)
340 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
341 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
343 (define-move-vop long-move :move (long-reg) (long-reg))
345 ;;; complex float register to register moves
346 (define-vop (complex-float-move)
347 (:args (x :target y :load-if (not (location= x y))))
348 (:results (y :load-if (not (location= x y))))
349 (:note "complex float move")
351 (unless (location= x y)
352 ;; Note the complex-float-regs are aligned to every second
353 ;; float register so there is not need to worry about overlap.
354 (let ((x-real (complex-double-reg-real-tn x))
355 (y-real (complex-double-reg-real-tn y)))
356 (cond ((zerop (tn-offset y-real))
357 (copy-fp-reg-to-fr0 x-real))
358 ((zerop (tn-offset x-real))
363 (inst fxch x-real))))
364 (let ((x-imag (complex-double-reg-imag-tn x))
365 (y-imag (complex-double-reg-imag-tn y)))
368 (inst fxch x-imag)))))
370 (define-vop (complex-single-move complex-float-move)
371 (:args (x :scs (complex-single-reg) :target y
372 :load-if (not (location= x y))))
373 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
374 (define-move-vop complex-single-move :move
375 (complex-single-reg) (complex-single-reg))
377 (define-vop (complex-double-move complex-float-move)
378 (:args (x :scs (complex-double-reg)
379 :target y :load-if (not (location= x y))))
380 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
381 (define-move-vop complex-double-move :move
382 (complex-double-reg) (complex-double-reg))
385 (define-vop (complex-long-move complex-float-move)
386 (:args (x :scs (complex-long-reg)
387 :target y :load-if (not (location= x y))))
388 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
390 (define-move-vop complex-long-move :move
391 (complex-long-reg) (complex-long-reg))
393 ;;; Move from float to a descriptor reg. allocating a new float
394 ;;; object in the process.
395 (define-vop (move-from-single)
396 (:args (x :scs (single-reg) :to :save))
397 (:results (y :scs (descriptor-reg)))
399 (:note "float to pointer coercion")
401 (with-fixed-allocation (y
403 single-float-size node)
405 (inst fst (ea-for-sf-desc y))))))
406 (define-move-vop move-from-single :move
407 (single-reg) (descriptor-reg))
409 (define-vop (move-from-double)
410 (:args (x :scs (double-reg) :to :save))
411 (:results (y :scs (descriptor-reg)))
413 (:note "float to pointer coercion")
415 (with-fixed-allocation (y
420 (inst fstd (ea-for-df-desc y))))))
421 (define-move-vop move-from-double :move
422 (double-reg) (descriptor-reg))
425 (define-vop (move-from-long)
426 (:args (x :scs (long-reg) :to :save))
427 (:results (y :scs (descriptor-reg)))
429 (:note "float to pointer coercion")
431 (with-fixed-allocation (y
436 (store-long-float (ea-for-lf-desc y))))))
438 (define-move-vop move-from-long :move
439 (long-reg) (descriptor-reg))
441 (define-vop (move-from-fp-constant)
442 (:args (x :scs (fp-constant)))
443 (:results (y :scs (descriptor-reg)))
445 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
446 (0f0 (load-symbol-value y *fp-constant-0f0*))
447 (1f0 (load-symbol-value y *fp-constant-1f0*))
448 (0d0 (load-symbol-value y *fp-constant-0d0*))
449 (1d0 (load-symbol-value y *fp-constant-1d0*))
451 (0l0 (load-symbol-value y *fp-constant-0l0*))
453 (1l0 (load-symbol-value y *fp-constant-1l0*))
455 (#.pi (load-symbol-value y *fp-constant-pi*))
457 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
459 (#.(log 2.718281828459045235360287471352662L0 2l0)
460 (load-symbol-value y *fp-constant-l2e*))
462 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
464 (#.(log 2l0 2.718281828459045235360287471352662L0)
465 (load-symbol-value y *fp-constant-ln2*)))))
466 (define-move-vop move-from-fp-constant :move
467 (fp-constant) (descriptor-reg))
469 ;;; Move from a descriptor to a float register.
470 (define-vop (move-to-single)
471 (:args (x :scs (descriptor-reg)))
472 (:results (y :scs (single-reg)))
473 (:note "pointer to float coercion")
475 (with-empty-tn@fp-top(y)
476 (inst fld (ea-for-sf-desc x)))))
477 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
479 (define-vop (move-to-double)
480 (:args (x :scs (descriptor-reg)))
481 (:results (y :scs (double-reg)))
482 (:note "pointer to float coercion")
484 (with-empty-tn@fp-top(y)
485 (inst fldd (ea-for-df-desc x)))))
486 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
489 (define-vop (move-to-long)
490 (:args (x :scs (descriptor-reg)))
491 (:results (y :scs (long-reg)))
492 (:note "pointer to float coercion")
494 (with-empty-tn@fp-top(y)
495 (inst fldl (ea-for-lf-desc x)))))
497 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
499 ;;; Move from complex float to a descriptor reg. allocating a new
500 ;;; complex float object in the process.
501 (define-vop (move-from-complex-single)
502 (:args (x :scs (complex-single-reg) :to :save))
503 (:results (y :scs (descriptor-reg)))
505 (:note "complex float to pointer coercion")
507 (with-fixed-allocation (y
508 complex-single-float-widetag
509 complex-single-float-size
511 (let ((real-tn (complex-single-reg-real-tn x)))
512 (with-tn@fp-top(real-tn)
513 (inst fst (ea-for-csf-real-desc y))))
514 (let ((imag-tn (complex-single-reg-imag-tn x)))
515 (with-tn@fp-top(imag-tn)
516 (inst fst (ea-for-csf-imag-desc y)))))))
517 (define-move-vop move-from-complex-single :move
518 (complex-single-reg) (descriptor-reg))
520 (define-vop (move-from-complex-double)
521 (:args (x :scs (complex-double-reg) :to :save))
522 (:results (y :scs (descriptor-reg)))
524 (:note "complex float to pointer coercion")
526 (with-fixed-allocation (y
527 complex-double-float-widetag
528 complex-double-float-size
530 (let ((real-tn (complex-double-reg-real-tn x)))
531 (with-tn@fp-top(real-tn)
532 (inst fstd (ea-for-cdf-real-desc y))))
533 (let ((imag-tn (complex-double-reg-imag-tn x)))
534 (with-tn@fp-top(imag-tn)
535 (inst fstd (ea-for-cdf-imag-desc y)))))))
536 (define-move-vop move-from-complex-double :move
537 (complex-double-reg) (descriptor-reg))
540 (define-vop (move-from-complex-long)
541 (:args (x :scs (complex-long-reg) :to :save))
542 (:results (y :scs (descriptor-reg)))
544 (:note "complex float to pointer coercion")
546 (with-fixed-allocation (y
547 complex-long-float-widetag
548 complex-long-float-size
550 (let ((real-tn (complex-long-reg-real-tn x)))
551 (with-tn@fp-top(real-tn)
552 (store-long-float (ea-for-clf-real-desc y))))
553 (let ((imag-tn (complex-long-reg-imag-tn x)))
554 (with-tn@fp-top(imag-tn)
555 (store-long-float (ea-for-clf-imag-desc y)))))))
557 (define-move-vop move-from-complex-long :move
558 (complex-long-reg) (descriptor-reg))
560 ;;; Move from a descriptor to a complex float register.
561 (macrolet ((frob (name sc format)
564 (:args (x :scs (descriptor-reg)))
565 (:results (y :scs (,sc)))
566 (:note "pointer to complex float coercion")
568 (let ((real-tn (complex-double-reg-real-tn y)))
569 (with-empty-tn@fp-top(real-tn)
571 (:single '((inst fld (ea-for-csf-real-desc x))))
572 (:double '((inst fldd (ea-for-cdf-real-desc x))))
574 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
575 (let ((imag-tn (complex-double-reg-imag-tn y)))
576 (with-empty-tn@fp-top(imag-tn)
578 (:single '((inst fld (ea-for-csf-imag-desc x))))
579 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
581 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
582 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
583 (frob move-to-complex-single complex-single-reg :single)
584 (frob move-to-complex-double complex-double-reg :double)
586 (frob move-to-complex-double complex-long-reg :long))
588 ;;;; the move argument vops
590 ;;;; Note these are also used to stuff fp numbers onto the c-call
591 ;;;; stack so the order is different than the lisp-stack.
593 ;;; the general MOVE-ARG VOP
594 (macrolet ((frob (name sc stack-sc format)
597 (:args (x :scs (,sc) :target y)
599 :load-if (not (sc-is y ,sc))))
601 (:note "float argument move")
602 (:generator ,(case format (:single 2) (:double 3) (:long 4))
605 (unless (location= x y)
606 (cond ((zerop (tn-offset y))
607 (copy-fp-reg-to-fr0 x))
608 ((zerop (tn-offset x))
615 (if (= (tn-offset fp) esp-offset)
616 (let* ((offset (* (tn-offset y) n-word-bytes))
617 (ea (make-ea :dword :base fp :disp offset)))
620 (:single '((inst fst ea)))
621 (:double '((inst fstd ea)))
623 (:long '((store-long-float ea))))))
626 :disp (- (* (+ (tn-offset y)
634 (:single '((inst fst ea)))
635 (:double '((inst fstd ea)))
637 (:long '((store-long-float ea)))))))))))
638 (define-move-vop ,name :move-arg
639 (,sc descriptor-reg) (,sc)))))
640 (frob move-single-float-arg single-reg single-stack :single)
641 (frob move-double-float-arg double-reg double-stack :double)
643 (frob move-long-float-arg long-reg long-stack :long))
645 ;;;; complex float MOVE-ARG VOP
646 (macrolet ((frob (name sc stack-sc format)
649 (:args (x :scs (,sc) :target y)
651 :load-if (not (sc-is y ,sc))))
653 (:note "complex float argument move")
654 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
657 (unless (location= x y)
658 (let ((x-real (complex-double-reg-real-tn x))
659 (y-real (complex-double-reg-real-tn y)))
660 (cond ((zerop (tn-offset y-real))
661 (copy-fp-reg-to-fr0 x-real))
662 ((zerop (tn-offset x-real))
667 (inst fxch x-real))))
668 (let ((x-imag (complex-double-reg-imag-tn x))
669 (y-imag (complex-double-reg-imag-tn y)))
672 (inst fxch x-imag))))
674 (let ((real-tn (complex-double-reg-real-tn x)))
675 (cond ((zerop (tn-offset real-tn))
679 (ea-for-csf-real-stack y fp))))
682 (ea-for-cdf-real-stack y fp))))
686 (ea-for-clf-real-stack y fp))))))
692 (ea-for-csf-real-stack y fp))))
695 (ea-for-cdf-real-stack y fp))))
699 (ea-for-clf-real-stack y fp)))))
700 (inst fxch real-tn))))
701 (let ((imag-tn (complex-double-reg-imag-tn x)))
705 '((inst fst (ea-for-csf-imag-stack y fp))))
707 '((inst fstd (ea-for-cdf-imag-stack y fp))))
711 (ea-for-clf-imag-stack y fp)))))
712 (inst fxch imag-tn))))))
713 (define-move-vop ,name :move-arg
714 (,sc descriptor-reg) (,sc)))))
715 (frob move-complex-single-float-arg
716 complex-single-reg complex-single-stack :single)
717 (frob move-complex-double-float-arg
718 complex-double-reg complex-double-stack :double)
720 (frob move-complex-long-float-arg
721 complex-long-reg complex-long-stack :long))
723 (define-move-vop move-arg :move-arg
724 (single-reg double-reg #!+long-float long-reg
725 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
731 ;;; dtc: the floating point arithmetic vops
733 ;;; Note: Although these can accept x and y on the stack or pointed to
734 ;;; from a descriptor register, they will work with register loading
735 ;;; without these. Same deal with the result - it need only be a
736 ;;; register. When load-tns are needed they will probably be in ST0
737 ;;; and the code below should be able to correctly handle all cases.
739 ;;; However it seems to produce better code if all arg. and result
740 ;;; options are used; on the P86 there is no extra cost in using a
741 ;;; memory operand to the FP instructions - not so on the PPro.
743 ;;; It may also be useful to handle constant args?
745 ;;; 22-Jul-97: descriptor args lose in some simple cases when
746 ;;; a function result computed in a loop. Then Python insists
747 ;;; on consing the intermediate values! For example
750 (declare (type (simple-array double-float (*)) a)
753 (declare (type double-float sum))
755 (incf sum (* (aref a i)(aref a i))))
758 ;;; So, disabling descriptor args until this can be fixed elsewhere.
760 ((frob (op fop-sti fopr-sti
762 fopd foprd dname dcost
764 #!-long-float (declare (ignore lcost lname))
768 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
770 (y :scs (single-reg single-stack #+nil descriptor-reg)
772 (:temporary (:sc single-reg :offset fr0-offset
773 :from :eval :to :result) fr0)
774 (:results (r :scs (single-reg single-stack)))
775 (:arg-types single-float single-float)
776 (:result-types single-float)
778 (:note "inline float arithmetic")
780 (:save-p :compute-only)
783 ;; Handle a few special cases
785 ;; x, y, and r are the same register.
786 ((and (sc-is x single-reg) (location= x r) (location= y r))
787 (cond ((zerop (tn-offset r))
792 ;; XX the source register will not be valid.
793 (note-next-instruction vop :internal-error)
796 ;; x and r are the same register.
797 ((and (sc-is x single-reg) (location= x r))
798 (cond ((zerop (tn-offset r))
801 ;; ST(0) = ST(0) op ST(y)
804 ;; ST(0) = ST(0) op Mem
805 (inst ,fop (ea-for-sf-stack y)))
807 (inst ,fop (ea-for-sf-desc y)))))
812 (unless (zerop (tn-offset y))
813 (copy-fp-reg-to-fr0 y)))
814 ((single-stack descriptor-reg)
816 (if (sc-is y single-stack)
817 (inst fld (ea-for-sf-stack y))
818 (inst fld (ea-for-sf-desc y)))))
819 ;; ST(i) = ST(i) op ST0
821 (maybe-fp-wait node vop))
822 ;; y and r are the same register.
823 ((and (sc-is y single-reg) (location= y r))
824 (cond ((zerop (tn-offset r))
827 ;; ST(0) = ST(x) op ST(0)
830 ;; ST(0) = Mem op ST(0)
831 (inst ,fopr (ea-for-sf-stack x)))
833 (inst ,fopr (ea-for-sf-desc x)))))
838 (unless (zerop (tn-offset x))
839 (copy-fp-reg-to-fr0 x)))
840 ((single-stack descriptor-reg)
842 (if (sc-is x single-stack)
843 (inst fld (ea-for-sf-stack x))
844 (inst fld (ea-for-sf-desc x)))))
845 ;; ST(i) = ST(0) op ST(i)
847 (maybe-fp-wait node vop))
850 ;; Get the result to ST0.
852 ;; Special handling is needed if x or y are in ST0, and
853 ;; simpler code is generated.
856 ((and (sc-is x single-reg) (zerop (tn-offset x)))
862 (inst ,fop (ea-for-sf-stack y)))
864 (inst ,fop (ea-for-sf-desc y)))))
866 ((and (sc-is y single-reg) (zerop (tn-offset y)))
872 (inst ,fopr (ea-for-sf-stack x)))
874 (inst ,fopr (ea-for-sf-desc x)))))
879 (copy-fp-reg-to-fr0 x))
882 (inst fld (ea-for-sf-stack x)))
885 (inst fld (ea-for-sf-desc x))))
891 (inst ,fop (ea-for-sf-stack y)))
893 (inst ,fop (ea-for-sf-desc y))))))
895 (note-next-instruction vop :internal-error)
897 ;; Finally save the result.
900 (cond ((zerop (tn-offset r))
901 (maybe-fp-wait node))
905 (inst fst (ea-for-sf-stack r))))))))
909 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
911 (y :scs (double-reg double-stack #+nil descriptor-reg)
913 (:temporary (:sc double-reg :offset fr0-offset
914 :from :eval :to :result) fr0)
915 (:results (r :scs (double-reg double-stack)))
916 (:arg-types double-float double-float)
917 (:result-types double-float)
919 (:note "inline float arithmetic")
921 (:save-p :compute-only)
924 ;; Handle a few special cases.
926 ;; x, y, and r are the same register.
927 ((and (sc-is x double-reg) (location= x r) (location= y r))
928 (cond ((zerop (tn-offset r))
933 ;; XX the source register will not be valid.
934 (note-next-instruction vop :internal-error)
937 ;; x and r are the same register.
938 ((and (sc-is x double-reg) (location= x r))
939 (cond ((zerop (tn-offset r))
942 ;; ST(0) = ST(0) op ST(y)
945 ;; ST(0) = ST(0) op Mem
946 (inst ,fopd (ea-for-df-stack y)))
948 (inst ,fopd (ea-for-df-desc y)))))
953 (unless (zerop (tn-offset y))
954 (copy-fp-reg-to-fr0 y)))
955 ((double-stack descriptor-reg)
957 (if (sc-is y double-stack)
958 (inst fldd (ea-for-df-stack y))
959 (inst fldd (ea-for-df-desc y)))))
960 ;; ST(i) = ST(i) op ST0
962 (maybe-fp-wait node vop))
963 ;; y and r are the same register.
964 ((and (sc-is y double-reg) (location= y r))
965 (cond ((zerop (tn-offset r))
968 ;; ST(0) = ST(x) op ST(0)
971 ;; ST(0) = Mem op ST(0)
972 (inst ,foprd (ea-for-df-stack x)))
974 (inst ,foprd (ea-for-df-desc x)))))
979 (unless (zerop (tn-offset x))
980 (copy-fp-reg-to-fr0 x)))
981 ((double-stack descriptor-reg)
983 (if (sc-is x double-stack)
984 (inst fldd (ea-for-df-stack x))
985 (inst fldd (ea-for-df-desc x)))))
986 ;; ST(i) = ST(0) op ST(i)
988 (maybe-fp-wait node vop))
991 ;; Get the result to ST0.
993 ;; Special handling is needed if x or y are in ST0, and
994 ;; simpler code is generated.
997 ((and (sc-is x double-reg) (zerop (tn-offset x)))
1003 (inst ,fopd (ea-for-df-stack y)))
1005 (inst ,fopd (ea-for-df-desc y)))))
1007 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1013 (inst ,foprd (ea-for-df-stack x)))
1015 (inst ,foprd (ea-for-df-desc x)))))
1020 (copy-fp-reg-to-fr0 x))
1023 (inst fldd (ea-for-df-stack x)))
1026 (inst fldd (ea-for-df-desc x))))
1032 (inst ,fopd (ea-for-df-stack y)))
1034 (inst ,fopd (ea-for-df-desc y))))))
1036 (note-next-instruction vop :internal-error)
1038 ;; Finally save the result.
1041 (cond ((zerop (tn-offset r))
1042 (maybe-fp-wait node))
1046 (inst fstd (ea-for-df-stack r))))))))
1049 (define-vop (,lname)
1051 (:args (x :scs (long-reg) :to :eval)
1052 (y :scs (long-reg) :to :eval))
1053 (:temporary (:sc long-reg :offset fr0-offset
1054 :from :eval :to :result) fr0)
1055 (:results (r :scs (long-reg)))
1056 (:arg-types long-float long-float)
1057 (:result-types long-float)
1058 (:policy :fast-safe)
1059 (:note "inline float arithmetic")
1061 (:save-p :compute-only)
1064 ;; Handle a few special cases.
1066 ;; x, y, and r are the same register.
1067 ((and (location= x r) (location= y r))
1068 (cond ((zerop (tn-offset r))
1073 ;; XX the source register will not be valid.
1074 (note-next-instruction vop :internal-error)
1077 ;; x and r are the same register.
1079 (cond ((zerop (tn-offset r))
1080 ;; ST(0) = ST(0) op ST(y)
1084 (unless (zerop (tn-offset y))
1085 (copy-fp-reg-to-fr0 y))
1086 ;; ST(i) = ST(i) op ST0
1088 (maybe-fp-wait node vop))
1089 ;; y and r are the same register.
1091 (cond ((zerop (tn-offset r))
1092 ;; ST(0) = ST(x) op ST(0)
1096 (unless (zerop (tn-offset x))
1097 (copy-fp-reg-to-fr0 x))
1098 ;; ST(i) = ST(0) op ST(i)
1099 (inst ,fopr-sti r)))
1100 (maybe-fp-wait node vop))
1103 ;; Get the result to ST0.
1105 ;; Special handling is needed if x or y are in ST0, and
1106 ;; simpler code is generated.
1109 ((zerop (tn-offset x))
1113 ((zerop (tn-offset y))
1118 (copy-fp-reg-to-fr0 x)
1122 (note-next-instruction vop :internal-error)
1124 ;; Finally save the result.
1125 (cond ((zerop (tn-offset r))
1126 (maybe-fp-wait node))
1128 (inst fst r))))))))))
1130 (frob + fadd-sti fadd-sti
1131 fadd fadd +/single-float 2
1132 faddd faddd +/double-float 2
1134 (frob - fsub-sti fsubr-sti
1135 fsub fsubr -/single-float 2
1136 fsubd fsubrd -/double-float 2
1138 (frob * fmul-sti fmul-sti
1139 fmul fmul */single-float 3
1140 fmuld fmuld */double-float 3
1142 (frob / fdiv-sti fdivr-sti
1143 fdiv fdivr //single-float 12
1144 fdivd fdivrd //double-float 12
1147 (macrolet ((frob (name inst translate sc type)
1148 `(define-vop (,name)
1149 (:args (x :scs (,sc) :target fr0))
1150 (:results (y :scs (,sc)))
1151 (:translate ,translate)
1152 (:policy :fast-safe)
1154 (:result-types ,type)
1155 (:temporary (:sc double-reg :offset fr0-offset
1156 :from :argument :to :result) fr0)
1158 (:note "inline float arithmetic")
1160 (:save-p :compute-only)
1162 (note-this-location vop :internal-error)
1163 (unless (zerop (tn-offset x))
1164 (inst fxch x) ; x to top of stack
1165 (unless (location= x y)
1166 (inst fst x))) ; Maybe save it.
1167 (inst ,inst) ; Clobber st0.
1168 (unless (zerop (tn-offset y))
1171 (frob abs/single-float fabs abs single-reg single-float)
1172 (frob abs/double-float fabs abs double-reg double-float)
1174 (frob abs/long-float fabs abs long-reg long-float)
1175 (frob %negate/single-float fchs %negate single-reg single-float)
1176 (frob %negate/double-float fchs %negate double-reg double-float)
1178 (frob %negate/long-float fchs %negate long-reg long-float))
1182 (define-vop (=/float)
1184 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1186 (:info target not-p)
1187 (:policy :fast-safe)
1189 (:save-p :compute-only)
1190 (:note "inline float comparison")
1193 (note-this-location vop :internal-error)
1195 ;; x is in ST0; y is in any reg.
1196 ((zerop (tn-offset x))
1198 ;; y is in ST0; x is in another reg.
1199 ((zerop (tn-offset y))
1201 ;; x and y are the same register, not ST0
1206 ;; x and y are different registers, neither ST0.
1211 (inst fnstsw) ; status word to ax
1212 (inst and ah-tn #x45) ; C3 C2 C0
1213 (inst cmp ah-tn #x40)
1214 (inst jmp (if not-p :ne :e) target)))
1216 (define-vop (=/single-float =/float)
1218 (:args (x :scs (single-reg))
1219 (y :scs (single-reg)))
1220 (:arg-types single-float single-float))
1222 (define-vop (=/double-float =/float)
1224 (:args (x :scs (double-reg))
1225 (y :scs (double-reg)))
1226 (:arg-types double-float double-float))
1229 (define-vop (=/long-float =/float)
1231 (:args (x :scs (long-reg))
1232 (y :scs (long-reg)))
1233 (:arg-types long-float long-float))
1235 (define-vop (<single-float)
1237 (:args (x :scs (single-reg single-stack descriptor-reg))
1238 (y :scs (single-reg single-stack descriptor-reg)))
1239 (:arg-types single-float single-float)
1240 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1241 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1243 (:info target not-p)
1244 (:policy :fast-safe)
1245 (:note "inline float comparison")
1248 ;; Handle a few special cases.
1251 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1255 ((single-stack descriptor-reg)
1256 (if (sc-is x single-stack)
1257 (inst fcom (ea-for-sf-stack x))
1258 (inst fcom (ea-for-sf-desc x)))))
1259 (inst fnstsw) ; status word to ax
1260 (inst and ah-tn #x45))
1262 ;; general case when y is not in ST0
1267 (unless (zerop (tn-offset x))
1268 (copy-fp-reg-to-fr0 x)))
1269 ((single-stack descriptor-reg)
1271 (if (sc-is x single-stack)
1272 (inst fld (ea-for-sf-stack x))
1273 (inst fld (ea-for-sf-desc x)))))
1277 ((single-stack descriptor-reg)
1278 (if (sc-is y single-stack)
1279 (inst fcom (ea-for-sf-stack y))
1280 (inst fcom (ea-for-sf-desc y)))))
1281 (inst fnstsw) ; status word to ax
1282 (inst and ah-tn #x45) ; C3 C2 C0
1283 (inst cmp ah-tn #x01)))
1284 (inst jmp (if not-p :ne :e) target)))
1286 (define-vop (<double-float)
1288 (:args (x :scs (double-reg double-stack descriptor-reg))
1289 (y :scs (double-reg double-stack descriptor-reg)))
1290 (:arg-types double-float double-float)
1291 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1292 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1294 (:info target not-p)
1295 (:policy :fast-safe)
1296 (:note "inline float comparison")
1299 ;; Handle a few special cases
1302 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1306 ((double-stack descriptor-reg)
1307 (if (sc-is x double-stack)
1308 (inst fcomd (ea-for-df-stack x))
1309 (inst fcomd (ea-for-df-desc x)))))
1310 (inst fnstsw) ; status word to ax
1311 (inst and ah-tn #x45))
1313 ;; General case when y is not in ST0.
1318 (unless (zerop (tn-offset x))
1319 (copy-fp-reg-to-fr0 x)))
1320 ((double-stack descriptor-reg)
1322 (if (sc-is x double-stack)
1323 (inst fldd (ea-for-df-stack x))
1324 (inst fldd (ea-for-df-desc x)))))
1328 ((double-stack descriptor-reg)
1329 (if (sc-is y double-stack)
1330 (inst fcomd (ea-for-df-stack y))
1331 (inst fcomd (ea-for-df-desc y)))))
1332 (inst fnstsw) ; status word to ax
1333 (inst and ah-tn #x45) ; C3 C2 C0
1334 (inst cmp ah-tn #x01)))
1335 (inst jmp (if not-p :ne :e) target)))
1338 (define-vop (<long-float)
1340 (:args (x :scs (long-reg))
1341 (y :scs (long-reg)))
1342 (:arg-types long-float long-float)
1343 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1345 (:info target not-p)
1346 (:policy :fast-safe)
1347 (:note "inline float comparison")
1351 ;; x is in ST0; y is in any reg.
1352 ((zerop (tn-offset x))
1354 (inst fnstsw) ; status word to ax
1355 (inst and ah-tn #x45) ; C3 C2 C0
1356 (inst cmp ah-tn #x01))
1357 ;; y is in ST0; x is in another reg.
1358 ((zerop (tn-offset y))
1360 (inst fnstsw) ; status word to ax
1361 (inst and ah-tn #x45))
1362 ;; x and y are the same register, not ST0
1363 ;; x and y are different registers, neither ST0.
1368 (inst fnstsw) ; status word to ax
1369 (inst and ah-tn #x45))) ; C3 C2 C0
1370 (inst jmp (if not-p :ne :e) target)))
1372 (define-vop (>single-float)
1374 (:args (x :scs (single-reg single-stack descriptor-reg))
1375 (y :scs (single-reg single-stack descriptor-reg)))
1376 (:arg-types single-float single-float)
1377 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1378 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1380 (:info target not-p)
1381 (:policy :fast-safe)
1382 (:note "inline float comparison")
1385 ;; Handle a few special cases.
1388 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1392 ((single-stack descriptor-reg)
1393 (if (sc-is x single-stack)
1394 (inst fcom (ea-for-sf-stack x))
1395 (inst fcom (ea-for-sf-desc x)))))
1396 (inst fnstsw) ; status word to ax
1397 (inst and ah-tn #x45)
1398 (inst cmp ah-tn #x01))
1400 ;; general case when y is not in ST0
1405 (unless (zerop (tn-offset x))
1406 (copy-fp-reg-to-fr0 x)))
1407 ((single-stack descriptor-reg)
1409 (if (sc-is x single-stack)
1410 (inst fld (ea-for-sf-stack x))
1411 (inst fld (ea-for-sf-desc x)))))
1415 ((single-stack descriptor-reg)
1416 (if (sc-is y single-stack)
1417 (inst fcom (ea-for-sf-stack y))
1418 (inst fcom (ea-for-sf-desc y)))))
1419 (inst fnstsw) ; status word to ax
1420 (inst and ah-tn #x45)))
1421 (inst jmp (if not-p :ne :e) target)))
1423 (define-vop (>double-float)
1425 (:args (x :scs (double-reg double-stack descriptor-reg))
1426 (y :scs (double-reg double-stack descriptor-reg)))
1427 (:arg-types double-float double-float)
1428 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1429 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1431 (:info target not-p)
1432 (:policy :fast-safe)
1433 (:note "inline float comparison")
1436 ;; Handle a few special cases.
1439 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1443 ((double-stack descriptor-reg)
1444 (if (sc-is x double-stack)
1445 (inst fcomd (ea-for-df-stack x))
1446 (inst fcomd (ea-for-df-desc x)))))
1447 (inst fnstsw) ; status word to ax
1448 (inst and ah-tn #x45)
1449 (inst cmp ah-tn #x01))
1451 ;; general case when y is not in ST0
1456 (unless (zerop (tn-offset x))
1457 (copy-fp-reg-to-fr0 x)))
1458 ((double-stack descriptor-reg)
1460 (if (sc-is x double-stack)
1461 (inst fldd (ea-for-df-stack x))
1462 (inst fldd (ea-for-df-desc x)))))
1466 ((double-stack descriptor-reg)
1467 (if (sc-is y double-stack)
1468 (inst fcomd (ea-for-df-stack y))
1469 (inst fcomd (ea-for-df-desc y)))))
1470 (inst fnstsw) ; status word to ax
1471 (inst and ah-tn #x45)))
1472 (inst jmp (if not-p :ne :e) target)))
1475 (define-vop (>long-float)
1477 (:args (x :scs (long-reg))
1478 (y :scs (long-reg)))
1479 (:arg-types long-float long-float)
1480 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1482 (:info target not-p)
1483 (:policy :fast-safe)
1484 (:note "inline float comparison")
1488 ;; y is in ST0; x is in any reg.
1489 ((zerop (tn-offset y))
1491 (inst fnstsw) ; status word to ax
1492 (inst and ah-tn #x45)
1493 (inst cmp ah-tn #x01))
1494 ;; x is in ST0; y is in another reg.
1495 ((zerop (tn-offset x))
1497 (inst fnstsw) ; status word to ax
1498 (inst and ah-tn #x45))
1499 ;; y and x are the same register, not ST0
1500 ;; y and x are different registers, neither ST0.
1505 (inst fnstsw) ; status word to ax
1506 (inst and ah-tn #x45)))
1507 (inst jmp (if not-p :ne :e) target)))
1509 ;;; Comparisons with 0 can use the FTST instruction.
1511 (define-vop (float-test)
1513 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1515 (:info target not-p y)
1516 (:variant-vars code)
1517 (:policy :fast-safe)
1519 (:save-p :compute-only)
1520 (:note "inline float comparison")
1523 (note-this-location vop :internal-error)
1526 ((zerop (tn-offset x))
1533 (inst fnstsw) ; status word to ax
1534 (inst and ah-tn #x45) ; C3 C2 C0
1535 (unless (zerop code)
1536 (inst cmp ah-tn code))
1537 (inst jmp (if not-p :ne :e) target)))
1539 (define-vop (=0/single-float float-test)
1541 (:args (x :scs (single-reg)))
1542 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1544 (define-vop (=0/double-float float-test)
1546 (:args (x :scs (double-reg)))
1547 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1550 (define-vop (=0/long-float float-test)
1552 (:args (x :scs (long-reg)))
1553 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1556 (define-vop (<0/single-float float-test)
1558 (:args (x :scs (single-reg)))
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 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1567 (define-vop (<0/long-float float-test)
1569 (:args (x :scs (long-reg)))
1570 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1573 (define-vop (>0/single-float float-test)
1575 (:args (x :scs (single-reg)))
1576 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1578 (define-vop (>0/double-float float-test)
1580 (:args (x :scs (double-reg)))
1581 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1584 (define-vop (>0/long-float float-test)
1586 (:args (x :scs (long-reg)))
1587 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1591 (deftransform eql ((x y) (long-float long-float))
1592 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1593 (= (long-float-high-bits x) (long-float-high-bits y))
1594 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1598 (macrolet ((frob (name translate to-sc to-type)
1599 `(define-vop (,name)
1600 (:args (x :scs (signed-stack signed-reg) :target temp))
1601 (:temporary (:sc signed-stack) temp)
1602 (:results (y :scs (,to-sc)))
1603 (:arg-types signed-num)
1604 (:result-types ,to-type)
1605 (:policy :fast-safe)
1606 (:note "inline float coercion")
1607 (:translate ,translate)
1609 (:save-p :compute-only)
1614 (with-empty-tn@fp-top(y)
1615 (note-this-location vop :internal-error)
1618 (with-empty-tn@fp-top(y)
1619 (note-this-location vop :internal-error)
1620 (inst fild x))))))))
1621 (frob %single-float/signed %single-float single-reg single-float)
1622 (frob %double-float/signed %double-float double-reg double-float)
1624 (frob %long-float/signed %long-float long-reg long-float))
1626 (macrolet ((frob (name translate to-sc to-type)
1627 `(define-vop (,name)
1628 (:args (x :scs (unsigned-reg)))
1629 (:results (y :scs (,to-sc)))
1630 (:arg-types unsigned-num)
1631 (:result-types ,to-type)
1632 (:policy :fast-safe)
1633 (:note "inline float coercion")
1634 (:translate ,translate)
1636 (:save-p :compute-only)
1640 (with-empty-tn@fp-top(y)
1641 (note-this-location vop :internal-error)
1642 (inst fildl (make-ea :dword :base esp-tn)))
1643 (inst add esp-tn 8)))))
1644 (frob %single-float/unsigned %single-float single-reg single-float)
1645 (frob %double-float/unsigned %double-float double-reg double-float)
1647 (frob %long-float/unsigned %long-float long-reg long-float))
1649 ;;; These should be no-ops but the compiler might want to move some
1651 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1652 `(define-vop (,name)
1653 (:args (x :scs (,from-sc) :target y))
1654 (:results (y :scs (,to-sc)))
1655 (:arg-types ,from-type)
1656 (:result-types ,to-type)
1657 (:policy :fast-safe)
1658 (:note "inline float coercion")
1659 (:translate ,translate)
1661 (:save-p :compute-only)
1663 (note-this-location vop :internal-error)
1664 (unless (location= x y)
1666 ((zerop (tn-offset x))
1667 ;; x is in ST0, y is in another reg. not ST0
1669 ((zerop (tn-offset y))
1670 ;; y is in ST0, x is in another reg. not ST0
1671 (copy-fp-reg-to-fr0 x))
1673 ;; Neither x or y are in ST0, and they are not in
1677 (inst fxch x))))))))
1679 (frob %single-float/double-float %single-float double-reg
1680 double-float single-reg single-float)
1682 (frob %single-float/long-float %single-float long-reg
1683 long-float single-reg single-float)
1684 (frob %double-float/single-float %double-float single-reg single-float
1685 double-reg double-float)
1687 (frob %double-float/long-float %double-float long-reg long-float
1688 double-reg double-float)
1690 (frob %long-float/single-float %long-float single-reg single-float
1691 long-reg long-float)
1693 (frob %long-float/double-float %long-float double-reg double-float
1694 long-reg long-float))
1696 (macrolet ((frob (trans from-sc from-type round-p)
1697 `(define-vop (,(symbolicate trans "/" from-type))
1698 (:args (x :scs (,from-sc)))
1699 (:temporary (:sc signed-stack) stack-temp)
1701 '((:temporary (:sc unsigned-stack) scw)
1702 (:temporary (:sc any-reg) rcw)))
1703 (:results (y :scs (signed-reg)))
1704 (:arg-types ,from-type)
1705 (:result-types signed-num)
1707 (:policy :fast-safe)
1708 (:note "inline float truncate")
1710 (:save-p :compute-only)
1713 '((note-this-location vop :internal-error)
1714 ;; Catch any pending FPE exceptions.
1716 (,(if round-p 'progn 'pseudo-atomic)
1717 ;; Normal mode (for now) is "round to best".
1720 '((inst fnstcw scw) ; save current control word
1721 (move rcw scw) ; into 16-bit register
1722 (inst or rcw (ash #b11 10)) ; CHOP
1723 (move stack-temp rcw)
1724 (inst fldcw stack-temp)))
1729 (inst fist stack-temp)
1730 (inst mov y stack-temp)))
1732 '((inst fldcw scw)))))))))
1733 (frob %unary-truncate single-reg single-float nil)
1734 (frob %unary-truncate double-reg double-float nil)
1736 (frob %unary-truncate long-reg long-float nil)
1737 (frob %unary-round single-reg single-float t)
1738 (frob %unary-round double-reg double-float t)
1740 (frob %unary-round long-reg long-float t))
1742 (macrolet ((frob (trans from-sc from-type round-p)
1743 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1744 (:args (x :scs (,from-sc) :target fr0))
1745 (:temporary (:sc double-reg :offset fr0-offset
1746 :from :argument :to :result) fr0)
1748 '((:temporary (:sc unsigned-stack) stack-temp)
1749 (:temporary (:sc unsigned-stack) scw)
1750 (:temporary (:sc any-reg) rcw)))
1751 (:results (y :scs (unsigned-reg)))
1752 (:arg-types ,from-type)
1753 (:result-types unsigned-num)
1755 (:policy :fast-safe)
1756 (:note "inline float truncate")
1758 (:save-p :compute-only)
1761 '((note-this-location vop :internal-error)
1762 ;; Catch any pending FPE exceptions.
1764 ;; Normal mode (for now) is "round to best".
1765 (unless (zerop (tn-offset x))
1766 (copy-fp-reg-to-fr0 x))
1768 '((inst fnstcw scw) ; save current control word
1769 (move rcw scw) ; into 16-bit register
1770 (inst or rcw (ash #b11 10)) ; CHOP
1771 (move stack-temp rcw)
1772 (inst fldcw stack-temp)))
1774 (inst fistpl (make-ea :dword :base esp-tn))
1776 (inst fld fr0) ; copy fr0 to at least restore stack.
1779 '((inst fldcw scw)))))))
1780 (frob %unary-truncate single-reg single-float nil)
1781 (frob %unary-truncate double-reg double-float nil)
1783 (frob %unary-truncate long-reg long-float nil)
1784 (frob %unary-round single-reg single-float t)
1785 (frob %unary-round double-reg double-float t)
1787 (frob %unary-round long-reg long-float t))
1789 (define-vop (make-single-float)
1790 (:args (bits :scs (signed-reg) :target res
1791 :load-if (not (or (and (sc-is bits signed-stack)
1792 (sc-is res single-reg))
1793 (and (sc-is bits signed-stack)
1794 (sc-is res single-stack)
1795 (location= bits res))))))
1796 (:results (res :scs (single-reg single-stack)))
1797 (:temporary (:sc signed-stack) stack-temp)
1798 (:arg-types signed-num)
1799 (:result-types single-float)
1800 (:translate make-single-float)
1801 (:policy :fast-safe)
1808 (inst mov res bits))
1810 (aver (location= bits res)))))
1814 ;; source must be in memory
1815 (inst mov stack-temp bits)
1816 (with-empty-tn@fp-top(res)
1817 (inst fld stack-temp)))
1819 (with-empty-tn@fp-top(res)
1820 (inst fld bits))))))))
1822 (define-vop (make-double-float)
1823 (:args (hi-bits :scs (signed-reg))
1824 (lo-bits :scs (unsigned-reg)))
1825 (:results (res :scs (double-reg)))
1826 (:temporary (:sc double-stack) temp)
1827 (:arg-types signed-num unsigned-num)
1828 (:result-types double-float)
1829 (:translate make-double-float)
1830 (:policy :fast-safe)
1833 (let ((offset (1+ (tn-offset temp))))
1834 (storew hi-bits ebp-tn (- offset))
1835 (storew lo-bits ebp-tn (- (1+ offset)))
1836 (with-empty-tn@fp-top(res)
1837 (inst fldd (make-ea :dword :base ebp-tn
1838 :disp (- (* (1+ offset) n-word-bytes))))))))
1841 (define-vop (make-long-float)
1842 (:args (exp-bits :scs (signed-reg))
1843 (hi-bits :scs (unsigned-reg))
1844 (lo-bits :scs (unsigned-reg)))
1845 (:results (res :scs (long-reg)))
1846 (:temporary (:sc long-stack) temp)
1847 (:arg-types signed-num unsigned-num unsigned-num)
1848 (:result-types long-float)
1849 (:translate make-long-float)
1850 (:policy :fast-safe)
1853 (let ((offset (1+ (tn-offset temp))))
1854 (storew exp-bits ebp-tn (- offset))
1855 (storew hi-bits ebp-tn (- (1+ offset)))
1856 (storew lo-bits ebp-tn (- (+ offset 2)))
1857 (with-empty-tn@fp-top(res)
1858 (inst fldl (make-ea :dword :base ebp-tn
1859 :disp (- (* (+ offset 2) n-word-bytes))))))))
1861 (define-vop (single-float-bits)
1862 (:args (float :scs (single-reg descriptor-reg)
1863 :load-if (not (sc-is float single-stack))))
1864 (:results (bits :scs (signed-reg)))
1865 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1866 (:arg-types single-float)
1867 (:result-types signed-num)
1868 (:translate single-float-bits)
1869 (:policy :fast-safe)
1876 (with-tn@fp-top(float)
1877 (inst fst stack-temp)
1878 (inst mov bits stack-temp)))
1880 (inst mov bits float))
1883 bits float single-float-value-slot
1884 other-pointer-lowtag))))
1888 (with-tn@fp-top(float)
1889 (inst fst bits))))))))
1891 (define-vop (double-float-high-bits)
1892 (:args (float :scs (double-reg descriptor-reg)
1893 :load-if (not (sc-is float double-stack))))
1894 (:results (hi-bits :scs (signed-reg)))
1895 (:temporary (:sc double-stack) temp)
1896 (:arg-types double-float)
1897 (:result-types signed-num)
1898 (:translate double-float-high-bits)
1899 (:policy :fast-safe)
1904 (with-tn@fp-top(float)
1905 (let ((where (make-ea :dword :base ebp-tn
1906 :disp (- (* (+ 2 (tn-offset temp))
1909 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1911 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1913 (loadw hi-bits float (1+ double-float-value-slot)
1914 other-pointer-lowtag)))))
1916 (define-vop (double-float-low-bits)
1917 (:args (float :scs (double-reg descriptor-reg)
1918 :load-if (not (sc-is float double-stack))))
1919 (:results (lo-bits :scs (unsigned-reg)))
1920 (:temporary (:sc double-stack) temp)
1921 (:arg-types double-float)
1922 (:result-types unsigned-num)
1923 (:translate double-float-low-bits)
1924 (:policy :fast-safe)
1929 (with-tn@fp-top(float)
1930 (let ((where (make-ea :dword :base ebp-tn
1931 :disp (- (* (+ 2 (tn-offset temp))
1934 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1936 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1938 (loadw lo-bits float double-float-value-slot
1939 other-pointer-lowtag)))))
1942 (define-vop (long-float-exp-bits)
1943 (:args (float :scs (long-reg descriptor-reg)
1944 :load-if (not (sc-is float long-stack))))
1945 (:results (exp-bits :scs (signed-reg)))
1946 (:temporary (:sc long-stack) temp)
1947 (:arg-types long-float)
1948 (:result-types signed-num)
1949 (:translate long-float-exp-bits)
1950 (:policy :fast-safe)
1955 (with-tn@fp-top(float)
1956 (let ((where (make-ea :dword :base ebp-tn
1957 :disp (- (* (+ 3 (tn-offset temp))
1959 (store-long-float where)))
1960 (inst movsx exp-bits
1961 (make-ea :word :base ebp-tn
1962 :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
1964 (inst movsx exp-bits
1965 (make-ea :word :base ebp-tn
1966 :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
1968 (inst movsx exp-bits
1969 (make-ea :word :base float
1970 :disp (- (* (+ 2 long-float-value-slot)
1972 other-pointer-lowtag)))))))
1975 (define-vop (long-float-high-bits)
1976 (:args (float :scs (long-reg descriptor-reg)
1977 :load-if (not (sc-is float long-stack))))
1978 (:results (hi-bits :scs (unsigned-reg)))
1979 (:temporary (:sc long-stack) temp)
1980 (:arg-types long-float)
1981 (:result-types unsigned-num)
1982 (:translate long-float-high-bits)
1983 (:policy :fast-safe)
1988 (with-tn@fp-top(float)
1989 (let ((where (make-ea :dword :base ebp-tn
1990 :disp (- (* (+ 3 (tn-offset temp))
1992 (store-long-float where)))
1993 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
1995 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
1997 (loadw hi-bits float (1+ long-float-value-slot)
1998 other-pointer-lowtag)))))
2001 (define-vop (long-float-low-bits)
2002 (:args (float :scs (long-reg descriptor-reg)
2003 :load-if (not (sc-is float long-stack))))
2004 (:results (lo-bits :scs (unsigned-reg)))
2005 (:temporary (:sc long-stack) temp)
2006 (:arg-types long-float)
2007 (:result-types unsigned-num)
2008 (:translate long-float-low-bits)
2009 (:policy :fast-safe)
2014 (with-tn@fp-top(float)
2015 (let ((where (make-ea :dword :base ebp-tn
2016 :disp (- (* (+ 3 (tn-offset temp))
2018 (store-long-float where)))
2019 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2021 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2023 (loadw lo-bits float long-float-value-slot
2024 other-pointer-lowtag)))))
2026 ;;;; float mode hackery
2028 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2029 (defknown floating-point-modes () float-modes (flushable))
2030 (defknown ((setf floating-point-modes)) (float-modes)
2033 (def!constant npx-env-size (* 7 n-word-bytes))
2034 (def!constant npx-cw-offset 0)
2035 (def!constant npx-sw-offset 4)
2037 (define-vop (floating-point-modes)
2038 (:results (res :scs (unsigned-reg)))
2039 (:result-types unsigned-num)
2040 (:translate floating-point-modes)
2041 (:policy :fast-safe)
2042 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2045 (inst sub esp-tn npx-env-size) ; Make space on stack.
2046 (inst wait) ; Catch any pending FPE exceptions
2047 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2048 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2049 ;; Move current status to high word.
2050 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2051 ;; Move exception mask to low word.
2052 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2053 (inst add esp-tn npx-env-size) ; Pop stack.
2054 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2057 (define-vop (set-floating-point-modes)
2058 (:args (new :scs (unsigned-reg) :to :result :target res))
2059 (:results (res :scs (unsigned-reg)))
2060 (:arg-types unsigned-num)
2061 (:result-types unsigned-num)
2062 (:translate (setf floating-point-modes))
2063 (:policy :fast-safe)
2064 (:temporary (:sc unsigned-reg :offset eax-offset
2065 :from :eval :to :result) eax)
2067 (inst sub esp-tn npx-env-size) ; Make space on stack.
2068 (inst wait) ; Catch any pending FPE exceptions.
2069 (inst fstenv (make-ea :dword :base esp-tn))
2071 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2072 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2073 (inst shr eax 16) ; position status word
2074 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2075 (inst fldenv (make-ea :dword :base esp-tn))
2076 (inst add esp-tn npx-env-size) ; Pop stack.
2082 ;;; Let's use some of the 80387 special functions.
2084 ;;; These defs will not take effect unless code/irrat.lisp is modified
2085 ;;; to remove the inlined alien routine def.
2087 (macrolet ((frob (func trans op)
2088 `(define-vop (,func)
2089 (:args (x :scs (double-reg) :target fr0))
2090 (:temporary (:sc double-reg :offset fr0-offset
2091 :from :argument :to :result) fr0)
2093 (:results (y :scs (double-reg)))
2094 (:arg-types double-float)
2095 (:result-types double-float)
2097 (:policy :fast-safe)
2098 (:note "inline NPX function")
2100 (:save-p :compute-only)
2103 (note-this-location vop :internal-error)
2104 (unless (zerop (tn-offset x))
2105 (inst fxch x) ; x to top of stack
2106 (unless (location= x y)
2107 (inst fst x))) ; maybe save it
2108 (inst ,op) ; clobber st0
2109 (cond ((zerop (tn-offset y))
2110 (maybe-fp-wait node))
2114 ;; Quick versions of fsin and fcos that require the argument to be
2115 ;; within range 2^63.
2116 (frob fsin-quick %sin-quick fsin)
2117 (frob fcos-quick %cos-quick fcos)
2118 (frob fsqrt %sqrt fsqrt))
2120 ;;; Quick version of ftan that requires the argument to be within
2122 (define-vop (ftan-quick)
2123 (:translate %tan-quick)
2124 (:args (x :scs (double-reg) :target fr0))
2125 (:temporary (:sc double-reg :offset fr0-offset
2126 :from :argument :to :result) fr0)
2127 (:temporary (:sc double-reg :offset fr1-offset
2128 :from :argument :to :result) fr1)
2129 (:results (y :scs (double-reg)))
2130 (:arg-types double-float)
2131 (:result-types double-float)
2132 (:policy :fast-safe)
2133 (:note "inline tan function")
2135 (:save-p :compute-only)
2137 (note-this-location vop :internal-error)
2146 (inst fldd (make-random-tn :kind :normal
2147 :sc (sc-or-lose 'double-reg)
2148 :offset (- (tn-offset x) 2)))))
2159 ;;; These versions of fsin, fcos, and ftan try to use argument
2160 ;;; reduction but to do this accurately requires greater precision and
2161 ;;; it is hopelessly inaccurate.
2163 (macrolet ((frob (func trans op)
2164 `(define-vop (,func)
2166 (:args (x :scs (double-reg) :target fr0))
2167 (:temporary (:sc unsigned-reg :offset eax-offset
2168 :from :eval :to :result) eax)
2169 (:temporary (:sc unsigned-reg :offset fr0-offset
2170 :from :argument :to :result) fr0)
2171 (:temporary (:sc unsigned-reg :offset fr1-offset
2172 :from :argument :to :result) fr1)
2173 (:results (y :scs (double-reg)))
2174 (:arg-types double-float)
2175 (:result-types double-float)
2176 (:policy :fast-safe)
2177 (:note "inline sin/cos function")
2179 (:save-p :compute-only)
2182 (note-this-location vop :internal-error)
2183 (unless (zerop (tn-offset x))
2184 (inst fxch x) ; x to top of stack
2185 (unless (location= x y)
2186 (inst fst x))) ; maybe save it
2188 (inst fnstsw) ; status word to ax
2189 (inst and ah-tn #x04) ; C2
2191 ;; Else x was out of range so reduce it; ST0 is unchanged.
2192 (inst fstp fr1) ; Load 2*PI
2198 (inst fnstsw) ; status word to ax
2199 (inst and ah-tn #x04) ; C2
2203 (unless (zerop (tn-offset y))
2205 (frob fsin %sin fsin)
2206 (frob fcos %cos fcos))
2211 (:args (x :scs (double-reg) :target fr0))
2212 (:temporary (:sc unsigned-reg :offset eax-offset
2213 :from :argument :to :result) eax)
2214 (:temporary (:sc double-reg :offset fr0-offset
2215 :from :argument :to :result) fr0)
2216 (:temporary (:sc double-reg :offset fr1-offset
2217 :from :argument :to :result) fr1)
2218 (:results (y :scs (double-reg)))
2219 (:arg-types double-float)
2220 (:result-types double-float)
2221 (:policy :fast-safe)
2222 (:note "inline tan function")
2224 (:save-p :compute-only)
2227 (note-this-location vop :internal-error)
2236 (inst fldd (make-random-tn :kind :normal
2237 :sc (sc-or-lose 'double-reg)
2238 :offset (- (tn-offset x) 2)))))
2240 (inst fnstsw) ; status word to ax
2241 (inst and ah-tn #x04) ; C2
2243 ;; Else x was out of range so reduce it; ST0 is unchanged.
2244 (inst fldpi) ; Load 2*PI
2249 (inst fnstsw) ; status word to ax
2250 (inst and ah-tn #x04) ; C2
2264 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2265 ;;; the argument is out of range 2^63 and would thus be hopelessly
2267 (macrolet ((frob (func trans op)
2268 `(define-vop (,func)
2270 (:args (x :scs (double-reg) :target fr0))
2271 (:temporary (:sc double-reg :offset fr0-offset
2272 :from :argument :to :result) fr0)
2273 (:temporary (:sc unsigned-reg :offset eax-offset
2274 :from :argument :to :result) eax)
2275 (:results (y :scs (double-reg)))
2276 (:arg-types double-float)
2277 (:result-types double-float)
2278 (:policy :fast-safe)
2279 (:note "inline sin/cos function")
2281 (:save-p :compute-only)
2284 (note-this-location vop :internal-error)
2285 (unless (zerop (tn-offset x))
2286 (inst fxch x) ; x to top of stack
2287 (unless (location= x y)
2288 (inst fst x))) ; maybe save it
2290 (inst fnstsw) ; status word to ax
2291 (inst and ah-tn #x04) ; C2
2293 ;; Else x was out of range so reduce it; ST0 is unchanged.
2294 (inst fstp fr0) ; Load 0.0
2297 (unless (zerop (tn-offset y))
2299 (frob fsin %sin fsin)
2300 (frob fcos %cos fcos))
2304 (:args (x :scs (double-reg) :target fr0))
2305 (:temporary (:sc double-reg :offset fr0-offset
2306 :from :argument :to :result) fr0)
2307 (:temporary (:sc double-reg :offset fr1-offset
2308 :from :argument :to :result) fr1)
2309 (:temporary (:sc unsigned-reg :offset eax-offset
2310 :from :argument :to :result) eax)
2311 (:results (y :scs (double-reg)))
2312 (:arg-types double-float)
2313 (:result-types double-float)
2315 (:policy :fast-safe)
2316 (:note "inline tan function")
2318 (:save-p :compute-only)
2321 (note-this-location vop :internal-error)
2330 (inst fldd (make-random-tn :kind :normal
2331 :sc (sc-or-lose 'double-reg)
2332 :offset (- (tn-offset x) 2)))))
2334 (inst fnstsw) ; status word to ax
2335 (inst and ah-tn #x04) ; C2
2337 ;; Else x was out of range so reduce it; ST0 is unchanged.
2338 (inst fldz) ; Load 0.0
2353 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2354 (:temporary (:sc double-reg :offset fr0-offset
2355 :from :argument :to :result) fr0)
2356 (:temporary (:sc double-reg :offset fr1-offset
2357 :from :argument :to :result) fr1)
2358 (:temporary (:sc double-reg :offset fr2-offset
2359 :from :argument :to :result) fr2)
2360 (:results (y :scs (double-reg)))
2361 (:arg-types double-float)
2362 (:result-types double-float)
2363 (:policy :fast-safe)
2364 (:note "inline exp function")
2366 (:save-p :compute-only)
2368 (note-this-location vop :internal-error)
2371 (cond ((zerop (tn-offset x))
2377 ;; x is in a FP reg, not fr0
2381 ((double-stack descriptor-reg)
2384 (if (sc-is x double-stack)
2385 (inst fmuld (ea-for-df-stack x))
2386 (inst fmuld (ea-for-df-desc x)))))
2387 ;; Now fr0=x log2(e)
2391 (inst fsubp-sti fr1)
2394 (inst faddp-sti fr1)
2399 (t (inst fstd y)))))
2401 ;;; Modified exp that handles the following special cases:
2402 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2405 (:args (x :scs (double-reg) :target fr0))
2406 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2407 (:temporary (:sc double-reg :offset fr0-offset
2408 :from :argument :to :result) fr0)
2409 (:temporary (:sc double-reg :offset fr1-offset
2410 :from :argument :to :result) fr1)
2411 (:temporary (:sc double-reg :offset fr2-offset
2412 :from :argument :to :result) fr2)
2413 (:results (y :scs (double-reg)))
2414 (:arg-types double-float)
2415 (:result-types double-float)
2416 (:policy :fast-safe)
2417 (:note "inline exp function")
2419 (:save-p :compute-only)
2422 (note-this-location vop :internal-error)
2423 (unless (zerop (tn-offset x))
2424 (inst fxch x) ; x to top of stack
2425 (unless (location= x y)
2426 (inst fst x))) ; maybe save it
2427 ;; Check for Inf or NaN
2431 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2432 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2433 (inst and ah-tn #x02) ; Test sign of Inf.
2434 (inst jmp :z DONE) ; +Inf gives +Inf.
2435 (inst fstp fr0) ; -Inf gives 0
2437 (inst jmp-short DONE)
2442 ;; Now fr0=x log2(e)
2446 (inst fsubp-sti fr1)
2449 (inst faddp-sti fr1)
2453 (unless (zerop (tn-offset y))
2456 ;;; Expm1 = exp(x) - 1.
2457 ;;; Handles the following special cases:
2458 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2459 (define-vop (fexpm1)
2461 (:args (x :scs (double-reg) :target fr0))
2462 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2463 (:temporary (:sc double-reg :offset fr0-offset
2464 :from :argument :to :result) fr0)
2465 (:temporary (:sc double-reg :offset fr1-offset
2466 :from :argument :to :result) fr1)
2467 (:temporary (:sc double-reg :offset fr2-offset
2468 :from :argument :to :result) fr2)
2469 (:results (y :scs (double-reg)))
2470 (:arg-types double-float)
2471 (:result-types double-float)
2472 (:policy :fast-safe)
2473 (:note "inline expm1 function")
2475 (:save-p :compute-only)
2478 (note-this-location vop :internal-error)
2479 (unless (zerop (tn-offset x))
2480 (inst fxch x) ; x to top of stack
2481 (unless (location= x y)
2482 (inst fst x))) ; maybe save it
2483 ;; Check for Inf or NaN
2487 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2488 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2489 (inst and ah-tn #x02) ; Test sign of Inf.
2490 (inst jmp :z DONE) ; +Inf gives +Inf.
2491 (inst fstp fr0) ; -Inf gives -1.0
2494 (inst jmp-short DONE)
2496 ;; Free two stack slots leaving the argument on top.
2500 (inst fmul fr1) ; Now fr0 = x log2(e)
2515 (unless (zerop (tn-offset y))
2520 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2521 (:temporary (:sc double-reg :offset fr0-offset
2522 :from :argument :to :result) fr0)
2523 (:temporary (:sc double-reg :offset fr1-offset
2524 :from :argument :to :result) fr1)
2525 (:results (y :scs (double-reg)))
2526 (:arg-types double-float)
2527 (:result-types double-float)
2528 (:policy :fast-safe)
2529 (:note "inline log function")
2531 (:save-p :compute-only)
2533 (note-this-location vop :internal-error)
2548 ;; x is in a FP reg, not fr0 or fr1
2552 (inst fldd (make-random-tn :kind :normal
2553 :sc (sc-or-lose 'double-reg)
2554 :offset (1- (tn-offset x))))))
2556 ((double-stack descriptor-reg)
2560 (if (sc-is x double-stack)
2561 (inst fldd (ea-for-df-stack x))
2562 (inst fldd (ea-for-df-desc x)))
2567 (t (inst fstd y)))))
2569 (define-vop (flog10)
2571 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2572 (:temporary (:sc double-reg :offset fr0-offset
2573 :from :argument :to :result) fr0)
2574 (:temporary (:sc double-reg :offset fr1-offset
2575 :from :argument :to :result) fr1)
2576 (:results (y :scs (double-reg)))
2577 (:arg-types double-float)
2578 (:result-types double-float)
2579 (:policy :fast-safe)
2580 (:note "inline log10 function")
2582 (:save-p :compute-only)
2584 (note-this-location vop :internal-error)
2599 ;; x is in a FP reg, not fr0 or fr1
2603 (inst fldd (make-random-tn :kind :normal
2604 :sc (sc-or-lose 'double-reg)
2605 :offset (1- (tn-offset x))))))
2607 ((double-stack descriptor-reg)
2611 (if (sc-is x double-stack)
2612 (inst fldd (ea-for-df-stack x))
2613 (inst fldd (ea-for-df-desc x)))
2618 (t (inst fstd y)))))
2622 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2623 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2624 (:temporary (:sc double-reg :offset fr0-offset
2625 :from (:argument 0) :to :result) fr0)
2626 (:temporary (:sc double-reg :offset fr1-offset
2627 :from (:argument 1) :to :result) fr1)
2628 (:temporary (:sc double-reg :offset fr2-offset
2629 :from :load :to :result) fr2)
2630 (:results (r :scs (double-reg)))
2631 (:arg-types double-float double-float)
2632 (:result-types double-float)
2633 (:policy :fast-safe)
2634 (:note "inline pow function")
2636 (:save-p :compute-only)
2638 (note-this-location vop :internal-error)
2639 ;; Setup x in fr0 and y in fr1
2641 ;; x in fr0; y in fr1
2642 ((and (sc-is x double-reg) (zerop (tn-offset x))
2643 (sc-is y double-reg) (= 1 (tn-offset y))))
2644 ;; y in fr1; x not in fr0
2645 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2649 (copy-fp-reg-to-fr0 x))
2652 (inst fldd (ea-for-df-stack x)))
2655 (inst fldd (ea-for-df-desc x)))))
2656 ;; x in fr0; y not in fr1
2657 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2659 ;; Now load y to fr0
2662 (copy-fp-reg-to-fr0 y))
2665 (inst fldd (ea-for-df-stack y)))
2668 (inst fldd (ea-for-df-desc y))))
2670 ;; x in fr1; y not in fr1
2671 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2675 (copy-fp-reg-to-fr0 y))
2678 (inst fldd (ea-for-df-stack y)))
2681 (inst fldd (ea-for-df-desc y))))
2684 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2686 ;; Now load x to fr0
2689 (copy-fp-reg-to-fr0 x))
2692 (inst fldd (ea-for-df-stack x)))
2695 (inst fldd (ea-for-df-desc x)))))
2696 ;; Neither x or y are in either fr0 or fr1
2703 (inst fldd (make-random-tn :kind :normal
2704 :sc (sc-or-lose 'double-reg)
2705 :offset (- (tn-offset y) 2))))
2707 (inst fldd (ea-for-df-stack y)))
2709 (inst fldd (ea-for-df-desc y))))
2713 (inst fldd (make-random-tn :kind :normal
2714 :sc (sc-or-lose 'double-reg)
2715 :offset (1- (tn-offset x)))))
2717 (inst fldd (ea-for-df-stack x)))
2719 (inst fldd (ea-for-df-desc x))))))
2721 ;; Now have x at fr0; and y at fr1
2723 ;; Now fr0=y log2(x)
2727 (inst fsubp-sti fr1)
2730 (inst faddp-sti fr1)
2735 (t (inst fstd r)))))
2737 (define-vop (fscalen)
2738 (:translate %scalbn)
2739 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2740 (y :scs (signed-stack signed-reg) :target temp))
2741 (:temporary (:sc double-reg :offset fr0-offset
2742 :from (:argument 0) :to :result) fr0)
2743 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2744 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2745 (:results (r :scs (double-reg)))
2746 (:arg-types double-float signed-num)
2747 (:result-types double-float)
2748 (:policy :fast-safe)
2749 (:note "inline scalbn function")
2751 ;; Setup x in fr0 and y in fr1
2782 (inst fld (make-random-tn :kind :normal
2783 :sc (sc-or-lose 'double-reg)
2784 :offset (1- (tn-offset x)))))))
2785 ((double-stack descriptor-reg)
2794 (if (sc-is x double-stack)
2795 (inst fldd (ea-for-df-stack x))
2796 (inst fldd (ea-for-df-desc x)))))
2798 (unless (zerop (tn-offset r))
2801 (define-vop (fscale)
2803 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2804 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2805 (:temporary (:sc double-reg :offset fr0-offset
2806 :from (:argument 0) :to :result) fr0)
2807 (:temporary (:sc double-reg :offset fr1-offset
2808 :from (:argument 1) :to :result) fr1)
2809 (:results (r :scs (double-reg)))
2810 (:arg-types double-float double-float)
2811 (:result-types double-float)
2812 (:policy :fast-safe)
2813 (:note "inline scalb function")
2815 (:save-p :compute-only)
2817 (note-this-location vop :internal-error)
2818 ;; Setup x in fr0 and y in fr1
2820 ;; x in fr0; y in fr1
2821 ((and (sc-is x double-reg) (zerop (tn-offset x))
2822 (sc-is y double-reg) (= 1 (tn-offset y))))
2823 ;; y in fr1; x not in fr0
2824 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2828 (copy-fp-reg-to-fr0 x))
2831 (inst fldd (ea-for-df-stack x)))
2834 (inst fldd (ea-for-df-desc x)))))
2835 ;; x in fr0; y not in fr1
2836 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2838 ;; Now load y to fr0
2841 (copy-fp-reg-to-fr0 y))
2844 (inst fldd (ea-for-df-stack y)))
2847 (inst fldd (ea-for-df-desc y))))
2849 ;; x in fr1; y not in fr1
2850 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2854 (copy-fp-reg-to-fr0 y))
2857 (inst fldd (ea-for-df-stack y)))
2860 (inst fldd (ea-for-df-desc y))))
2863 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2865 ;; Now load x to fr0
2868 (copy-fp-reg-to-fr0 x))
2871 (inst fldd (ea-for-df-stack x)))
2874 (inst fldd (ea-for-df-desc x)))))
2875 ;; Neither x or y are in either fr0 or fr1
2882 (inst fldd (make-random-tn :kind :normal
2883 :sc (sc-or-lose 'double-reg)
2884 :offset (- (tn-offset y) 2))))
2886 (inst fldd (ea-for-df-stack y)))
2888 (inst fldd (ea-for-df-desc y))))
2892 (inst fldd (make-random-tn :kind :normal
2893 :sc (sc-or-lose 'double-reg)
2894 :offset (1- (tn-offset x)))))
2896 (inst fldd (ea-for-df-stack x)))
2898 (inst fldd (ea-for-df-desc x))))))
2900 ;; Now have x at fr0; and y at fr1
2902 (unless (zerop (tn-offset r))
2905 (define-vop (flog1p)
2907 (:args (x :scs (double-reg) :to :result))
2908 (:temporary (:sc double-reg :offset fr0-offset
2909 :from :argument :to :result) fr0)
2910 (:temporary (:sc double-reg :offset fr1-offset
2911 :from :argument :to :result) fr1)
2912 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2913 (:results (y :scs (double-reg)))
2914 (:arg-types double-float)
2915 (:result-types double-float)
2916 (:policy :fast-safe)
2917 (:note "inline log1p function")
2920 ;; x is in a FP reg, not fr0, fr1.
2923 (inst fldd (make-random-tn :kind :normal
2924 :sc (sc-or-lose 'double-reg)
2925 :offset (- (tn-offset x) 2)))
2927 (inst push #x3e947ae1) ; Constant 0.29
2929 (inst fld (make-ea :dword :base esp-tn))
2932 (inst fnstsw) ; status word to ax
2933 (inst and ah-tn #x45)
2934 (inst jmp :z WITHIN-RANGE)
2935 ;; Out of range for fyl2xp1.
2937 (inst faddd (make-random-tn :kind :normal
2938 :sc (sc-or-lose 'double-reg)
2939 :offset (- (tn-offset x) 1)))
2947 (inst fldd (make-random-tn :kind :normal
2948 :sc (sc-or-lose 'double-reg)
2949 :offset (- (tn-offset x) 1)))
2955 (t (inst fstd y)))))
2957 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2958 ;;; instruction and a range check can be avoided.
2959 (define-vop (flog1p-pentium)
2961 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2962 (:temporary (:sc double-reg :offset fr0-offset
2963 :from :argument :to :result) fr0)
2964 (:temporary (:sc double-reg :offset fr1-offset
2965 :from :argument :to :result) fr1)
2966 (:results (y :scs (double-reg)))
2967 (:arg-types double-float)
2968 (:result-types double-float)
2969 (:policy :fast-safe)
2970 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2971 (:note "inline log1p with limited x range function")
2973 (:save-p :compute-only)
2975 (note-this-location vop :internal-error)
2990 ;; x is in a FP reg, not fr0 or fr1
2994 (inst fldd (make-random-tn :kind :normal
2995 :sc (sc-or-lose 'double-reg)
2996 :offset (1- (tn-offset x)))))))
2997 ((double-stack descriptor-reg)
3001 (if (sc-is x double-stack)
3002 (inst fldd (ea-for-df-stack x))
3003 (inst fldd (ea-for-df-desc x)))))
3008 (t (inst fstd y)))))
3012 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3013 (:temporary (:sc double-reg :offset fr0-offset
3014 :from :argument :to :result) fr0)
3015 (:temporary (:sc double-reg :offset fr1-offset
3016 :from :argument :to :result) fr1)
3017 (:results (y :scs (double-reg)))
3018 (:arg-types double-float)
3019 (:result-types double-float)
3020 (:policy :fast-safe)
3021 (:note "inline logb function")
3023 (:save-p :compute-only)
3025 (note-this-location vop :internal-error)
3036 ;; x is in a FP reg, not fr0 or fr1
3039 (inst fldd (make-random-tn :kind :normal
3040 :sc (sc-or-lose 'double-reg)
3041 :offset (- (tn-offset x) 2))))))
3042 ((double-stack descriptor-reg)
3045 (if (sc-is x double-stack)
3046 (inst fldd (ea-for-df-stack x))
3047 (inst fldd (ea-for-df-desc x)))))
3058 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3059 (:temporary (:sc double-reg :offset fr0-offset
3060 :from (:argument 0) :to :result) fr0)
3061 (:temporary (:sc double-reg :offset fr1-offset
3062 :from (:argument 0) :to :result) fr1)
3063 (:results (r :scs (double-reg)))
3064 (:arg-types double-float)
3065 (:result-types double-float)
3066 (:policy :fast-safe)
3067 (:note "inline atan function")
3069 (:save-p :compute-only)
3071 (note-this-location vop :internal-error)
3072 ;; Setup x in fr1 and 1.0 in fr0
3075 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3078 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3080 ;; x not in fr0 or fr1
3087 (inst fldd (make-random-tn :kind :normal
3088 :sc (sc-or-lose 'double-reg)
3089 :offset (- (tn-offset x) 2))))
3091 (inst fldd (ea-for-df-stack x)))
3093 (inst fldd (ea-for-df-desc x))))))
3095 ;; Now have x at fr1; and 1.0 at fr0
3100 (t (inst fstd r)))))
3102 (define-vop (fatan2)
3104 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3105 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3106 (:temporary (:sc double-reg :offset fr0-offset
3107 :from (:argument 1) :to :result) fr0)
3108 (:temporary (:sc double-reg :offset fr1-offset
3109 :from (:argument 0) :to :result) fr1)
3110 (:results (r :scs (double-reg)))
3111 (:arg-types double-float double-float)
3112 (:result-types double-float)
3113 (:policy :fast-safe)
3114 (:note "inline atan2 function")
3116 (:save-p :compute-only)
3118 (note-this-location vop :internal-error)
3119 ;; Setup x in fr1 and y in fr0
3121 ;; y in fr0; x in fr1
3122 ((and (sc-is y double-reg) (zerop (tn-offset y))
3123 (sc-is x double-reg) (= 1 (tn-offset x))))
3124 ;; x in fr1; y not in fr0
3125 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3129 (copy-fp-reg-to-fr0 y))
3132 (inst fldd (ea-for-df-stack y)))
3135 (inst fldd (ea-for-df-desc y)))))
3136 ((and (sc-is x double-reg) (zerop (tn-offset x))
3137 (sc-is y double-reg) (zerop (tn-offset x)))
3140 ;; y in fr0; x not in fr1
3141 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3143 ;; Now load x to fr0
3146 (copy-fp-reg-to-fr0 x))
3149 (inst fldd (ea-for-df-stack x)))
3152 (inst fldd (ea-for-df-desc x))))
3154 ;; y in fr1; x not in fr1
3155 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3159 (copy-fp-reg-to-fr0 x))
3162 (inst fldd (ea-for-df-stack x)))
3165 (inst fldd (ea-for-df-desc x))))
3168 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3170 ;; Now load y to fr0
3173 (copy-fp-reg-to-fr0 y))
3176 (inst fldd (ea-for-df-stack y)))
3179 (inst fldd (ea-for-df-desc y)))))
3180 ;; Neither y or x are in either fr0 or fr1
3187 (inst fldd (make-random-tn :kind :normal
3188 :sc (sc-or-lose 'double-reg)
3189 :offset (- (tn-offset x) 2))))
3191 (inst fldd (ea-for-df-stack x)))
3193 (inst fldd (ea-for-df-desc x))))
3197 (inst fldd (make-random-tn :kind :normal
3198 :sc (sc-or-lose 'double-reg)
3199 :offset (1- (tn-offset y)))))
3201 (inst fldd (ea-for-df-stack y)))
3203 (inst fldd (ea-for-df-desc y))))))
3205 ;; Now have y at fr0; and x at fr1
3210 (t (inst fstd r)))))
3211 ) ; PROGN #!-LONG-FLOAT
3216 ;;; Lets use some of the 80387 special functions.
3218 ;;; These defs will not take effect unless code/irrat.lisp is modified
3219 ;;; to remove the inlined alien routine def.
3221 (macrolet ((frob (func trans op)
3222 `(define-vop (,func)
3223 (:args (x :scs (long-reg) :target fr0))
3224 (:temporary (:sc long-reg :offset fr0-offset
3225 :from :argument :to :result) fr0)
3227 (:results (y :scs (long-reg)))
3228 (:arg-types long-float)
3229 (:result-types long-float)
3231 (:policy :fast-safe)
3232 (:note "inline NPX function")
3234 (:save-p :compute-only)
3237 (note-this-location vop :internal-error)
3238 (unless (zerop (tn-offset x))
3239 (inst fxch x) ; x to top of stack
3240 (unless (location= x y)
3241 (inst fst x))) ; maybe save it
3242 (inst ,op) ; clobber st0
3243 (cond ((zerop (tn-offset y))
3244 (maybe-fp-wait node))
3248 ;; Quick versions of FSIN and FCOS that require the argument to be
3249 ;; within range 2^63.
3250 (frob fsin-quick %sin-quick fsin)
3251 (frob fcos-quick %cos-quick fcos)
3252 (frob fsqrt %sqrt fsqrt))
3254 ;;; Quick version of ftan that requires the argument to be within
3256 (define-vop (ftan-quick)
3257 (:translate %tan-quick)
3258 (:args (x :scs (long-reg) :target fr0))
3259 (:temporary (:sc long-reg :offset fr0-offset
3260 :from :argument :to :result) fr0)
3261 (:temporary (:sc long-reg :offset fr1-offset
3262 :from :argument :to :result) fr1)
3263 (:results (y :scs (long-reg)))
3264 (:arg-types long-float)
3265 (:result-types long-float)
3266 (:policy :fast-safe)
3267 (:note "inline tan function")
3269 (:save-p :compute-only)
3271 (note-this-location vop :internal-error)
3280 (inst fldd (make-random-tn :kind :normal
3281 :sc (sc-or-lose 'double-reg)
3282 :offset (- (tn-offset x) 2)))))
3293 ;;; These versions of fsin, fcos, and ftan try to use argument
3294 ;;; reduction but to do this accurately requires greater precision and
3295 ;;; it is hopelessly inaccurate.
3297 (macrolet ((frob (func trans op)
3298 `(define-vop (,func)
3300 (:args (x :scs (long-reg) :target fr0))
3301 (:temporary (:sc unsigned-reg :offset eax-offset
3302 :from :eval :to :result) eax)
3303 (:temporary (:sc long-reg :offset fr0-offset
3304 :from :argument :to :result) fr0)
3305 (:temporary (:sc long-reg :offset fr1-offset
3306 :from :argument :to :result) fr1)
3307 (:results (y :scs (long-reg)))
3308 (:arg-types long-float)
3309 (:result-types long-float)
3310 (:policy :fast-safe)
3311 (:note "inline sin/cos function")
3313 (:save-p :compute-only)
3316 (note-this-location vop :internal-error)
3317 (unless (zerop (tn-offset x))
3318 (inst fxch x) ; x to top of stack
3319 (unless (location= x y)
3320 (inst fst x))) ; maybe save it
3322 (inst fnstsw) ; status word to ax
3323 (inst and ah-tn #x04) ; C2
3325 ;; Else x was out of range so reduce it; ST0 is unchanged.
3326 (inst fstp fr1) ; Load 2*PI
3332 (inst fnstsw) ; status word to ax
3333 (inst and ah-tn #x04) ; C2
3337 (unless (zerop (tn-offset y))
3339 (frob fsin %sin fsin)
3340 (frob fcos %cos fcos))
3345 (:args (x :scs (long-reg) :target fr0))
3346 (:temporary (:sc unsigned-reg :offset eax-offset
3347 :from :argument :to :result) eax)
3348 (:temporary (:sc long-reg :offset fr0-offset
3349 :from :argument :to :result) fr0)
3350 (:temporary (:sc long-reg :offset fr1-offset
3351 :from :argument :to :result) fr1)
3352 (:results (y :scs (long-reg)))
3353 (:arg-types long-float)
3354 (:result-types long-float)
3355 (:policy :fast-safe)
3356 (:note "inline tan function")
3358 (:save-p :compute-only)
3361 (note-this-location vop :internal-error)
3370 (inst fldd (make-random-tn :kind :normal
3371 :sc (sc-or-lose 'double-reg)
3372 :offset (- (tn-offset x) 2)))))
3374 (inst fnstsw) ; status word to ax
3375 (inst and ah-tn #x04) ; C2
3377 ;; Else x was out of range so reduce it; ST0 is unchanged.
3378 (inst fldpi) ; Load 2*PI
3383 (inst fnstsw) ; status word to ax
3384 (inst and ah-tn #x04) ; C2
3398 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3399 ;;; the argument is out of range 2^63 and would thus be hopelessly
3401 (macrolet ((frob (func trans op)
3402 `(define-vop (,func)
3404 (:args (x :scs (long-reg) :target fr0))
3405 (:temporary (:sc long-reg :offset fr0-offset
3406 :from :argument :to :result) fr0)
3407 (:temporary (:sc unsigned-reg :offset eax-offset
3408 :from :argument :to :result) eax)
3409 (:results (y :scs (long-reg)))
3410 (:arg-types long-float)
3411 (:result-types long-float)
3412 (:policy :fast-safe)
3413 (:note "inline sin/cos function")
3415 (:save-p :compute-only)
3418 (note-this-location vop :internal-error)
3419 (unless (zerop (tn-offset x))
3420 (inst fxch x) ; x to top of stack
3421 (unless (location= x y)
3422 (inst fst x))) ; maybe save it
3424 (inst fnstsw) ; status word to ax
3425 (inst and ah-tn #x04) ; C2
3427 ;; Else x was out of range so reduce it; ST0 is unchanged.
3428 (inst fstp fr0) ; Load 0.0
3431 (unless (zerop (tn-offset y))
3433 (frob fsin %sin fsin)
3434 (frob fcos %cos fcos))
3438 (:args (x :scs (long-reg) :target fr0))
3439 (:temporary (:sc long-reg :offset fr0-offset
3440 :from :argument :to :result) fr0)
3441 (:temporary (:sc long-reg :offset fr1-offset
3442 :from :argument :to :result) fr1)
3443 (:temporary (:sc unsigned-reg :offset eax-offset
3444 :from :argument :to :result) eax)
3445 (:results (y :scs (long-reg)))
3446 (:arg-types long-float)
3447 (:result-types long-float)
3449 (:policy :fast-safe)
3450 (:note "inline tan function")
3452 (:save-p :compute-only)
3455 (note-this-location vop :internal-error)
3464 (inst fldd (make-random-tn :kind :normal
3465 :sc (sc-or-lose 'double-reg)
3466 :offset (- (tn-offset x) 2)))))
3468 (inst fnstsw) ; status word to ax
3469 (inst and ah-tn #x04) ; C2
3471 ;; Else x was out of range so reduce it; ST0 is unchanged.
3472 (inst fldz) ; Load 0.0
3484 ;;; Modified exp that handles the following special cases:
3485 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3488 (:args (x :scs (long-reg) :target fr0))
3489 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3490 (:temporary (:sc long-reg :offset fr0-offset
3491 :from :argument :to :result) fr0)
3492 (:temporary (:sc long-reg :offset fr1-offset
3493 :from :argument :to :result) fr1)
3494 (:temporary (:sc long-reg :offset fr2-offset
3495 :from :argument :to :result) fr2)
3496 (:results (y :scs (long-reg)))
3497 (:arg-types long-float)
3498 (:result-types long-float)
3499 (:policy :fast-safe)
3500 (:note "inline exp function")
3502 (:save-p :compute-only)
3505 (note-this-location vop :internal-error)
3506 (unless (zerop (tn-offset x))
3507 (inst fxch x) ; x to top of stack
3508 (unless (location= x y)
3509 (inst fst x))) ; maybe save it
3510 ;; Check for Inf or NaN
3514 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3515 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3516 (inst and ah-tn #x02) ; Test sign of Inf.
3517 (inst jmp :z DONE) ; +Inf gives +Inf.
3518 (inst fstp fr0) ; -Inf gives 0
3520 (inst jmp-short DONE)
3525 ;; Now fr0=x log2(e)
3529 (inst fsubp-sti fr1)
3532 (inst faddp-sti fr1)
3536 (unless (zerop (tn-offset y))
3539 ;;; Expm1 = exp(x) - 1.
3540 ;;; Handles the following special cases:
3541 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3542 (define-vop (fexpm1)
3544 (:args (x :scs (long-reg) :target fr0))
3545 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3546 (:temporary (:sc long-reg :offset fr0-offset
3547 :from :argument :to :result) fr0)
3548 (:temporary (:sc long-reg :offset fr1-offset
3549 :from :argument :to :result) fr1)
3550 (:temporary (:sc long-reg :offset fr2-offset
3551 :from :argument :to :result) fr2)
3552 (:results (y :scs (long-reg)))
3553 (:arg-types long-float)
3554 (:result-types long-float)
3555 (:policy :fast-safe)
3556 (:note "inline expm1 function")
3558 (:save-p :compute-only)
3561 (note-this-location vop :internal-error)
3562 (unless (zerop (tn-offset x))
3563 (inst fxch x) ; x to top of stack
3564 (unless (location= x y)
3565 (inst fst x))) ; maybe save it
3566 ;; Check for Inf or NaN
3570 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3571 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3572 (inst and ah-tn #x02) ; Test sign of Inf.
3573 (inst jmp :z DONE) ; +Inf gives +Inf.
3574 (inst fstp fr0) ; -Inf gives -1.0
3577 (inst jmp-short DONE)
3579 ;; Free two stack slots leaving the argument on top.
3583 (inst fmul fr1) ; Now fr0 = x log2(e)
3598 (unless (zerop (tn-offset y))
3603 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3604 (:temporary (:sc long-reg :offset fr0-offset
3605 :from :argument :to :result) fr0)
3606 (:temporary (:sc long-reg :offset fr1-offset
3607 :from :argument :to :result) fr1)
3608 (:results (y :scs (long-reg)))
3609 (:arg-types long-float)
3610 (:result-types long-float)
3611 (:policy :fast-safe)
3612 (:note "inline log function")
3614 (:save-p :compute-only)
3616 (note-this-location vop :internal-error)
3631 ;; x is in a FP reg, not fr0 or fr1
3635 (inst fldd (make-random-tn :kind :normal
3636 :sc (sc-or-lose 'double-reg)
3637 :offset (1- (tn-offset x))))))
3639 ((long-stack descriptor-reg)
3643 (if (sc-is x long-stack)
3644 (inst fldl (ea-for-lf-stack x))
3645 (inst fldl (ea-for-lf-desc x)))
3650 (t (inst fstd y)))))
3652 (define-vop (flog10)
3654 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3655 (:temporary (:sc long-reg :offset fr0-offset
3656 :from :argument :to :result) fr0)
3657 (:temporary (:sc long-reg :offset fr1-offset
3658 :from :argument :to :result) fr1)
3659 (:results (y :scs (long-reg)))
3660 (:arg-types long-float)
3661 (:result-types long-float)
3662 (:policy :fast-safe)
3663 (:note "inline log10 function")
3665 (:save-p :compute-only)
3667 (note-this-location vop :internal-error)
3682 ;; x is in a FP reg, not fr0 or fr1
3686 (inst fldd (make-random-tn :kind :normal
3687 :sc (sc-or-lose 'double-reg)
3688 :offset (1- (tn-offset x))))))
3690 ((long-stack descriptor-reg)
3694 (if (sc-is x long-stack)
3695 (inst fldl (ea-for-lf-stack x))
3696 (inst fldl (ea-for-lf-desc x)))
3701 (t (inst fstd y)))))
3705 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3706 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3707 (:temporary (:sc long-reg :offset fr0-offset
3708 :from (:argument 0) :to :result) fr0)
3709 (:temporary (:sc long-reg :offset fr1-offset
3710 :from (:argument 1) :to :result) fr1)
3711 (:temporary (:sc long-reg :offset fr2-offset
3712 :from :load :to :result) fr2)
3713 (:results (r :scs (long-reg)))
3714 (:arg-types long-float long-float)
3715 (:result-types long-float)
3716 (:policy :fast-safe)
3717 (:note "inline pow function")
3719 (:save-p :compute-only)
3721 (note-this-location vop :internal-error)
3722 ;; Setup x in fr0 and y in fr1
3724 ;; x in fr0; y in fr1
3725 ((and (sc-is x long-reg) (zerop (tn-offset x))
3726 (sc-is y long-reg) (= 1 (tn-offset y))))
3727 ;; y in fr1; x not in fr0
3728 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3732 (copy-fp-reg-to-fr0 x))
3735 (inst fldl (ea-for-lf-stack x)))
3738 (inst fldl (ea-for-lf-desc x)))))
3739 ;; x in fr0; y not in fr1
3740 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3742 ;; Now load y to fr0
3745 (copy-fp-reg-to-fr0 y))
3748 (inst fldl (ea-for-lf-stack y)))
3751 (inst fldl (ea-for-lf-desc y))))
3753 ;; x in fr1; y not in fr1
3754 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3758 (copy-fp-reg-to-fr0 y))
3761 (inst fldl (ea-for-lf-stack y)))
3764 (inst fldl (ea-for-lf-desc y))))
3767 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3769 ;; Now load x to fr0
3772 (copy-fp-reg-to-fr0 x))
3775 (inst fldl (ea-for-lf-stack x)))
3778 (inst fldl (ea-for-lf-desc x)))))
3779 ;; Neither x or y are in either fr0 or fr1
3786 (inst fldd (make-random-tn :kind :normal
3787 :sc (sc-or-lose 'double-reg)
3788 :offset (- (tn-offset y) 2))))
3790 (inst fldl (ea-for-lf-stack y)))
3792 (inst fldl (ea-for-lf-desc y))))
3796 (inst fldd (make-random-tn :kind :normal
3797 :sc (sc-or-lose 'double-reg)
3798 :offset (1- (tn-offset x)))))
3800 (inst fldl (ea-for-lf-stack x)))
3802 (inst fldl (ea-for-lf-desc x))))))
3804 ;; Now have x at fr0; and y at fr1
3806 ;; Now fr0=y log2(x)
3810 (inst fsubp-sti fr1)
3813 (inst faddp-sti fr1)
3818 (t (inst fstd r)))))
3820 (define-vop (fscalen)
3821 (:translate %scalbn)
3822 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3823 (y :scs (signed-stack signed-reg) :target temp))
3824 (:temporary (:sc long-reg :offset fr0-offset
3825 :from (:argument 0) :to :result) fr0)
3826 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3827 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3828 (:results (r :scs (long-reg)))
3829 (:arg-types long-float signed-num)
3830 (:result-types long-float)
3831 (:policy :fast-safe)
3832 (:note "inline scalbn function")
3834 ;; Setup x in fr0 and y in fr1
3865 (inst fld (make-random-tn :kind :normal
3866 :sc (sc-or-lose 'double-reg)
3867 :offset (1- (tn-offset x)))))))
3868 ((long-stack descriptor-reg)
3877 (if (sc-is x long-stack)
3878 (inst fldl (ea-for-lf-stack x))
3879 (inst fldl (ea-for-lf-desc x)))))
3881 (unless (zerop (tn-offset r))
3884 (define-vop (fscale)
3886 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3887 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3888 (:temporary (:sc long-reg :offset fr0-offset
3889 :from (:argument 0) :to :result) fr0)
3890 (:temporary (:sc long-reg :offset fr1-offset
3891 :from (:argument 1) :to :result) fr1)
3892 (:results (r :scs (long-reg)))
3893 (:arg-types long-float long-float)
3894 (:result-types long-float)
3895 (:policy :fast-safe)
3896 (:note "inline scalb function")
3898 (:save-p :compute-only)
3900 (note-this-location vop :internal-error)
3901 ;; Setup x in fr0 and y in fr1
3903 ;; x in fr0; y in fr1
3904 ((and (sc-is x long-reg) (zerop (tn-offset x))
3905 (sc-is y long-reg) (= 1 (tn-offset y))))
3906 ;; y in fr1; x not in fr0
3907 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3911 (copy-fp-reg-to-fr0 x))
3914 (inst fldl (ea-for-lf-stack x)))
3917 (inst fldl (ea-for-lf-desc x)))))
3918 ;; x in fr0; y not in fr1
3919 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3921 ;; Now load y to fr0
3924 (copy-fp-reg-to-fr0 y))
3927 (inst fldl (ea-for-lf-stack y)))
3930 (inst fldl (ea-for-lf-desc y))))
3932 ;; x in fr1; y not in fr1
3933 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3937 (copy-fp-reg-to-fr0 y))
3940 (inst fldl (ea-for-lf-stack y)))
3943 (inst fldl (ea-for-lf-desc y))))
3946 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3948 ;; Now load x to fr0
3951 (copy-fp-reg-to-fr0 x))
3954 (inst fldl (ea-for-lf-stack x)))
3957 (inst fldl (ea-for-lf-desc x)))))
3958 ;; Neither x or y are in either fr0 or fr1
3965 (inst fldd (make-random-tn :kind :normal
3966 :sc (sc-or-lose 'double-reg)
3967 :offset (- (tn-offset y) 2))))
3969 (inst fldl (ea-for-lf-stack y)))
3971 (inst fldl (ea-for-lf-desc y))))
3975 (inst fldd (make-random-tn :kind :normal
3976 :sc (sc-or-lose 'double-reg)
3977 :offset (1- (tn-offset x)))))
3979 (inst fldl (ea-for-lf-stack x)))
3981 (inst fldl (ea-for-lf-desc x))))))
3983 ;; Now have x at fr0; and y at fr1
3985 (unless (zerop (tn-offset r))
3988 (define-vop (flog1p)
3990 (:args (x :scs (long-reg) :to :result))
3991 (:temporary (:sc long-reg :offset fr0-offset
3992 :from :argument :to :result) fr0)
3993 (:temporary (:sc long-reg :offset fr1-offset
3994 :from :argument :to :result) fr1)
3995 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3996 (:results (y :scs (long-reg)))
3997 (:arg-types long-float)
3998 (:result-types long-float)
3999 (:policy :fast-safe)
4000 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
4001 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
4002 ;; an enormous PROGN above. Still, it would be probably be good to
4003 ;; add some code to warn about redefining VOPs.
4004 (:note "inline log1p function")
4007 ;; x is in a FP reg, not fr0, fr1.
4010 (inst fldd (make-random-tn :kind :normal
4011 :sc (sc-or-lose 'double-reg)
4012 :offset (- (tn-offset x) 2)))
4014 (inst push #x3e947ae1) ; Constant 0.29
4016 (inst fld (make-ea :dword :base esp-tn))
4019 (inst fnstsw) ; status word to ax
4020 (inst and ah-tn #x45)
4021 (inst jmp :z WITHIN-RANGE)
4022 ;; Out of range for fyl2xp1.
4024 (inst faddd (make-random-tn :kind :normal
4025 :sc (sc-or-lose 'double-reg)
4026 :offset (- (tn-offset x) 1)))
4034 (inst fldd (make-random-tn :kind :normal
4035 :sc (sc-or-lose 'double-reg)
4036 :offset (- (tn-offset x) 1)))
4042 (t (inst fstd y)))))
4044 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4045 ;;; instruction and a range check can be avoided.
4046 (define-vop (flog1p-pentium)
4048 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4049 (:temporary (:sc long-reg :offset fr0-offset
4050 :from :argument :to :result) fr0)
4051 (:temporary (:sc long-reg :offset fr1-offset
4052 :from :argument :to :result) fr1)
4053 (:results (y :scs (long-reg)))
4054 (:arg-types long-float)
4055 (:result-types long-float)
4056 (:policy :fast-safe)
4057 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
4058 (:note "inline log1p function")
4074 ;; x is in a FP reg, not fr0 or fr1
4078 (inst fldd (make-random-tn :kind :normal
4079 :sc (sc-or-lose 'double-reg)
4080 :offset (1- (tn-offset x)))))))
4081 ((long-stack descriptor-reg)
4085 (if (sc-is x long-stack)
4086 (inst fldl (ea-for-lf-stack x))
4087 (inst fldl (ea-for-lf-desc x)))))
4092 (t (inst fstd y)))))
4096 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4097 (:temporary (:sc long-reg :offset fr0-offset
4098 :from :argument :to :result) fr0)
4099 (:temporary (:sc long-reg :offset fr1-offset
4100 :from :argument :to :result) fr1)
4101 (:results (y :scs (long-reg)))
4102 (:arg-types long-float)
4103 (:result-types long-float)
4104 (:policy :fast-safe)
4105 (:note "inline logb function")
4107 (:save-p :compute-only)
4109 (note-this-location vop :internal-error)
4120 ;; x is in a FP reg, not fr0 or fr1
4123 (inst fldd (make-random-tn :kind :normal
4124 :sc (sc-or-lose 'double-reg)
4125 :offset (- (tn-offset x) 2))))))
4126 ((long-stack descriptor-reg)
4129 (if (sc-is x long-stack)
4130 (inst fldl (ea-for-lf-stack x))
4131 (inst fldl (ea-for-lf-desc x)))))
4142 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4143 (:temporary (:sc long-reg :offset fr0-offset
4144 :from (:argument 0) :to :result) fr0)
4145 (:temporary (:sc long-reg :offset fr1-offset
4146 :from (:argument 0) :to :result) fr1)
4147 (:results (r :scs (long-reg)))
4148 (:arg-types long-float)
4149 (:result-types long-float)
4150 (:policy :fast-safe)
4151 (:note "inline atan function")
4153 (:save-p :compute-only)
4155 (note-this-location vop :internal-error)
4156 ;; Setup x in fr1 and 1.0 in fr0
4159 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4162 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4164 ;; x not in fr0 or fr1
4171 (inst fldd (make-random-tn :kind :normal
4172 :sc (sc-or-lose 'double-reg)
4173 :offset (- (tn-offset x) 2))))
4175 (inst fldl (ea-for-lf-stack x)))
4177 (inst fldl (ea-for-lf-desc x))))))
4179 ;; Now have x at fr1; and 1.0 at fr0
4184 (t (inst fstd r)))))
4186 (define-vop (fatan2)
4188 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4189 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4190 (:temporary (:sc long-reg :offset fr0-offset
4191 :from (:argument 1) :to :result) fr0)
4192 (:temporary (:sc long-reg :offset fr1-offset
4193 :from (:argument 0) :to :result) fr1)
4194 (:results (r :scs (long-reg)))
4195 (:arg-types long-float long-float)
4196 (:result-types long-float)
4197 (:policy :fast-safe)
4198 (:note "inline atan2 function")
4200 (:save-p :compute-only)
4202 (note-this-location vop :internal-error)
4203 ;; Setup x in fr1 and y in fr0
4205 ;; y in fr0; x in fr1
4206 ((and (sc-is y long-reg) (zerop (tn-offset y))
4207 (sc-is x long-reg) (= 1 (tn-offset x))))
4208 ;; x in fr1; y not in fr0
4209 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4213 (copy-fp-reg-to-fr0 y))
4216 (inst fldl (ea-for-lf-stack y)))
4219 (inst fldl (ea-for-lf-desc y)))))
4220 ;; y in fr0; x not in fr1
4221 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4223 ;; Now load x to fr0
4226 (copy-fp-reg-to-fr0 x))
4229 (inst fldl (ea-for-lf-stack x)))
4232 (inst fldl (ea-for-lf-desc x))))
4234 ;; y in fr1; x not in fr1
4235 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4239 (copy-fp-reg-to-fr0 x))
4242 (inst fldl (ea-for-lf-stack x)))
4245 (inst fldl (ea-for-lf-desc x))))
4248 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4250 ;; Now load y to fr0
4253 (copy-fp-reg-to-fr0 y))
4256 (inst fldl (ea-for-lf-stack y)))
4259 (inst fldl (ea-for-lf-desc y)))))
4260 ;; Neither y or x are in either fr0 or fr1
4267 (inst fldd (make-random-tn :kind :normal
4268 :sc (sc-or-lose 'double-reg)
4269 :offset (- (tn-offset x) 2))))
4271 (inst fldl (ea-for-lf-stack x)))
4273 (inst fldl (ea-for-lf-desc x))))
4277 (inst fldd (make-random-tn :kind :normal
4278 :sc (sc-or-lose 'double-reg)
4279 :offset (1- (tn-offset y)))))
4281 (inst fldl (ea-for-lf-stack y)))
4283 (inst fldl (ea-for-lf-desc y))))))
4285 ;; Now have y at fr0; and x at fr1
4290 (t (inst fstd r)))))
4292 ) ; PROGN #!+LONG-FLOAT
4294 ;;;; complex float VOPs
4296 (define-vop (make-complex-single-float)
4297 (:translate complex)
4298 (:args (real :scs (single-reg) :to :result :target r
4299 :load-if (not (location= real r)))
4300 (imag :scs (single-reg) :to :save))
4301 (:arg-types single-float single-float)
4302 (:results (r :scs (complex-single-reg) :from (:argument 0)
4303 :load-if (not (sc-is r complex-single-stack))))
4304 (:result-types complex-single-float)
4305 (:note "inline complex single-float creation")
4306 (:policy :fast-safe)
4310 (let ((r-real (complex-double-reg-real-tn r)))
4311 (unless (location= real r-real)
4312 (cond ((zerop (tn-offset r-real))
4313 (copy-fp-reg-to-fr0 real))
4314 ((zerop (tn-offset real))
4319 (inst fxch real)))))
4320 (let ((r-imag (complex-double-reg-imag-tn r)))
4321 (unless (location= imag r-imag)
4322 (cond ((zerop (tn-offset imag))
4327 (inst fxch imag))))))
4328 (complex-single-stack
4329 (unless (location= real r)
4330 (cond ((zerop (tn-offset real))
4331 (inst fst (ea-for-csf-real-stack r)))
4334 (inst fst (ea-for-csf-real-stack r))
4337 (inst fst (ea-for-csf-imag-stack r))
4338 (inst fxch imag)))))
4340 (define-vop (make-complex-double-float)
4341 (:translate complex)
4342 (:args (real :scs (double-reg) :target r
4343 :load-if (not (location= real r)))
4344 (imag :scs (double-reg) :to :save))
4345 (:arg-types double-float double-float)
4346 (:results (r :scs (complex-double-reg) :from (:argument 0)
4347 :load-if (not (sc-is r complex-double-stack))))
4348 (:result-types complex-double-float)
4349 (:note "inline complex double-float creation")
4350 (:policy :fast-safe)
4354 (let ((r-real (complex-double-reg-real-tn r)))
4355 (unless (location= real r-real)
4356 (cond ((zerop (tn-offset r-real))
4357 (copy-fp-reg-to-fr0 real))
4358 ((zerop (tn-offset real))
4363 (inst fxch real)))))
4364 (let ((r-imag (complex-double-reg-imag-tn r)))
4365 (unless (location= imag r-imag)
4366 (cond ((zerop (tn-offset imag))
4371 (inst fxch imag))))))
4372 (complex-double-stack
4373 (unless (location= real r)
4374 (cond ((zerop (tn-offset real))
4375 (inst fstd (ea-for-cdf-real-stack r)))
4378 (inst fstd (ea-for-cdf-real-stack r))
4381 (inst fstd (ea-for-cdf-imag-stack r))
4382 (inst fxch imag)))))
4385 (define-vop (make-complex-long-float)
4386 (:translate complex)
4387 (:args (real :scs (long-reg) :target r
4388 :load-if (not (location= real r)))
4389 (imag :scs (long-reg) :to :save))
4390 (:arg-types long-float long-float)
4391 (:results (r :scs (complex-long-reg) :from (:argument 0)
4392 :load-if (not (sc-is r complex-long-stack))))
4393 (:result-types complex-long-float)
4394 (:note "inline complex long-float creation")
4395 (:policy :fast-safe)
4399 (let ((r-real (complex-double-reg-real-tn r)))
4400 (unless (location= real r-real)
4401 (cond ((zerop (tn-offset r-real))
4402 (copy-fp-reg-to-fr0 real))
4403 ((zerop (tn-offset real))
4408 (inst fxch real)))))
4409 (let ((r-imag (complex-double-reg-imag-tn r)))
4410 (unless (location= imag r-imag)
4411 (cond ((zerop (tn-offset imag))
4416 (inst fxch imag))))))
4418 (unless (location= real r)
4419 (cond ((zerop (tn-offset real))
4420 (store-long-float (ea-for-clf-real-stack r)))
4423 (store-long-float (ea-for-clf-real-stack r))
4426 (store-long-float (ea-for-clf-imag-stack r))
4427 (inst fxch imag)))))
4430 (define-vop (complex-float-value)
4431 (:args (x :target r))
4433 (:variant-vars offset)
4434 (:policy :fast-safe)
4436 (cond ((sc-is x complex-single-reg complex-double-reg
4437 #!+long-float complex-long-reg)
4439 (make-random-tn :kind :normal
4440 :sc (sc-or-lose 'double-reg)
4441 :offset (+ offset (tn-offset x)))))
4442 (unless (location= value-tn r)
4443 (cond ((zerop (tn-offset r))
4444 (copy-fp-reg-to-fr0 value-tn))
4445 ((zerop (tn-offset value-tn))
4448 (inst fxch value-tn)
4450 (inst fxch value-tn))))))
4451 ((sc-is r single-reg)
4452 (let ((ea (sc-case x
4453 (complex-single-stack
4455 (0 (ea-for-csf-real-stack x))
4456 (1 (ea-for-csf-imag-stack x))))
4459 (0 (ea-for-csf-real-desc x))
4460 (1 (ea-for-csf-imag-desc x)))))))
4461 (with-empty-tn@fp-top(r)
4463 ((sc-is r double-reg)
4464 (let ((ea (sc-case x
4465 (complex-double-stack
4467 (0 (ea-for-cdf-real-stack x))
4468 (1 (ea-for-cdf-imag-stack x))))
4471 (0 (ea-for-cdf-real-desc x))
4472 (1 (ea-for-cdf-imag-desc x)))))))
4473 (with-empty-tn@fp-top(r)
4477 (let ((ea (sc-case x
4480 (0 (ea-for-clf-real-stack x))
4481 (1 (ea-for-clf-imag-stack x))))
4484 (0 (ea-for-clf-real-desc x))
4485 (1 (ea-for-clf-imag-desc x)))))))
4486 (with-empty-tn@fp-top(r)
4488 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4490 (define-vop (realpart/complex-single-float complex-float-value)
4491 (:translate realpart)
4492 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4494 (:arg-types complex-single-float)
4495 (:results (r :scs (single-reg)))
4496 (:result-types single-float)
4497 (:note "complex float realpart")
4500 (define-vop (realpart/complex-double-float complex-float-value)
4501 (:translate realpart)
4502 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4504 (:arg-types complex-double-float)
4505 (:results (r :scs (double-reg)))
4506 (:result-types double-float)
4507 (:note "complex float realpart")
4511 (define-vop (realpart/complex-long-float complex-float-value)
4512 (:translate realpart)
4513 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4515 (:arg-types complex-long-float)
4516 (:results (r :scs (long-reg)))
4517 (:result-types long-float)
4518 (:note "complex float realpart")
4521 (define-vop (imagpart/complex-single-float complex-float-value)
4522 (:translate imagpart)
4523 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4525 (:arg-types complex-single-float)
4526 (:results (r :scs (single-reg)))
4527 (:result-types single-float)
4528 (:note "complex float imagpart")
4531 (define-vop (imagpart/complex-double-float complex-float-value)
4532 (:translate imagpart)
4533 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4535 (:arg-types complex-double-float)
4536 (:results (r :scs (double-reg)))
4537 (:result-types double-float)
4538 (:note "complex float imagpart")
4542 (define-vop (imagpart/complex-long-float complex-float-value)
4543 (:translate imagpart)
4544 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4546 (:arg-types complex-long-float)
4547 (:results (r :scs (long-reg)))
4548 (:result-types long-float)
4549 (:note "complex float imagpart")
4552 ;;; hack dummy VOPs to bias the representation selection of their
4553 ;;; arguments towards a FP register, which can help avoid consing at
4554 ;;; inappropriate locations
4555 (defknown double-float-reg-bias (double-float) (values))
4556 (define-vop (double-float-reg-bias)
4557 (:translate double-float-reg-bias)
4558 (:args (x :scs (double-reg double-stack) :load-if nil))
4559 (:arg-types double-float)
4560 (:policy :fast-safe)
4561 (:note "inline dummy FP register bias")
4564 (defknown single-float-reg-bias (single-float) (values))
4565 (define-vop (single-float-reg-bias)
4566 (:translate single-float-reg-bias)
4567 (:args (x :scs (single-reg single-stack) :load-if nil))
4568 (:arg-types single-float)
4569 (:policy :fast-safe)
4570 (:note "inline dummy FP register bias")