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)
15 `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag)))
16 (defun ea-for-sf-desc (tn)
17 (ea-for-xf-desc tn single-float-value-slot))
18 (defun ea-for-df-desc (tn)
19 (ea-for-xf-desc tn double-float-value-slot))
21 (defun ea-for-lf-desc (tn)
22 (ea-for-xf-desc tn long-float-value-slot))
24 (defun ea-for-csf-real-desc (tn)
25 (ea-for-xf-desc tn complex-single-float-real-slot))
26 (defun ea-for-csf-imag-desc (tn)
27 (ea-for-xf-desc tn complex-single-float-imag-slot))
28 (defun ea-for-cdf-real-desc (tn)
29 (ea-for-xf-desc tn complex-double-float-real-slot))
30 (defun ea-for-cdf-imag-desc (tn)
31 (ea-for-xf-desc tn complex-double-float-imag-slot))
33 (defun ea-for-clf-real-desc (tn)
34 (ea-for-xf-desc tn complex-long-float-real-slot))
36 (defun ea-for-clf-imag-desc (tn)
37 (ea-for-xf-desc tn complex-long-float-imag-slot)))
39 (macrolet ((ea-for-xf-stack (tn kind)
42 :disp (frame-byte-offset
44 (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
45 (defun ea-for-sf-stack (tn)
46 (ea-for-xf-stack tn :single))
47 (defun ea-for-df-stack (tn)
48 (ea-for-xf-stack tn :double))
50 (defun ea-for-lf-stack (tn)
51 (ea-for-xf-stack tn :long)))
53 ;;; Telling the FPU to wait is required in order to make signals occur
54 ;;; at the expected place, but naturally slows things down.
56 ;;; NODE is the node whose compilation policy controls the decision
57 ;;; whether to just blast through carelessly or carefully emit wait
58 ;;; instructions and whatnot.
60 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
61 ;;; #'NOTE-NEXT-INSTRUCTION.
63 ;;; Until 2004-03-15, the implementation of this was buggy; it
64 ;;; unconditionally emitted the WAIT instruction. It turns out that
65 ;;; this is the right thing to do anyway; omitting them can lead to
66 ;;; system corruption on conforming code. -- CSR
67 (defun maybe-fp-wait (node &optional note-next-instruction)
68 (declare (ignore node))
70 (when (policy node (or (= debug 3) (> safety speed))))
71 (when note-next-instruction
72 (note-next-instruction note-next-instruction :internal-error))
75 ;;; complex float stack EAs
76 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
79 :disp (frame-byte-offset
86 (ecase ,slot (:real 1) (:imag 2))))))))
87 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
88 (ea-for-cxf-stack tn :single :real base))
89 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
90 (ea-for-cxf-stack tn :single :imag base))
91 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
92 (ea-for-cxf-stack tn :double :real base))
93 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
94 (ea-for-cxf-stack tn :double :imag base))
96 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
97 (ea-for-cxf-stack tn :long :real base))
99 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
100 (ea-for-cxf-stack tn :long :imag base)))
102 ;;; Abstract out the copying of a FP register to the FP stack top, and
103 ;;; provide two alternatives for its implementation. Note: it's not
104 ;;; necessary to distinguish between a single or double register move
107 ;;; Using a Pop then load.
108 (defun copy-fp-reg-to-fr0 (reg)
109 (aver (not (zerop (tn-offset reg))))
111 (inst fld (make-random-tn :kind :normal
112 :sc (sc-or-lose 'double-reg)
113 :offset (1- (tn-offset reg)))))
114 ;;; Using Fxch then Fst to restore the original reg contents.
116 (defun copy-fp-reg-to-fr0 (reg)
117 (aver (not (zerop (tn-offset reg))))
121 ;;; The x86 can't store a long-float to memory without popping the
122 ;;; stack and marking a register as empty, so it is necessary to
123 ;;; restore the register from memory.
125 (defun store-long-float (ea)
131 ;;; X is source, Y is destination.
132 (define-move-fun (load-single 2) (vop x y)
133 ((single-stack) (single-reg))
134 (with-empty-tn@fp-top(y)
135 (inst fld (ea-for-sf-stack x))))
137 (define-move-fun (store-single 2) (vop x y)
138 ((single-reg) (single-stack))
139 (cond ((zerop (tn-offset x))
140 (inst fst (ea-for-sf-stack y)))
143 (inst fst (ea-for-sf-stack y))
144 ;; This may not be necessary as ST0 is likely invalid now.
147 (define-move-fun (load-double 2) (vop x y)
148 ((double-stack) (double-reg))
149 (with-empty-tn@fp-top(y)
150 (inst fldd (ea-for-df-stack x))))
152 (define-move-fun (store-double 2) (vop x y)
153 ((double-reg) (double-stack))
154 (cond ((zerop (tn-offset x))
155 (inst fstd (ea-for-df-stack y)))
158 (inst fstd (ea-for-df-stack y))
159 ;; This may not be necessary as ST0 is likely invalid now.
163 (define-move-fun (load-long 2) (vop x y)
164 ((long-stack) (long-reg))
165 (with-empty-tn@fp-top(y)
166 (inst fldl (ea-for-lf-stack x))))
169 (define-move-fun (store-long 2) (vop x y)
170 ((long-reg) (long-stack))
171 (cond ((zerop (tn-offset x))
172 (store-long-float (ea-for-lf-stack y)))
175 (store-long-float (ea-for-lf-stack y))
176 ;; This may not be necessary as ST0 is likely invalid now.
179 ;;; The i387 has instructions to load some useful constants. This
180 ;;; doesn't save much time but might cut down on memory access and
181 ;;; reduce the size of the constant vector (CV). Intel claims they are
182 ;;; stored in a more precise form on chip. Anyhow, might as well use
183 ;;; the feature. It can be turned off by hacking the
184 ;;; "immediate-constant-sc" in vm.lisp.
185 (eval-when (:compile-toplevel :execute)
186 (setf *read-default-float-format*
187 #!+long-float 'long-float #!-long-float 'double-float))
188 (define-move-fun (load-fp-constant 2) (vop x y)
189 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
190 (let ((value (tn-value x)))
191 (with-empty-tn@fp-top(y)
192 (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0))
197 ((= value (coerce pi *read-default-float-format*))
200 ((= value (log 10e0 2e0))
203 ((= value (log 2.718281828459045235360287471352662e0 2e0))
206 ((= value (log 2e0 10e0))
209 ((= value (log 2e0 2.718281828459045235360287471352662e0))
211 (t (warn "ignoring bogus i387 constant ~A" value))))))
213 (define-move-fun (load-fp-immediate 2) (vop x y)
214 ((fp-single-immediate) (single-reg)
215 (fp-double-immediate) (double-reg))
216 (let ((value (register-inline-constant (tn-value x))))
217 (with-empty-tn@fp-top(y)
222 (inst fldd value))))))
223 (eval-when (:compile-toplevel :execute)
224 (setf *read-default-float-format* 'single-float))
226 ;;;; complex float move functions
228 (defun complex-single-reg-real-tn (x)
229 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
230 :offset (tn-offset x)))
231 (defun complex-single-reg-imag-tn (x)
232 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
233 :offset (1+ (tn-offset x))))
235 (defun complex-double-reg-real-tn (x)
236 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
237 :offset (tn-offset x)))
238 (defun complex-double-reg-imag-tn (x)
239 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
240 :offset (1+ (tn-offset x))))
243 (defun complex-long-reg-real-tn (x)
244 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
245 :offset (tn-offset x)))
247 (defun complex-long-reg-imag-tn (x)
248 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
249 :offset (1+ (tn-offset x))))
251 ;;; X is source, Y is destination.
252 (define-move-fun (load-complex-single 2) (vop x y)
253 ((complex-single-stack) (complex-single-reg))
254 (let ((real-tn (complex-single-reg-real-tn y)))
255 (with-empty-tn@fp-top (real-tn)
256 (inst fld (ea-for-csf-real-stack x))))
257 (let ((imag-tn (complex-single-reg-imag-tn y)))
258 (with-empty-tn@fp-top (imag-tn)
259 (inst fld (ea-for-csf-imag-stack x)))))
261 (define-move-fun (store-complex-single 2) (vop x y)
262 ((complex-single-reg) (complex-single-stack))
263 (let ((real-tn (complex-single-reg-real-tn x)))
264 (cond ((zerop (tn-offset real-tn))
265 (inst fst (ea-for-csf-real-stack y)))
268 (inst fst (ea-for-csf-real-stack y))
269 (inst fxch real-tn))))
270 (let ((imag-tn (complex-single-reg-imag-tn x)))
272 (inst fst (ea-for-csf-imag-stack y))
273 (inst fxch imag-tn)))
275 (define-move-fun (load-complex-double 2) (vop x y)
276 ((complex-double-stack) (complex-double-reg))
277 (let ((real-tn (complex-double-reg-real-tn y)))
278 (with-empty-tn@fp-top(real-tn)
279 (inst fldd (ea-for-cdf-real-stack x))))
280 (let ((imag-tn (complex-double-reg-imag-tn y)))
281 (with-empty-tn@fp-top(imag-tn)
282 (inst fldd (ea-for-cdf-imag-stack x)))))
284 (define-move-fun (store-complex-double 2) (vop x y)
285 ((complex-double-reg) (complex-double-stack))
286 (let ((real-tn (complex-double-reg-real-tn x)))
287 (cond ((zerop (tn-offset real-tn))
288 (inst fstd (ea-for-cdf-real-stack y)))
291 (inst fstd (ea-for-cdf-real-stack y))
292 (inst fxch real-tn))))
293 (let ((imag-tn (complex-double-reg-imag-tn x)))
295 (inst fstd (ea-for-cdf-imag-stack y))
296 (inst fxch imag-tn)))
299 (define-move-fun (load-complex-long 2) (vop x y)
300 ((complex-long-stack) (complex-long-reg))
301 (let ((real-tn (complex-long-reg-real-tn y)))
302 (with-empty-tn@fp-top(real-tn)
303 (inst fldl (ea-for-clf-real-stack x))))
304 (let ((imag-tn (complex-long-reg-imag-tn y)))
305 (with-empty-tn@fp-top(imag-tn)
306 (inst fldl (ea-for-clf-imag-stack x)))))
309 (define-move-fun (store-complex-long 2) (vop x y)
310 ((complex-long-reg) (complex-long-stack))
311 (let ((real-tn (complex-long-reg-real-tn x)))
312 (cond ((zerop (tn-offset real-tn))
313 (store-long-float (ea-for-clf-real-stack y)))
316 (store-long-float (ea-for-clf-real-stack y))
317 (inst fxch real-tn))))
318 (let ((imag-tn (complex-long-reg-imag-tn x)))
320 (store-long-float (ea-for-clf-imag-stack y))
321 (inst fxch imag-tn)))
326 ;;; float register to register moves
327 (define-vop (float-move)
332 (unless (location= x y)
333 (cond ((zerop (tn-offset y))
334 (copy-fp-reg-to-fr0 x))
335 ((zerop (tn-offset x))
342 (define-vop (single-move float-move)
343 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
344 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
345 (define-move-vop single-move :move (single-reg) (single-reg))
347 (define-vop (double-move float-move)
348 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
349 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
350 (define-move-vop double-move :move (double-reg) (double-reg))
353 (define-vop (long-move float-move)
354 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
355 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
357 (define-move-vop long-move :move (long-reg) (long-reg))
359 ;;; complex float register to register moves
360 (define-vop (complex-float-move)
361 (:args (x :target y :load-if (not (location= x y))))
362 (:results (y :load-if (not (location= x y))))
363 (:note "complex float move")
365 (unless (location= x y)
366 ;; Note the complex-float-regs are aligned to every second
367 ;; float register so there is not need to worry about overlap.
368 (let ((x-real (complex-double-reg-real-tn x))
369 (y-real (complex-double-reg-real-tn y)))
370 (cond ((zerop (tn-offset y-real))
371 (copy-fp-reg-to-fr0 x-real))
372 ((zerop (tn-offset x-real))
377 (inst fxch x-real))))
378 (let ((x-imag (complex-double-reg-imag-tn x))
379 (y-imag (complex-double-reg-imag-tn y)))
382 (inst fxch x-imag)))))
384 (define-vop (complex-single-move complex-float-move)
385 (:args (x :scs (complex-single-reg) :target y
386 :load-if (not (location= x y))))
387 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
388 (define-move-vop complex-single-move :move
389 (complex-single-reg) (complex-single-reg))
391 (define-vop (complex-double-move complex-float-move)
392 (:args (x :scs (complex-double-reg)
393 :target y :load-if (not (location= x y))))
394 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
395 (define-move-vop complex-double-move :move
396 (complex-double-reg) (complex-double-reg))
399 (define-vop (complex-long-move complex-float-move)
400 (:args (x :scs (complex-long-reg)
401 :target y :load-if (not (location= x y))))
402 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
404 (define-move-vop complex-long-move :move
405 (complex-long-reg) (complex-long-reg))
407 ;;; Move from float to a descriptor reg. allocating a new float
408 ;;; object in the process.
409 (define-vop (move-from-single)
410 (:args (x :scs (single-reg) :to :save))
411 (:results (y :scs (descriptor-reg)))
413 (:note "float to pointer coercion")
415 (with-fixed-allocation (y
417 single-float-size node)
418 ;; w-f-a checks for empty body
421 (inst fst (ea-for-sf-desc y)))))
422 (define-move-vop move-from-single :move
423 (single-reg) (descriptor-reg))
425 (define-vop (move-from-double)
426 (:args (x :scs (double-reg) :to :save))
427 (:results (y :scs (descriptor-reg)))
429 (:note "float to pointer coercion")
431 (with-fixed-allocation (y
437 (inst fstd (ea-for-df-desc y)))))
438 (define-move-vop move-from-double :move
439 (double-reg) (descriptor-reg))
442 (define-vop (move-from-long)
443 (:args (x :scs (long-reg) :to :save))
444 (:results (y :scs (descriptor-reg)))
446 (:note "float to pointer coercion")
448 (with-fixed-allocation (y
454 (store-long-float (ea-for-lf-desc y)))))
456 (define-move-vop move-from-long :move
457 (long-reg) (descriptor-reg))
459 (define-vop (move-from-fp-constant)
460 (:args (x :scs (fp-constant)))
461 (:results (y :scs (descriptor-reg)))
463 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
464 (0f0 (load-symbol-value y *fp-constant-0f0*))
465 (1f0 (load-symbol-value y *fp-constant-1f0*))
466 (0d0 (load-symbol-value y *fp-constant-0d0*))
467 (1d0 (load-symbol-value y *fp-constant-1d0*))
469 (0l0 (load-symbol-value y *fp-constant-0l0*))
471 (1l0 (load-symbol-value y *fp-constant-1l0*))
473 (#.pi (load-symbol-value y *fp-constant-pi*))
475 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
477 (#.(log 2.718281828459045235360287471352662L0 2l0)
478 (load-symbol-value y *fp-constant-l2e*))
480 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
482 (#.(log 2l0 2.718281828459045235360287471352662L0)
483 (load-symbol-value y *fp-constant-ln2*)))))
484 (define-move-vop move-from-fp-constant :move
485 (fp-constant) (descriptor-reg))
487 ;;; Move from a descriptor to a float register.
488 (define-vop (move-to-single)
489 (:args (x :scs (descriptor-reg)))
490 (:results (y :scs (single-reg)))
491 (:note "pointer to float coercion")
493 (with-empty-tn@fp-top(y)
494 (inst fld (ea-for-sf-desc x)))))
495 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
497 (define-vop (move-to-double)
498 (:args (x :scs (descriptor-reg)))
499 (:results (y :scs (double-reg)))
500 (:note "pointer to float coercion")
502 (with-empty-tn@fp-top(y)
503 (inst fldd (ea-for-df-desc x)))))
504 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
507 (define-vop (move-to-long)
508 (:args (x :scs (descriptor-reg)))
509 (:results (y :scs (long-reg)))
510 (:note "pointer to float coercion")
512 (with-empty-tn@fp-top(y)
513 (inst fldl (ea-for-lf-desc x)))))
515 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
517 ;;; Move from complex float to a descriptor reg. allocating a new
518 ;;; complex float object in the process.
519 (define-vop (move-from-complex-single)
520 (:args (x :scs (complex-single-reg) :to :save))
521 (:results (y :scs (descriptor-reg)))
523 (:note "complex float to pointer coercion")
525 (with-fixed-allocation (y
526 complex-single-float-widetag
527 complex-single-float-size
529 (let ((real-tn (complex-single-reg-real-tn x)))
530 (with-tn@fp-top(real-tn)
531 (inst fst (ea-for-csf-real-desc y))))
532 (let ((imag-tn (complex-single-reg-imag-tn x)))
533 (with-tn@fp-top(imag-tn)
534 (inst fst (ea-for-csf-imag-desc y)))))))
535 (define-move-vop move-from-complex-single :move
536 (complex-single-reg) (descriptor-reg))
538 (define-vop (move-from-complex-double)
539 (:args (x :scs (complex-double-reg) :to :save))
540 (:results (y :scs (descriptor-reg)))
542 (:note "complex float to pointer coercion")
544 (with-fixed-allocation (y
545 complex-double-float-widetag
546 complex-double-float-size
548 (let ((real-tn (complex-double-reg-real-tn x)))
549 (with-tn@fp-top(real-tn)
550 (inst fstd (ea-for-cdf-real-desc y))))
551 (let ((imag-tn (complex-double-reg-imag-tn x)))
552 (with-tn@fp-top(imag-tn)
553 (inst fstd (ea-for-cdf-imag-desc y)))))))
554 (define-move-vop move-from-complex-double :move
555 (complex-double-reg) (descriptor-reg))
558 (define-vop (move-from-complex-long)
559 (:args (x :scs (complex-long-reg) :to :save))
560 (:results (y :scs (descriptor-reg)))
562 (:note "complex float to pointer coercion")
564 (with-fixed-allocation (y
565 complex-long-float-widetag
566 complex-long-float-size
568 (let ((real-tn (complex-long-reg-real-tn x)))
569 (with-tn@fp-top(real-tn)
570 (store-long-float (ea-for-clf-real-desc y))))
571 (let ((imag-tn (complex-long-reg-imag-tn x)))
572 (with-tn@fp-top(imag-tn)
573 (store-long-float (ea-for-clf-imag-desc y)))))))
575 (define-move-vop move-from-complex-long :move
576 (complex-long-reg) (descriptor-reg))
578 ;;; Move from a descriptor to a complex float register.
579 (macrolet ((frob (name sc format)
582 (:args (x :scs (descriptor-reg)))
583 (:results (y :scs (,sc)))
584 (:note "pointer to complex float coercion")
586 (let ((real-tn (complex-double-reg-real-tn y)))
587 (with-empty-tn@fp-top(real-tn)
589 (:single '((inst fld (ea-for-csf-real-desc x))))
590 (:double '((inst fldd (ea-for-cdf-real-desc x))))
592 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
593 (let ((imag-tn (complex-double-reg-imag-tn y)))
594 (with-empty-tn@fp-top(imag-tn)
596 (:single '((inst fld (ea-for-csf-imag-desc x))))
597 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
599 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
600 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
601 (frob move-to-complex-single complex-single-reg :single)
602 (frob move-to-complex-double complex-double-reg :double)
604 (frob move-to-complex-double complex-long-reg :long))
606 ;;;; the move argument vops
608 ;;;; Note these are also used to stuff fp numbers onto the c-call
609 ;;;; stack so the order is different than the lisp-stack.
611 ;;; the general MOVE-ARG VOP
612 (macrolet ((frob (name sc stack-sc format)
615 (:args (x :scs (,sc) :target y)
617 :load-if (not (sc-is y ,sc))))
619 (:note "float argument move")
620 (:generator ,(case format (:single 2) (:double 3) (:long 4))
623 (unless (location= x y)
624 (cond ((zerop (tn-offset y))
625 (copy-fp-reg-to-fr0 x))
626 ((zerop (tn-offset x))
633 (if (= (tn-offset fp) esp-offset)
635 (let* ((offset (* (tn-offset y) n-word-bytes))
636 (ea (make-ea :dword :base fp :disp offset)))
639 (:single '((inst fst ea)))
640 (:double '((inst fstd ea)))
642 (:long '((store-long-float ea))))))
646 :disp (frame-byte-offset
654 (:single '((inst fst ea)))
655 (:double '((inst fstd ea)))
657 (:long '((store-long-float ea)))))))))))
658 (define-move-vop ,name :move-arg
659 (,sc descriptor-reg) (,sc)))))
660 (frob move-single-float-arg single-reg single-stack :single)
661 (frob move-double-float-arg double-reg double-stack :double)
663 (frob move-long-float-arg long-reg long-stack :long))
665 ;;;; complex float MOVE-ARG VOP
666 (macrolet ((frob (name sc stack-sc format)
669 (:args (x :scs (,sc) :target y)
671 :load-if (not (sc-is y ,sc))))
673 (:note "complex float argument move")
674 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
677 (unless (location= x y)
678 (let ((x-real (complex-double-reg-real-tn x))
679 (y-real (complex-double-reg-real-tn y)))
680 (cond ((zerop (tn-offset y-real))
681 (copy-fp-reg-to-fr0 x-real))
682 ((zerop (tn-offset x-real))
687 (inst fxch x-real))))
688 (let ((x-imag (complex-double-reg-imag-tn x))
689 (y-imag (complex-double-reg-imag-tn y)))
692 (inst fxch x-imag))))
694 (let ((real-tn (complex-double-reg-real-tn x)))
695 (cond ((zerop (tn-offset real-tn))
699 (ea-for-csf-real-stack y fp))))
702 (ea-for-cdf-real-stack y fp))))
706 (ea-for-clf-real-stack y fp))))))
712 (ea-for-csf-real-stack y fp))))
715 (ea-for-cdf-real-stack y fp))))
719 (ea-for-clf-real-stack y fp)))))
720 (inst fxch real-tn))))
721 (let ((imag-tn (complex-double-reg-imag-tn x)))
725 '((inst fst (ea-for-csf-imag-stack y fp))))
727 '((inst fstd (ea-for-cdf-imag-stack y fp))))
731 (ea-for-clf-imag-stack y fp)))))
732 (inst fxch imag-tn))))))
733 (define-move-vop ,name :move-arg
734 (,sc descriptor-reg) (,sc)))))
735 (frob move-complex-single-float-arg
736 complex-single-reg complex-single-stack :single)
737 (frob move-complex-double-float-arg
738 complex-double-reg complex-double-stack :double)
740 (frob move-complex-long-float-arg
741 complex-long-reg complex-long-stack :long))
743 (define-move-vop move-arg :move-arg
744 (single-reg double-reg #!+long-float long-reg
745 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
751 ;;; dtc: the floating point arithmetic vops
753 ;;; Note: Although these can accept x and y on the stack or pointed to
754 ;;; from a descriptor register, they will work with register loading
755 ;;; without these. Same deal with the result - it need only be a
756 ;;; register. When load-tns are needed they will probably be in ST0
757 ;;; and the code below should be able to correctly handle all cases.
759 ;;; However it seems to produce better code if all arg. and result
760 ;;; options are used; on the P86 there is no extra cost in using a
761 ;;; memory operand to the FP instructions - not so on the PPro.
763 ;;; It may also be useful to handle constant args?
765 ;;; 22-Jul-97: descriptor args lose in some simple cases when
766 ;;; a function result computed in a loop. Then Python insists
767 ;;; on consing the intermediate values! For example
770 ;;; (declare (type (simple-array double-float (*)) a)
773 ;;; (declare (type double-float sum))
775 ;;; (incf sum (* (aref a i)(aref a i))))
778 ;;; So, disabling descriptor args until this can be fixed elsewhere.
780 ((frob (op fop-sti fopr-sti
782 fopd foprd dname dcost
784 #!-long-float (declare (ignore lcost lname))
788 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
790 (y :scs (single-reg single-stack #+nil descriptor-reg)
792 (:temporary (:sc single-reg :offset fr0-offset
793 :from :eval :to :result) fr0)
794 (:results (r :scs (single-reg single-stack)))
795 (:arg-types single-float single-float)
796 (:result-types single-float)
798 (:note "inline float arithmetic")
800 (:save-p :compute-only)
803 ;; Handle a few special cases
805 ;; x, y, and r are the same register.
806 ((and (sc-is x single-reg) (location= x r) (location= y r))
807 (cond ((zerop (tn-offset r))
812 ;; XX the source register will not be valid.
813 (note-next-instruction vop :internal-error)
816 ;; x and r are the same register.
817 ((and (sc-is x single-reg) (location= x r))
818 (cond ((zerop (tn-offset r))
821 ;; ST(0) = ST(0) op ST(y)
824 ;; ST(0) = ST(0) op Mem
825 (inst ,fop (ea-for-sf-stack y)))
827 (inst ,fop (ea-for-sf-desc y)))))
832 (unless (zerop (tn-offset y))
833 (copy-fp-reg-to-fr0 y)))
834 ((single-stack descriptor-reg)
836 (if (sc-is y single-stack)
837 (inst fld (ea-for-sf-stack y))
838 (inst fld (ea-for-sf-desc y)))))
839 ;; ST(i) = ST(i) op ST0
841 (maybe-fp-wait node vop))
842 ;; y and r are the same register.
843 ((and (sc-is y single-reg) (location= y r))
844 (cond ((zerop (tn-offset r))
847 ;; ST(0) = ST(x) op ST(0)
850 ;; ST(0) = Mem op ST(0)
851 (inst ,fopr (ea-for-sf-stack x)))
853 (inst ,fopr (ea-for-sf-desc x)))))
858 (unless (zerop (tn-offset x))
859 (copy-fp-reg-to-fr0 x)))
860 ((single-stack descriptor-reg)
862 (if (sc-is x single-stack)
863 (inst fld (ea-for-sf-stack x))
864 (inst fld (ea-for-sf-desc x)))))
865 ;; ST(i) = ST(0) op ST(i)
867 (maybe-fp-wait node vop))
870 ;; Get the result to ST0.
872 ;; Special handling is needed if x or y are in ST0, and
873 ;; simpler code is generated.
876 ((and (sc-is x single-reg) (zerop (tn-offset x)))
882 (inst ,fop (ea-for-sf-stack y)))
884 (inst ,fop (ea-for-sf-desc y)))))
886 ((and (sc-is y single-reg) (zerop (tn-offset y)))
892 (inst ,fopr (ea-for-sf-stack x)))
894 (inst ,fopr (ea-for-sf-desc x)))))
899 (copy-fp-reg-to-fr0 x))
902 (inst fld (ea-for-sf-stack x)))
905 (inst fld (ea-for-sf-desc x))))
911 (inst ,fop (ea-for-sf-stack y)))
913 (inst ,fop (ea-for-sf-desc y))))))
915 (note-next-instruction vop :internal-error)
917 ;; Finally save the result.
920 (cond ((zerop (tn-offset r))
921 (maybe-fp-wait node))
925 (inst fst (ea-for-sf-stack r))))))))
929 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
931 (y :scs (double-reg double-stack #+nil descriptor-reg)
933 (:temporary (:sc double-reg :offset fr0-offset
934 :from :eval :to :result) fr0)
935 (:results (r :scs (double-reg double-stack)))
936 (:arg-types double-float double-float)
937 (:result-types double-float)
939 (:note "inline float arithmetic")
941 (:save-p :compute-only)
944 ;; Handle a few special cases.
946 ;; x, y, and r are the same register.
947 ((and (sc-is x double-reg) (location= x r) (location= y r))
948 (cond ((zerop (tn-offset r))
953 ;; XX the source register will not be valid.
954 (note-next-instruction vop :internal-error)
957 ;; x and r are the same register.
958 ((and (sc-is x double-reg) (location= x r))
959 (cond ((zerop (tn-offset r))
962 ;; ST(0) = ST(0) op ST(y)
965 ;; ST(0) = ST(0) op Mem
966 (inst ,fopd (ea-for-df-stack y)))
968 (inst ,fopd (ea-for-df-desc y)))))
973 (unless (zerop (tn-offset y))
974 (copy-fp-reg-to-fr0 y)))
975 ((double-stack descriptor-reg)
977 (if (sc-is y double-stack)
978 (inst fldd (ea-for-df-stack y))
979 (inst fldd (ea-for-df-desc y)))))
980 ;; ST(i) = ST(i) op ST0
982 (maybe-fp-wait node vop))
983 ;; y and r are the same register.
984 ((and (sc-is y double-reg) (location= y r))
985 (cond ((zerop (tn-offset r))
988 ;; ST(0) = ST(x) op ST(0)
991 ;; ST(0) = Mem op ST(0)
992 (inst ,foprd (ea-for-df-stack x)))
994 (inst ,foprd (ea-for-df-desc x)))))
999 (unless (zerop (tn-offset x))
1000 (copy-fp-reg-to-fr0 x)))
1001 ((double-stack descriptor-reg)
1003 (if (sc-is x double-stack)
1004 (inst fldd (ea-for-df-stack x))
1005 (inst fldd (ea-for-df-desc x)))))
1006 ;; ST(i) = ST(0) op ST(i)
1007 (inst ,fopr-sti r)))
1008 (maybe-fp-wait node vop))
1011 ;; Get the result to ST0.
1013 ;; Special handling is needed if x or y are in ST0, and
1014 ;; simpler code is generated.
1017 ((and (sc-is x double-reg) (zerop (tn-offset x)))
1023 (inst ,fopd (ea-for-df-stack y)))
1025 (inst ,fopd (ea-for-df-desc y)))))
1027 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1033 (inst ,foprd (ea-for-df-stack x)))
1035 (inst ,foprd (ea-for-df-desc x)))))
1040 (copy-fp-reg-to-fr0 x))
1043 (inst fldd (ea-for-df-stack x)))
1046 (inst fldd (ea-for-df-desc x))))
1052 (inst ,fopd (ea-for-df-stack y)))
1054 (inst ,fopd (ea-for-df-desc y))))))
1056 (note-next-instruction vop :internal-error)
1058 ;; Finally save the result.
1061 (cond ((zerop (tn-offset r))
1062 (maybe-fp-wait node))
1066 (inst fstd (ea-for-df-stack r))))))))
1069 (define-vop (,lname)
1071 (:args (x :scs (long-reg) :to :eval)
1072 (y :scs (long-reg) :to :eval))
1073 (:temporary (:sc long-reg :offset fr0-offset
1074 :from :eval :to :result) fr0)
1075 (:results (r :scs (long-reg)))
1076 (:arg-types long-float long-float)
1077 (:result-types long-float)
1078 (:policy :fast-safe)
1079 (:note "inline float arithmetic")
1081 (:save-p :compute-only)
1084 ;; Handle a few special cases.
1086 ;; x, y, and r are the same register.
1087 ((and (location= x r) (location= y r))
1088 (cond ((zerop (tn-offset r))
1093 ;; XX the source register will not be valid.
1094 (note-next-instruction vop :internal-error)
1097 ;; x and r are the same register.
1099 (cond ((zerop (tn-offset r))
1100 ;; ST(0) = ST(0) op ST(y)
1104 (unless (zerop (tn-offset y))
1105 (copy-fp-reg-to-fr0 y))
1106 ;; ST(i) = ST(i) op ST0
1108 (maybe-fp-wait node vop))
1109 ;; y and r are the same register.
1111 (cond ((zerop (tn-offset r))
1112 ;; ST(0) = ST(x) op ST(0)
1116 (unless (zerop (tn-offset x))
1117 (copy-fp-reg-to-fr0 x))
1118 ;; ST(i) = ST(0) op ST(i)
1119 (inst ,fopr-sti r)))
1120 (maybe-fp-wait node vop))
1123 ;; Get the result to ST0.
1125 ;; Special handling is needed if x or y are in ST0, and
1126 ;; simpler code is generated.
1129 ((zerop (tn-offset x))
1133 ((zerop (tn-offset y))
1138 (copy-fp-reg-to-fr0 x)
1142 (note-next-instruction vop :internal-error)
1144 ;; Finally save the result.
1145 (cond ((zerop (tn-offset r))
1146 (maybe-fp-wait node))
1148 (inst fst r))))))))))
1150 (frob + fadd-sti fadd-sti
1151 fadd fadd +/single-float 2
1152 faddd faddd +/double-float 2
1154 (frob - fsub-sti fsubr-sti
1155 fsub fsubr -/single-float 2
1156 fsubd fsubrd -/double-float 2
1158 (frob * fmul-sti fmul-sti
1159 fmul fmul */single-float 3
1160 fmuld fmuld */double-float 3
1162 (frob / fdiv-sti fdivr-sti
1163 fdiv fdivr //single-float 12
1164 fdivd fdivrd //double-float 12
1167 (macrolet ((frob (name inst translate sc type)
1168 `(define-vop (,name)
1169 (:args (x :scs (,sc) :target fr0))
1170 (:results (y :scs (,sc)))
1171 (:translate ,translate)
1172 (:policy :fast-safe)
1174 (:result-types ,type)
1175 (:temporary (:sc double-reg :offset fr0-offset
1176 :from :argument :to :result) fr0)
1178 (:note "inline float arithmetic")
1180 (:save-p :compute-only)
1182 (note-this-location vop :internal-error)
1183 (unless (zerop (tn-offset x))
1184 (inst fxch x) ; x to top of stack
1185 (unless (location= x y)
1186 (inst fst x))) ; Maybe save it.
1187 (inst ,inst) ; Clobber st0.
1188 (unless (zerop (tn-offset y))
1191 (frob abs/single-float fabs abs single-reg single-float)
1192 (frob abs/double-float fabs abs double-reg double-float)
1194 (frob abs/long-float fabs abs long-reg long-float)
1195 (frob %negate/single-float fchs %negate single-reg single-float)
1196 (frob %negate/double-float fchs %negate double-reg double-float)
1198 (frob %negate/long-float fchs %negate long-reg long-float))
1202 (define-vop (=/float)
1204 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1206 (:policy :fast-safe)
1208 (:save-p :compute-only)
1209 (:note "inline float comparison")
1212 (note-this-location vop :internal-error)
1214 ;; x is in ST0; y is in any reg.
1215 ((zerop (tn-offset x))
1217 ;; y is in ST0; x is in another reg.
1218 ((zerop (tn-offset y))
1220 ;; x and y are the same register, not ST0
1225 ;; x and y are different registers, neither ST0.
1230 (inst fnstsw) ; status word to ax
1231 (inst and ah-tn #x45) ; C3 C2 C0
1232 (inst cmp ah-tn #x40)))
1234 (define-vop (=/single-float =/float)
1236 (:args (x :scs (single-reg))
1237 (y :scs (single-reg)))
1238 (:arg-types single-float single-float))
1240 (define-vop (=/double-float =/float)
1242 (:args (x :scs (double-reg))
1243 (y :scs (double-reg)))
1244 (:arg-types double-float double-float))
1247 (define-vop (=/long-float =/float)
1249 (:args (x :scs (long-reg))
1250 (y :scs (long-reg)))
1251 (:arg-types long-float long-float))
1253 (define-vop (<single-float)
1255 (:args (x :scs (single-reg single-stack descriptor-reg))
1256 (y :scs (single-reg single-stack descriptor-reg)))
1257 (:arg-types single-float single-float)
1258 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1259 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1261 (:policy :fast-safe)
1262 (:note "inline float comparison")
1265 ;; Handle a few special cases.
1268 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1272 ((single-stack descriptor-reg)
1273 (if (sc-is x single-stack)
1274 (inst fcom (ea-for-sf-stack x))
1275 (inst fcom (ea-for-sf-desc x)))))
1276 (inst fnstsw) ; status word to ax
1277 (inst and ah-tn #x45))
1279 ;; general case when y is not in ST0
1284 (unless (zerop (tn-offset x))
1285 (copy-fp-reg-to-fr0 x)))
1286 ((single-stack descriptor-reg)
1288 (if (sc-is x single-stack)
1289 (inst fld (ea-for-sf-stack x))
1290 (inst fld (ea-for-sf-desc x)))))
1294 ((single-stack descriptor-reg)
1295 (if (sc-is y single-stack)
1296 (inst fcom (ea-for-sf-stack y))
1297 (inst fcom (ea-for-sf-desc y)))))
1298 (inst fnstsw) ; status word to ax
1299 (inst and ah-tn #x45) ; C3 C2 C0
1300 (inst cmp ah-tn #x01)))))
1302 (define-vop (<double-float)
1304 (:args (x :scs (double-reg double-stack descriptor-reg))
1305 (y :scs (double-reg double-stack descriptor-reg)))
1306 (:arg-types double-float double-float)
1307 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1308 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1310 (:policy :fast-safe)
1311 (:note "inline float comparison")
1314 ;; Handle a few special cases
1317 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1321 ((double-stack descriptor-reg)
1322 (if (sc-is x double-stack)
1323 (inst fcomd (ea-for-df-stack x))
1324 (inst fcomd (ea-for-df-desc x)))))
1325 (inst fnstsw) ; status word to ax
1326 (inst and ah-tn #x45))
1328 ;; General case when y is not in ST0.
1333 (unless (zerop (tn-offset x))
1334 (copy-fp-reg-to-fr0 x)))
1335 ((double-stack descriptor-reg)
1337 (if (sc-is x double-stack)
1338 (inst fldd (ea-for-df-stack x))
1339 (inst fldd (ea-for-df-desc x)))))
1343 ((double-stack descriptor-reg)
1344 (if (sc-is y double-stack)
1345 (inst fcomd (ea-for-df-stack y))
1346 (inst fcomd (ea-for-df-desc y)))))
1347 (inst fnstsw) ; status word to ax
1348 (inst and ah-tn #x45) ; C3 C2 C0
1349 (inst cmp ah-tn #x01)))))
1352 (define-vop (<long-float)
1354 (:args (x :scs (long-reg))
1355 (y :scs (long-reg)))
1356 (:arg-types long-float long-float)
1357 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1359 (:policy :fast-safe)
1360 (:note "inline float comparison")
1364 ;; x is in ST0; y is in any reg.
1365 ((zerop (tn-offset x))
1367 (inst fnstsw) ; status word to ax
1368 (inst and ah-tn #x45) ; C3 C2 C0
1369 (inst cmp ah-tn #x01))
1370 ;; y is in ST0; x is in another reg.
1371 ((zerop (tn-offset y))
1373 (inst fnstsw) ; status word to ax
1374 (inst and ah-tn #x45))
1375 ;; x and y are the same register, not ST0
1376 ;; x and y are different registers, neither ST0.
1381 (inst fnstsw) ; status word to ax
1382 (inst and ah-tn #x45))))) ; C3 C2 C0
1385 (define-vop (>single-float)
1387 (:args (x :scs (single-reg single-stack descriptor-reg))
1388 (y :scs (single-reg single-stack descriptor-reg)))
1389 (:arg-types single-float single-float)
1390 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1391 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1393 (:policy :fast-safe)
1394 (:note "inline float comparison")
1397 ;; Handle a few special cases.
1400 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1404 ((single-stack descriptor-reg)
1405 (if (sc-is x single-stack)
1406 (inst fcom (ea-for-sf-stack x))
1407 (inst fcom (ea-for-sf-desc x)))))
1408 (inst fnstsw) ; status word to ax
1409 (inst and ah-tn #x45)
1410 (inst cmp ah-tn #x01))
1412 ;; general case when y is not in ST0
1417 (unless (zerop (tn-offset x))
1418 (copy-fp-reg-to-fr0 x)))
1419 ((single-stack descriptor-reg)
1421 (if (sc-is x single-stack)
1422 (inst fld (ea-for-sf-stack x))
1423 (inst fld (ea-for-sf-desc x)))))
1427 ((single-stack descriptor-reg)
1428 (if (sc-is y single-stack)
1429 (inst fcom (ea-for-sf-stack y))
1430 (inst fcom (ea-for-sf-desc y)))))
1431 (inst fnstsw) ; status word to ax
1432 (inst and ah-tn #x45)))))
1434 (define-vop (>double-float)
1436 (:args (x :scs (double-reg double-stack descriptor-reg))
1437 (y :scs (double-reg double-stack descriptor-reg)))
1438 (:arg-types double-float double-float)
1439 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1440 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1442 (:policy :fast-safe)
1443 (:note "inline float comparison")
1446 ;; Handle a few special cases.
1449 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1453 ((double-stack descriptor-reg)
1454 (if (sc-is x double-stack)
1455 (inst fcomd (ea-for-df-stack x))
1456 (inst fcomd (ea-for-df-desc x)))))
1457 (inst fnstsw) ; status word to ax
1458 (inst and ah-tn #x45)
1459 (inst cmp ah-tn #x01))
1461 ;; general case when y is not in ST0
1466 (unless (zerop (tn-offset x))
1467 (copy-fp-reg-to-fr0 x)))
1468 ((double-stack descriptor-reg)
1470 (if (sc-is x double-stack)
1471 (inst fldd (ea-for-df-stack x))
1472 (inst fldd (ea-for-df-desc x)))))
1476 ((double-stack descriptor-reg)
1477 (if (sc-is y double-stack)
1478 (inst fcomd (ea-for-df-stack y))
1479 (inst fcomd (ea-for-df-desc y)))))
1480 (inst fnstsw) ; status word to ax
1481 (inst and ah-tn #x45)))))
1484 (define-vop (>long-float)
1486 (:args (x :scs (long-reg))
1487 (y :scs (long-reg)))
1488 (:arg-types long-float long-float)
1489 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1491 (:policy :fast-safe)
1492 (:note "inline float comparison")
1496 ;; y is in ST0; x is in any reg.
1497 ((zerop (tn-offset y))
1499 (inst fnstsw) ; status word to ax
1500 (inst and ah-tn #x45)
1501 (inst cmp ah-tn #x01))
1502 ;; x is in ST0; y is in another reg.
1503 ((zerop (tn-offset x))
1505 (inst fnstsw) ; status word to ax
1506 (inst and ah-tn #x45))
1507 ;; y and x are the same register, not ST0
1508 ;; y and x are different registers, neither ST0.
1513 (inst fnstsw) ; status word to ax
1514 (inst and ah-tn #x45)))))
1516 ;;; Comparisons with 0 can use the FTST instruction.
1518 (define-vop (float-test)
1520 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1523 (:variant-vars code)
1524 (:policy :fast-safe)
1526 (:save-p :compute-only)
1527 (:note "inline float comparison")
1530 (note-this-location vop :internal-error)
1533 ((zerop (tn-offset x))
1540 (inst fnstsw) ; status word to ax
1541 (inst and ah-tn #x45) ; C3 C2 C0
1542 (unless (zerop code)
1543 (inst cmp ah-tn code))))
1545 (define-vop (=0/single-float float-test)
1547 (:args (x :scs (single-reg)))
1548 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1550 (define-vop (=0/double-float float-test)
1552 (:args (x :scs (double-reg)))
1553 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1556 (define-vop (=0/long-float float-test)
1558 (:args (x :scs (long-reg)))
1559 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1562 (define-vop (<0/single-float float-test)
1564 (:args (x :scs (single-reg)))
1565 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1567 (define-vop (<0/double-float float-test)
1569 (:args (x :scs (double-reg)))
1570 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1573 (define-vop (<0/long-float float-test)
1575 (:args (x :scs (long-reg)))
1576 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1579 (define-vop (>0/single-float float-test)
1581 (:args (x :scs (single-reg)))
1582 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1584 (define-vop (>0/double-float float-test)
1586 (:args (x :scs (double-reg)))
1587 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1590 (define-vop (>0/long-float float-test)
1592 (:args (x :scs (long-reg)))
1593 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1597 (deftransform eql ((x y) (long-float long-float))
1598 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1599 (= (long-float-high-bits x) (long-float-high-bits y))
1600 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1604 (macrolet ((frob (name translate to-sc to-type)
1605 `(define-vop (,name)
1606 (:args (x :scs (signed-stack signed-reg) :target temp))
1607 (:temporary (:sc signed-stack) temp)
1608 (:results (y :scs (,to-sc)))
1609 (:arg-types signed-num)
1610 (:result-types ,to-type)
1611 (:policy :fast-safe)
1612 (:note "inline float coercion")
1613 (:translate ,translate)
1615 (:save-p :compute-only)
1620 (with-empty-tn@fp-top(y)
1621 (note-this-location vop :internal-error)
1624 (with-empty-tn@fp-top(y)
1625 (note-this-location vop :internal-error)
1626 (inst fild x))))))))
1627 (frob %single-float/signed %single-float single-reg single-float)
1628 (frob %double-float/signed %double-float double-reg double-float)
1630 (frob %long-float/signed %long-float long-reg long-float))
1632 (macrolet ((frob (name translate to-sc to-type)
1633 `(define-vop (,name)
1634 (:args (x :scs (unsigned-reg)))
1635 (:results (y :scs (,to-sc)))
1636 (:arg-types unsigned-num)
1637 (:result-types ,to-type)
1638 (:policy :fast-safe)
1639 (:note "inline float coercion")
1640 (:translate ,translate)
1642 (:save-p :compute-only)
1646 (with-empty-tn@fp-top(y)
1647 (note-this-location vop :internal-error)
1648 (inst fildl (make-ea :dword :base esp-tn)))
1649 (inst add esp-tn 8)))))
1650 (frob %single-float/unsigned %single-float single-reg single-float)
1651 (frob %double-float/unsigned %double-float double-reg double-float)
1653 (frob %long-float/unsigned %long-float long-reg long-float))
1655 (macrolet ((frob (name translate from-sc from-type to-sc to-type
1656 &optional to-stack-sc store-inst load-inst)
1657 `(define-vop (,name)
1658 (:args (x :scs (,from-sc) :target y))
1660 `((:temporary (:sc ,to-stack-sc) temp)))
1661 (:results (y :scs (,to-sc)))
1662 (:arg-types ,from-type)
1663 (:result-types ,to-type)
1664 (:policy :fast-safe)
1665 (:note "inline float coercion")
1666 (:translate ,translate)
1668 (:save-p :compute-only)
1670 (note-this-location vop :internal-error)
1674 (inst ,store-inst temp))
1675 (with-empty-tn@fp-top (y)
1676 (inst ,load-inst temp)))
1677 `(unless (location= x y)
1679 ((zerop (tn-offset x))
1680 ;; x is in ST0, y is in another reg. not ST0
1682 ((zerop (tn-offset y))
1683 ;; y is in ST0, x is in another reg. not ST0
1684 (copy-fp-reg-to-fr0 x))
1686 ;; Neither x or y are in ST0, and they are not in
1690 (inst fxch x)))))))))
1692 (frob %single-float/double-float %single-float double-reg double-float
1693 single-reg single-float
1694 single-stack fst fld)
1696 (frob %single-float/long-float %single-float long-reg
1697 long-float single-reg single-float
1698 single-stack fst fld)
1699 (frob %double-float/single-float %double-float single-reg single-float
1700 double-reg double-float)
1702 (frob %double-float/long-float %double-float long-reg long-float
1703 double-reg double-float
1704 double-stack fstd fldd)
1706 (frob %long-float/single-float %long-float single-reg single-float
1707 long-reg long-float)
1709 (frob %long-float/double-float %long-float double-reg double-float
1710 long-reg long-float))
1712 (macrolet ((frob (trans from-sc from-type round-p)
1713 `(define-vop (,(symbolicate trans "/" from-type))
1714 (:args (x :scs (,from-sc)))
1715 (:temporary (:sc signed-stack) stack-temp)
1717 '((:temporary (:sc unsigned-stack) scw)
1718 (:temporary (:sc any-reg) rcw)))
1719 (:results (y :scs (signed-reg)))
1720 (:arg-types ,from-type)
1721 (:result-types signed-num)
1723 (:policy :fast-safe)
1724 (:note "inline float truncate")
1726 (:save-p :compute-only)
1729 '((note-this-location vop :internal-error)
1730 ;; Catch any pending FPE exceptions.
1732 (,(if round-p 'progn 'pseudo-atomic)
1733 ;; Normal mode (for now) is "round to best".
1736 '((inst fnstcw scw) ; save current control word
1737 (move rcw scw) ; into 16-bit register
1738 (inst or rcw (ash #b11 10)) ; CHOP
1739 (move stack-temp rcw)
1740 (inst fldcw stack-temp)))
1745 (inst fist stack-temp)
1746 (inst mov y stack-temp)))
1748 '((inst fldcw scw)))))))))
1749 (frob %unary-truncate/single-float single-reg single-float nil)
1750 (frob %unary-truncate/double-float double-reg double-float nil)
1752 (frob %unary-truncate/long-float long-reg long-float nil)
1753 (frob %unary-round single-reg single-float t)
1754 (frob %unary-round double-reg double-float t)
1756 (frob %unary-round long-reg long-float t))
1758 (macrolet ((frob (trans from-sc from-type round-p)
1759 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1760 (:args (x :scs (,from-sc) :target fr0))
1761 (:temporary (:sc double-reg :offset fr0-offset
1762 :from :argument :to :result) fr0)
1764 '((:temporary (:sc unsigned-stack) stack-temp)
1765 (:temporary (:sc unsigned-stack) scw)
1766 (:temporary (:sc any-reg) rcw)))
1767 (:results (y :scs (unsigned-reg)))
1768 (:arg-types ,from-type)
1769 (:result-types unsigned-num)
1771 (:policy :fast-safe)
1772 (:note "inline float truncate")
1774 (:save-p :compute-only)
1777 '((note-this-location vop :internal-error)
1778 ;; Catch any pending FPE exceptions.
1780 ;; Normal mode (for now) is "round to best".
1781 (unless (zerop (tn-offset x))
1782 (copy-fp-reg-to-fr0 x))
1784 '((inst fnstcw scw) ; save current control word
1785 (move rcw scw) ; into 16-bit register
1786 (inst or rcw (ash #b11 10)) ; CHOP
1787 (move stack-temp rcw)
1788 (inst fldcw stack-temp)))
1790 (inst fistpl (make-ea :dword :base esp-tn))
1792 (inst fld fr0) ; copy fr0 to at least restore stack.
1795 '((inst fldcw scw)))))))
1796 (frob %unary-truncate/single-float single-reg single-float nil)
1797 (frob %unary-truncate/double-float double-reg double-float nil)
1799 (frob %unary-truncate/long-float long-reg long-float nil)
1800 (frob %unary-round single-reg single-float t)
1801 (frob %unary-round double-reg double-float t)
1803 (frob %unary-round long-reg long-float t))
1805 (define-vop (make-single-float)
1806 (:args (bits :scs (signed-reg) :target res
1807 :load-if (not (or (and (sc-is bits signed-stack)
1808 (sc-is res single-reg))
1809 (and (sc-is bits signed-stack)
1810 (sc-is res single-stack)
1811 (location= bits res))))))
1812 (:results (res :scs (single-reg single-stack)))
1813 (:temporary (:sc signed-stack) stack-temp)
1814 (:arg-types signed-num)
1815 (:result-types single-float)
1816 (:translate make-single-float)
1817 (:policy :fast-safe)
1824 (inst mov res bits))
1826 (aver (location= bits res)))))
1830 ;; source must be in memory
1831 (inst mov stack-temp bits)
1832 (with-empty-tn@fp-top(res)
1833 (inst fld stack-temp)))
1835 (with-empty-tn@fp-top(res)
1836 (inst fld bits))))))))
1838 (define-vop (make-single-float-c)
1839 (:results (res :scs (single-reg single-stack)))
1840 (:arg-types (:constant (signed-byte 32)))
1841 (:result-types single-float)
1843 (:translate make-single-float)
1844 (:policy :fast-safe)
1849 (inst mov res bits))
1851 (with-empty-tn@fp-top (res)
1852 (inst fld (register-inline-constant :dword bits)))))))
1854 (define-vop (make-double-float)
1855 (:args (hi-bits :scs (signed-reg))
1856 (lo-bits :scs (unsigned-reg)))
1857 (:results (res :scs (double-reg)))
1858 (:temporary (:sc double-stack) temp)
1859 (:arg-types signed-num unsigned-num)
1860 (:result-types double-float)
1861 (:translate make-double-float)
1862 (:policy :fast-safe)
1865 (let ((offset (tn-offset temp)))
1866 (storew hi-bits ebp-tn (frame-word-offset offset))
1867 (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
1868 (with-empty-tn@fp-top(res)
1869 (inst fldd (make-ea :dword :base ebp-tn
1870 :disp (frame-byte-offset (1+ offset))))))))
1872 (define-vop (make-double-float-c)
1873 (:results (res :scs (double-reg)))
1874 (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32)))
1875 (:result-types double-float)
1877 (:translate make-double-float)
1878 (:policy :fast-safe)
1881 (with-empty-tn@fp-top(res)
1882 (inst fldd (register-inline-constant
1883 :double-float-bits (logior (ash hi 32) lo))))))
1886 (define-vop (make-long-float)
1887 (:args (exp-bits :scs (signed-reg))
1888 (hi-bits :scs (unsigned-reg))
1889 (lo-bits :scs (unsigned-reg)))
1890 (:results (res :scs (long-reg)))
1891 (:temporary (:sc long-stack) temp)
1892 (:arg-types signed-num unsigned-num unsigned-num)
1893 (:result-types long-float)
1894 (:translate make-long-float)
1895 (:policy :fast-safe)
1898 (let ((offset (tn-offset temp)))
1899 (storew exp-bits ebp-tn (frame-word-offset offset))
1900 (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
1901 (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
1902 (with-empty-tn@fp-top(res)
1903 (inst fldl (make-ea :dword :base ebp-tn
1904 :disp (frame-byte-offset (+ offset 2))))))))
1906 (define-vop (single-float-bits)
1907 (:args (float :scs (single-reg descriptor-reg)
1908 :load-if (not (sc-is float single-stack))))
1909 (:results (bits :scs (signed-reg)))
1910 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1911 (:arg-types single-float)
1912 (:result-types signed-num)
1913 (:translate single-float-bits)
1914 (:policy :fast-safe)
1921 (with-tn@fp-top(float)
1922 (inst fst stack-temp)
1923 (inst mov bits stack-temp)))
1925 (inst mov bits float))
1928 bits float single-float-value-slot
1929 other-pointer-lowtag))))
1933 (with-tn@fp-top(float)
1934 (inst fst bits))))))))
1936 (define-vop (double-float-high-bits)
1937 (:args (float :scs (double-reg descriptor-reg)
1938 :load-if (not (sc-is float double-stack))))
1939 (:results (hi-bits :scs (signed-reg)))
1940 (:temporary (:sc double-stack) temp)
1941 (:arg-types double-float)
1942 (:result-types signed-num)
1943 (:translate double-float-high-bits)
1944 (:policy :fast-safe)
1949 (with-tn@fp-top(float)
1950 (let ((where (make-ea :dword :base ebp-tn
1951 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1953 (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
1955 (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
1957 (loadw hi-bits float (1+ double-float-value-slot)
1958 other-pointer-lowtag)))))
1960 (define-vop (double-float-low-bits)
1961 (:args (float :scs (double-reg descriptor-reg)
1962 :load-if (not (sc-is float double-stack))))
1963 (:results (lo-bits :scs (unsigned-reg)))
1964 (:temporary (:sc double-stack) temp)
1965 (:arg-types double-float)
1966 (:result-types unsigned-num)
1967 (:translate double-float-low-bits)
1968 (:policy :fast-safe)
1973 (with-tn@fp-top(float)
1974 (let ((where (make-ea :dword :base ebp-tn
1975 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1977 (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1979 (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
1981 (loadw lo-bits float double-float-value-slot
1982 other-pointer-lowtag)))))
1985 (define-vop (long-float-exp-bits)
1986 (:args (float :scs (long-reg descriptor-reg)
1987 :load-if (not (sc-is float long-stack))))
1988 (:results (exp-bits :scs (signed-reg)))
1989 (:temporary (:sc long-stack) temp)
1990 (:arg-types long-float)
1991 (:result-types signed-num)
1992 (:translate long-float-exp-bits)
1993 (:policy :fast-safe)
1998 (with-tn@fp-top(float)
1999 (let ((where (make-ea :dword :base ebp-tn
2000 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2001 (store-long-float where)))
2002 (inst movsx exp-bits
2003 (make-ea :word :base ebp-tn
2004 :disp (frame-byte-offset (tn-offset temp)))))
2006 (inst movsx exp-bits
2007 (make-ea :word :base ebp-tn
2008 :disp (frame-byte-offset (tn-offset temp)))))
2010 (inst movsx exp-bits
2011 (make-ea-for-object-slot float (+ 2 long-float-value-slot)
2012 other-pointer-lowtag :word))))))
2015 (define-vop (long-float-high-bits)
2016 (:args (float :scs (long-reg descriptor-reg)
2017 :load-if (not (sc-is float long-stack))))
2018 (:results (hi-bits :scs (unsigned-reg)))
2019 (:temporary (:sc long-stack) temp)
2020 (:arg-types long-float)
2021 (:result-types unsigned-num)
2022 (:translate long-float-high-bits)
2023 (:policy :fast-safe)
2028 (with-tn@fp-top(float)
2029 (let ((where (make-ea :dword :base ebp-tn
2030 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2031 (store-long-float where)))
2032 (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
2034 (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
2036 (loadw hi-bits float (1+ long-float-value-slot)
2037 other-pointer-lowtag)))))
2040 (define-vop (long-float-low-bits)
2041 (:args (float :scs (long-reg descriptor-reg)
2042 :load-if (not (sc-is float long-stack))))
2043 (:results (lo-bits :scs (unsigned-reg)))
2044 (:temporary (:sc long-stack) temp)
2045 (:arg-types long-float)
2046 (:result-types unsigned-num)
2047 (:translate long-float-low-bits)
2048 (:policy :fast-safe)
2053 (with-tn@fp-top(float)
2054 (let ((where (make-ea :dword :base ebp-tn
2055 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2056 (store-long-float where)))
2057 (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
2059 (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
2061 (loadw lo-bits float long-float-value-slot
2062 other-pointer-lowtag)))))
2064 ;;;; float mode hackery
2066 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2067 (defknown floating-point-modes () float-modes (flushable))
2068 (defknown ((setf floating-point-modes)) (float-modes)
2071 (def!constant npx-env-size (* 7 n-word-bytes))
2072 (def!constant npx-cw-offset 0)
2073 (def!constant npx-sw-offset 4)
2075 (define-vop (floating-point-modes)
2076 (:results (res :scs (unsigned-reg)))
2077 (:result-types unsigned-num)
2078 (:translate floating-point-modes)
2079 (:policy :fast-safe)
2080 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2083 (inst sub esp-tn npx-env-size) ; Make space on stack.
2084 (inst wait) ; Catch any pending FPE exceptions
2085 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2086 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2087 ;; Move current status to high word.
2088 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2089 ;; Move exception mask to low word.
2090 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2091 (inst add esp-tn npx-env-size) ; Pop stack.
2092 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2095 (define-vop (set-floating-point-modes)
2096 (:args (new :scs (unsigned-reg) :to :result :target res))
2097 (:results (res :scs (unsigned-reg)))
2098 (:arg-types unsigned-num)
2099 (:result-types unsigned-num)
2100 (:translate (setf floating-point-modes))
2101 (:policy :fast-safe)
2102 (:temporary (:sc unsigned-reg :offset eax-offset
2103 :from :eval :to :result) eax)
2105 (inst sub esp-tn npx-env-size) ; Make space on stack.
2106 (inst wait) ; Catch any pending FPE exceptions.
2107 (inst fstenv (make-ea :dword :base esp-tn))
2109 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2110 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2111 (inst shr eax 16) ; position status word
2112 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2113 (inst fldenv (make-ea :dword :base esp-tn))
2114 (inst add esp-tn npx-env-size) ; Pop stack.
2120 ;;; Let's use some of the 80387 special functions.
2122 ;;; These defs will not take effect unless code/irrat.lisp is modified
2123 ;;; to remove the inlined alien routine def.
2125 (macrolet ((frob (func trans op)
2126 `(define-vop (,func)
2127 (:args (x :scs (double-reg) :target fr0))
2128 (:temporary (:sc double-reg :offset fr0-offset
2129 :from :argument :to :result) fr0)
2131 (:results (y :scs (double-reg)))
2132 (:arg-types double-float)
2133 (:result-types double-float)
2135 (:policy :fast-safe)
2136 (:note "inline NPX function")
2138 (:save-p :compute-only)
2141 (note-this-location vop :internal-error)
2142 (unless (zerop (tn-offset x))
2143 (inst fxch x) ; x to top of stack
2144 (unless (location= x y)
2145 (inst fst x))) ; maybe save it
2146 (inst ,op) ; clobber st0
2147 (cond ((zerop (tn-offset y))
2148 (maybe-fp-wait node))
2152 ;; Quick versions of fsin and fcos that require the argument to be
2153 ;; within range 2^63.
2154 (frob fsin-quick %sin-quick fsin)
2155 (frob fcos-quick %cos-quick fcos)
2156 (frob fsqrt %sqrt fsqrt))
2158 ;;; Quick version of ftan that requires the argument to be within
2160 (define-vop (ftan-quick)
2161 (:translate %tan-quick)
2162 (:args (x :scs (double-reg) :target fr0))
2163 (:temporary (:sc double-reg :offset fr0-offset
2164 :from :argument :to :result) fr0)
2165 (:temporary (:sc double-reg :offset fr1-offset
2166 :from :argument :to :result) fr1)
2167 (:results (y :scs (double-reg)))
2168 (:arg-types double-float)
2169 (:result-types double-float)
2170 (:policy :fast-safe)
2171 (:note "inline tan function")
2173 (:save-p :compute-only)
2175 (note-this-location vop :internal-error)
2184 (inst fldd (make-random-tn :kind :normal
2185 :sc (sc-or-lose 'double-reg)
2186 :offset (- (tn-offset x) 2)))))
2197 ;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
2198 ;;; result if the argument is out of range 2^63 and would thus be
2199 ;;; hopelessly inaccurate.
2200 (macrolet ((frob (func trans op)
2201 `(define-vop (,func)
2203 (:args (x :scs (double-reg) :target fr0))
2204 (:temporary (:sc double-reg :offset fr0-offset
2205 :from :argument :to :result) fr0)
2206 ;; FIXME: make that an arbitrary location and
2207 ;; FXCH only when range reduction needed
2208 (:temporary (:sc double-reg :offset fr1-offset
2209 :from :argument :to :result) fr1)
2210 (:temporary (:sc unsigned-reg :offset eax-offset
2211 :from :argument :to :result) eax)
2212 (:results (y :scs (double-reg)))
2213 (:arg-types double-float)
2214 (:result-types double-float)
2215 (:policy :fast-safe)
2216 (:note "inline sin/cos function")
2218 (:save-p :compute-only)
2221 (let ((DONE (gen-label))
2222 (REDUCE (gen-label))
2223 (REDUCE-LOOP (gen-label)))
2224 (note-this-location vop :internal-error)
2225 (unless (zerop (tn-offset x))
2226 (inst fxch x) ; x to top of stack
2227 (unless (location= x y)
2228 (inst fst x))) ; maybe save it
2230 (inst fnstsw) ; status word to ax
2231 (inst and ah-tn #x04) ; C2
2232 (inst jmp :nz REDUCE)
2234 (unless (zerop (tn-offset y))
2236 (assemble (*elsewhere*)
2238 ;; Else x was out of range so reduce it; ST0 is unchanged.
2239 (with-empty-tn@fp-top (fr1)
2242 (emit-label REDUCE-LOOP)
2245 (inst and ah-tn #x04)
2246 (inst jmp :nz REDUCE-LOOP)
2248 (inst jmp DONE)))))))
2249 (frob fsin %sin fsin)
2250 (frob fcos %cos fcos))
2254 (:args (x :scs (double-reg) :target fr0))
2255 (:temporary (:sc double-reg :offset fr0-offset
2256 :from :argument :to :result) fr0)
2257 (:temporary (:sc double-reg :offset fr1-offset
2258 :from :argument :to :result) fr1)
2259 (:temporary (:sc unsigned-reg :offset eax-offset
2260 :from :argument :to :result) eax)
2261 (:results (y :scs (double-reg)))
2262 (:arg-types double-float)
2263 (:result-types double-float)
2265 (:policy :fast-safe)
2266 (:note "inline tan function")
2268 (:save-p :compute-only)
2271 (note-this-location vop :internal-error)
2280 (inst fldd (make-random-tn :kind :normal
2281 :sc (sc-or-lose 'double-reg)
2282 :offset (- (tn-offset x) 2)))))
2284 (let ((REDUCE (gen-label))
2285 (REDUCE-LOOP (gen-label)))
2286 (inst fnstsw) ; status word to ax
2287 (inst and ah-tn #x04) ; C2
2288 (inst jmp :nz REDUCE)
2289 (assemble (*elsewhere*)
2291 ;; Else x was out of range so reduce it; ST0 is unchanged.
2292 (with-empty-tn@fp-top (fr1)
2295 (emit-label REDUCE-LOOP)
2298 (inst and ah-tn #x04)
2299 (inst jmp :nz REDUCE-LOOP)
2312 ;;; %exp that handles the following special cases: exp(+Inf) is +Inf;
2313 ;;; exp(-Inf) is 0; exp(NaN) is NaN.
2316 (:args (x :scs (double-reg) :target fr0))
2317 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2318 (:temporary (:sc double-reg :offset fr0-offset
2319 :from :argument :to :result) fr0)
2320 (:temporary (:sc double-reg :offset fr1-offset
2321 :from :argument :to :result) fr1)
2322 (:temporary (:sc double-reg :offset fr2-offset
2323 :from :argument :to :result) fr2)
2324 (:results (y :scs (double-reg)))
2325 (:arg-types double-float)
2326 (:result-types double-float)
2327 (:policy :fast-safe)
2328 (:note "inline exp function")
2330 (:save-p :compute-only)
2333 (note-this-location vop :internal-error)
2334 (unless (zerop (tn-offset x))
2335 (inst fxch x) ; x to top of stack
2336 (unless (location= x y)
2337 (inst fst x))) ; maybe save it
2338 ;; Check for Inf or NaN
2342 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2343 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2344 (inst and ah-tn #x02) ; Test sign of Inf.
2345 (inst jmp :z DONE) ; +Inf gives +Inf.
2346 (inst fstp fr0) ; -Inf gives 0
2348 (inst jmp-short DONE)
2353 ;; Now fr0=x log2(e)
2357 (inst fsubp-sti fr1)
2360 (inst faddp-sti fr1)
2364 (unless (zerop (tn-offset y))
2367 ;;; Expm1 = exp(x) - 1.
2368 ;;; Handles the following special cases:
2369 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2370 (define-vop (fexpm1)
2372 (:args (x :scs (double-reg) :target fr0))
2373 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2374 (:temporary (:sc double-reg :offset fr0-offset
2375 :from :argument :to :result) fr0)
2376 (:temporary (:sc double-reg :offset fr1-offset
2377 :from :argument :to :result) fr1)
2378 (:temporary (:sc double-reg :offset fr2-offset
2379 :from :argument :to :result) fr2)
2380 (:results (y :scs (double-reg)))
2381 (:arg-types double-float)
2382 (:result-types double-float)
2383 (:policy :fast-safe)
2384 (:note "inline expm1 function")
2386 (:save-p :compute-only)
2389 (note-this-location vop :internal-error)
2390 (unless (zerop (tn-offset x))
2391 (inst fxch x) ; x to top of stack
2392 (unless (location= x y)
2393 (inst fst x))) ; maybe save it
2394 ;; Check for Inf or NaN
2398 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2399 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2400 (inst and ah-tn #x02) ; Test sign of Inf.
2401 (inst jmp :z DONE) ; +Inf gives +Inf.
2402 (inst fstp fr0) ; -Inf gives -1.0
2405 (inst jmp-short DONE)
2407 ;; Free two stack slots leaving the argument on top.
2411 (inst fmul fr1) ; Now fr0 = x log2(e)
2426 (unless (zerop (tn-offset y))
2431 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2432 (:temporary (:sc double-reg :offset fr0-offset
2433 :from :argument :to :result) fr0)
2434 (:temporary (:sc double-reg :offset fr1-offset
2435 :from :argument :to :result) fr1)
2436 (:results (y :scs (double-reg)))
2437 (:arg-types double-float)
2438 (:result-types double-float)
2439 (:policy :fast-safe)
2440 (:note "inline log function")
2442 (:save-p :compute-only)
2444 (note-this-location vop :internal-error)
2459 ;; x is in a FP reg, not fr0 or fr1
2463 (inst fldd (make-random-tn :kind :normal
2464 :sc (sc-or-lose 'double-reg)
2465 :offset (1- (tn-offset x))))))
2467 ((double-stack descriptor-reg)
2471 (if (sc-is x double-stack)
2472 (inst fldd (ea-for-df-stack x))
2473 (inst fldd (ea-for-df-desc x)))
2478 (t (inst fstd y)))))
2480 (define-vop (flog10)
2482 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2483 (:temporary (:sc double-reg :offset fr0-offset
2484 :from :argument :to :result) fr0)
2485 (:temporary (:sc double-reg :offset fr1-offset
2486 :from :argument :to :result) fr1)
2487 (:results (y :scs (double-reg)))
2488 (:arg-types double-float)
2489 (:result-types double-float)
2490 (:policy :fast-safe)
2491 (:note "inline log10 function")
2493 (:save-p :compute-only)
2495 (note-this-location vop :internal-error)
2510 ;; x is in a FP reg, not fr0 or fr1
2514 (inst fldd (make-random-tn :kind :normal
2515 :sc (sc-or-lose 'double-reg)
2516 :offset (1- (tn-offset x))))))
2518 ((double-stack descriptor-reg)
2522 (if (sc-is x double-stack)
2523 (inst fldd (ea-for-df-stack x))
2524 (inst fldd (ea-for-df-desc x)))
2529 (t (inst fstd y)))))
2533 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2534 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2535 (:temporary (:sc double-reg :offset fr0-offset
2536 :from (:argument 0) :to :result) fr0)
2537 (:temporary (:sc double-reg :offset fr1-offset
2538 :from (:argument 1) :to :result) fr1)
2539 (:temporary (:sc double-reg :offset fr2-offset
2540 :from :load :to :result) fr2)
2541 (:results (r :scs (double-reg)))
2542 (:arg-types double-float double-float)
2543 (:result-types double-float)
2544 (:policy :fast-safe)
2545 (:note "inline pow function")
2547 (:save-p :compute-only)
2549 (note-this-location vop :internal-error)
2550 ;; Setup x in fr0 and y in fr1
2552 ;; x in fr0; y in fr1
2553 ((and (sc-is x double-reg) (zerop (tn-offset x))
2554 (sc-is y double-reg) (= 1 (tn-offset y))))
2555 ;; y in fr1; x not in fr0
2556 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2560 (copy-fp-reg-to-fr0 x))
2563 (inst fldd (ea-for-df-stack x)))
2566 (inst fldd (ea-for-df-desc x)))))
2567 ;; x in fr0; y not in fr1
2568 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2570 ;; Now load y to fr0
2573 (copy-fp-reg-to-fr0 y))
2576 (inst fldd (ea-for-df-stack y)))
2579 (inst fldd (ea-for-df-desc y))))
2581 ;; x in fr1; y not in fr1
2582 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2586 (copy-fp-reg-to-fr0 y))
2589 (inst fldd (ea-for-df-stack y)))
2592 (inst fldd (ea-for-df-desc y))))
2595 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2597 ;; Now load x to fr0
2600 (copy-fp-reg-to-fr0 x))
2603 (inst fldd (ea-for-df-stack x)))
2606 (inst fldd (ea-for-df-desc x)))))
2607 ;; Neither x or y are in either fr0 or fr1
2614 (inst fldd (make-random-tn :kind :normal
2615 :sc (sc-or-lose 'double-reg)
2616 :offset (- (tn-offset y) 2))))
2618 (inst fldd (ea-for-df-stack y)))
2620 (inst fldd (ea-for-df-desc y))))
2624 (inst fldd (make-random-tn :kind :normal
2625 :sc (sc-or-lose 'double-reg)
2626 :offset (1- (tn-offset x)))))
2628 (inst fldd (ea-for-df-stack x)))
2630 (inst fldd (ea-for-df-desc x))))))
2632 ;; Now have x at fr0; and y at fr1
2634 ;; Now fr0=y log2(x)
2638 (inst fsubp-sti fr1)
2641 (inst faddp-sti fr1)
2646 (t (inst fstd r)))))
2648 (define-vop (fscalen)
2649 (:translate %scalbn)
2650 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2651 (y :scs (signed-stack signed-reg) :target temp))
2652 (:temporary (:sc double-reg :offset fr0-offset
2653 :from (:argument 0) :to :result) fr0)
2654 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2655 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2656 (:results (r :scs (double-reg)))
2657 (:arg-types double-float signed-num)
2658 (:result-types double-float)
2659 (:policy :fast-safe)
2660 (:note "inline scalbn function")
2662 ;; Setup x in fr0 and y in fr1
2693 (inst fld (make-random-tn :kind :normal
2694 :sc (sc-or-lose 'double-reg)
2695 :offset (1- (tn-offset x)))))))
2696 ((double-stack descriptor-reg)
2705 (if (sc-is x double-stack)
2706 (inst fldd (ea-for-df-stack x))
2707 (inst fldd (ea-for-df-desc x)))))
2709 (unless (zerop (tn-offset r))
2712 (define-vop (fscale)
2714 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2715 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2716 (:temporary (:sc double-reg :offset fr0-offset
2717 :from (:argument 0) :to :result) fr0)
2718 (:temporary (:sc double-reg :offset fr1-offset
2719 :from (:argument 1) :to :result) fr1)
2720 (:results (r :scs (double-reg)))
2721 (:arg-types double-float double-float)
2722 (:result-types double-float)
2723 (:policy :fast-safe)
2724 (:note "inline scalb function")
2726 (:save-p :compute-only)
2728 (note-this-location vop :internal-error)
2729 ;; Setup x in fr0 and y in fr1
2731 ;; x in fr0; y in fr1
2732 ((and (sc-is x double-reg) (zerop (tn-offset x))
2733 (sc-is y double-reg) (= 1 (tn-offset y))))
2734 ;; y in fr1; x not in fr0
2735 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2739 (copy-fp-reg-to-fr0 x))
2742 (inst fldd (ea-for-df-stack x)))
2745 (inst fldd (ea-for-df-desc x)))))
2746 ;; x in fr0; y not in fr1
2747 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2749 ;; Now load y to fr0
2752 (copy-fp-reg-to-fr0 y))
2755 (inst fldd (ea-for-df-stack y)))
2758 (inst fldd (ea-for-df-desc y))))
2760 ;; x in fr1; y not in fr1
2761 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2765 (copy-fp-reg-to-fr0 y))
2768 (inst fldd (ea-for-df-stack y)))
2771 (inst fldd (ea-for-df-desc y))))
2774 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2776 ;; Now load x to fr0
2779 (copy-fp-reg-to-fr0 x))
2782 (inst fldd (ea-for-df-stack x)))
2785 (inst fldd (ea-for-df-desc x)))))
2786 ;; Neither x or y are in either fr0 or fr1
2793 (inst fldd (make-random-tn :kind :normal
2794 :sc (sc-or-lose 'double-reg)
2795 :offset (- (tn-offset y) 2))))
2797 (inst fldd (ea-for-df-stack y)))
2799 (inst fldd (ea-for-df-desc y))))
2803 (inst fldd (make-random-tn :kind :normal
2804 :sc (sc-or-lose 'double-reg)
2805 :offset (1- (tn-offset x)))))
2807 (inst fldd (ea-for-df-stack x)))
2809 (inst fldd (ea-for-df-desc x))))))
2811 ;; Now have x at fr0; and y at fr1
2813 (unless (zerop (tn-offset r))
2816 (define-vop (flog1p)
2818 (:args (x :scs (double-reg) :to :result))
2819 (:temporary (:sc double-reg :offset fr0-offset
2820 :from :argument :to :result) fr0)
2821 (:temporary (:sc double-reg :offset fr1-offset
2822 :from :argument :to :result) fr1)
2823 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2824 (:results (y :scs (double-reg)))
2825 (:arg-types double-float)
2826 (:result-types double-float)
2827 (:policy :fast-safe)
2828 (:note "inline log1p function")
2831 ;; x is in a FP reg, not fr0, fr1.
2834 (inst fldd (make-random-tn :kind :normal
2835 :sc (sc-or-lose 'double-reg)
2836 :offset (- (tn-offset x) 2)))
2838 (inst push #x3e947ae1) ; Constant 0.29
2840 (inst fld (make-ea :dword :base esp-tn))
2843 (inst fnstsw) ; status word to ax
2844 (inst and ah-tn #x45)
2845 (inst jmp :z WITHIN-RANGE)
2846 ;; Out of range for fyl2xp1.
2848 (inst faddd (make-random-tn :kind :normal
2849 :sc (sc-or-lose 'double-reg)
2850 :offset (- (tn-offset x) 1)))
2858 (inst fldd (make-random-tn :kind :normal
2859 :sc (sc-or-lose 'double-reg)
2860 :offset (- (tn-offset x) 1)))
2866 (t (inst fstd y)))))
2868 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2869 ;;; instruction and a range check can be avoided.
2870 (define-vop (flog1p-pentium)
2872 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2873 (:temporary (:sc double-reg :offset fr0-offset
2874 :from :argument :to :result) fr0)
2875 (:temporary (:sc double-reg :offset fr1-offset
2876 :from :argument :to :result) fr1)
2877 (:results (y :scs (double-reg)))
2878 (:arg-types double-float)
2879 (:result-types double-float)
2880 (:policy :fast-safe)
2881 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2882 (:note "inline log1p with limited x range function")
2884 (:save-p :compute-only)
2886 (note-this-location vop :internal-error)
2901 ;; x is in a FP reg, not fr0 or fr1
2905 (inst fldd (make-random-tn :kind :normal
2906 :sc (sc-or-lose 'double-reg)
2907 :offset (1- (tn-offset x)))))))
2908 ((double-stack descriptor-reg)
2912 (if (sc-is x double-stack)
2913 (inst fldd (ea-for-df-stack x))
2914 (inst fldd (ea-for-df-desc x)))))
2919 (t (inst fstd y)))))
2923 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2924 (:temporary (:sc double-reg :offset fr0-offset
2925 :from :argument :to :result) fr0)
2926 (:temporary (:sc double-reg :offset fr1-offset
2927 :from :argument :to :result) fr1)
2928 (:results (y :scs (double-reg)))
2929 (:arg-types double-float)
2930 (:result-types double-float)
2931 (:policy :fast-safe)
2932 (:note "inline logb function")
2934 (:save-p :compute-only)
2936 (note-this-location vop :internal-error)
2947 ;; x is in a FP reg, not fr0 or fr1
2950 (inst fldd (make-random-tn :kind :normal
2951 :sc (sc-or-lose 'double-reg)
2952 :offset (- (tn-offset x) 2))))))
2953 ((double-stack descriptor-reg)
2956 (if (sc-is x double-stack)
2957 (inst fldd (ea-for-df-stack x))
2958 (inst fldd (ea-for-df-desc x)))))
2969 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2970 (:temporary (:sc double-reg :offset fr0-offset
2971 :from (:argument 0) :to :result) fr0)
2972 (:temporary (:sc double-reg :offset fr1-offset
2973 :from (:argument 0) :to :result) fr1)
2974 (:results (r :scs (double-reg)))
2975 (:arg-types double-float)
2976 (:result-types double-float)
2977 (:policy :fast-safe)
2978 (:note "inline atan function")
2980 (:save-p :compute-only)
2982 (note-this-location vop :internal-error)
2983 ;; Setup x in fr1 and 1.0 in fr0
2986 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2989 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2991 ;; x not in fr0 or fr1
2998 (inst fldd (make-random-tn :kind :normal
2999 :sc (sc-or-lose 'double-reg)
3000 :offset (- (tn-offset x) 2))))
3002 (inst fldd (ea-for-df-stack x)))
3004 (inst fldd (ea-for-df-desc x))))))
3006 ;; Now have x at fr1; and 1.0 at fr0
3011 (t (inst fstd r)))))
3013 (define-vop (fatan2)
3015 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3016 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3017 (:temporary (:sc double-reg :offset fr0-offset
3018 :from (:argument 1) :to :result) fr0)
3019 (:temporary (:sc double-reg :offset fr1-offset
3020 :from (:argument 0) :to :result) fr1)
3021 (:results (r :scs (double-reg)))
3022 (:arg-types double-float double-float)
3023 (:result-types double-float)
3024 (:policy :fast-safe)
3025 (:note "inline atan2 function")
3027 (:save-p :compute-only)
3029 (note-this-location vop :internal-error)
3030 ;; Setup x in fr1 and y in fr0
3032 ;; y in fr0; x in fr1
3033 ((and (sc-is y double-reg) (zerop (tn-offset y))
3034 (sc-is x double-reg) (= 1 (tn-offset x))))
3035 ;; x in fr1; y not in fr0
3036 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3040 (copy-fp-reg-to-fr0 y))
3043 (inst fldd (ea-for-df-stack y)))
3046 (inst fldd (ea-for-df-desc y)))))
3047 ((and (sc-is x double-reg) (zerop (tn-offset x))
3048 (sc-is y double-reg) (zerop (tn-offset x)))
3051 ;; y in fr0; x not in fr1
3052 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3054 ;; Now load x to fr0
3057 (copy-fp-reg-to-fr0 x))
3060 (inst fldd (ea-for-df-stack x)))
3063 (inst fldd (ea-for-df-desc x))))
3065 ;; y in fr1; x not in fr1
3066 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3070 (copy-fp-reg-to-fr0 x))
3073 (inst fldd (ea-for-df-stack x)))
3076 (inst fldd (ea-for-df-desc x))))
3079 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3081 ;; Now load y to fr0
3084 (copy-fp-reg-to-fr0 y))
3087 (inst fldd (ea-for-df-stack y)))
3090 (inst fldd (ea-for-df-desc y)))))
3091 ;; Neither y or x are in either fr0 or fr1
3098 (inst fldd (make-random-tn :kind :normal
3099 :sc (sc-or-lose 'double-reg)
3100 :offset (- (tn-offset x) 2))))
3102 (inst fldd (ea-for-df-stack x)))
3104 (inst fldd (ea-for-df-desc x))))
3108 (inst fldd (make-random-tn :kind :normal
3109 :sc (sc-or-lose 'double-reg)
3110 :offset (1- (tn-offset y)))))
3112 (inst fldd (ea-for-df-stack y)))
3114 (inst fldd (ea-for-df-desc y))))))
3116 ;; Now have y at fr0; and x at fr1
3121 (t (inst fstd r)))))
3122 ) ; PROGN #!-LONG-FLOAT
3127 ;;; Lets use some of the 80387 special functions.
3129 ;;; These defs will not take effect unless code/irrat.lisp is modified
3130 ;;; to remove the inlined alien routine def.
3132 (macrolet ((frob (func trans op)
3133 `(define-vop (,func)
3134 (:args (x :scs (long-reg) :target fr0))
3135 (:temporary (:sc long-reg :offset fr0-offset
3136 :from :argument :to :result) fr0)
3138 (:results (y :scs (long-reg)))
3139 (:arg-types long-float)
3140 (:result-types long-float)
3142 (:policy :fast-safe)
3143 (:note "inline NPX function")
3145 (:save-p :compute-only)
3148 (note-this-location vop :internal-error)
3149 (unless (zerop (tn-offset x))
3150 (inst fxch x) ; x to top of stack
3151 (unless (location= x y)
3152 (inst fst x))) ; maybe save it
3153 (inst ,op) ; clobber st0
3154 (cond ((zerop (tn-offset y))
3155 (maybe-fp-wait node))
3159 ;; Quick versions of FSIN and FCOS that require the argument to be
3160 ;; within range 2^63.
3161 (frob fsin-quick %sin-quick fsin)
3162 (frob fcos-quick %cos-quick fcos)
3163 (frob fsqrt %sqrt fsqrt))
3165 ;;; Quick version of ftan that requires the argument to be within
3167 (define-vop (ftan-quick)
3168 (:translate %tan-quick)
3169 (:args (x :scs (long-reg) :target fr0))
3170 (:temporary (:sc long-reg :offset fr0-offset
3171 :from :argument :to :result) fr0)
3172 (:temporary (:sc long-reg :offset fr1-offset
3173 :from :argument :to :result) fr1)
3174 (:results (y :scs (long-reg)))
3175 (:arg-types long-float)
3176 (:result-types long-float)
3177 (:policy :fast-safe)
3178 (:note "inline tan function")
3180 (:save-p :compute-only)
3182 (note-this-location vop :internal-error)
3191 (inst fldd (make-random-tn :kind :normal
3192 :sc (sc-or-lose 'double-reg)
3193 :offset (- (tn-offset x) 2)))))
3204 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3205 ;;; the argument is out of range 2^63 and would thus be hopelessly
3207 (macrolet ((frob (func trans op)
3208 `(define-vop (,func)
3210 (:args (x :scs (long-reg) :target fr0))
3211 (:temporary (:sc long-reg :offset fr0-offset
3212 :from :argument :to :result) fr0)
3213 (:temporary (:sc unsigned-reg :offset eax-offset
3214 :from :argument :to :result) eax)
3215 (:results (y :scs (long-reg)))
3216 (:arg-types long-float)
3217 (:result-types long-float)
3218 (:policy :fast-safe)
3219 (:note "inline sin/cos function")
3221 (:save-p :compute-only)
3224 (note-this-location vop :internal-error)
3225 (unless (zerop (tn-offset x))
3226 (inst fxch x) ; x to top of stack
3227 (unless (location= x y)
3228 (inst fst x))) ; maybe save it
3230 (inst fnstsw) ; status word to ax
3231 (inst and ah-tn #x04) ; C2
3233 ;; Else x was out of range so reduce it; ST0 is unchanged.
3234 (inst fstp fr0) ; Load 0.0
3237 (unless (zerop (tn-offset y))
3239 (frob fsin %sin fsin)
3240 (frob fcos %cos fcos))
3244 (:args (x :scs (long-reg) :target fr0))
3245 (:temporary (:sc long-reg :offset fr0-offset
3246 :from :argument :to :result) fr0)
3247 (:temporary (:sc long-reg :offset fr1-offset
3248 :from :argument :to :result) fr1)
3249 (:temporary (:sc unsigned-reg :offset eax-offset
3250 :from :argument :to :result) eax)
3251 (:results (y :scs (long-reg)))
3252 (:arg-types long-float)
3253 (:result-types long-float)
3255 (:policy :fast-safe)
3256 (:note "inline tan function")
3258 (:save-p :compute-only)
3261 (note-this-location vop :internal-error)
3270 (inst fldd (make-random-tn :kind :normal
3271 :sc (sc-or-lose 'double-reg)
3272 :offset (- (tn-offset x) 2)))))
3274 (inst fnstsw) ; status word to ax
3275 (inst and ah-tn #x04) ; C2
3277 ;; Else x was out of range so reduce it; ST0 is unchanged.
3278 (inst fldz) ; Load 0.0
3290 ;;; Modified exp that handles the following special cases:
3291 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3294 (:args (x :scs (long-reg) :target fr0))
3295 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
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 (:temporary (:sc long-reg :offset fr2-offset
3301 :from :argument :to :result) fr2)
3302 (:results (y :scs (long-reg)))
3303 (:arg-types long-float)
3304 (:result-types long-float)
3305 (:policy :fast-safe)
3306 (:note "inline exp function")
3308 (:save-p :compute-only)
3311 (note-this-location vop :internal-error)
3312 (unless (zerop (tn-offset x))
3313 (inst fxch x) ; x to top of stack
3314 (unless (location= x y)
3315 (inst fst x))) ; maybe save it
3316 ;; Check for Inf or NaN
3320 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3321 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3322 (inst and ah-tn #x02) ; Test sign of Inf.
3323 (inst jmp :z DONE) ; +Inf gives +Inf.
3324 (inst fstp fr0) ; -Inf gives 0
3326 (inst jmp-short DONE)
3331 ;; Now fr0=x log2(e)
3335 (inst fsubp-sti fr1)
3338 (inst faddp-sti fr1)
3342 (unless (zerop (tn-offset y))
3345 ;;; Expm1 = exp(x) - 1.
3346 ;;; Handles the following special cases:
3347 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3348 (define-vop (fexpm1)
3350 (:args (x :scs (long-reg) :target fr0))
3351 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3352 (:temporary (:sc long-reg :offset fr0-offset
3353 :from :argument :to :result) fr0)
3354 (:temporary (:sc long-reg :offset fr1-offset
3355 :from :argument :to :result) fr1)
3356 (:temporary (:sc long-reg :offset fr2-offset
3357 :from :argument :to :result) fr2)
3358 (:results (y :scs (long-reg)))
3359 (:arg-types long-float)
3360 (:result-types long-float)
3361 (:policy :fast-safe)
3362 (:note "inline expm1 function")
3364 (:save-p :compute-only)
3367 (note-this-location vop :internal-error)
3368 (unless (zerop (tn-offset x))
3369 (inst fxch x) ; x to top of stack
3370 (unless (location= x y)
3371 (inst fst x))) ; maybe save it
3372 ;; Check for Inf or NaN
3376 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3377 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3378 (inst and ah-tn #x02) ; Test sign of Inf.
3379 (inst jmp :z DONE) ; +Inf gives +Inf.
3380 (inst fstp fr0) ; -Inf gives -1.0
3383 (inst jmp-short DONE)
3385 ;; Free two stack slots leaving the argument on top.
3389 (inst fmul fr1) ; Now fr0 = x log2(e)
3404 (unless (zerop (tn-offset y))
3409 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3410 (:temporary (:sc long-reg :offset fr0-offset
3411 :from :argument :to :result) fr0)
3412 (:temporary (:sc long-reg :offset fr1-offset
3413 :from :argument :to :result) fr1)
3414 (:results (y :scs (long-reg)))
3415 (:arg-types long-float)
3416 (:result-types long-float)
3417 (:policy :fast-safe)
3418 (:note "inline log function")
3420 (:save-p :compute-only)
3422 (note-this-location vop :internal-error)
3437 ;; x is in a FP reg, not fr0 or fr1
3441 (inst fldd (make-random-tn :kind :normal
3442 :sc (sc-or-lose 'double-reg)
3443 :offset (1- (tn-offset x))))))
3445 ((long-stack descriptor-reg)
3449 (if (sc-is x long-stack)
3450 (inst fldl (ea-for-lf-stack x))
3451 (inst fldl (ea-for-lf-desc x)))
3456 (t (inst fstd y)))))
3458 (define-vop (flog10)
3460 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3461 (:temporary (:sc long-reg :offset fr0-offset
3462 :from :argument :to :result) fr0)
3463 (:temporary (:sc long-reg :offset fr1-offset
3464 :from :argument :to :result) fr1)
3465 (:results (y :scs (long-reg)))
3466 (:arg-types long-float)
3467 (:result-types long-float)
3468 (:policy :fast-safe)
3469 (:note "inline log10 function")
3471 (:save-p :compute-only)
3473 (note-this-location vop :internal-error)
3488 ;; x is in a FP reg, not fr0 or fr1
3492 (inst fldd (make-random-tn :kind :normal
3493 :sc (sc-or-lose 'double-reg)
3494 :offset (1- (tn-offset x))))))
3496 ((long-stack descriptor-reg)
3500 (if (sc-is x long-stack)
3501 (inst fldl (ea-for-lf-stack x))
3502 (inst fldl (ea-for-lf-desc x)))
3507 (t (inst fstd y)))))
3511 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3512 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3513 (:temporary (:sc long-reg :offset fr0-offset
3514 :from (:argument 0) :to :result) fr0)
3515 (:temporary (:sc long-reg :offset fr1-offset
3516 :from (:argument 1) :to :result) fr1)
3517 (:temporary (:sc long-reg :offset fr2-offset
3518 :from :load :to :result) fr2)
3519 (:results (r :scs (long-reg)))
3520 (:arg-types long-float long-float)
3521 (:result-types long-float)
3522 (:policy :fast-safe)
3523 (:note "inline pow function")
3525 (:save-p :compute-only)
3527 (note-this-location vop :internal-error)
3528 ;; Setup x in fr0 and y in fr1
3530 ;; x in fr0; y in fr1
3531 ((and (sc-is x long-reg) (zerop (tn-offset x))
3532 (sc-is y long-reg) (= 1 (tn-offset y))))
3533 ;; y in fr1; x not in fr0
3534 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3538 (copy-fp-reg-to-fr0 x))
3541 (inst fldl (ea-for-lf-stack x)))
3544 (inst fldl (ea-for-lf-desc x)))))
3545 ;; x in fr0; y not in fr1
3546 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3548 ;; Now load y to fr0
3551 (copy-fp-reg-to-fr0 y))
3554 (inst fldl (ea-for-lf-stack y)))
3557 (inst fldl (ea-for-lf-desc y))))
3559 ;; x in fr1; y not in fr1
3560 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3564 (copy-fp-reg-to-fr0 y))
3567 (inst fldl (ea-for-lf-stack y)))
3570 (inst fldl (ea-for-lf-desc y))))
3573 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3575 ;; Now load x to fr0
3578 (copy-fp-reg-to-fr0 x))
3581 (inst fldl (ea-for-lf-stack x)))
3584 (inst fldl (ea-for-lf-desc x)))))
3585 ;; Neither x or y are in either fr0 or fr1
3592 (inst fldd (make-random-tn :kind :normal
3593 :sc (sc-or-lose 'double-reg)
3594 :offset (- (tn-offset y) 2))))
3596 (inst fldl (ea-for-lf-stack y)))
3598 (inst fldl (ea-for-lf-desc y))))
3602 (inst fldd (make-random-tn :kind :normal
3603 :sc (sc-or-lose 'double-reg)
3604 :offset (1- (tn-offset x)))))
3606 (inst fldl (ea-for-lf-stack x)))
3608 (inst fldl (ea-for-lf-desc x))))))
3610 ;; Now have x at fr0; and y at fr1
3612 ;; Now fr0=y log2(x)
3616 (inst fsubp-sti fr1)
3619 (inst faddp-sti fr1)
3624 (t (inst fstd r)))))
3626 (define-vop (fscalen)
3627 (:translate %scalbn)
3628 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3629 (y :scs (signed-stack signed-reg) :target temp))
3630 (:temporary (:sc long-reg :offset fr0-offset
3631 :from (:argument 0) :to :result) fr0)
3632 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3633 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3634 (:results (r :scs (long-reg)))
3635 (:arg-types long-float signed-num)
3636 (:result-types long-float)
3637 (:policy :fast-safe)
3638 (:note "inline scalbn function")
3640 ;; Setup x in fr0 and y in fr1
3671 (inst fld (make-random-tn :kind :normal
3672 :sc (sc-or-lose 'double-reg)
3673 :offset (1- (tn-offset x)))))))
3674 ((long-stack descriptor-reg)
3683 (if (sc-is x long-stack)
3684 (inst fldl (ea-for-lf-stack x))
3685 (inst fldl (ea-for-lf-desc x)))))
3687 (unless (zerop (tn-offset r))
3690 (define-vop (fscale)
3692 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3693 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3694 (:temporary (:sc long-reg :offset fr0-offset
3695 :from (:argument 0) :to :result) fr0)
3696 (:temporary (:sc long-reg :offset fr1-offset
3697 :from (:argument 1) :to :result) fr1)
3698 (:results (r :scs (long-reg)))
3699 (:arg-types long-float long-float)
3700 (:result-types long-float)
3701 (:policy :fast-safe)
3702 (:note "inline scalb function")
3704 (:save-p :compute-only)
3706 (note-this-location vop :internal-error)
3707 ;; Setup x in fr0 and y in fr1
3709 ;; x in fr0; y in fr1
3710 ((and (sc-is x long-reg) (zerop (tn-offset x))
3711 (sc-is y long-reg) (= 1 (tn-offset y))))
3712 ;; y in fr1; x not in fr0
3713 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3717 (copy-fp-reg-to-fr0 x))
3720 (inst fldl (ea-for-lf-stack x)))
3723 (inst fldl (ea-for-lf-desc x)))))
3724 ;; x in fr0; y not in fr1
3725 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3727 ;; Now load y to fr0
3730 (copy-fp-reg-to-fr0 y))
3733 (inst fldl (ea-for-lf-stack y)))
3736 (inst fldl (ea-for-lf-desc y))))
3738 ;; x in fr1; y not in fr1
3739 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3743 (copy-fp-reg-to-fr0 y))
3746 (inst fldl (ea-for-lf-stack y)))
3749 (inst fldl (ea-for-lf-desc y))))
3752 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3754 ;; Now load x to fr0
3757 (copy-fp-reg-to-fr0 x))
3760 (inst fldl (ea-for-lf-stack x)))
3763 (inst fldl (ea-for-lf-desc x)))))
3764 ;; Neither x or y are in either fr0 or fr1
3771 (inst fldd (make-random-tn :kind :normal
3772 :sc (sc-or-lose 'double-reg)
3773 :offset (- (tn-offset y) 2))))
3775 (inst fldl (ea-for-lf-stack y)))
3777 (inst fldl (ea-for-lf-desc y))))
3781 (inst fldd (make-random-tn :kind :normal
3782 :sc (sc-or-lose 'double-reg)
3783 :offset (1- (tn-offset x)))))
3785 (inst fldl (ea-for-lf-stack x)))
3787 (inst fldl (ea-for-lf-desc x))))))
3789 ;; Now have x at fr0; and y at fr1
3791 (unless (zerop (tn-offset r))
3794 (define-vop (flog1p)
3796 (:args (x :scs (long-reg) :to :result))
3797 (:temporary (:sc long-reg :offset fr0-offset
3798 :from :argument :to :result) fr0)
3799 (:temporary (:sc long-reg :offset fr1-offset
3800 :from :argument :to :result) fr1)
3801 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3802 (:results (y :scs (long-reg)))
3803 (:arg-types long-float)
3804 (:result-types long-float)
3805 (:policy :fast-safe)
3806 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3807 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3808 ;; an enormous PROGN above. Still, it would be probably be good to
3809 ;; add some code to warn about redefining VOPs.
3810 (:note "inline log1p function")
3813 ;; x is in a FP reg, not fr0, fr1.
3816 (inst fldd (make-random-tn :kind :normal
3817 :sc (sc-or-lose 'double-reg)
3818 :offset (- (tn-offset x) 2)))
3820 (inst push #x3e947ae1) ; Constant 0.29
3822 (inst fld (make-ea :dword :base esp-tn))
3825 (inst fnstsw) ; status word to ax
3826 (inst and ah-tn #x45)
3827 (inst jmp :z WITHIN-RANGE)
3828 ;; Out of range for fyl2xp1.
3830 (inst faddd (make-random-tn :kind :normal
3831 :sc (sc-or-lose 'double-reg)
3832 :offset (- (tn-offset x) 1)))
3840 (inst fldd (make-random-tn :kind :normal
3841 :sc (sc-or-lose 'double-reg)
3842 :offset (- (tn-offset x) 1)))
3848 (t (inst fstd y)))))
3850 ;;; The Pentium has a less restricted implementation of the fyl2xp1
3851 ;;; instruction and a range check can be avoided.
3852 (define-vop (flog1p-pentium)
3854 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3855 (:temporary (:sc long-reg :offset fr0-offset
3856 :from :argument :to :result) fr0)
3857 (:temporary (:sc long-reg :offset fr1-offset
3858 :from :argument :to :result) fr1)
3859 (:results (y :scs (long-reg)))
3860 (:arg-types long-float)
3861 (:result-types long-float)
3862 (:policy :fast-safe)
3863 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
3864 (:note "inline log1p function")
3880 ;; x is in a FP reg, not fr0 or fr1
3884 (inst fldd (make-random-tn :kind :normal
3885 :sc (sc-or-lose 'double-reg)
3886 :offset (1- (tn-offset x)))))))
3887 ((long-stack descriptor-reg)
3891 (if (sc-is x long-stack)
3892 (inst fldl (ea-for-lf-stack x))
3893 (inst fldl (ea-for-lf-desc x)))))
3898 (t (inst fstd y)))))
3902 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3903 (:temporary (:sc long-reg :offset fr0-offset
3904 :from :argument :to :result) fr0)
3905 (:temporary (:sc long-reg :offset fr1-offset
3906 :from :argument :to :result) fr1)
3907 (:results (y :scs (long-reg)))
3908 (:arg-types long-float)
3909 (:result-types long-float)
3910 (:policy :fast-safe)
3911 (:note "inline logb function")
3913 (:save-p :compute-only)
3915 (note-this-location vop :internal-error)
3926 ;; x is in a FP reg, not fr0 or fr1
3929 (inst fldd (make-random-tn :kind :normal
3930 :sc (sc-or-lose 'double-reg)
3931 :offset (- (tn-offset x) 2))))))
3932 ((long-stack descriptor-reg)
3935 (if (sc-is x long-stack)
3936 (inst fldl (ea-for-lf-stack x))
3937 (inst fldl (ea-for-lf-desc x)))))
3948 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3949 (:temporary (:sc long-reg :offset fr0-offset
3950 :from (:argument 0) :to :result) fr0)
3951 (:temporary (:sc long-reg :offset fr1-offset
3952 :from (:argument 0) :to :result) fr1)
3953 (:results (r :scs (long-reg)))
3954 (:arg-types long-float)
3955 (:result-types long-float)
3956 (:policy :fast-safe)
3957 (:note "inline atan function")
3959 (:save-p :compute-only)
3961 (note-this-location vop :internal-error)
3962 ;; Setup x in fr1 and 1.0 in fr0
3965 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3968 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3970 ;; x not in fr0 or fr1
3977 (inst fldd (make-random-tn :kind :normal
3978 :sc (sc-or-lose 'double-reg)
3979 :offset (- (tn-offset x) 2))))
3981 (inst fldl (ea-for-lf-stack x)))
3983 (inst fldl (ea-for-lf-desc x))))))
3985 ;; Now have x at fr1; and 1.0 at fr0
3990 (t (inst fstd r)))))
3992 (define-vop (fatan2)
3994 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
3995 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
3996 (:temporary (:sc long-reg :offset fr0-offset
3997 :from (:argument 1) :to :result) fr0)
3998 (:temporary (:sc long-reg :offset fr1-offset
3999 :from (:argument 0) :to :result) fr1)
4000 (:results (r :scs (long-reg)))
4001 (:arg-types long-float long-float)
4002 (:result-types long-float)
4003 (:policy :fast-safe)
4004 (:note "inline atan2 function")
4006 (:save-p :compute-only)
4008 (note-this-location vop :internal-error)
4009 ;; Setup x in fr1 and y in fr0
4011 ;; y in fr0; x in fr1
4012 ((and (sc-is y long-reg) (zerop (tn-offset y))
4013 (sc-is x long-reg) (= 1 (tn-offset x))))
4014 ;; x in fr1; y not in fr0
4015 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4019 (copy-fp-reg-to-fr0 y))
4022 (inst fldl (ea-for-lf-stack y)))
4025 (inst fldl (ea-for-lf-desc y)))))
4026 ;; y in fr0; x not in fr1
4027 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4029 ;; Now load x to fr0
4032 (copy-fp-reg-to-fr0 x))
4035 (inst fldl (ea-for-lf-stack x)))
4038 (inst fldl (ea-for-lf-desc x))))
4040 ;; y in fr1; x not in fr1
4041 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4045 (copy-fp-reg-to-fr0 x))
4048 (inst fldl (ea-for-lf-stack x)))
4051 (inst fldl (ea-for-lf-desc x))))
4054 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4056 ;; Now load y to fr0
4059 (copy-fp-reg-to-fr0 y))
4062 (inst fldl (ea-for-lf-stack y)))
4065 (inst fldl (ea-for-lf-desc y)))))
4066 ;; Neither y or x are in either fr0 or fr1
4073 (inst fldd (make-random-tn :kind :normal
4074 :sc (sc-or-lose 'double-reg)
4075 :offset (- (tn-offset x) 2))))
4077 (inst fldl (ea-for-lf-stack x)))
4079 (inst fldl (ea-for-lf-desc x))))
4083 (inst fldd (make-random-tn :kind :normal
4084 :sc (sc-or-lose 'double-reg)
4085 :offset (1- (tn-offset y)))))
4087 (inst fldl (ea-for-lf-stack y)))
4089 (inst fldl (ea-for-lf-desc y))))))
4091 ;; Now have y at fr0; and x at fr1
4096 (t (inst fstd r)))))
4098 ) ; PROGN #!+LONG-FLOAT
4100 ;;;; complex float VOPs
4102 (define-vop (make-complex-single-float)
4103 (:translate complex)
4104 (:args (real :scs (single-reg) :to :result :target r
4105 :load-if (not (location= real r)))
4106 (imag :scs (single-reg) :to :save))
4107 (:arg-types single-float single-float)
4108 (:results (r :scs (complex-single-reg) :from (:argument 0)
4109 :load-if (not (sc-is r complex-single-stack))))
4110 (:result-types complex-single-float)
4111 (:note "inline complex single-float creation")
4112 (:policy :fast-safe)
4116 (let ((r-real (complex-double-reg-real-tn r)))
4117 (unless (location= real r-real)
4118 (cond ((zerop (tn-offset r-real))
4119 (copy-fp-reg-to-fr0 real))
4120 ((zerop (tn-offset real))
4125 (inst fxch real)))))
4126 (let ((r-imag (complex-double-reg-imag-tn r)))
4127 (unless (location= imag r-imag)
4128 (cond ((zerop (tn-offset imag))
4133 (inst fxch imag))))))
4134 (complex-single-stack
4135 (unless (location= real r)
4136 (cond ((zerop (tn-offset real))
4137 (inst fst (ea-for-csf-real-stack r)))
4140 (inst fst (ea-for-csf-real-stack r))
4143 (inst fst (ea-for-csf-imag-stack r))
4144 (inst fxch imag)))))
4146 (define-vop (make-complex-double-float)
4147 (:translate complex)
4148 (:args (real :scs (double-reg) :target r
4149 :load-if (not (location= real r)))
4150 (imag :scs (double-reg) :to :save))
4151 (:arg-types double-float double-float)
4152 (:results (r :scs (complex-double-reg) :from (:argument 0)
4153 :load-if (not (sc-is r complex-double-stack))))
4154 (:result-types complex-double-float)
4155 (:note "inline complex double-float creation")
4156 (:policy :fast-safe)
4160 (let ((r-real (complex-double-reg-real-tn r)))
4161 (unless (location= real r-real)
4162 (cond ((zerop (tn-offset r-real))
4163 (copy-fp-reg-to-fr0 real))
4164 ((zerop (tn-offset real))
4169 (inst fxch real)))))
4170 (let ((r-imag (complex-double-reg-imag-tn r)))
4171 (unless (location= imag r-imag)
4172 (cond ((zerop (tn-offset imag))
4177 (inst fxch imag))))))
4178 (complex-double-stack
4179 (unless (location= real r)
4180 (cond ((zerop (tn-offset real))
4181 (inst fstd (ea-for-cdf-real-stack r)))
4184 (inst fstd (ea-for-cdf-real-stack r))
4187 (inst fstd (ea-for-cdf-imag-stack r))
4188 (inst fxch imag)))))
4191 (define-vop (make-complex-long-float)
4192 (:translate complex)
4193 (:args (real :scs (long-reg) :target r
4194 :load-if (not (location= real r)))
4195 (imag :scs (long-reg) :to :save))
4196 (:arg-types long-float long-float)
4197 (:results (r :scs (complex-long-reg) :from (:argument 0)
4198 :load-if (not (sc-is r complex-long-stack))))
4199 (:result-types complex-long-float)
4200 (:note "inline complex long-float creation")
4201 (:policy :fast-safe)
4205 (let ((r-real (complex-double-reg-real-tn r)))
4206 (unless (location= real r-real)
4207 (cond ((zerop (tn-offset r-real))
4208 (copy-fp-reg-to-fr0 real))
4209 ((zerop (tn-offset real))
4214 (inst fxch real)))))
4215 (let ((r-imag (complex-double-reg-imag-tn r)))
4216 (unless (location= imag r-imag)
4217 (cond ((zerop (tn-offset imag))
4222 (inst fxch imag))))))
4224 (unless (location= real r)
4225 (cond ((zerop (tn-offset real))
4226 (store-long-float (ea-for-clf-real-stack r)))
4229 (store-long-float (ea-for-clf-real-stack r))
4232 (store-long-float (ea-for-clf-imag-stack r))
4233 (inst fxch imag)))))
4236 (define-vop (complex-float-value)
4237 (:args (x :target r))
4239 (:variant-vars offset)
4240 (:policy :fast-safe)
4242 (cond ((sc-is x complex-single-reg complex-double-reg
4243 #!+long-float complex-long-reg)
4245 (make-random-tn :kind :normal
4246 :sc (sc-or-lose 'double-reg)
4247 :offset (+ offset (tn-offset x)))))
4248 (unless (location= value-tn r)
4249 (cond ((zerop (tn-offset r))
4250 (copy-fp-reg-to-fr0 value-tn))
4251 ((zerop (tn-offset value-tn))
4254 (inst fxch value-tn)
4256 (inst fxch value-tn))))))
4257 ((sc-is r single-reg)
4258 (let ((ea (sc-case x
4259 (complex-single-stack
4261 (0 (ea-for-csf-real-stack x))
4262 (1 (ea-for-csf-imag-stack x))))
4265 (0 (ea-for-csf-real-desc x))
4266 (1 (ea-for-csf-imag-desc x)))))))
4267 (with-empty-tn@fp-top(r)
4269 ((sc-is r double-reg)
4270 (let ((ea (sc-case x
4271 (complex-double-stack
4273 (0 (ea-for-cdf-real-stack x))
4274 (1 (ea-for-cdf-imag-stack x))))
4277 (0 (ea-for-cdf-real-desc x))
4278 (1 (ea-for-cdf-imag-desc x)))))))
4279 (with-empty-tn@fp-top(r)
4283 (let ((ea (sc-case x
4286 (0 (ea-for-clf-real-stack x))
4287 (1 (ea-for-clf-imag-stack x))))
4290 (0 (ea-for-clf-real-desc x))
4291 (1 (ea-for-clf-imag-desc x)))))))
4292 (with-empty-tn@fp-top(r)
4294 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4296 (define-vop (realpart/complex-single-float complex-float-value)
4297 (:translate realpart)
4298 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4300 (:arg-types complex-single-float)
4301 (:results (r :scs (single-reg)))
4302 (:result-types single-float)
4303 (:note "complex float realpart")
4306 (define-vop (realpart/complex-double-float complex-float-value)
4307 (:translate realpart)
4308 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4310 (:arg-types complex-double-float)
4311 (:results (r :scs (double-reg)))
4312 (:result-types double-float)
4313 (:note "complex float realpart")
4317 (define-vop (realpart/complex-long-float complex-float-value)
4318 (:translate realpart)
4319 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4321 (:arg-types complex-long-float)
4322 (:results (r :scs (long-reg)))
4323 (:result-types long-float)
4324 (:note "complex float realpart")
4327 (define-vop (imagpart/complex-single-float complex-float-value)
4328 (:translate imagpart)
4329 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4331 (:arg-types complex-single-float)
4332 (:results (r :scs (single-reg)))
4333 (:result-types single-float)
4334 (:note "complex float imagpart")
4337 (define-vop (imagpart/complex-double-float complex-float-value)
4338 (:translate imagpart)
4339 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4341 (:arg-types complex-double-float)
4342 (:results (r :scs (double-reg)))
4343 (:result-types double-float)
4344 (:note "complex float imagpart")
4348 (define-vop (imagpart/complex-long-float complex-float-value)
4349 (:translate imagpart)
4350 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4352 (:arg-types complex-long-float)
4353 (:results (r :scs (long-reg)))
4354 (:result-types long-float)
4355 (:note "complex float imagpart")
4358 ;;; hack dummy VOPs to bias the representation selection of their
4359 ;;; arguments towards a FP register, which can help avoid consing at
4360 ;;; inappropriate locations
4361 (defknown double-float-reg-bias (double-float) (values))
4362 (define-vop (double-float-reg-bias)
4363 (:translate double-float-reg-bias)
4364 (:args (x :scs (double-reg double-stack) :load-if nil))
4365 (:arg-types double-float)
4366 (:policy :fast-safe)
4367 (:note "inline dummy FP register bias")
4370 (defknown single-float-reg-bias (single-float) (values))
4371 (define-vop (single-float-reg-bias)
4372 (:translate single-float-reg-bias)
4373 (:args (x :scs (single-reg single-stack) :load-if nil))
4374 (:arg-types single-float)
4375 (:policy :fast-safe)
4376 (:note "inline dummy FP register bias")