1 ;;;; floating point support for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (macrolet ((ea-for-xf-desc (tn slot)
17 :disp (- (* ,slot n-word-bytes)
18 other-pointer-lowtag))))
19 (defun ea-for-sf-desc (tn)
20 (ea-for-xf-desc tn single-float-value-slot))
21 (defun ea-for-df-desc (tn)
22 (ea-for-xf-desc tn double-float-value-slot))
24 (defun ea-for-lf-desc (tn)
25 (ea-for-xf-desc tn long-float-value-slot))
27 (defun ea-for-csf-real-desc (tn)
28 (ea-for-xf-desc tn complex-single-float-real-slot))
29 (defun ea-for-csf-imag-desc (tn)
30 (ea-for-xf-desc tn complex-single-float-imag-slot))
31 (defun ea-for-cdf-real-desc (tn)
32 (ea-for-xf-desc tn complex-double-float-real-slot))
33 (defun ea-for-cdf-imag-desc (tn)
34 (ea-for-xf-desc tn complex-double-float-imag-slot))
36 (defun ea-for-clf-real-desc (tn)
37 (ea-for-xf-desc tn complex-long-float-real-slot))
39 (defun ea-for-clf-imag-desc (tn)
40 (ea-for-xf-desc tn complex-long-float-imag-slot)))
42 (macrolet ((ea-for-xf-stack (tn kind)
45 :disp (- (* (+ (tn-offset ,tn)
46 (ecase ,kind (:single 1) (:double 2) (:long 3)))
48 (defun ea-for-sf-stack (tn)
49 (ea-for-xf-stack tn :single))
50 (defun ea-for-df-stack (tn)
51 (ea-for-xf-stack tn :double))
53 (defun ea-for-lf-stack (tn)
54 (ea-for-xf-stack tn :long)))
56 ;;; Telling the FPU to wait is required in order to make signals occur
57 ;;; at the expected place, but naturally slows things down.
59 ;;; NODE is the node whose compilation policy controls the decision
60 ;;; whether to just blast through carelessly or carefully emit wait
61 ;;; instructions and whatnot.
63 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
64 ;;; #'NOTE-NEXT-INSTRUCTION.
65 (defun maybe-fp-wait (node &optional note-next-instruction)
66 (when (policy node (or (= debug 3) (> safety speed))))
67 (when note-next-instruction
68 (note-next-instruction note-next-instruction :internal-error))
71 ;;; complex float stack EAs
72 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
75 :disp (- (* (+ (tn-offset ,tn)
80 (ecase ,slot (:real 1) (:imag 2))))
82 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
83 (ea-for-cxf-stack tn :single :real base))
84 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
85 (ea-for-cxf-stack tn :single :imag base))
86 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
87 (ea-for-cxf-stack tn :double :real base))
88 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
89 (ea-for-cxf-stack tn :double :imag base))
91 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
92 (ea-for-cxf-stack tn :long :real base))
94 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
95 (ea-for-cxf-stack tn :long :imag base)))
97 ;;; Abstract out the copying of a FP register to the FP stack top, and
98 ;;; provide two alternatives for its implementation. Note: it's not
99 ;;; necessary to distinguish between a single or double register move
102 ;;; Using a Pop then load.
103 (defun copy-fp-reg-to-fr0 (reg)
104 (aver (not (zerop (tn-offset reg))))
106 (inst fld (make-random-tn :kind :normal
107 :sc (sc-or-lose 'double-reg)
108 :offset (1- (tn-offset reg)))))
109 ;;; Using Fxch then Fst to restore the original reg contents.
111 (defun copy-fp-reg-to-fr0 (reg)
112 (aver (not (zerop (tn-offset reg))))
116 ;;; The x86 can't store a long-float to memory without popping the
117 ;;; stack and marking a register as empty, so it is necessary to
118 ;;; restore the register from memory.
120 (defun store-long-float (ea)
126 ;;; X is source, Y is destination.
127 (define-move-fun (load-single 2) (vop x y)
128 ((single-stack) (single-reg))
129 (with-empty-tn@fp-top(y)
130 (inst fld (ea-for-sf-stack x))))
132 (define-move-fun (store-single 2) (vop x y)
133 ((single-reg) (single-stack))
134 (cond ((zerop (tn-offset x))
135 (inst fst (ea-for-sf-stack y)))
138 (inst fst (ea-for-sf-stack y))
139 ;; This may not be necessary as ST0 is likely invalid now.
142 (define-move-fun (load-double 2) (vop x y)
143 ((double-stack) (double-reg))
144 (with-empty-tn@fp-top(y)
145 (inst fldd (ea-for-df-stack x))))
147 (define-move-fun (store-double 2) (vop x y)
148 ((double-reg) (double-stack))
149 (cond ((zerop (tn-offset x))
150 (inst fstd (ea-for-df-stack y)))
153 (inst fstd (ea-for-df-stack y))
154 ;; This may not be necessary as ST0 is likely invalid now.
158 (define-move-fun (load-long 2) (vop x y)
159 ((long-stack) (long-reg))
160 (with-empty-tn@fp-top(y)
161 (inst fldl (ea-for-lf-stack x))))
164 (define-move-fun (store-long 2) (vop x y)
165 ((long-reg) (long-stack))
166 (cond ((zerop (tn-offset x))
167 (store-long-float (ea-for-lf-stack y)))
170 (store-long-float (ea-for-lf-stack y))
171 ;; This may not be necessary as ST0 is likely invalid now.
174 ;;; The i387 has instructions to load some useful constants. This
175 ;;; doesn't save much time but might cut down on memory access and
176 ;;; reduce the size of the constant vector (CV). Intel claims they are
177 ;;; stored in a more precise form on chip. Anyhow, might as well use
178 ;;; the feature. It can be turned off by hacking the
179 ;;; "immediate-constant-sc" in vm.lisp.
180 (eval-when (:compile-toplevel :execute)
181 (setf *read-default-float-format*
182 #!+long-float 'long-float #!-long-float 'double-float))
183 (define-move-fun (load-fp-constant 2) (vop x y)
184 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
185 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
186 (with-empty-tn@fp-top(y)
191 ((= value (coerce pi *read-default-float-format*))
193 ((= value (log 10e0 2e0))
195 ((= value (log 2.718281828459045235360287471352662e0 2e0))
197 ((= value (log 2e0 10e0))
199 ((= value (log 2e0 2.718281828459045235360287471352662e0))
201 (t (warn "ignoring bogus i387 constant ~A" value))))))
202 (eval-when (:compile-toplevel :execute)
203 (setf *read-default-float-format* 'single-float))
205 ;;;; complex float move functions
207 (defun complex-single-reg-real-tn (x)
208 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
209 :offset (tn-offset x)))
210 (defun complex-single-reg-imag-tn (x)
211 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
212 :offset (1+ (tn-offset x))))
214 (defun complex-double-reg-real-tn (x)
215 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
216 :offset (tn-offset x)))
217 (defun complex-double-reg-imag-tn (x)
218 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
219 :offset (1+ (tn-offset x))))
222 (defun complex-long-reg-real-tn (x)
223 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
224 :offset (tn-offset x)))
226 (defun complex-long-reg-imag-tn (x)
227 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
228 :offset (1+ (tn-offset x))))
230 ;;; X is source, Y is destination.
231 (define-move-fun (load-complex-single 2) (vop x y)
232 ((complex-single-stack) (complex-single-reg))
233 (let ((real-tn (complex-single-reg-real-tn y)))
234 (with-empty-tn@fp-top (real-tn)
235 (inst fld (ea-for-csf-real-stack x))))
236 (let ((imag-tn (complex-single-reg-imag-tn y)))
237 (with-empty-tn@fp-top (imag-tn)
238 (inst fld (ea-for-csf-imag-stack x)))))
240 (define-move-fun (store-complex-single 2) (vop x y)
241 ((complex-single-reg) (complex-single-stack))
242 (let ((real-tn (complex-single-reg-real-tn x)))
243 (cond ((zerop (tn-offset real-tn))
244 (inst fst (ea-for-csf-real-stack y)))
247 (inst fst (ea-for-csf-real-stack y))
248 (inst fxch real-tn))))
249 (let ((imag-tn (complex-single-reg-imag-tn x)))
251 (inst fst (ea-for-csf-imag-stack y))
252 (inst fxch imag-tn)))
254 (define-move-fun (load-complex-double 2) (vop x y)
255 ((complex-double-stack) (complex-double-reg))
256 (let ((real-tn (complex-double-reg-real-tn y)))
257 (with-empty-tn@fp-top(real-tn)
258 (inst fldd (ea-for-cdf-real-stack x))))
259 (let ((imag-tn (complex-double-reg-imag-tn y)))
260 (with-empty-tn@fp-top(imag-tn)
261 (inst fldd (ea-for-cdf-imag-stack x)))))
263 (define-move-fun (store-complex-double 2) (vop x y)
264 ((complex-double-reg) (complex-double-stack))
265 (let ((real-tn (complex-double-reg-real-tn x)))
266 (cond ((zerop (tn-offset real-tn))
267 (inst fstd (ea-for-cdf-real-stack y)))
270 (inst fstd (ea-for-cdf-real-stack y))
271 (inst fxch real-tn))))
272 (let ((imag-tn (complex-double-reg-imag-tn x)))
274 (inst fstd (ea-for-cdf-imag-stack y))
275 (inst fxch imag-tn)))
278 (define-move-fun (load-complex-long 2) (vop x y)
279 ((complex-long-stack) (complex-long-reg))
280 (let ((real-tn (complex-long-reg-real-tn y)))
281 (with-empty-tn@fp-top(real-tn)
282 (inst fldl (ea-for-clf-real-stack x))))
283 (let ((imag-tn (complex-long-reg-imag-tn y)))
284 (with-empty-tn@fp-top(imag-tn)
285 (inst fldl (ea-for-clf-imag-stack x)))))
288 (define-move-fun (store-complex-long 2) (vop x y)
289 ((complex-long-reg) (complex-long-stack))
290 (let ((real-tn (complex-long-reg-real-tn x)))
291 (cond ((zerop (tn-offset real-tn))
292 (store-long-float (ea-for-clf-real-stack y)))
295 (store-long-float (ea-for-clf-real-stack y))
296 (inst fxch real-tn))))
297 (let ((imag-tn (complex-long-reg-imag-tn x)))
299 (store-long-float (ea-for-clf-imag-stack y))
300 (inst fxch imag-tn)))
305 ;;; float register to register moves
306 (define-vop (float-move)
311 (unless (location= x y)
312 (cond ((zerop (tn-offset y))
313 (copy-fp-reg-to-fr0 x))
314 ((zerop (tn-offset x))
321 (define-vop (single-move float-move)
322 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
323 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
324 (define-move-vop single-move :move (single-reg) (single-reg))
326 (define-vop (double-move float-move)
327 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
328 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
329 (define-move-vop double-move :move (double-reg) (double-reg))
332 (define-vop (long-move float-move)
333 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
334 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
336 (define-move-vop long-move :move (long-reg) (long-reg))
338 ;;; complex float register to register moves
339 (define-vop (complex-float-move)
340 (:args (x :target y :load-if (not (location= x y))))
341 (:results (y :load-if (not (location= x y))))
342 (:note "complex float move")
344 (unless (location= x y)
345 ;; Note the complex-float-regs are aligned to every second
346 ;; float register so there is not need to worry about overlap.
347 (let ((x-real (complex-double-reg-real-tn x))
348 (y-real (complex-double-reg-real-tn y)))
349 (cond ((zerop (tn-offset y-real))
350 (copy-fp-reg-to-fr0 x-real))
351 ((zerop (tn-offset x-real))
356 (inst fxch x-real))))
357 (let ((x-imag (complex-double-reg-imag-tn x))
358 (y-imag (complex-double-reg-imag-tn y)))
361 (inst fxch x-imag)))))
363 (define-vop (complex-single-move complex-float-move)
364 (:args (x :scs (complex-single-reg) :target y
365 :load-if (not (location= x y))))
366 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
367 (define-move-vop complex-single-move :move
368 (complex-single-reg) (complex-single-reg))
370 (define-vop (complex-double-move complex-float-move)
371 (:args (x :scs (complex-double-reg)
372 :target y :load-if (not (location= x y))))
373 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
374 (define-move-vop complex-double-move :move
375 (complex-double-reg) (complex-double-reg))
378 (define-vop (complex-long-move complex-float-move)
379 (:args (x :scs (complex-long-reg)
380 :target y :load-if (not (location= x y))))
381 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
383 (define-move-vop complex-long-move :move
384 (complex-long-reg) (complex-long-reg))
386 ;;; Move from float to a descriptor reg. allocating a new float
387 ;;; object in the process.
388 (define-vop (move-from-single)
389 (:args (x :scs (single-reg) :to :save))
390 (:results (y :scs (descriptor-reg)))
392 (:note "float to pointer coercion")
394 (with-fixed-allocation (y
396 single-float-size node)
398 (inst fst (ea-for-sf-desc y))))))
399 (define-move-vop move-from-single :move
400 (single-reg) (descriptor-reg))
402 (define-vop (move-from-double)
403 (:args (x :scs (double-reg) :to :save))
404 (:results (y :scs (descriptor-reg)))
406 (:note "float to pointer coercion")
408 (with-fixed-allocation (y
413 (inst fstd (ea-for-df-desc y))))))
414 (define-move-vop move-from-double :move
415 (double-reg) (descriptor-reg))
418 (define-vop (move-from-long)
419 (:args (x :scs (long-reg) :to :save))
420 (:results (y :scs (descriptor-reg)))
422 (:note "float to pointer coercion")
424 (with-fixed-allocation (y
429 (store-long-float (ea-for-lf-desc y))))))
431 (define-move-vop move-from-long :move
432 (long-reg) (descriptor-reg))
434 (define-vop (move-from-fp-constant)
435 (:args (x :scs (fp-constant)))
436 (:results (y :scs (descriptor-reg)))
438 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
439 (0f0 (load-symbol-value y *fp-constant-0f0*))
440 (1f0 (load-symbol-value y *fp-constant-1f0*))
441 (0d0 (load-symbol-value y *fp-constant-0d0*))
442 (1d0 (load-symbol-value y *fp-constant-1d0*))
444 (0l0 (load-symbol-value y *fp-constant-0l0*))
446 (1l0 (load-symbol-value y *fp-constant-1l0*))
448 (#.pi (load-symbol-value y *fp-constant-pi*))
450 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
452 (#.(log 2.718281828459045235360287471352662L0 2l0)
453 (load-symbol-value y *fp-constant-l2e*))
455 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
457 (#.(log 2l0 2.718281828459045235360287471352662L0)
458 (load-symbol-value y *fp-constant-ln2*)))))
459 (define-move-vop move-from-fp-constant :move
460 (fp-constant) (descriptor-reg))
462 ;;; Move from a descriptor to a float register.
463 (define-vop (move-to-single)
464 (:args (x :scs (descriptor-reg)))
465 (:results (y :scs (single-reg)))
466 (:note "pointer to float coercion")
468 (with-empty-tn@fp-top(y)
469 (inst fld (ea-for-sf-desc x)))))
470 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
472 (define-vop (move-to-double)
473 (:args (x :scs (descriptor-reg)))
474 (:results (y :scs (double-reg)))
475 (:note "pointer to float coercion")
477 (with-empty-tn@fp-top(y)
478 (inst fldd (ea-for-df-desc x)))))
479 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
482 (define-vop (move-to-long)
483 (:args (x :scs (descriptor-reg)))
484 (:results (y :scs (long-reg)))
485 (:note "pointer to float coercion")
487 (with-empty-tn@fp-top(y)
488 (inst fldl (ea-for-lf-desc x)))))
490 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
492 ;;; Move from complex float to a descriptor reg. allocating a new
493 ;;; complex float object in the process.
494 (define-vop (move-from-complex-single)
495 (:args (x :scs (complex-single-reg) :to :save))
496 (:results (y :scs (descriptor-reg)))
498 (:note "complex float to pointer coercion")
500 (with-fixed-allocation (y
501 complex-single-float-widetag
502 complex-single-float-size
504 (let ((real-tn (complex-single-reg-real-tn x)))
505 (with-tn@fp-top(real-tn)
506 (inst fst (ea-for-csf-real-desc y))))
507 (let ((imag-tn (complex-single-reg-imag-tn x)))
508 (with-tn@fp-top(imag-tn)
509 (inst fst (ea-for-csf-imag-desc y)))))))
510 (define-move-vop move-from-complex-single :move
511 (complex-single-reg) (descriptor-reg))
513 (define-vop (move-from-complex-double)
514 (:args (x :scs (complex-double-reg) :to :save))
515 (:results (y :scs (descriptor-reg)))
517 (:note "complex float to pointer coercion")
519 (with-fixed-allocation (y
520 complex-double-float-widetag
521 complex-double-float-size
523 (let ((real-tn (complex-double-reg-real-tn x)))
524 (with-tn@fp-top(real-tn)
525 (inst fstd (ea-for-cdf-real-desc y))))
526 (let ((imag-tn (complex-double-reg-imag-tn x)))
527 (with-tn@fp-top(imag-tn)
528 (inst fstd (ea-for-cdf-imag-desc y)))))))
529 (define-move-vop move-from-complex-double :move
530 (complex-double-reg) (descriptor-reg))
533 (define-vop (move-from-complex-long)
534 (:args (x :scs (complex-long-reg) :to :save))
535 (:results (y :scs (descriptor-reg)))
537 (:note "complex float to pointer coercion")
539 (with-fixed-allocation (y
540 complex-long-float-widetag
541 complex-long-float-size
543 (let ((real-tn (complex-long-reg-real-tn x)))
544 (with-tn@fp-top(real-tn)
545 (store-long-float (ea-for-clf-real-desc y))))
546 (let ((imag-tn (complex-long-reg-imag-tn x)))
547 (with-tn@fp-top(imag-tn)
548 (store-long-float (ea-for-clf-imag-desc y)))))))
550 (define-move-vop move-from-complex-long :move
551 (complex-long-reg) (descriptor-reg))
553 ;;; Move from a descriptor to a complex float register.
554 (macrolet ((frob (name sc format)
557 (:args (x :scs (descriptor-reg)))
558 (:results (y :scs (,sc)))
559 (:note "pointer to complex float coercion")
561 (let ((real-tn (complex-double-reg-real-tn y)))
562 (with-empty-tn@fp-top(real-tn)
564 (:single '((inst fld (ea-for-csf-real-desc x))))
565 (:double '((inst fldd (ea-for-cdf-real-desc x))))
567 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
568 (let ((imag-tn (complex-double-reg-imag-tn y)))
569 (with-empty-tn@fp-top(imag-tn)
571 (:single '((inst fld (ea-for-csf-imag-desc x))))
572 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
574 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
575 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
576 (frob move-to-complex-single complex-single-reg :single)
577 (frob move-to-complex-double complex-double-reg :double)
579 (frob move-to-complex-double complex-long-reg :long))
581 ;;;; the move argument vops
583 ;;;; Note these are also used to stuff fp numbers onto the c-call
584 ;;;; stack so the order is different than the lisp-stack.
586 ;;; the general MOVE-ARG VOP
587 (macrolet ((frob (name sc stack-sc format)
590 (:args (x :scs (,sc) :target y)
592 :load-if (not (sc-is y ,sc))))
594 (:note "float argument move")
595 (:generator ,(case format (:single 2) (:double 3) (:long 4))
598 (unless (location= x y)
599 (cond ((zerop (tn-offset y))
600 (copy-fp-reg-to-fr0 x))
601 ((zerop (tn-offset x))
608 (if (= (tn-offset fp) esp-offset)
609 (let* ((offset (* (tn-offset y) n-word-bytes))
610 (ea (make-ea :dword :base fp :disp offset)))
613 (:single '((inst fst ea)))
614 (:double '((inst fstd ea)))
616 (:long '((store-long-float ea))))))
619 :disp (- (* (+ (tn-offset y)
627 (:single '((inst fst ea)))
628 (:double '((inst fstd ea)))
630 (:long '((store-long-float ea)))))))))))
631 (define-move-vop ,name :move-arg
632 (,sc descriptor-reg) (,sc)))))
633 (frob move-single-float-arg single-reg single-stack :single)
634 (frob move-double-float-arg double-reg double-stack :double)
636 (frob move-long-float-arg long-reg long-stack :long))
638 ;;;; complex float MOVE-ARG VOP
639 (macrolet ((frob (name sc stack-sc format)
642 (:args (x :scs (,sc) :target y)
644 :load-if (not (sc-is y ,sc))))
646 (:note "complex float argument move")
647 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
650 (unless (location= x y)
651 (let ((x-real (complex-double-reg-real-tn x))
652 (y-real (complex-double-reg-real-tn y)))
653 (cond ((zerop (tn-offset y-real))
654 (copy-fp-reg-to-fr0 x-real))
655 ((zerop (tn-offset x-real))
660 (inst fxch x-real))))
661 (let ((x-imag (complex-double-reg-imag-tn x))
662 (y-imag (complex-double-reg-imag-tn y)))
665 (inst fxch x-imag))))
667 (let ((real-tn (complex-double-reg-real-tn x)))
668 (cond ((zerop (tn-offset real-tn))
672 (ea-for-csf-real-stack y fp))))
675 (ea-for-cdf-real-stack y fp))))
679 (ea-for-clf-real-stack y fp))))))
685 (ea-for-csf-real-stack y fp))))
688 (ea-for-cdf-real-stack y fp))))
692 (ea-for-clf-real-stack y fp)))))
693 (inst fxch real-tn))))
694 (let ((imag-tn (complex-double-reg-imag-tn x)))
698 '((inst fst (ea-for-csf-imag-stack y fp))))
700 '((inst fstd (ea-for-cdf-imag-stack y fp))))
704 (ea-for-clf-imag-stack y fp)))))
705 (inst fxch imag-tn))))))
706 (define-move-vop ,name :move-arg
707 (,sc descriptor-reg) (,sc)))))
708 (frob move-complex-single-float-arg
709 complex-single-reg complex-single-stack :single)
710 (frob move-complex-double-float-arg
711 complex-double-reg complex-double-stack :double)
713 (frob move-complex-long-float-arg
714 complex-long-reg complex-long-stack :long))
716 (define-move-vop move-arg :move-arg
717 (single-reg double-reg #!+long-float long-reg
718 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
724 ;;; dtc: the floating point arithmetic vops
726 ;;; Note: Although these can accept x and y on the stack or pointed to
727 ;;; from a descriptor register, they will work with register loading
728 ;;; without these. Same deal with the result - it need only be a
729 ;;; register. When load-tns are needed they will probably be in ST0
730 ;;; and the code below should be able to correctly handle all cases.
732 ;;; However it seems to produce better code if all arg. and result
733 ;;; options are used; on the P86 there is no extra cost in using a
734 ;;; memory operand to the FP instructions - not so on the PPro.
736 ;;; It may also be useful to handle constant args?
738 ;;; 22-Jul-97: descriptor args lose in some simple cases when
739 ;;; a function result computed in a loop. Then Python insists
740 ;;; on consing the intermediate values! For example
743 (declare (type (simple-array double-float (*)) a)
746 (declare (type double-float sum))
748 (incf sum (* (aref a i)(aref a i))))
751 ;;; So, disabling descriptor args until this can be fixed elsewhere.
753 ((frob (op fop-sti fopr-sti
755 fopd foprd dname dcost
757 #!-long-float (declare (ignore lcost lname))
761 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
763 (y :scs (single-reg single-stack #+nil descriptor-reg)
765 (:temporary (:sc single-reg :offset fr0-offset
766 :from :eval :to :result) fr0)
767 (:results (r :scs (single-reg single-stack)))
768 (:arg-types single-float single-float)
769 (:result-types single-float)
771 (:note "inline float arithmetic")
773 (:save-p :compute-only)
776 ;; Handle a few special cases
778 ;; x, y, and r are the same register.
779 ((and (sc-is x single-reg) (location= x r) (location= y r))
780 (cond ((zerop (tn-offset r))
785 ;; XX the source register will not be valid.
786 (note-next-instruction vop :internal-error)
789 ;; x and r are the same register.
790 ((and (sc-is x single-reg) (location= x r))
791 (cond ((zerop (tn-offset r))
794 ;; ST(0) = ST(0) op ST(y)
797 ;; ST(0) = ST(0) op Mem
798 (inst ,fop (ea-for-sf-stack y)))
800 (inst ,fop (ea-for-sf-desc y)))))
805 (unless (zerop (tn-offset y))
806 (copy-fp-reg-to-fr0 y)))
807 ((single-stack descriptor-reg)
809 (if (sc-is y single-stack)
810 (inst fld (ea-for-sf-stack y))
811 (inst fld (ea-for-sf-desc y)))))
812 ;; ST(i) = ST(i) op ST0
814 (maybe-fp-wait node vop))
815 ;; y and r are the same register.
816 ((and (sc-is y single-reg) (location= y r))
817 (cond ((zerop (tn-offset r))
820 ;; ST(0) = ST(x) op ST(0)
823 ;; ST(0) = Mem op ST(0)
824 (inst ,fopr (ea-for-sf-stack x)))
826 (inst ,fopr (ea-for-sf-desc x)))))
831 (unless (zerop (tn-offset x))
832 (copy-fp-reg-to-fr0 x)))
833 ((single-stack descriptor-reg)
835 (if (sc-is x single-stack)
836 (inst fld (ea-for-sf-stack x))
837 (inst fld (ea-for-sf-desc x)))))
838 ;; ST(i) = ST(0) op ST(i)
840 (maybe-fp-wait node vop))
843 ;; Get the result to ST0.
845 ;; Special handling is needed if x or y are in ST0, and
846 ;; simpler code is generated.
849 ((and (sc-is x single-reg) (zerop (tn-offset x)))
855 (inst ,fop (ea-for-sf-stack y)))
857 (inst ,fop (ea-for-sf-desc y)))))
859 ((and (sc-is y single-reg) (zerop (tn-offset y)))
865 (inst ,fopr (ea-for-sf-stack x)))
867 (inst ,fopr (ea-for-sf-desc x)))))
872 (copy-fp-reg-to-fr0 x))
875 (inst fld (ea-for-sf-stack x)))
878 (inst fld (ea-for-sf-desc x))))
884 (inst ,fop (ea-for-sf-stack y)))
886 (inst ,fop (ea-for-sf-desc y))))))
888 (note-next-instruction vop :internal-error)
890 ;; Finally save the result.
893 (cond ((zerop (tn-offset r))
894 (maybe-fp-wait node))
898 (inst fst (ea-for-sf-stack r))))))))
902 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
904 (y :scs (double-reg double-stack #+nil descriptor-reg)
906 (:temporary (:sc double-reg :offset fr0-offset
907 :from :eval :to :result) fr0)
908 (:results (r :scs (double-reg double-stack)))
909 (:arg-types double-float double-float)
910 (:result-types double-float)
912 (:note "inline float arithmetic")
914 (:save-p :compute-only)
917 ;; Handle a few special cases.
919 ;; x, y, and r are the same register.
920 ((and (sc-is x double-reg) (location= x r) (location= y r))
921 (cond ((zerop (tn-offset r))
926 ;; XX the source register will not be valid.
927 (note-next-instruction vop :internal-error)
930 ;; x and r are the same register.
931 ((and (sc-is x double-reg) (location= x r))
932 (cond ((zerop (tn-offset r))
935 ;; ST(0) = ST(0) op ST(y)
938 ;; ST(0) = ST(0) op Mem
939 (inst ,fopd (ea-for-df-stack y)))
941 (inst ,fopd (ea-for-df-desc y)))))
946 (unless (zerop (tn-offset y))
947 (copy-fp-reg-to-fr0 y)))
948 ((double-stack descriptor-reg)
950 (if (sc-is y double-stack)
951 (inst fldd (ea-for-df-stack y))
952 (inst fldd (ea-for-df-desc y)))))
953 ;; ST(i) = ST(i) op ST0
955 (maybe-fp-wait node vop))
956 ;; y and r are the same register.
957 ((and (sc-is y double-reg) (location= y r))
958 (cond ((zerop (tn-offset r))
961 ;; ST(0) = ST(x) op ST(0)
964 ;; ST(0) = Mem op ST(0)
965 (inst ,foprd (ea-for-df-stack x)))
967 (inst ,foprd (ea-for-df-desc x)))))
972 (unless (zerop (tn-offset x))
973 (copy-fp-reg-to-fr0 x)))
974 ((double-stack descriptor-reg)
976 (if (sc-is x double-stack)
977 (inst fldd (ea-for-df-stack x))
978 (inst fldd (ea-for-df-desc x)))))
979 ;; ST(i) = ST(0) op ST(i)
981 (maybe-fp-wait node vop))
984 ;; Get the result to ST0.
986 ;; Special handling is needed if x or y are in ST0, and
987 ;; simpler code is generated.
990 ((and (sc-is x double-reg) (zerop (tn-offset x)))
996 (inst ,fopd (ea-for-df-stack y)))
998 (inst ,fopd (ea-for-df-desc y)))))
1000 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1006 (inst ,foprd (ea-for-df-stack x)))
1008 (inst ,foprd (ea-for-df-desc x)))))
1013 (copy-fp-reg-to-fr0 x))
1016 (inst fldd (ea-for-df-stack x)))
1019 (inst fldd (ea-for-df-desc x))))
1025 (inst ,fopd (ea-for-df-stack y)))
1027 (inst ,fopd (ea-for-df-desc y))))))
1029 (note-next-instruction vop :internal-error)
1031 ;; Finally save the result.
1034 (cond ((zerop (tn-offset r))
1035 (maybe-fp-wait node))
1039 (inst fstd (ea-for-df-stack r))))))))
1042 (define-vop (,lname)
1044 (:args (x :scs (long-reg) :to :eval)
1045 (y :scs (long-reg) :to :eval))
1046 (:temporary (:sc long-reg :offset fr0-offset
1047 :from :eval :to :result) fr0)
1048 (:results (r :scs (long-reg)))
1049 (:arg-types long-float long-float)
1050 (:result-types long-float)
1051 (:policy :fast-safe)
1052 (:note "inline float arithmetic")
1054 (:save-p :compute-only)
1057 ;; Handle a few special cases.
1059 ;; x, y, and r are the same register.
1060 ((and (location= x r) (location= y r))
1061 (cond ((zerop (tn-offset r))
1066 ;; XX the source register will not be valid.
1067 (note-next-instruction vop :internal-error)
1070 ;; x and r are the same register.
1072 (cond ((zerop (tn-offset r))
1073 ;; ST(0) = ST(0) op ST(y)
1077 (unless (zerop (tn-offset y))
1078 (copy-fp-reg-to-fr0 y))
1079 ;; ST(i) = ST(i) op ST0
1081 (maybe-fp-wait node vop))
1082 ;; y and r are the same register.
1084 (cond ((zerop (tn-offset r))
1085 ;; ST(0) = ST(x) op ST(0)
1089 (unless (zerop (tn-offset x))
1090 (copy-fp-reg-to-fr0 x))
1091 ;; ST(i) = ST(0) op ST(i)
1092 (inst ,fopr-sti r)))
1093 (maybe-fp-wait node vop))
1096 ;; Get the result to ST0.
1098 ;; Special handling is needed if x or y are in ST0, and
1099 ;; simpler code is generated.
1102 ((zerop (tn-offset x))
1106 ((zerop (tn-offset y))
1111 (copy-fp-reg-to-fr0 x)
1115 (note-next-instruction vop :internal-error)
1117 ;; Finally save the result.
1118 (cond ((zerop (tn-offset r))
1119 (maybe-fp-wait node))
1121 (inst fst r))))))))))
1123 (frob + fadd-sti fadd-sti
1124 fadd fadd +/single-float 2
1125 faddd faddd +/double-float 2
1127 (frob - fsub-sti fsubr-sti
1128 fsub fsubr -/single-float 2
1129 fsubd fsubrd -/double-float 2
1131 (frob * fmul-sti fmul-sti
1132 fmul fmul */single-float 3
1133 fmuld fmuld */double-float 3
1135 (frob / fdiv-sti fdivr-sti
1136 fdiv fdivr //single-float 12
1137 fdivd fdivrd //double-float 12
1140 (macrolet ((frob (name inst translate sc type)
1141 `(define-vop (,name)
1142 (:args (x :scs (,sc) :target fr0))
1143 (:results (y :scs (,sc)))
1144 (:translate ,translate)
1145 (:policy :fast-safe)
1147 (:result-types ,type)
1148 (:temporary (:sc double-reg :offset fr0-offset
1149 :from :argument :to :result) fr0)
1151 (:note "inline float arithmetic")
1153 (:save-p :compute-only)
1155 (note-this-location vop :internal-error)
1156 (unless (zerop (tn-offset x))
1157 (inst fxch x) ; x to top of stack
1158 (unless (location= x y)
1159 (inst fst x))) ; Maybe save it.
1160 (inst ,inst) ; Clobber st0.
1161 (unless (zerop (tn-offset y))
1164 (frob abs/single-float fabs abs single-reg single-float)
1165 (frob abs/double-float fabs abs double-reg double-float)
1167 (frob abs/long-float fabs abs long-reg long-float)
1168 (frob %negate/single-float fchs %negate single-reg single-float)
1169 (frob %negate/double-float fchs %negate double-reg double-float)
1171 (frob %negate/long-float fchs %negate long-reg long-float))
1175 (define-vop (=/float)
1177 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1179 (:info target not-p)
1180 (:policy :fast-safe)
1182 (:save-p :compute-only)
1183 (:note "inline float comparison")
1186 (note-this-location vop :internal-error)
1188 ;; x is in ST0; y is in any reg.
1189 ((zerop (tn-offset x))
1191 ;; y is in ST0; x is in another reg.
1192 ((zerop (tn-offset y))
1194 ;; x and y are the same register, not ST0
1199 ;; x and y are different registers, neither ST0.
1204 (inst fnstsw) ; status word to ax
1205 (inst and ah-tn #x45) ; C3 C2 C0
1206 (inst cmp ah-tn #x40)
1207 (inst jmp (if not-p :ne :e) target)))
1209 (define-vop (=/single-float =/float)
1211 (:args (x :scs (single-reg))
1212 (y :scs (single-reg)))
1213 (:arg-types single-float single-float))
1215 (define-vop (=/double-float =/float)
1217 (:args (x :scs (double-reg))
1218 (y :scs (double-reg)))
1219 (:arg-types double-float double-float))
1222 (define-vop (=/long-float =/float)
1224 (:args (x :scs (long-reg))
1225 (y :scs (long-reg)))
1226 (:arg-types long-float long-float))
1228 (define-vop (<single-float)
1230 (:args (x :scs (single-reg single-stack descriptor-reg))
1231 (y :scs (single-reg single-stack descriptor-reg)))
1232 (:arg-types single-float single-float)
1233 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1234 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1236 (:info target not-p)
1237 (:policy :fast-safe)
1238 (:note "inline float comparison")
1241 ;; Handle a few special cases.
1244 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1248 ((single-stack descriptor-reg)
1249 (if (sc-is x single-stack)
1250 (inst fcom (ea-for-sf-stack x))
1251 (inst fcom (ea-for-sf-desc x)))))
1252 (inst fnstsw) ; status word to ax
1253 (inst and ah-tn #x45))
1255 ;; general case when y is not in ST0
1260 (unless (zerop (tn-offset x))
1261 (copy-fp-reg-to-fr0 x)))
1262 ((single-stack descriptor-reg)
1264 (if (sc-is x single-stack)
1265 (inst fld (ea-for-sf-stack x))
1266 (inst fld (ea-for-sf-desc x)))))
1270 ((single-stack descriptor-reg)
1271 (if (sc-is y single-stack)
1272 (inst fcom (ea-for-sf-stack y))
1273 (inst fcom (ea-for-sf-desc y)))))
1274 (inst fnstsw) ; status word to ax
1275 (inst and ah-tn #x45) ; C3 C2 C0
1276 (inst cmp ah-tn #x01)))
1277 (inst jmp (if not-p :ne :e) target)))
1279 (define-vop (<double-float)
1281 (:args (x :scs (double-reg double-stack descriptor-reg))
1282 (y :scs (double-reg double-stack descriptor-reg)))
1283 (:arg-types double-float double-float)
1284 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1285 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1287 (:info target not-p)
1288 (:policy :fast-safe)
1289 (:note "inline float comparison")
1292 ;; Handle a few special cases
1295 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1299 ((double-stack descriptor-reg)
1300 (if (sc-is x double-stack)
1301 (inst fcomd (ea-for-df-stack x))
1302 (inst fcomd (ea-for-df-desc x)))))
1303 (inst fnstsw) ; status word to ax
1304 (inst and ah-tn #x45))
1306 ;; General case when y is not in ST0.
1311 (unless (zerop (tn-offset x))
1312 (copy-fp-reg-to-fr0 x)))
1313 ((double-stack descriptor-reg)
1315 (if (sc-is x double-stack)
1316 (inst fldd (ea-for-df-stack x))
1317 (inst fldd (ea-for-df-desc x)))))
1321 ((double-stack descriptor-reg)
1322 (if (sc-is y double-stack)
1323 (inst fcomd (ea-for-df-stack y))
1324 (inst fcomd (ea-for-df-desc y)))))
1325 (inst fnstsw) ; status word to ax
1326 (inst and ah-tn #x45) ; C3 C2 C0
1327 (inst cmp ah-tn #x01)))
1328 (inst jmp (if not-p :ne :e) target)))
1331 (define-vop (<long-float)
1333 (:args (x :scs (long-reg))
1334 (y :scs (long-reg)))
1335 (:arg-types long-float long-float)
1336 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1338 (:info target not-p)
1339 (:policy :fast-safe)
1340 (:note "inline float comparison")
1344 ;; x is in ST0; y is in any reg.
1345 ((zerop (tn-offset x))
1347 (inst fnstsw) ; status word to ax
1348 (inst and ah-tn #x45) ; C3 C2 C0
1349 (inst cmp ah-tn #x01))
1350 ;; y is in ST0; x is in another reg.
1351 ((zerop (tn-offset y))
1353 (inst fnstsw) ; status word to ax
1354 (inst and ah-tn #x45))
1355 ;; x and y are the same register, not ST0
1356 ;; x and y are different registers, neither ST0.
1361 (inst fnstsw) ; status word to ax
1362 (inst and ah-tn #x45))) ; C3 C2 C0
1363 (inst jmp (if not-p :ne :e) target)))
1365 (define-vop (>single-float)
1367 (:args (x :scs (single-reg single-stack descriptor-reg))
1368 (y :scs (single-reg single-stack descriptor-reg)))
1369 (:arg-types single-float single-float)
1370 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1371 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1373 (:info target not-p)
1374 (:policy :fast-safe)
1375 (:note "inline float comparison")
1378 ;; Handle a few special cases.
1381 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1385 ((single-stack descriptor-reg)
1386 (if (sc-is x single-stack)
1387 (inst fcom (ea-for-sf-stack x))
1388 (inst fcom (ea-for-sf-desc x)))))
1389 (inst fnstsw) ; status word to ax
1390 (inst and ah-tn #x45)
1391 (inst cmp ah-tn #x01))
1393 ;; general case when y is not in ST0
1398 (unless (zerop (tn-offset x))
1399 (copy-fp-reg-to-fr0 x)))
1400 ((single-stack descriptor-reg)
1402 (if (sc-is x single-stack)
1403 (inst fld (ea-for-sf-stack x))
1404 (inst fld (ea-for-sf-desc x)))))
1408 ((single-stack descriptor-reg)
1409 (if (sc-is y single-stack)
1410 (inst fcom (ea-for-sf-stack y))
1411 (inst fcom (ea-for-sf-desc y)))))
1412 (inst fnstsw) ; status word to ax
1413 (inst and ah-tn #x45)))
1414 (inst jmp (if not-p :ne :e) target)))
1416 (define-vop (>double-float)
1418 (:args (x :scs (double-reg double-stack descriptor-reg))
1419 (y :scs (double-reg double-stack descriptor-reg)))
1420 (:arg-types double-float double-float)
1421 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1422 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1424 (:info target not-p)
1425 (:policy :fast-safe)
1426 (:note "inline float comparison")
1429 ;; Handle a few special cases.
1432 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1436 ((double-stack descriptor-reg)
1437 (if (sc-is x double-stack)
1438 (inst fcomd (ea-for-df-stack x))
1439 (inst fcomd (ea-for-df-desc x)))))
1440 (inst fnstsw) ; status word to ax
1441 (inst and ah-tn #x45)
1442 (inst cmp ah-tn #x01))
1444 ;; general case when y is not in ST0
1449 (unless (zerop (tn-offset x))
1450 (copy-fp-reg-to-fr0 x)))
1451 ((double-stack descriptor-reg)
1453 (if (sc-is x double-stack)
1454 (inst fldd (ea-for-df-stack x))
1455 (inst fldd (ea-for-df-desc x)))))
1459 ((double-stack descriptor-reg)
1460 (if (sc-is y double-stack)
1461 (inst fcomd (ea-for-df-stack y))
1462 (inst fcomd (ea-for-df-desc y)))))
1463 (inst fnstsw) ; status word to ax
1464 (inst and ah-tn #x45)))
1465 (inst jmp (if not-p :ne :e) target)))
1468 (define-vop (>long-float)
1470 (:args (x :scs (long-reg))
1471 (y :scs (long-reg)))
1472 (:arg-types long-float long-float)
1473 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1475 (:info target not-p)
1476 (:policy :fast-safe)
1477 (:note "inline float comparison")
1481 ;; y is in ST0; x is in any reg.
1482 ((zerop (tn-offset y))
1484 (inst fnstsw) ; status word to ax
1485 (inst and ah-tn #x45)
1486 (inst cmp ah-tn #x01))
1487 ;; x is in ST0; y is in another reg.
1488 ((zerop (tn-offset x))
1490 (inst fnstsw) ; status word to ax
1491 (inst and ah-tn #x45))
1492 ;; y and x are the same register, not ST0
1493 ;; y and x are different registers, neither ST0.
1498 (inst fnstsw) ; status word to ax
1499 (inst and ah-tn #x45)))
1500 (inst jmp (if not-p :ne :e) target)))
1502 ;;; Comparisons with 0 can use the FTST instruction.
1504 (define-vop (float-test)
1506 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1508 (:info target not-p y)
1509 (:variant-vars code)
1510 (:policy :fast-safe)
1512 (:save-p :compute-only)
1513 (:note "inline float comparison")
1516 (note-this-location vop :internal-error)
1519 ((zerop (tn-offset x))
1526 (inst fnstsw) ; status word to ax
1527 (inst and ah-tn #x45) ; C3 C2 C0
1528 (unless (zerop code)
1529 (inst cmp ah-tn code))
1530 (inst jmp (if not-p :ne :e) target)))
1532 (define-vop (=0/single-float float-test)
1534 (:args (x :scs (single-reg)))
1535 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1537 (define-vop (=0/double-float float-test)
1539 (:args (x :scs (double-reg)))
1540 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1543 (define-vop (=0/long-float float-test)
1545 (:args (x :scs (long-reg)))
1546 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1549 (define-vop (<0/single-float float-test)
1551 (:args (x :scs (single-reg)))
1552 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1554 (define-vop (<0/double-float float-test)
1556 (:args (x :scs (double-reg)))
1557 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1560 (define-vop (<0/long-float float-test)
1562 (:args (x :scs (long-reg)))
1563 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1566 (define-vop (>0/single-float float-test)
1568 (:args (x :scs (single-reg)))
1569 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1571 (define-vop (>0/double-float float-test)
1573 (:args (x :scs (double-reg)))
1574 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1577 (define-vop (>0/long-float float-test)
1579 (:args (x :scs (long-reg)))
1580 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1584 (deftransform eql ((x y) (long-float long-float))
1585 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1586 (= (long-float-high-bits x) (long-float-high-bits y))
1587 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1591 (macrolet ((frob (name translate to-sc to-type)
1592 `(define-vop (,name)
1593 (:args (x :scs (signed-stack signed-reg) :target temp))
1594 (:temporary (:sc signed-stack) temp)
1595 (:results (y :scs (,to-sc)))
1596 (:arg-types signed-num)
1597 (:result-types ,to-type)
1598 (:policy :fast-safe)
1599 (:note "inline float coercion")
1600 (:translate ,translate)
1602 (:save-p :compute-only)
1607 (with-empty-tn@fp-top(y)
1608 (note-this-location vop :internal-error)
1611 (with-empty-tn@fp-top(y)
1612 (note-this-location vop :internal-error)
1613 (inst fild x))))))))
1614 (frob %single-float/signed %single-float single-reg single-float)
1615 (frob %double-float/signed %double-float double-reg double-float)
1617 (frob %long-float/signed %long-float long-reg long-float))
1619 (macrolet ((frob (name translate to-sc to-type)
1620 `(define-vop (,name)
1621 (:args (x :scs (unsigned-reg)))
1622 (:results (y :scs (,to-sc)))
1623 (:arg-types unsigned-num)
1624 (:result-types ,to-type)
1625 (:policy :fast-safe)
1626 (:note "inline float coercion")
1627 (:translate ,translate)
1629 (:save-p :compute-only)
1633 (with-empty-tn@fp-top(y)
1634 (note-this-location vop :internal-error)
1635 (inst fildl (make-ea :dword :base esp-tn)))
1636 (inst add esp-tn 8)))))
1637 (frob %single-float/unsigned %single-float single-reg single-float)
1638 (frob %double-float/unsigned %double-float double-reg double-float)
1640 (frob %long-float/unsigned %long-float long-reg long-float))
1642 ;;; These should be no-ops but the compiler might want to move some
1644 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1645 `(define-vop (,name)
1646 (:args (x :scs (,from-sc) :target y))
1647 (:results (y :scs (,to-sc)))
1648 (:arg-types ,from-type)
1649 (:result-types ,to-type)
1650 (:policy :fast-safe)
1651 (:note "inline float coercion")
1652 (:translate ,translate)
1654 (:save-p :compute-only)
1656 (note-this-location vop :internal-error)
1657 (unless (location= x y)
1659 ((zerop (tn-offset x))
1660 ;; x is in ST0, y is in another reg. not ST0
1662 ((zerop (tn-offset y))
1663 ;; y is in ST0, x is in another reg. not ST0
1664 (copy-fp-reg-to-fr0 x))
1666 ;; Neither x or y are in ST0, and they are not in
1670 (inst fxch x))))))))
1672 (frob %single-float/double-float %single-float double-reg
1673 double-float single-reg single-float)
1675 (frob %single-float/long-float %single-float long-reg
1676 long-float single-reg single-float)
1677 (frob %double-float/single-float %double-float single-reg single-float
1678 double-reg double-float)
1680 (frob %double-float/long-float %double-float long-reg long-float
1681 double-reg double-float)
1683 (frob %long-float/single-float %long-float single-reg single-float
1684 long-reg long-float)
1686 (frob %long-float/double-float %long-float double-reg double-float
1687 long-reg long-float))
1689 (macrolet ((frob (trans from-sc from-type round-p)
1690 `(define-vop (,(symbolicate trans "/" from-type))
1691 (:args (x :scs (,from-sc)))
1692 (:temporary (:sc signed-stack) stack-temp)
1694 '((:temporary (:sc unsigned-stack) scw)
1695 (:temporary (:sc any-reg) rcw)))
1696 (:results (y :scs (signed-reg)))
1697 (:arg-types ,from-type)
1698 (:result-types signed-num)
1700 (:policy :fast-safe)
1701 (:note "inline float truncate")
1703 (:save-p :compute-only)
1706 '((note-this-location vop :internal-error)
1707 ;; Catch any pending FPE exceptions.
1709 (,(if round-p 'progn 'pseudo-atomic)
1710 ;; Normal mode (for now) is "round to best".
1713 '((inst fnstcw scw) ; save current control word
1714 (move rcw scw) ; into 16-bit register
1715 (inst or rcw (ash #b11 10)) ; CHOP
1716 (move stack-temp rcw)
1717 (inst fldcw stack-temp)))
1722 (inst fist stack-temp)
1723 (inst mov y stack-temp)))
1725 '((inst fldcw scw)))))))))
1726 (frob %unary-truncate single-reg single-float nil)
1727 (frob %unary-truncate double-reg double-float nil)
1729 (frob %unary-truncate long-reg long-float nil)
1730 (frob %unary-round single-reg single-float t)
1731 (frob %unary-round double-reg double-float t)
1733 (frob %unary-round long-reg long-float t))
1735 (macrolet ((frob (trans from-sc from-type round-p)
1736 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1737 (:args (x :scs (,from-sc) :target fr0))
1738 (:temporary (:sc double-reg :offset fr0-offset
1739 :from :argument :to :result) fr0)
1741 '((:temporary (:sc unsigned-stack) stack-temp)
1742 (:temporary (:sc unsigned-stack) scw)
1743 (:temporary (:sc any-reg) rcw)))
1744 (:results (y :scs (unsigned-reg)))
1745 (:arg-types ,from-type)
1746 (:result-types unsigned-num)
1748 (:policy :fast-safe)
1749 (:note "inline float truncate")
1751 (:save-p :compute-only)
1754 '((note-this-location vop :internal-error)
1755 ;; Catch any pending FPE exceptions.
1757 ;; Normal mode (for now) is "round to best".
1758 (unless (zerop (tn-offset x))
1759 (copy-fp-reg-to-fr0 x))
1761 '((inst fnstcw scw) ; save current control word
1762 (move rcw scw) ; into 16-bit register
1763 (inst or rcw (ash #b11 10)) ; CHOP
1764 (move stack-temp rcw)
1765 (inst fldcw stack-temp)))
1767 (inst fistpl (make-ea :dword :base esp-tn))
1769 (inst fld fr0) ; copy fr0 to at least restore stack.
1772 '((inst fldcw scw)))))))
1773 (frob %unary-truncate single-reg single-float nil)
1774 (frob %unary-truncate double-reg double-float nil)
1776 (frob %unary-truncate long-reg long-float nil)
1777 (frob %unary-round single-reg single-float t)
1778 (frob %unary-round double-reg double-float t)
1780 (frob %unary-round long-reg long-float t))
1782 (define-vop (make-single-float)
1783 (:args (bits :scs (signed-reg) :target res
1784 :load-if (not (or (and (sc-is bits signed-stack)
1785 (sc-is res single-reg))
1786 (and (sc-is bits signed-stack)
1787 (sc-is res single-stack)
1788 (location= bits res))))))
1789 (:results (res :scs (single-reg single-stack)))
1790 (:temporary (:sc signed-stack) stack-temp)
1791 (:arg-types signed-num)
1792 (:result-types single-float)
1793 (:translate make-single-float)
1794 (:policy :fast-safe)
1801 (inst mov res bits))
1803 (aver (location= bits res)))))
1807 ;; source must be in memory
1808 (inst mov stack-temp bits)
1809 (with-empty-tn@fp-top(res)
1810 (inst fld stack-temp)))
1812 (with-empty-tn@fp-top(res)
1813 (inst fld bits))))))))
1815 (define-vop (make-double-float)
1816 (:args (hi-bits :scs (signed-reg))
1817 (lo-bits :scs (unsigned-reg)))
1818 (:results (res :scs (double-reg)))
1819 (:temporary (:sc double-stack) temp)
1820 (:arg-types signed-num unsigned-num)
1821 (:result-types double-float)
1822 (:translate make-double-float)
1823 (:policy :fast-safe)
1826 (let ((offset (1+ (tn-offset temp))))
1827 (storew hi-bits ebp-tn (- offset))
1828 (storew lo-bits ebp-tn (- (1+ offset)))
1829 (with-empty-tn@fp-top(res)
1830 (inst fldd (make-ea :dword :base ebp-tn
1831 :disp (- (* (1+ offset) n-word-bytes))))))))
1834 (define-vop (make-long-float)
1835 (:args (exp-bits :scs (signed-reg))
1836 (hi-bits :scs (unsigned-reg))
1837 (lo-bits :scs (unsigned-reg)))
1838 (:results (res :scs (long-reg)))
1839 (:temporary (:sc long-stack) temp)
1840 (:arg-types signed-num unsigned-num unsigned-num)
1841 (:result-types long-float)
1842 (:translate make-long-float)
1843 (:policy :fast-safe)
1846 (let ((offset (1+ (tn-offset temp))))
1847 (storew exp-bits ebp-tn (- offset))
1848 (storew hi-bits ebp-tn (- (1+ offset)))
1849 (storew lo-bits ebp-tn (- (+ offset 2)))
1850 (with-empty-tn@fp-top(res)
1851 (inst fldl (make-ea :dword :base ebp-tn
1852 :disp (- (* (+ offset 2) n-word-bytes))))))))
1854 (define-vop (single-float-bits)
1855 (:args (float :scs (single-reg descriptor-reg)
1856 :load-if (not (sc-is float single-stack))))
1857 (:results (bits :scs (signed-reg)))
1858 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1859 (:arg-types single-float)
1860 (:result-types signed-num)
1861 (:translate single-float-bits)
1862 (:policy :fast-safe)
1869 (with-tn@fp-top(float)
1870 (inst fst stack-temp)
1871 (inst mov bits stack-temp)))
1873 (inst mov bits float))
1876 bits float single-float-value-slot
1877 other-pointer-lowtag))))
1881 (with-tn@fp-top(float)
1882 (inst fst bits))))))))
1884 (define-vop (double-float-high-bits)
1885 (:args (float :scs (double-reg descriptor-reg)
1886 :load-if (not (sc-is float double-stack))))
1887 (:results (hi-bits :scs (signed-reg)))
1888 (:temporary (:sc double-stack) temp)
1889 (:arg-types double-float)
1890 (:result-types signed-num)
1891 (:translate double-float-high-bits)
1892 (:policy :fast-safe)
1897 (with-tn@fp-top(float)
1898 (let ((where (make-ea :dword :base ebp-tn
1899 :disp (- (* (+ 2 (tn-offset temp))
1902 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1904 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1906 (loadw hi-bits float (1+ double-float-value-slot)
1907 other-pointer-lowtag)))))
1909 (define-vop (double-float-low-bits)
1910 (:args (float :scs (double-reg descriptor-reg)
1911 :load-if (not (sc-is float double-stack))))
1912 (:results (lo-bits :scs (unsigned-reg)))
1913 (:temporary (:sc double-stack) temp)
1914 (:arg-types double-float)
1915 (:result-types unsigned-num)
1916 (:translate double-float-low-bits)
1917 (:policy :fast-safe)
1922 (with-tn@fp-top(float)
1923 (let ((where (make-ea :dword :base ebp-tn
1924 :disp (- (* (+ 2 (tn-offset temp))
1927 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1929 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1931 (loadw lo-bits float double-float-value-slot
1932 other-pointer-lowtag)))))
1935 (define-vop (long-float-exp-bits)
1936 (:args (float :scs (long-reg descriptor-reg)
1937 :load-if (not (sc-is float long-stack))))
1938 (:results (exp-bits :scs (signed-reg)))
1939 (:temporary (:sc long-stack) temp)
1940 (:arg-types long-float)
1941 (:result-types signed-num)
1942 (:translate long-float-exp-bits)
1943 (:policy :fast-safe)
1948 (with-tn@fp-top(float)
1949 (let ((where (make-ea :dword :base ebp-tn
1950 :disp (- (* (+ 3 (tn-offset temp))
1952 (store-long-float where)))
1953 (inst movsx exp-bits
1954 (make-ea :word :base ebp-tn
1955 :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
1957 (inst movsx exp-bits
1958 (make-ea :word :base ebp-tn
1959 :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
1961 (inst movsx exp-bits
1962 (make-ea :word :base float
1963 :disp (- (* (+ 2 long-float-value-slot)
1965 other-pointer-lowtag)))))))
1968 (define-vop (long-float-high-bits)
1969 (:args (float :scs (long-reg descriptor-reg)
1970 :load-if (not (sc-is float long-stack))))
1971 (:results (hi-bits :scs (unsigned-reg)))
1972 (:temporary (:sc long-stack) temp)
1973 (:arg-types long-float)
1974 (:result-types unsigned-num)
1975 (:translate long-float-high-bits)
1976 (:policy :fast-safe)
1981 (with-tn@fp-top(float)
1982 (let ((where (make-ea :dword :base ebp-tn
1983 :disp (- (* (+ 3 (tn-offset temp))
1985 (store-long-float where)))
1986 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
1988 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
1990 (loadw hi-bits float (1+ long-float-value-slot)
1991 other-pointer-lowtag)))))
1994 (define-vop (long-float-low-bits)
1995 (:args (float :scs (long-reg descriptor-reg)
1996 :load-if (not (sc-is float long-stack))))
1997 (:results (lo-bits :scs (unsigned-reg)))
1998 (:temporary (:sc long-stack) temp)
1999 (:arg-types long-float)
2000 (:result-types unsigned-num)
2001 (:translate long-float-low-bits)
2002 (:policy :fast-safe)
2007 (with-tn@fp-top(float)
2008 (let ((where (make-ea :dword :base ebp-tn
2009 :disp (- (* (+ 3 (tn-offset temp))
2011 (store-long-float where)))
2012 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2014 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2016 (loadw lo-bits float long-float-value-slot
2017 other-pointer-lowtag)))))
2019 ;;;; float mode hackery
2021 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2022 (defknown floating-point-modes () float-modes (flushable))
2023 (defknown ((setf floating-point-modes)) (float-modes)
2026 (def!constant npx-env-size (* 7 n-word-bytes))
2027 (def!constant npx-cw-offset 0)
2028 (def!constant npx-sw-offset 4)
2030 (define-vop (floating-point-modes)
2031 (:results (res :scs (unsigned-reg)))
2032 (:result-types unsigned-num)
2033 (:translate floating-point-modes)
2034 (:policy :fast-safe)
2035 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2038 (inst sub esp-tn npx-env-size) ; Make space on stack.
2039 (inst wait) ; Catch any pending FPE exceptions
2040 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2041 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2042 ;; Move current status to high word.
2043 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2044 ;; Move exception mask to low word.
2045 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2046 (inst add esp-tn npx-env-size) ; Pop stack.
2047 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2050 (define-vop (set-floating-point-modes)
2051 (:args (new :scs (unsigned-reg) :to :result :target res))
2052 (:results (res :scs (unsigned-reg)))
2053 (:arg-types unsigned-num)
2054 (:result-types unsigned-num)
2055 (:translate (setf floating-point-modes))
2056 (:policy :fast-safe)
2057 (:temporary (:sc unsigned-reg :offset eax-offset
2058 :from :eval :to :result) eax)
2060 (inst sub esp-tn npx-env-size) ; Make space on stack.
2061 (inst wait) ; Catch any pending FPE exceptions.
2062 (inst fstenv (make-ea :dword :base esp-tn))
2064 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2065 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2066 (inst shr eax 16) ; position status word
2067 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2068 (inst fldenv (make-ea :dword :base esp-tn))
2069 (inst add esp-tn npx-env-size) ; Pop stack.
2075 ;;; Let's use some of the 80387 special functions.
2077 ;;; These defs will not take effect unless code/irrat.lisp is modified
2078 ;;; to remove the inlined alien routine def.
2080 (macrolet ((frob (func trans op)
2081 `(define-vop (,func)
2082 (:args (x :scs (double-reg) :target fr0))
2083 (:temporary (:sc double-reg :offset fr0-offset
2084 :from :argument :to :result) fr0)
2086 (:results (y :scs (double-reg)))
2087 (:arg-types double-float)
2088 (:result-types double-float)
2090 (:policy :fast-safe)
2091 (:note "inline NPX function")
2093 (:save-p :compute-only)
2096 (note-this-location vop :internal-error)
2097 (unless (zerop (tn-offset x))
2098 (inst fxch x) ; x to top of stack
2099 (unless (location= x y)
2100 (inst fst x))) ; maybe save it
2101 (inst ,op) ; clobber st0
2102 (cond ((zerop (tn-offset y))
2103 (maybe-fp-wait node))
2107 ;; Quick versions of fsin and fcos that require the argument to be
2108 ;; within range 2^63.
2109 (frob fsin-quick %sin-quick fsin)
2110 (frob fcos-quick %cos-quick fcos)
2111 (frob fsqrt %sqrt fsqrt))
2113 ;;; Quick version of ftan that requires the argument to be within
2115 (define-vop (ftan-quick)
2116 (:translate %tan-quick)
2117 (:args (x :scs (double-reg) :target fr0))
2118 (:temporary (:sc double-reg :offset fr0-offset
2119 :from :argument :to :result) fr0)
2120 (:temporary (:sc double-reg :offset fr1-offset
2121 :from :argument :to :result) fr1)
2122 (:results (y :scs (double-reg)))
2123 (:arg-types double-float)
2124 (:result-types double-float)
2125 (:policy :fast-safe)
2126 (:note "inline tan function")
2128 (:save-p :compute-only)
2130 (note-this-location vop :internal-error)
2139 (inst fldd (make-random-tn :kind :normal
2140 :sc (sc-or-lose 'double-reg)
2141 :offset (- (tn-offset x) 2)))))
2152 ;;; These versions of fsin, fcos, and ftan try to use argument
2153 ;;; reduction but to do this accurately requires greater precision and
2154 ;;; it is hopelessly inaccurate.
2156 (macrolet ((frob (func trans op)
2157 `(define-vop (,func)
2159 (:args (x :scs (double-reg) :target fr0))
2160 (:temporary (:sc unsigned-reg :offset eax-offset
2161 :from :eval :to :result) eax)
2162 (:temporary (:sc unsigned-reg :offset fr0-offset
2163 :from :argument :to :result) fr0)
2164 (:temporary (:sc unsigned-reg :offset fr1-offset
2165 :from :argument :to :result) fr1)
2166 (:results (y :scs (double-reg)))
2167 (:arg-types double-float)
2168 (:result-types double-float)
2169 (:policy :fast-safe)
2170 (:note "inline sin/cos function")
2172 (:save-p :compute-only)
2175 (note-this-location vop :internal-error)
2176 (unless (zerop (tn-offset x))
2177 (inst fxch x) ; x to top of stack
2178 (unless (location= x y)
2179 (inst fst x))) ; maybe save it
2181 (inst fnstsw) ; status word to ax
2182 (inst and ah-tn #x04) ; C2
2184 ;; Else x was out of range so reduce it; ST0 is unchanged.
2185 (inst fstp fr1) ; Load 2*PI
2191 (inst fnstsw) ; status word to ax
2192 (inst and ah-tn #x04) ; C2
2196 (unless (zerop (tn-offset y))
2198 (frob fsin %sin fsin)
2199 (frob fcos %cos fcos))
2204 (:args (x :scs (double-reg) :target fr0))
2205 (:temporary (:sc unsigned-reg :offset eax-offset
2206 :from :argument :to :result) eax)
2207 (:temporary (:sc double-reg :offset fr0-offset
2208 :from :argument :to :result) fr0)
2209 (:temporary (:sc double-reg :offset fr1-offset
2210 :from :argument :to :result) fr1)
2211 (:results (y :scs (double-reg)))
2212 (:arg-types double-float)
2213 (:result-types double-float)
2214 (:policy :fast-safe)
2215 (:note "inline tan function")
2217 (:save-p :compute-only)
2220 (note-this-location vop :internal-error)
2229 (inst fldd (make-random-tn :kind :normal
2230 :sc (sc-or-lose 'double-reg)
2231 :offset (- (tn-offset x) 2)))))
2233 (inst fnstsw) ; status word to ax
2234 (inst and ah-tn #x04) ; C2
2236 ;; Else x was out of range so reduce it; ST0 is unchanged.
2237 (inst fldpi) ; Load 2*PI
2242 (inst fnstsw) ; status word to ax
2243 (inst and ah-tn #x04) ; C2
2257 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2258 ;;; the argument is out of range 2^63 and would thus be hopelessly
2260 (macrolet ((frob (func trans op)
2261 `(define-vop (,func)
2263 (:args (x :scs (double-reg) :target fr0))
2264 (:temporary (:sc double-reg :offset fr0-offset
2265 :from :argument :to :result) fr0)
2266 (:temporary (:sc unsigned-reg :offset eax-offset
2267 :from :argument :to :result) eax)
2268 (:results (y :scs (double-reg)))
2269 (:arg-types double-float)
2270 (:result-types double-float)
2271 (:policy :fast-safe)
2272 (:note "inline sin/cos function")
2274 (:save-p :compute-only)
2277 (note-this-location vop :internal-error)
2278 (unless (zerop (tn-offset x))
2279 (inst fxch x) ; x to top of stack
2280 (unless (location= x y)
2281 (inst fst x))) ; maybe save it
2283 (inst fnstsw) ; status word to ax
2284 (inst and ah-tn #x04) ; C2
2286 ;; Else x was out of range so reduce it; ST0 is unchanged.
2287 (inst fstp fr0) ; Load 0.0
2290 (unless (zerop (tn-offset y))
2292 (frob fsin %sin fsin)
2293 (frob fcos %cos fcos))
2297 (:args (x :scs (double-reg) :target fr0))
2298 (:temporary (:sc double-reg :offset fr0-offset
2299 :from :argument :to :result) fr0)
2300 (:temporary (:sc double-reg :offset fr1-offset
2301 :from :argument :to :result) fr1)
2302 (:temporary (:sc unsigned-reg :offset eax-offset
2303 :from :argument :to :result) eax)
2304 (:results (y :scs (double-reg)))
2305 (:arg-types double-float)
2306 (:result-types double-float)
2308 (:policy :fast-safe)
2309 (:note "inline tan function")
2311 (:save-p :compute-only)
2314 (note-this-location vop :internal-error)
2323 (inst fldd (make-random-tn :kind :normal
2324 :sc (sc-or-lose 'double-reg)
2325 :offset (- (tn-offset x) 2)))))
2327 (inst fnstsw) ; status word to ax
2328 (inst and ah-tn #x04) ; C2
2330 ;; Else x was out of range so reduce it; ST0 is unchanged.
2331 (inst fldz) ; Load 0.0
2346 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2347 (:temporary (:sc double-reg :offset fr0-offset
2348 :from :argument :to :result) fr0)
2349 (:temporary (:sc double-reg :offset fr1-offset
2350 :from :argument :to :result) fr1)
2351 (:temporary (:sc double-reg :offset fr2-offset
2352 :from :argument :to :result) fr2)
2353 (:results (y :scs (double-reg)))
2354 (:arg-types double-float)
2355 (:result-types double-float)
2356 (:policy :fast-safe)
2357 (:note "inline exp function")
2359 (:save-p :compute-only)
2361 (note-this-location vop :internal-error)
2364 (cond ((zerop (tn-offset x))
2370 ;; x is in a FP reg, not fr0
2374 ((double-stack descriptor-reg)
2377 (if (sc-is x double-stack)
2378 (inst fmuld (ea-for-df-stack x))
2379 (inst fmuld (ea-for-df-desc x)))))
2380 ;; Now fr0=x log2(e)
2384 (inst fsubp-sti fr1)
2387 (inst faddp-sti fr1)
2392 (t (inst fstd y)))))
2394 ;;; Modified exp that handles the following special cases:
2395 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2398 (:args (x :scs (double-reg) :target fr0))
2399 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2400 (:temporary (:sc double-reg :offset fr0-offset
2401 :from :argument :to :result) fr0)
2402 (:temporary (:sc double-reg :offset fr1-offset
2403 :from :argument :to :result) fr1)
2404 (:temporary (:sc double-reg :offset fr2-offset
2405 :from :argument :to :result) fr2)
2406 (:results (y :scs (double-reg)))
2407 (:arg-types double-float)
2408 (:result-types double-float)
2409 (:policy :fast-safe)
2410 (:note "inline exp function")
2412 (:save-p :compute-only)
2415 (note-this-location vop :internal-error)
2416 (unless (zerop (tn-offset x))
2417 (inst fxch x) ; x to top of stack
2418 (unless (location= x y)
2419 (inst fst x))) ; maybe save it
2420 ;; Check for Inf or NaN
2424 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2425 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2426 (inst and ah-tn #x02) ; Test sign of Inf.
2427 (inst jmp :z DONE) ; +Inf gives +Inf.
2428 (inst fstp fr0) ; -Inf gives 0
2430 (inst jmp-short DONE)
2435 ;; Now fr0=x log2(e)
2439 (inst fsubp-sti fr1)
2442 (inst faddp-sti fr1)
2446 (unless (zerop (tn-offset y))
2449 ;;; Expm1 = exp(x) - 1.
2450 ;;; Handles the following special cases:
2451 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2452 (define-vop (fexpm1)
2454 (:args (x :scs (double-reg) :target fr0))
2455 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2456 (:temporary (:sc double-reg :offset fr0-offset
2457 :from :argument :to :result) fr0)
2458 (:temporary (:sc double-reg :offset fr1-offset
2459 :from :argument :to :result) fr1)
2460 (:temporary (:sc double-reg :offset fr2-offset
2461 :from :argument :to :result) fr2)
2462 (:results (y :scs (double-reg)))
2463 (:arg-types double-float)
2464 (:result-types double-float)
2465 (:policy :fast-safe)
2466 (:note "inline expm1 function")
2468 (:save-p :compute-only)
2471 (note-this-location vop :internal-error)
2472 (unless (zerop (tn-offset x))
2473 (inst fxch x) ; x to top of stack
2474 (unless (location= x y)
2475 (inst fst x))) ; maybe save it
2476 ;; Check for Inf or NaN
2480 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2481 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2482 (inst and ah-tn #x02) ; Test sign of Inf.
2483 (inst jmp :z DONE) ; +Inf gives +Inf.
2484 (inst fstp fr0) ; -Inf gives -1.0
2487 (inst jmp-short DONE)
2489 ;; Free two stack slots leaving the argument on top.
2493 (inst fmul fr1) ; Now fr0 = x log2(e)
2508 (unless (zerop (tn-offset y))
2513 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2514 (:temporary (:sc double-reg :offset fr0-offset
2515 :from :argument :to :result) fr0)
2516 (:temporary (:sc double-reg :offset fr1-offset
2517 :from :argument :to :result) fr1)
2518 (:results (y :scs (double-reg)))
2519 (:arg-types double-float)
2520 (:result-types double-float)
2521 (:policy :fast-safe)
2522 (:note "inline log function")
2524 (:save-p :compute-only)
2526 (note-this-location vop :internal-error)
2541 ;; x is in a FP reg, not fr0 or fr1
2545 (inst fldd (make-random-tn :kind :normal
2546 :sc (sc-or-lose 'double-reg)
2547 :offset (1- (tn-offset x))))))
2549 ((double-stack descriptor-reg)
2553 (if (sc-is x double-stack)
2554 (inst fldd (ea-for-df-stack x))
2555 (inst fldd (ea-for-df-desc x)))
2560 (t (inst fstd y)))))
2562 (define-vop (flog10)
2564 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2565 (:temporary (:sc double-reg :offset fr0-offset
2566 :from :argument :to :result) fr0)
2567 (:temporary (:sc double-reg :offset fr1-offset
2568 :from :argument :to :result) fr1)
2569 (:results (y :scs (double-reg)))
2570 (:arg-types double-float)
2571 (:result-types double-float)
2572 (:policy :fast-safe)
2573 (:note "inline log10 function")
2575 (:save-p :compute-only)
2577 (note-this-location vop :internal-error)
2592 ;; x is in a FP reg, not fr0 or fr1
2596 (inst fldd (make-random-tn :kind :normal
2597 :sc (sc-or-lose 'double-reg)
2598 :offset (1- (tn-offset x))))))
2600 ((double-stack descriptor-reg)
2604 (if (sc-is x double-stack)
2605 (inst fldd (ea-for-df-stack x))
2606 (inst fldd (ea-for-df-desc x)))
2611 (t (inst fstd y)))))
2615 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2616 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2617 (:temporary (:sc double-reg :offset fr0-offset
2618 :from (:argument 0) :to :result) fr0)
2619 (:temporary (:sc double-reg :offset fr1-offset
2620 :from (:argument 1) :to :result) fr1)
2621 (:temporary (:sc double-reg :offset fr2-offset
2622 :from :load :to :result) fr2)
2623 (:results (r :scs (double-reg)))
2624 (:arg-types double-float double-float)
2625 (:result-types double-float)
2626 (:policy :fast-safe)
2627 (:note "inline pow function")
2629 (:save-p :compute-only)
2631 (note-this-location vop :internal-error)
2632 ;; Setup x in fr0 and y in fr1
2634 ;; x in fr0; y in fr1
2635 ((and (sc-is x double-reg) (zerop (tn-offset x))
2636 (sc-is y double-reg) (= 1 (tn-offset y))))
2637 ;; y in fr1; x not in fr0
2638 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2642 (copy-fp-reg-to-fr0 x))
2645 (inst fldd (ea-for-df-stack x)))
2648 (inst fldd (ea-for-df-desc x)))))
2649 ;; x in fr0; y not in fr1
2650 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2652 ;; Now load y to fr0
2655 (copy-fp-reg-to-fr0 y))
2658 (inst fldd (ea-for-df-stack y)))
2661 (inst fldd (ea-for-df-desc y))))
2663 ;; x in fr1; y not in fr1
2664 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2668 (copy-fp-reg-to-fr0 y))
2671 (inst fldd (ea-for-df-stack y)))
2674 (inst fldd (ea-for-df-desc y))))
2677 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2679 ;; Now load x to fr0
2682 (copy-fp-reg-to-fr0 x))
2685 (inst fldd (ea-for-df-stack x)))
2688 (inst fldd (ea-for-df-desc x)))))
2689 ;; Neither x or y are in either fr0 or fr1
2696 (inst fldd (make-random-tn :kind :normal
2697 :sc (sc-or-lose 'double-reg)
2698 :offset (- (tn-offset y) 2))))
2700 (inst fldd (ea-for-df-stack y)))
2702 (inst fldd (ea-for-df-desc y))))
2706 (inst fldd (make-random-tn :kind :normal
2707 :sc (sc-or-lose 'double-reg)
2708 :offset (1- (tn-offset x)))))
2710 (inst fldd (ea-for-df-stack x)))
2712 (inst fldd (ea-for-df-desc x))))))
2714 ;; Now have x at fr0; and y at fr1
2716 ;; Now fr0=y log2(x)
2720 (inst fsubp-sti fr1)
2723 (inst faddp-sti fr1)
2728 (t (inst fstd r)))))
2730 (define-vop (fscalen)
2731 (:translate %scalbn)
2732 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2733 (y :scs (signed-stack signed-reg) :target temp))
2734 (:temporary (:sc double-reg :offset fr0-offset
2735 :from (:argument 0) :to :result) fr0)
2736 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2737 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2738 (:results (r :scs (double-reg)))
2739 (:arg-types double-float signed-num)
2740 (:result-types double-float)
2741 (:policy :fast-safe)
2742 (:note "inline scalbn function")
2744 ;; Setup x in fr0 and y in fr1
2775 (inst fld (make-random-tn :kind :normal
2776 :sc (sc-or-lose 'double-reg)
2777 :offset (1- (tn-offset x)))))))
2778 ((double-stack descriptor-reg)
2787 (if (sc-is x double-stack)
2788 (inst fldd (ea-for-df-stack x))
2789 (inst fldd (ea-for-df-desc x)))))
2791 (unless (zerop (tn-offset r))
2794 (define-vop (fscale)
2796 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2797 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2798 (:temporary (:sc double-reg :offset fr0-offset
2799 :from (:argument 0) :to :result) fr0)
2800 (:temporary (:sc double-reg :offset fr1-offset
2801 :from (:argument 1) :to :result) fr1)
2802 (:results (r :scs (double-reg)))
2803 (:arg-types double-float double-float)
2804 (:result-types double-float)
2805 (:policy :fast-safe)
2806 (:note "inline scalb function")
2808 (:save-p :compute-only)
2810 (note-this-location vop :internal-error)
2811 ;; Setup x in fr0 and y in fr1
2813 ;; x in fr0; y in fr1
2814 ((and (sc-is x double-reg) (zerop (tn-offset x))
2815 (sc-is y double-reg) (= 1 (tn-offset y))))
2816 ;; y in fr1; x not in fr0
2817 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2821 (copy-fp-reg-to-fr0 x))
2824 (inst fldd (ea-for-df-stack x)))
2827 (inst fldd (ea-for-df-desc x)))))
2828 ;; x in fr0; y not in fr1
2829 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2831 ;; Now load y to fr0
2834 (copy-fp-reg-to-fr0 y))
2837 (inst fldd (ea-for-df-stack y)))
2840 (inst fldd (ea-for-df-desc y))))
2842 ;; x in fr1; y not in fr1
2843 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2847 (copy-fp-reg-to-fr0 y))
2850 (inst fldd (ea-for-df-stack y)))
2853 (inst fldd (ea-for-df-desc y))))
2856 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2858 ;; Now load x to fr0
2861 (copy-fp-reg-to-fr0 x))
2864 (inst fldd (ea-for-df-stack x)))
2867 (inst fldd (ea-for-df-desc x)))))
2868 ;; Neither x or y are in either fr0 or fr1
2875 (inst fldd (make-random-tn :kind :normal
2876 :sc (sc-or-lose 'double-reg)
2877 :offset (- (tn-offset y) 2))))
2879 (inst fldd (ea-for-df-stack y)))
2881 (inst fldd (ea-for-df-desc y))))
2885 (inst fldd (make-random-tn :kind :normal
2886 :sc (sc-or-lose 'double-reg)
2887 :offset (1- (tn-offset x)))))
2889 (inst fldd (ea-for-df-stack x)))
2891 (inst fldd (ea-for-df-desc x))))))
2893 ;; Now have x at fr0; and y at fr1
2895 (unless (zerop (tn-offset r))
2898 (define-vop (flog1p)
2900 (:args (x :scs (double-reg) :to :result))
2901 (:temporary (:sc double-reg :offset fr0-offset
2902 :from :argument :to :result) fr0)
2903 (:temporary (:sc double-reg :offset fr1-offset
2904 :from :argument :to :result) fr1)
2905 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2906 (:results (y :scs (double-reg)))
2907 (:arg-types double-float)
2908 (:result-types double-float)
2909 (:policy :fast-safe)
2910 (:note "inline log1p function")
2913 ;; x is in a FP reg, not fr0, fr1.
2916 (inst fldd (make-random-tn :kind :normal
2917 :sc (sc-or-lose 'double-reg)
2918 :offset (- (tn-offset x) 2)))
2920 (inst push #x3e947ae1) ; Constant 0.29
2922 (inst fld (make-ea :dword :base esp-tn))
2925 (inst fnstsw) ; status word to ax
2926 (inst and ah-tn #x45)
2927 (inst jmp :z WITHIN-RANGE)
2928 ;; Out of range for fyl2xp1.
2930 (inst faddd (make-random-tn :kind :normal
2931 :sc (sc-or-lose 'double-reg)
2932 :offset (- (tn-offset x) 1)))
2940 (inst fldd (make-random-tn :kind :normal
2941 :sc (sc-or-lose 'double-reg)
2942 :offset (- (tn-offset x) 1)))
2948 (t (inst fstd y)))))
2950 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2951 ;;; instruction and a range check can be avoided.
2952 (define-vop (flog1p-pentium)
2954 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2955 (:temporary (:sc double-reg :offset fr0-offset
2956 :from :argument :to :result) fr0)
2957 (:temporary (:sc double-reg :offset fr1-offset
2958 :from :argument :to :result) fr1)
2959 (:results (y :scs (double-reg)))
2960 (:arg-types double-float)
2961 (:result-types double-float)
2962 (:policy :fast-safe)
2963 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2964 (:note "inline log1p with limited x range function")
2966 (:save-p :compute-only)
2968 (note-this-location vop :internal-error)
2983 ;; x is in a FP reg, not fr0 or fr1
2987 (inst fldd (make-random-tn :kind :normal
2988 :sc (sc-or-lose 'double-reg)
2989 :offset (1- (tn-offset x)))))))
2990 ((double-stack descriptor-reg)
2994 (if (sc-is x double-stack)
2995 (inst fldd (ea-for-df-stack x))
2996 (inst fldd (ea-for-df-desc x)))))
3001 (t (inst fstd y)))))
3005 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3006 (:temporary (:sc double-reg :offset fr0-offset
3007 :from :argument :to :result) fr0)
3008 (:temporary (:sc double-reg :offset fr1-offset
3009 :from :argument :to :result) fr1)
3010 (:results (y :scs (double-reg)))
3011 (:arg-types double-float)
3012 (:result-types double-float)
3013 (:policy :fast-safe)
3014 (:note "inline logb function")
3016 (:save-p :compute-only)
3018 (note-this-location vop :internal-error)
3029 ;; x is in a FP reg, not fr0 or fr1
3032 (inst fldd (make-random-tn :kind :normal
3033 :sc (sc-or-lose 'double-reg)
3034 :offset (- (tn-offset x) 2))))))
3035 ((double-stack descriptor-reg)
3038 (if (sc-is x double-stack)
3039 (inst fldd (ea-for-df-stack x))
3040 (inst fldd (ea-for-df-desc x)))))
3051 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3052 (:temporary (:sc double-reg :offset fr0-offset
3053 :from (:argument 0) :to :result) fr0)
3054 (:temporary (:sc double-reg :offset fr1-offset
3055 :from (:argument 0) :to :result) fr1)
3056 (:results (r :scs (double-reg)))
3057 (:arg-types double-float)
3058 (:result-types double-float)
3059 (:policy :fast-safe)
3060 (:note "inline atan function")
3062 (:save-p :compute-only)
3064 (note-this-location vop :internal-error)
3065 ;; Setup x in fr1 and 1.0 in fr0
3068 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3071 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3073 ;; x not in fr0 or fr1
3080 (inst fldd (make-random-tn :kind :normal
3081 :sc (sc-or-lose 'double-reg)
3082 :offset (- (tn-offset x) 2))))
3084 (inst fldd (ea-for-df-stack x)))
3086 (inst fldd (ea-for-df-desc x))))))
3088 ;; Now have x at fr1; and 1.0 at fr0
3093 (t (inst fstd r)))))
3095 (define-vop (fatan2)
3097 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3098 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3099 (:temporary (:sc double-reg :offset fr0-offset
3100 :from (:argument 1) :to :result) fr0)
3101 (:temporary (:sc double-reg :offset fr1-offset
3102 :from (:argument 0) :to :result) fr1)
3103 (:results (r :scs (double-reg)))
3104 (:arg-types double-float double-float)
3105 (:result-types double-float)
3106 (:policy :fast-safe)
3107 (:note "inline atan2 function")
3109 (:save-p :compute-only)
3111 (note-this-location vop :internal-error)
3112 ;; Setup x in fr1 and y in fr0
3114 ;; y in fr0; x in fr1
3115 ((and (sc-is y double-reg) (zerop (tn-offset y))
3116 (sc-is x double-reg) (= 1 (tn-offset x))))
3117 ;; x in fr1; y not in fr0
3118 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3122 (copy-fp-reg-to-fr0 y))
3125 (inst fldd (ea-for-df-stack y)))
3128 (inst fldd (ea-for-df-desc y)))))
3129 ((and (sc-is x double-reg) (zerop (tn-offset x))
3130 (sc-is y double-reg) (zerop (tn-offset x)))
3133 ;; y in fr0; x not in fr1
3134 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3136 ;; Now load x to fr0
3139 (copy-fp-reg-to-fr0 x))
3142 (inst fldd (ea-for-df-stack x)))
3145 (inst fldd (ea-for-df-desc x))))
3147 ;; y in fr1; x not in fr1
3148 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3152 (copy-fp-reg-to-fr0 x))
3155 (inst fldd (ea-for-df-stack x)))
3158 (inst fldd (ea-for-df-desc x))))
3161 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3163 ;; Now load y to fr0
3166 (copy-fp-reg-to-fr0 y))
3169 (inst fldd (ea-for-df-stack y)))
3172 (inst fldd (ea-for-df-desc y)))))
3173 ;; Neither y or x are in either fr0 or fr1
3180 (inst fldd (make-random-tn :kind :normal
3181 :sc (sc-or-lose 'double-reg)
3182 :offset (- (tn-offset x) 2))))
3184 (inst fldd (ea-for-df-stack x)))
3186 (inst fldd (ea-for-df-desc x))))
3190 (inst fldd (make-random-tn :kind :normal
3191 :sc (sc-or-lose 'double-reg)
3192 :offset (1- (tn-offset y)))))
3194 (inst fldd (ea-for-df-stack y)))
3196 (inst fldd (ea-for-df-desc y))))))
3198 ;; Now have y at fr0; and x at fr1
3203 (t (inst fstd r)))))
3204 ) ; PROGN #!-LONG-FLOAT
3209 ;;; Lets use some of the 80387 special functions.
3211 ;;; These defs will not take effect unless code/irrat.lisp is modified
3212 ;;; to remove the inlined alien routine def.
3214 (macrolet ((frob (func trans op)
3215 `(define-vop (,func)
3216 (:args (x :scs (long-reg) :target fr0))
3217 (:temporary (:sc long-reg :offset fr0-offset
3218 :from :argument :to :result) fr0)
3220 (:results (y :scs (long-reg)))
3221 (:arg-types long-float)
3222 (:result-types long-float)
3224 (:policy :fast-safe)
3225 (:note "inline NPX function")
3227 (:save-p :compute-only)
3230 (note-this-location vop :internal-error)
3231 (unless (zerop (tn-offset x))
3232 (inst fxch x) ; x to top of stack
3233 (unless (location= x y)
3234 (inst fst x))) ; maybe save it
3235 (inst ,op) ; clobber st0
3236 (cond ((zerop (tn-offset y))
3237 (maybe-fp-wait node))
3241 ;; Quick versions of FSIN and FCOS that require the argument to be
3242 ;; within range 2^63.
3243 (frob fsin-quick %sin-quick fsin)
3244 (frob fcos-quick %cos-quick fcos)
3245 (frob fsqrt %sqrt fsqrt))
3247 ;;; Quick version of ftan that requires the argument to be within
3249 (define-vop (ftan-quick)
3250 (:translate %tan-quick)
3251 (:args (x :scs (long-reg) :target fr0))
3252 (:temporary (:sc long-reg :offset fr0-offset
3253 :from :argument :to :result) fr0)
3254 (:temporary (:sc long-reg :offset fr1-offset
3255 :from :argument :to :result) fr1)
3256 (:results (y :scs (long-reg)))
3257 (:arg-types long-float)
3258 (:result-types long-float)
3259 (:policy :fast-safe)
3260 (:note "inline tan function")
3262 (:save-p :compute-only)
3264 (note-this-location vop :internal-error)
3273 (inst fldd (make-random-tn :kind :normal
3274 :sc (sc-or-lose 'double-reg)
3275 :offset (- (tn-offset x) 2)))))
3286 ;;; These versions of fsin, fcos, and ftan try to use argument
3287 ;;; reduction but to do this accurately requires greater precision and
3288 ;;; it is hopelessly inaccurate.
3290 (macrolet ((frob (func trans op)
3291 `(define-vop (,func)
3293 (:args (x :scs (long-reg) :target fr0))
3294 (:temporary (:sc unsigned-reg :offset eax-offset
3295 :from :eval :to :result) eax)
3296 (:temporary (:sc long-reg :offset fr0-offset
3297 :from :argument :to :result) fr0)
3298 (:temporary (:sc long-reg :offset fr1-offset
3299 :from :argument :to :result) fr1)
3300 (:results (y :scs (long-reg)))
3301 (:arg-types long-float)
3302 (:result-types long-float)
3303 (:policy :fast-safe)
3304 (:note "inline sin/cos function")
3306 (:save-p :compute-only)
3309 (note-this-location vop :internal-error)
3310 (unless (zerop (tn-offset x))
3311 (inst fxch x) ; x to top of stack
3312 (unless (location= x y)
3313 (inst fst x))) ; maybe save it
3315 (inst fnstsw) ; status word to ax
3316 (inst and ah-tn #x04) ; C2
3318 ;; Else x was out of range so reduce it; ST0 is unchanged.
3319 (inst fstp fr1) ; Load 2*PI
3325 (inst fnstsw) ; status word to ax
3326 (inst and ah-tn #x04) ; C2
3330 (unless (zerop (tn-offset y))
3332 (frob fsin %sin fsin)
3333 (frob fcos %cos fcos))
3338 (:args (x :scs (long-reg) :target fr0))
3339 (:temporary (:sc unsigned-reg :offset eax-offset
3340 :from :argument :to :result) eax)
3341 (:temporary (:sc long-reg :offset fr0-offset
3342 :from :argument :to :result) fr0)
3343 (:temporary (:sc long-reg :offset fr1-offset
3344 :from :argument :to :result) fr1)
3345 (:results (y :scs (long-reg)))
3346 (:arg-types long-float)
3347 (:result-types long-float)
3348 (:policy :fast-safe)
3349 (:note "inline tan function")
3351 (:save-p :compute-only)
3354 (note-this-location vop :internal-error)
3363 (inst fldd (make-random-tn :kind :normal
3364 :sc (sc-or-lose 'double-reg)
3365 :offset (- (tn-offset x) 2)))))
3367 (inst fnstsw) ; status word to ax
3368 (inst and ah-tn #x04) ; C2
3370 ;; Else x was out of range so reduce it; ST0 is unchanged.
3371 (inst fldpi) ; Load 2*PI
3376 (inst fnstsw) ; status word to ax
3377 (inst and ah-tn #x04) ; C2
3391 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3392 ;;; the argument is out of range 2^63 and would thus be hopelessly
3394 (macrolet ((frob (func trans op)
3395 `(define-vop (,func)
3397 (:args (x :scs (long-reg) :target fr0))
3398 (:temporary (:sc long-reg :offset fr0-offset
3399 :from :argument :to :result) fr0)
3400 (:temporary (:sc unsigned-reg :offset eax-offset
3401 :from :argument :to :result) eax)
3402 (:results (y :scs (long-reg)))
3403 (:arg-types long-float)
3404 (:result-types long-float)
3405 (:policy :fast-safe)
3406 (:note "inline sin/cos function")
3408 (:save-p :compute-only)
3411 (note-this-location vop :internal-error)
3412 (unless (zerop (tn-offset x))
3413 (inst fxch x) ; x to top of stack
3414 (unless (location= x y)
3415 (inst fst x))) ; maybe save it
3417 (inst fnstsw) ; status word to ax
3418 (inst and ah-tn #x04) ; C2
3420 ;; Else x was out of range so reduce it; ST0 is unchanged.
3421 (inst fstp fr0) ; Load 0.0
3424 (unless (zerop (tn-offset y))
3426 (frob fsin %sin fsin)
3427 (frob fcos %cos fcos))
3431 (:args (x :scs (long-reg) :target fr0))
3432 (:temporary (:sc long-reg :offset fr0-offset
3433 :from :argument :to :result) fr0)
3434 (:temporary (:sc long-reg :offset fr1-offset
3435 :from :argument :to :result) fr1)
3436 (:temporary (:sc unsigned-reg :offset eax-offset
3437 :from :argument :to :result) eax)
3438 (:results (y :scs (long-reg)))
3439 (:arg-types long-float)
3440 (:result-types long-float)
3442 (:policy :fast-safe)
3443 (:note "inline tan function")
3445 (:save-p :compute-only)
3448 (note-this-location vop :internal-error)
3457 (inst fldd (make-random-tn :kind :normal
3458 :sc (sc-or-lose 'double-reg)
3459 :offset (- (tn-offset x) 2)))))
3461 (inst fnstsw) ; status word to ax
3462 (inst and ah-tn #x04) ; C2
3464 ;; Else x was out of range so reduce it; ST0 is unchanged.
3465 (inst fldz) ; Load 0.0
3477 ;;; Modified exp that handles the following special cases:
3478 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3481 (:args (x :scs (long-reg) :target fr0))
3482 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3483 (:temporary (:sc long-reg :offset fr0-offset
3484 :from :argument :to :result) fr0)
3485 (:temporary (:sc long-reg :offset fr1-offset
3486 :from :argument :to :result) fr1)
3487 (:temporary (:sc long-reg :offset fr2-offset
3488 :from :argument :to :result) fr2)
3489 (:results (y :scs (long-reg)))
3490 (:arg-types long-float)
3491 (:result-types long-float)
3492 (:policy :fast-safe)
3493 (:note "inline exp function")
3495 (:save-p :compute-only)
3498 (note-this-location vop :internal-error)
3499 (unless (zerop (tn-offset x))
3500 (inst fxch x) ; x to top of stack
3501 (unless (location= x y)
3502 (inst fst x))) ; maybe save it
3503 ;; Check for Inf or NaN
3507 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3508 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3509 (inst and ah-tn #x02) ; Test sign of Inf.
3510 (inst jmp :z DONE) ; +Inf gives +Inf.
3511 (inst fstp fr0) ; -Inf gives 0
3513 (inst jmp-short DONE)
3518 ;; Now fr0=x log2(e)
3522 (inst fsubp-sti fr1)
3525 (inst faddp-sti fr1)
3529 (unless (zerop (tn-offset y))
3532 ;;; Expm1 = exp(x) - 1.
3533 ;;; Handles the following special cases:
3534 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3535 (define-vop (fexpm1)
3537 (:args (x :scs (long-reg) :target fr0))
3538 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3539 (:temporary (:sc long-reg :offset fr0-offset
3540 :from :argument :to :result) fr0)
3541 (:temporary (:sc long-reg :offset fr1-offset
3542 :from :argument :to :result) fr1)
3543 (:temporary (:sc long-reg :offset fr2-offset
3544 :from :argument :to :result) fr2)
3545 (:results (y :scs (long-reg)))
3546 (:arg-types long-float)
3547 (:result-types long-float)
3548 (:policy :fast-safe)
3549 (:note "inline expm1 function")
3551 (:save-p :compute-only)
3554 (note-this-location vop :internal-error)
3555 (unless (zerop (tn-offset x))
3556 (inst fxch x) ; x to top of stack
3557 (unless (location= x y)
3558 (inst fst x))) ; maybe save it
3559 ;; Check for Inf or NaN
3563 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3564 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3565 (inst and ah-tn #x02) ; Test sign of Inf.
3566 (inst jmp :z DONE) ; +Inf gives +Inf.
3567 (inst fstp fr0) ; -Inf gives -1.0
3570 (inst jmp-short DONE)
3572 ;; Free two stack slots leaving the argument on top.
3576 (inst fmul fr1) ; Now fr0 = x log2(e)
3591 (unless (zerop (tn-offset y))
3596 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3597 (:temporary (:sc long-reg :offset fr0-offset
3598 :from :argument :to :result) fr0)
3599 (:temporary (:sc long-reg :offset fr1-offset
3600 :from :argument :to :result) fr1)
3601 (:results (y :scs (long-reg)))
3602 (:arg-types long-float)
3603 (:result-types long-float)
3604 (:policy :fast-safe)
3605 (:note "inline log function")
3607 (:save-p :compute-only)
3609 (note-this-location vop :internal-error)
3624 ;; x is in a FP reg, not fr0 or fr1
3628 (inst fldd (make-random-tn :kind :normal
3629 :sc (sc-or-lose 'double-reg)
3630 :offset (1- (tn-offset x))))))
3632 ((long-stack descriptor-reg)
3636 (if (sc-is x long-stack)
3637 (inst fldl (ea-for-lf-stack x))
3638 (inst fldl (ea-for-lf-desc x)))
3643 (t (inst fstd y)))))
3645 (define-vop (flog10)
3647 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3648 (:temporary (:sc long-reg :offset fr0-offset
3649 :from :argument :to :result) fr0)
3650 (:temporary (:sc long-reg :offset fr1-offset
3651 :from :argument :to :result) fr1)
3652 (:results (y :scs (long-reg)))
3653 (:arg-types long-float)
3654 (:result-types long-float)
3655 (:policy :fast-safe)
3656 (:note "inline log10 function")
3658 (:save-p :compute-only)
3660 (note-this-location vop :internal-error)
3675 ;; x is in a FP reg, not fr0 or fr1
3679 (inst fldd (make-random-tn :kind :normal
3680 :sc (sc-or-lose 'double-reg)
3681 :offset (1- (tn-offset x))))))
3683 ((long-stack descriptor-reg)
3687 (if (sc-is x long-stack)
3688 (inst fldl (ea-for-lf-stack x))
3689 (inst fldl (ea-for-lf-desc x)))
3694 (t (inst fstd y)))))
3698 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3699 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3700 (:temporary (:sc long-reg :offset fr0-offset
3701 :from (:argument 0) :to :result) fr0)
3702 (:temporary (:sc long-reg :offset fr1-offset
3703 :from (:argument 1) :to :result) fr1)
3704 (:temporary (:sc long-reg :offset fr2-offset
3705 :from :load :to :result) fr2)
3706 (:results (r :scs (long-reg)))
3707 (:arg-types long-float long-float)
3708 (:result-types long-float)
3709 (:policy :fast-safe)
3710 (:note "inline pow function")
3712 (:save-p :compute-only)
3714 (note-this-location vop :internal-error)
3715 ;; Setup x in fr0 and y in fr1
3717 ;; x in fr0; y in fr1
3718 ((and (sc-is x long-reg) (zerop (tn-offset x))
3719 (sc-is y long-reg) (= 1 (tn-offset y))))
3720 ;; y in fr1; x not in fr0
3721 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3725 (copy-fp-reg-to-fr0 x))
3728 (inst fldl (ea-for-lf-stack x)))
3731 (inst fldl (ea-for-lf-desc x)))))
3732 ;; x in fr0; y not in fr1
3733 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3735 ;; Now load y to fr0
3738 (copy-fp-reg-to-fr0 y))
3741 (inst fldl (ea-for-lf-stack y)))
3744 (inst fldl (ea-for-lf-desc y))))
3746 ;; x in fr1; y not in fr1
3747 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3751 (copy-fp-reg-to-fr0 y))
3754 (inst fldl (ea-for-lf-stack y)))
3757 (inst fldl (ea-for-lf-desc y))))
3760 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3762 ;; Now load x to fr0
3765 (copy-fp-reg-to-fr0 x))
3768 (inst fldl (ea-for-lf-stack x)))
3771 (inst fldl (ea-for-lf-desc x)))))
3772 ;; Neither x or y are in either fr0 or fr1
3779 (inst fldd (make-random-tn :kind :normal
3780 :sc (sc-or-lose 'double-reg)
3781 :offset (- (tn-offset y) 2))))
3783 (inst fldl (ea-for-lf-stack y)))
3785 (inst fldl (ea-for-lf-desc y))))
3789 (inst fldd (make-random-tn :kind :normal
3790 :sc (sc-or-lose 'double-reg)
3791 :offset (1- (tn-offset x)))))
3793 (inst fldl (ea-for-lf-stack x)))
3795 (inst fldl (ea-for-lf-desc x))))))
3797 ;; Now have x at fr0; and y at fr1
3799 ;; Now fr0=y log2(x)
3803 (inst fsubp-sti fr1)
3806 (inst faddp-sti fr1)
3811 (t (inst fstd r)))))
3813 (define-vop (fscalen)
3814 (:translate %scalbn)
3815 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3816 (y :scs (signed-stack signed-reg) :target temp))
3817 (:temporary (:sc long-reg :offset fr0-offset
3818 :from (:argument 0) :to :result) fr0)
3819 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3820 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3821 (:results (r :scs (long-reg)))
3822 (:arg-types long-float signed-num)
3823 (:result-types long-float)
3824 (:policy :fast-safe)
3825 (:note "inline scalbn function")
3827 ;; Setup x in fr0 and y in fr1
3858 (inst fld (make-random-tn :kind :normal
3859 :sc (sc-or-lose 'double-reg)
3860 :offset (1- (tn-offset x)))))))
3861 ((long-stack descriptor-reg)
3870 (if (sc-is x long-stack)
3871 (inst fldl (ea-for-lf-stack x))
3872 (inst fldl (ea-for-lf-desc x)))))
3874 (unless (zerop (tn-offset r))
3877 (define-vop (fscale)
3879 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3880 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3881 (:temporary (:sc long-reg :offset fr0-offset
3882 :from (:argument 0) :to :result) fr0)
3883 (:temporary (:sc long-reg :offset fr1-offset
3884 :from (:argument 1) :to :result) fr1)
3885 (:results (r :scs (long-reg)))
3886 (:arg-types long-float long-float)
3887 (:result-types long-float)
3888 (:policy :fast-safe)
3889 (:note "inline scalb function")
3891 (:save-p :compute-only)
3893 (note-this-location vop :internal-error)
3894 ;; Setup x in fr0 and y in fr1
3896 ;; x in fr0; y in fr1
3897 ((and (sc-is x long-reg) (zerop (tn-offset x))
3898 (sc-is y long-reg) (= 1 (tn-offset y))))
3899 ;; y in fr1; x not in fr0
3900 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3904 (copy-fp-reg-to-fr0 x))
3907 (inst fldl (ea-for-lf-stack x)))
3910 (inst fldl (ea-for-lf-desc x)))))
3911 ;; x in fr0; y not in fr1
3912 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3914 ;; Now load y to fr0
3917 (copy-fp-reg-to-fr0 y))
3920 (inst fldl (ea-for-lf-stack y)))
3923 (inst fldl (ea-for-lf-desc y))))
3925 ;; x in fr1; y not in fr1
3926 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3930 (copy-fp-reg-to-fr0 y))
3933 (inst fldl (ea-for-lf-stack y)))
3936 (inst fldl (ea-for-lf-desc y))))
3939 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3941 ;; Now load x to fr0
3944 (copy-fp-reg-to-fr0 x))
3947 (inst fldl (ea-for-lf-stack x)))
3950 (inst fldl (ea-for-lf-desc x)))))
3951 ;; Neither x or y are in either fr0 or fr1
3958 (inst fldd (make-random-tn :kind :normal
3959 :sc (sc-or-lose 'double-reg)
3960 :offset (- (tn-offset y) 2))))
3962 (inst fldl (ea-for-lf-stack y)))
3964 (inst fldl (ea-for-lf-desc y))))
3968 (inst fldd (make-random-tn :kind :normal
3969 :sc (sc-or-lose 'double-reg)
3970 :offset (1- (tn-offset x)))))
3972 (inst fldl (ea-for-lf-stack x)))
3974 (inst fldl (ea-for-lf-desc x))))))
3976 ;; Now have x at fr0; and y at fr1
3978 (unless (zerop (tn-offset r))
3981 (define-vop (flog1p)
3983 (:args (x :scs (long-reg) :to :result))
3984 (:temporary (:sc long-reg :offset fr0-offset
3985 :from :argument :to :result) fr0)
3986 (:temporary (:sc long-reg :offset fr1-offset
3987 :from :argument :to :result) fr1)
3988 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3989 (:results (y :scs (long-reg)))
3990 (:arg-types long-float)
3991 (:result-types long-float)
3992 (:policy :fast-safe)
3993 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3994 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3995 ;; an enormous PROGN above. Still, it would be probably be good to
3996 ;; add some code to warn about redefining VOPs.
3997 (:note "inline log1p function")
4000 ;; x is in a FP reg, not fr0, fr1.
4003 (inst fldd (make-random-tn :kind :normal
4004 :sc (sc-or-lose 'double-reg)
4005 :offset (- (tn-offset x) 2)))
4007 (inst push #x3e947ae1) ; Constant 0.29
4009 (inst fld (make-ea :dword :base esp-tn))
4012 (inst fnstsw) ; status word to ax
4013 (inst and ah-tn #x45)
4014 (inst jmp :z WITHIN-RANGE)
4015 ;; Out of range for fyl2xp1.
4017 (inst faddd (make-random-tn :kind :normal
4018 :sc (sc-or-lose 'double-reg)
4019 :offset (- (tn-offset x) 1)))
4027 (inst fldd (make-random-tn :kind :normal
4028 :sc (sc-or-lose 'double-reg)
4029 :offset (- (tn-offset x) 1)))
4035 (t (inst fstd y)))))
4037 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4038 ;;; instruction and a range check can be avoided.
4039 (define-vop (flog1p-pentium)
4041 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4042 (:temporary (:sc long-reg :offset fr0-offset
4043 :from :argument :to :result) fr0)
4044 (:temporary (:sc long-reg :offset fr1-offset
4045 :from :argument :to :result) fr1)
4046 (:results (y :scs (long-reg)))
4047 (:arg-types long-float)
4048 (:result-types long-float)
4049 (:policy :fast-safe)
4050 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
4051 (:note "inline log1p function")
4067 ;; x is in a FP reg, not fr0 or fr1
4071 (inst fldd (make-random-tn :kind :normal
4072 :sc (sc-or-lose 'double-reg)
4073 :offset (1- (tn-offset x)))))))
4074 ((long-stack descriptor-reg)
4078 (if (sc-is x long-stack)
4079 (inst fldl (ea-for-lf-stack x))
4080 (inst fldl (ea-for-lf-desc x)))))
4085 (t (inst fstd y)))))
4089 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4090 (:temporary (:sc long-reg :offset fr0-offset
4091 :from :argument :to :result) fr0)
4092 (:temporary (:sc long-reg :offset fr1-offset
4093 :from :argument :to :result) fr1)
4094 (:results (y :scs (long-reg)))
4095 (:arg-types long-float)
4096 (:result-types long-float)
4097 (:policy :fast-safe)
4098 (:note "inline logb function")
4100 (:save-p :compute-only)
4102 (note-this-location vop :internal-error)
4113 ;; x is in a FP reg, not fr0 or fr1
4116 (inst fldd (make-random-tn :kind :normal
4117 :sc (sc-or-lose 'double-reg)
4118 :offset (- (tn-offset x) 2))))))
4119 ((long-stack descriptor-reg)
4122 (if (sc-is x long-stack)
4123 (inst fldl (ea-for-lf-stack x))
4124 (inst fldl (ea-for-lf-desc x)))))
4135 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4136 (:temporary (:sc long-reg :offset fr0-offset
4137 :from (:argument 0) :to :result) fr0)
4138 (:temporary (:sc long-reg :offset fr1-offset
4139 :from (:argument 0) :to :result) fr1)
4140 (:results (r :scs (long-reg)))
4141 (:arg-types long-float)
4142 (:result-types long-float)
4143 (:policy :fast-safe)
4144 (:note "inline atan function")
4146 (:save-p :compute-only)
4148 (note-this-location vop :internal-error)
4149 ;; Setup x in fr1 and 1.0 in fr0
4152 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4155 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4157 ;; x not in fr0 or fr1
4164 (inst fldd (make-random-tn :kind :normal
4165 :sc (sc-or-lose 'double-reg)
4166 :offset (- (tn-offset x) 2))))
4168 (inst fldl (ea-for-lf-stack x)))
4170 (inst fldl (ea-for-lf-desc x))))))
4172 ;; Now have x at fr1; and 1.0 at fr0
4177 (t (inst fstd r)))))
4179 (define-vop (fatan2)
4181 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4182 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4183 (:temporary (:sc long-reg :offset fr0-offset
4184 :from (:argument 1) :to :result) fr0)
4185 (:temporary (:sc long-reg :offset fr1-offset
4186 :from (:argument 0) :to :result) fr1)
4187 (:results (r :scs (long-reg)))
4188 (:arg-types long-float long-float)
4189 (:result-types long-float)
4190 (:policy :fast-safe)
4191 (:note "inline atan2 function")
4193 (:save-p :compute-only)
4195 (note-this-location vop :internal-error)
4196 ;; Setup x in fr1 and y in fr0
4198 ;; y in fr0; x in fr1
4199 ((and (sc-is y long-reg) (zerop (tn-offset y))
4200 (sc-is x long-reg) (= 1 (tn-offset x))))
4201 ;; x in fr1; y not in fr0
4202 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4206 (copy-fp-reg-to-fr0 y))
4209 (inst fldl (ea-for-lf-stack y)))
4212 (inst fldl (ea-for-lf-desc y)))))
4213 ;; y in fr0; x not in fr1
4214 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4216 ;; Now load x to fr0
4219 (copy-fp-reg-to-fr0 x))
4222 (inst fldl (ea-for-lf-stack x)))
4225 (inst fldl (ea-for-lf-desc x))))
4227 ;; y in fr1; x not in fr1
4228 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4232 (copy-fp-reg-to-fr0 x))
4235 (inst fldl (ea-for-lf-stack x)))
4238 (inst fldl (ea-for-lf-desc x))))
4241 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4243 ;; Now load y to fr0
4246 (copy-fp-reg-to-fr0 y))
4249 (inst fldl (ea-for-lf-stack y)))
4252 (inst fldl (ea-for-lf-desc y)))))
4253 ;; Neither y or x are in either fr0 or fr1
4260 (inst fldd (make-random-tn :kind :normal
4261 :sc (sc-or-lose 'double-reg)
4262 :offset (- (tn-offset x) 2))))
4264 (inst fldl (ea-for-lf-stack x)))
4266 (inst fldl (ea-for-lf-desc x))))
4270 (inst fldd (make-random-tn :kind :normal
4271 :sc (sc-or-lose 'double-reg)
4272 :offset (1- (tn-offset y)))))
4274 (inst fldl (ea-for-lf-stack y)))
4276 (inst fldl (ea-for-lf-desc y))))))
4278 ;; Now have y at fr0; and x at fr1
4283 (t (inst fstd r)))))
4285 ) ; PROGN #!+LONG-FLOAT
4287 ;;;; complex float VOPs
4289 (define-vop (make-complex-single-float)
4290 (:translate complex)
4291 (:args (real :scs (single-reg) :to :result :target r
4292 :load-if (not (location= real r)))
4293 (imag :scs (single-reg) :to :save))
4294 (:arg-types single-float single-float)
4295 (:results (r :scs (complex-single-reg) :from (:argument 0)
4296 :load-if (not (sc-is r complex-single-stack))))
4297 (:result-types complex-single-float)
4298 (:note "inline complex single-float creation")
4299 (:policy :fast-safe)
4303 (let ((r-real (complex-double-reg-real-tn r)))
4304 (unless (location= real r-real)
4305 (cond ((zerop (tn-offset r-real))
4306 (copy-fp-reg-to-fr0 real))
4307 ((zerop (tn-offset real))
4312 (inst fxch real)))))
4313 (let ((r-imag (complex-double-reg-imag-tn r)))
4314 (unless (location= imag r-imag)
4315 (cond ((zerop (tn-offset imag))
4320 (inst fxch imag))))))
4321 (complex-single-stack
4322 (unless (location= real r)
4323 (cond ((zerop (tn-offset real))
4324 (inst fst (ea-for-csf-real-stack r)))
4327 (inst fst (ea-for-csf-real-stack r))
4330 (inst fst (ea-for-csf-imag-stack r))
4331 (inst fxch imag)))))
4333 (define-vop (make-complex-double-float)
4334 (:translate complex)
4335 (:args (real :scs (double-reg) :target r
4336 :load-if (not (location= real r)))
4337 (imag :scs (double-reg) :to :save))
4338 (:arg-types double-float double-float)
4339 (:results (r :scs (complex-double-reg) :from (:argument 0)
4340 :load-if (not (sc-is r complex-double-stack))))
4341 (:result-types complex-double-float)
4342 (:note "inline complex double-float creation")
4343 (:policy :fast-safe)
4347 (let ((r-real (complex-double-reg-real-tn r)))
4348 (unless (location= real r-real)
4349 (cond ((zerop (tn-offset r-real))
4350 (copy-fp-reg-to-fr0 real))
4351 ((zerop (tn-offset real))
4356 (inst fxch real)))))
4357 (let ((r-imag (complex-double-reg-imag-tn r)))
4358 (unless (location= imag r-imag)
4359 (cond ((zerop (tn-offset imag))
4364 (inst fxch imag))))))
4365 (complex-double-stack
4366 (unless (location= real r)
4367 (cond ((zerop (tn-offset real))
4368 (inst fstd (ea-for-cdf-real-stack r)))
4371 (inst fstd (ea-for-cdf-real-stack r))
4374 (inst fstd (ea-for-cdf-imag-stack r))
4375 (inst fxch imag)))))
4378 (define-vop (make-complex-long-float)
4379 (:translate complex)
4380 (:args (real :scs (long-reg) :target r
4381 :load-if (not (location= real r)))
4382 (imag :scs (long-reg) :to :save))
4383 (:arg-types long-float long-float)
4384 (:results (r :scs (complex-long-reg) :from (:argument 0)
4385 :load-if (not (sc-is r complex-long-stack))))
4386 (:result-types complex-long-float)
4387 (:note "inline complex long-float creation")
4388 (:policy :fast-safe)
4392 (let ((r-real (complex-double-reg-real-tn r)))
4393 (unless (location= real r-real)
4394 (cond ((zerop (tn-offset r-real))
4395 (copy-fp-reg-to-fr0 real))
4396 ((zerop (tn-offset real))
4401 (inst fxch real)))))
4402 (let ((r-imag (complex-double-reg-imag-tn r)))
4403 (unless (location= imag r-imag)
4404 (cond ((zerop (tn-offset imag))
4409 (inst fxch imag))))))
4411 (unless (location= real r)
4412 (cond ((zerop (tn-offset real))
4413 (store-long-float (ea-for-clf-real-stack r)))
4416 (store-long-float (ea-for-clf-real-stack r))
4419 (store-long-float (ea-for-clf-imag-stack r))
4420 (inst fxch imag)))))
4423 (define-vop (complex-float-value)
4424 (:args (x :target r))
4426 (:variant-vars offset)
4427 (:policy :fast-safe)
4429 (cond ((sc-is x complex-single-reg complex-double-reg
4430 #!+long-float complex-long-reg)
4432 (make-random-tn :kind :normal
4433 :sc (sc-or-lose 'double-reg)
4434 :offset (+ offset (tn-offset x)))))
4435 (unless (location= value-tn r)
4436 (cond ((zerop (tn-offset r))
4437 (copy-fp-reg-to-fr0 value-tn))
4438 ((zerop (tn-offset value-tn))
4441 (inst fxch value-tn)
4443 (inst fxch value-tn))))))
4444 ((sc-is r single-reg)
4445 (let ((ea (sc-case x
4446 (complex-single-stack
4448 (0 (ea-for-csf-real-stack x))
4449 (1 (ea-for-csf-imag-stack x))))
4452 (0 (ea-for-csf-real-desc x))
4453 (1 (ea-for-csf-imag-desc x)))))))
4454 (with-empty-tn@fp-top(r)
4456 ((sc-is r double-reg)
4457 (let ((ea (sc-case x
4458 (complex-double-stack
4460 (0 (ea-for-cdf-real-stack x))
4461 (1 (ea-for-cdf-imag-stack x))))
4464 (0 (ea-for-cdf-real-desc x))
4465 (1 (ea-for-cdf-imag-desc x)))))))
4466 (with-empty-tn@fp-top(r)
4470 (let ((ea (sc-case x
4473 (0 (ea-for-clf-real-stack x))
4474 (1 (ea-for-clf-imag-stack x))))
4477 (0 (ea-for-clf-real-desc x))
4478 (1 (ea-for-clf-imag-desc x)))))))
4479 (with-empty-tn@fp-top(r)
4481 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4483 (define-vop (realpart/complex-single-float complex-float-value)
4484 (:translate realpart)
4485 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4487 (:arg-types complex-single-float)
4488 (:results (r :scs (single-reg)))
4489 (:result-types single-float)
4490 (:note "complex float realpart")
4493 (define-vop (realpart/complex-double-float complex-float-value)
4494 (:translate realpart)
4495 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4497 (:arg-types complex-double-float)
4498 (:results (r :scs (double-reg)))
4499 (:result-types double-float)
4500 (:note "complex float realpart")
4504 (define-vop (realpart/complex-long-float complex-float-value)
4505 (:translate realpart)
4506 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4508 (:arg-types complex-long-float)
4509 (:results (r :scs (long-reg)))
4510 (:result-types long-float)
4511 (:note "complex float realpart")
4514 (define-vop (imagpart/complex-single-float complex-float-value)
4515 (:translate imagpart)
4516 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4518 (:arg-types complex-single-float)
4519 (:results (r :scs (single-reg)))
4520 (:result-types single-float)
4521 (:note "complex float imagpart")
4524 (define-vop (imagpart/complex-double-float complex-float-value)
4525 (:translate imagpart)
4526 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4528 (:arg-types complex-double-float)
4529 (:results (r :scs (double-reg)))
4530 (:result-types double-float)
4531 (:note "complex float imagpart")
4535 (define-vop (imagpart/complex-long-float complex-float-value)
4536 (:translate imagpart)
4537 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4539 (:arg-types complex-long-float)
4540 (:results (r :scs (long-reg)))
4541 (:result-types long-float)
4542 (:note "complex float imagpart")
4545 ;;; hack dummy VOPs to bias the representation selection of their
4546 ;;; arguments towards a FP register, which can help avoid consing at
4547 ;;; inappropriate locations
4548 (defknown double-float-reg-bias (double-float) (values))
4549 (define-vop (double-float-reg-bias)
4550 (:translate double-float-reg-bias)
4551 (:args (x :scs (double-reg double-stack) :load-if nil))
4552 (:arg-types double-float)
4553 (:policy :fast-safe)
4554 (:note "inline dummy FP register bias")
4557 (defknown single-float-reg-bias (single-float) (values))
4558 (define-vop (single-float-reg-bias)
4559 (:translate single-float-reg-bias)
4560 (:args (x :scs (single-reg single-stack) :load-if nil))
4561 (:arg-types single-float)
4562 (:policy :fast-safe)
4563 (:note "inline dummy FP register bias")