1 ;;;; floating point support for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (macrolet ((ea-for-xf-desc (tn slot)
17 :disp (- (* ,slot n-word-bytes)
18 other-pointer-lowtag))))
19 (defun ea-for-sf-desc (tn)
20 (ea-for-xf-desc tn single-float-value-slot))
21 (defun ea-for-df-desc (tn)
22 (ea-for-xf-desc tn double-float-value-slot))
24 (defun ea-for-lf-desc (tn)
25 (ea-for-xf-desc tn long-float-value-slot))
27 (defun ea-for-csf-real-desc (tn)
28 (ea-for-xf-desc tn complex-single-float-real-slot))
29 (defun ea-for-csf-imag-desc (tn)
30 (ea-for-xf-desc tn complex-single-float-imag-slot))
31 (defun ea-for-cdf-real-desc (tn)
32 (ea-for-xf-desc tn complex-double-float-real-slot))
33 (defun ea-for-cdf-imag-desc (tn)
34 (ea-for-xf-desc tn complex-double-float-imag-slot))
36 (defun ea-for-clf-real-desc (tn)
37 (ea-for-xf-desc tn complex-long-float-real-slot))
39 (defun ea-for-clf-imag-desc (tn)
40 (ea-for-xf-desc tn complex-long-float-imag-slot)))
42 (macrolet ((ea-for-xf-stack (tn kind)
45 :disp (- (* (+ (tn-offset ,tn)
46 (ecase ,kind (:single 1) (:double 2) (:long 3)))
48 (defun ea-for-sf-stack (tn)
49 (ea-for-xf-stack tn :single))
50 (defun ea-for-df-stack (tn)
51 (ea-for-xf-stack tn :double))
53 (defun ea-for-lf-stack (tn)
54 (ea-for-xf-stack tn :long)))
56 ;;; Telling the FPU to wait is required in order to make signals occur
57 ;;; at the expected place, but naturally slows things down.
59 ;;; NODE is the node whose compilation policy controls the decision
60 ;;; whether to just blast through carelessly or carefully emit wait
61 ;;; instructions and whatnot.
63 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
64 ;;; #'NOTE-NEXT-INSTRUCTION.
66 ;;; Until 2004-03-15, the implementation of this was buggy; it
67 ;;; unconditionally emitted the WAIT instruction. It turns out that
68 ;;; this is the right thing to do anyway; omitting them can lead to
69 ;;; system corruption on conforming code. -- CSR
70 (defun maybe-fp-wait (node &optional note-next-instruction)
72 (when (policy node (or (= debug 3) (> safety speed))))
73 (when note-next-instruction
74 (note-next-instruction note-next-instruction :internal-error))
77 ;;; complex float stack EAs
78 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
81 :disp (- (* (+ (tn-offset ,tn)
86 (ecase ,slot (:real 1) (:imag 2))))
88 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
89 (ea-for-cxf-stack tn :single :real base))
90 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
91 (ea-for-cxf-stack tn :single :imag base))
92 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
93 (ea-for-cxf-stack tn :double :real base))
94 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
95 (ea-for-cxf-stack tn :double :imag base))
97 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
98 (ea-for-cxf-stack tn :long :real base))
100 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
101 (ea-for-cxf-stack tn :long :imag base)))
103 ;;; Abstract out the copying of a FP register to the FP stack top, and
104 ;;; provide two alternatives for its implementation. Note: it's not
105 ;;; necessary to distinguish between a single or double register move
108 ;;; Using a Pop then load.
109 (defun copy-fp-reg-to-fr0 (reg)
110 (aver (not (zerop (tn-offset reg))))
112 (inst fld (make-random-tn :kind :normal
113 :sc (sc-or-lose 'double-reg)
114 :offset (1- (tn-offset reg)))))
115 ;;; Using Fxch then Fst to restore the original reg contents.
117 (defun copy-fp-reg-to-fr0 (reg)
118 (aver (not (zerop (tn-offset reg))))
122 ;;; The x86 can't store a long-float to memory without popping the
123 ;;; stack and marking a register as empty, so it is necessary to
124 ;;; restore the register from memory.
126 (defun store-long-float (ea)
132 ;;; X is source, Y is destination.
133 (define-move-fun (load-single 2) (vop x y)
134 ((single-stack) (single-reg))
135 (with-empty-tn@fp-top(y)
136 (inst fld (ea-for-sf-stack x))))
138 (define-move-fun (store-single 2) (vop x y)
139 ((single-reg) (single-stack))
140 (cond ((zerop (tn-offset x))
141 (inst fst (ea-for-sf-stack y)))
144 (inst fst (ea-for-sf-stack y))
145 ;; This may not be necessary as ST0 is likely invalid now.
148 (define-move-fun (load-double 2) (vop x y)
149 ((double-stack) (double-reg))
150 (with-empty-tn@fp-top(y)
151 (inst fldd (ea-for-df-stack x))))
153 (define-move-fun (store-double 2) (vop x y)
154 ((double-reg) (double-stack))
155 (cond ((zerop (tn-offset x))
156 (inst fstd (ea-for-df-stack y)))
159 (inst fstd (ea-for-df-stack y))
160 ;; This may not be necessary as ST0 is likely invalid now.
164 (define-move-fun (load-long 2) (vop x y)
165 ((long-stack) (long-reg))
166 (with-empty-tn@fp-top(y)
167 (inst fldl (ea-for-lf-stack x))))
170 (define-move-fun (store-long 2) (vop x y)
171 ((long-reg) (long-stack))
172 (cond ((zerop (tn-offset x))
173 (store-long-float (ea-for-lf-stack y)))
176 (store-long-float (ea-for-lf-stack y))
177 ;; This may not be necessary as ST0 is likely invalid now.
180 ;;; The i387 has instructions to load some useful constants. This
181 ;;; doesn't save much time but might cut down on memory access and
182 ;;; reduce the size of the constant vector (CV). Intel claims they are
183 ;;; stored in a more precise form on chip. Anyhow, might as well use
184 ;;; the feature. It can be turned off by hacking the
185 ;;; "immediate-constant-sc" in vm.lisp.
186 (eval-when (:compile-toplevel :execute)
187 (setf *read-default-float-format*
188 #!+long-float 'long-float #!-long-float 'double-float))
189 (define-move-fun (load-fp-constant 2) (vop x y)
190 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
191 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
192 (with-empty-tn@fp-top(y)
197 ((= value (coerce pi *read-default-float-format*))
199 ((= value (log 10e0 2e0))
201 ((= value (log 2.718281828459045235360287471352662e0 2e0))
203 ((= value (log 2e0 10e0))
205 ((= value (log 2e0 2.718281828459045235360287471352662e0))
207 (t (warn "ignoring bogus i387 constant ~A" value))))))
208 (eval-when (:compile-toplevel :execute)
209 (setf *read-default-float-format* 'single-float))
211 ;;;; complex float move functions
213 (defun complex-single-reg-real-tn (x)
214 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
215 :offset (tn-offset x)))
216 (defun complex-single-reg-imag-tn (x)
217 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
218 :offset (1+ (tn-offset x))))
220 (defun complex-double-reg-real-tn (x)
221 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
222 :offset (tn-offset x)))
223 (defun complex-double-reg-imag-tn (x)
224 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
225 :offset (1+ (tn-offset x))))
228 (defun complex-long-reg-real-tn (x)
229 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
230 :offset (tn-offset x)))
232 (defun complex-long-reg-imag-tn (x)
233 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
234 :offset (1+ (tn-offset x))))
236 ;;; X is source, Y is destination.
237 (define-move-fun (load-complex-single 2) (vop x y)
238 ((complex-single-stack) (complex-single-reg))
239 (let ((real-tn (complex-single-reg-real-tn y)))
240 (with-empty-tn@fp-top (real-tn)
241 (inst fld (ea-for-csf-real-stack x))))
242 (let ((imag-tn (complex-single-reg-imag-tn y)))
243 (with-empty-tn@fp-top (imag-tn)
244 (inst fld (ea-for-csf-imag-stack x)))))
246 (define-move-fun (store-complex-single 2) (vop x y)
247 ((complex-single-reg) (complex-single-stack))
248 (let ((real-tn (complex-single-reg-real-tn x)))
249 (cond ((zerop (tn-offset real-tn))
250 (inst fst (ea-for-csf-real-stack y)))
253 (inst fst (ea-for-csf-real-stack y))
254 (inst fxch real-tn))))
255 (let ((imag-tn (complex-single-reg-imag-tn x)))
257 (inst fst (ea-for-csf-imag-stack y))
258 (inst fxch imag-tn)))
260 (define-move-fun (load-complex-double 2) (vop x y)
261 ((complex-double-stack) (complex-double-reg))
262 (let ((real-tn (complex-double-reg-real-tn y)))
263 (with-empty-tn@fp-top(real-tn)
264 (inst fldd (ea-for-cdf-real-stack x))))
265 (let ((imag-tn (complex-double-reg-imag-tn y)))
266 (with-empty-tn@fp-top(imag-tn)
267 (inst fldd (ea-for-cdf-imag-stack x)))))
269 (define-move-fun (store-complex-double 2) (vop x y)
270 ((complex-double-reg) (complex-double-stack))
271 (let ((real-tn (complex-double-reg-real-tn x)))
272 (cond ((zerop (tn-offset real-tn))
273 (inst fstd (ea-for-cdf-real-stack y)))
276 (inst fstd (ea-for-cdf-real-stack y))
277 (inst fxch real-tn))))
278 (let ((imag-tn (complex-double-reg-imag-tn x)))
280 (inst fstd (ea-for-cdf-imag-stack y))
281 (inst fxch imag-tn)))
284 (define-move-fun (load-complex-long 2) (vop x y)
285 ((complex-long-stack) (complex-long-reg))
286 (let ((real-tn (complex-long-reg-real-tn y)))
287 (with-empty-tn@fp-top(real-tn)
288 (inst fldl (ea-for-clf-real-stack x))))
289 (let ((imag-tn (complex-long-reg-imag-tn y)))
290 (with-empty-tn@fp-top(imag-tn)
291 (inst fldl (ea-for-clf-imag-stack x)))))
294 (define-move-fun (store-complex-long 2) (vop x y)
295 ((complex-long-reg) (complex-long-stack))
296 (let ((real-tn (complex-long-reg-real-tn x)))
297 (cond ((zerop (tn-offset real-tn))
298 (store-long-float (ea-for-clf-real-stack y)))
301 (store-long-float (ea-for-clf-real-stack y))
302 (inst fxch real-tn))))
303 (let ((imag-tn (complex-long-reg-imag-tn x)))
305 (store-long-float (ea-for-clf-imag-stack y))
306 (inst fxch imag-tn)))
311 ;;; float register to register moves
312 (define-vop (float-move)
317 (unless (location= x y)
318 (cond ((zerop (tn-offset y))
319 (copy-fp-reg-to-fr0 x))
320 ((zerop (tn-offset x))
327 (define-vop (single-move float-move)
328 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
329 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
330 (define-move-vop single-move :move (single-reg) (single-reg))
332 (define-vop (double-move float-move)
333 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
334 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
335 (define-move-vop double-move :move (double-reg) (double-reg))
338 (define-vop (long-move float-move)
339 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
340 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
342 (define-move-vop long-move :move (long-reg) (long-reg))
344 ;;; complex float register to register moves
345 (define-vop (complex-float-move)
346 (:args (x :target y :load-if (not (location= x y))))
347 (:results (y :load-if (not (location= x y))))
348 (:note "complex float move")
350 (unless (location= x y)
351 ;; Note the complex-float-regs are aligned to every second
352 ;; float register so there is not need to worry about overlap.
353 (let ((x-real (complex-double-reg-real-tn x))
354 (y-real (complex-double-reg-real-tn y)))
355 (cond ((zerop (tn-offset y-real))
356 (copy-fp-reg-to-fr0 x-real))
357 ((zerop (tn-offset x-real))
362 (inst fxch x-real))))
363 (let ((x-imag (complex-double-reg-imag-tn x))
364 (y-imag (complex-double-reg-imag-tn y)))
367 (inst fxch x-imag)))))
369 (define-vop (complex-single-move complex-float-move)
370 (:args (x :scs (complex-single-reg) :target y
371 :load-if (not (location= x y))))
372 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
373 (define-move-vop complex-single-move :move
374 (complex-single-reg) (complex-single-reg))
376 (define-vop (complex-double-move complex-float-move)
377 (:args (x :scs (complex-double-reg)
378 :target y :load-if (not (location= x y))))
379 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
380 (define-move-vop complex-double-move :move
381 (complex-double-reg) (complex-double-reg))
384 (define-vop (complex-long-move complex-float-move)
385 (:args (x :scs (complex-long-reg)
386 :target y :load-if (not (location= x y))))
387 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
389 (define-move-vop complex-long-move :move
390 (complex-long-reg) (complex-long-reg))
392 ;;; Move from float to a descriptor reg. allocating a new float
393 ;;; object in the process.
394 (define-vop (move-from-single)
395 (:args (x :scs (single-reg) :to :save))
396 (:results (y :scs (descriptor-reg)))
398 (:note "float to pointer coercion")
400 (with-fixed-allocation (y
402 single-float-size node)
404 (inst fst (ea-for-sf-desc y))))))
405 (define-move-vop move-from-single :move
406 (single-reg) (descriptor-reg))
408 (define-vop (move-from-double)
409 (:args (x :scs (double-reg) :to :save))
410 (:results (y :scs (descriptor-reg)))
412 (:note "float to pointer coercion")
414 (with-fixed-allocation (y
419 (inst fstd (ea-for-df-desc y))))))
420 (define-move-vop move-from-double :move
421 (double-reg) (descriptor-reg))
424 (define-vop (move-from-long)
425 (:args (x :scs (long-reg) :to :save))
426 (:results (y :scs (descriptor-reg)))
428 (:note "float to pointer coercion")
430 (with-fixed-allocation (y
435 (store-long-float (ea-for-lf-desc y))))))
437 (define-move-vop move-from-long :move
438 (long-reg) (descriptor-reg))
440 (define-vop (move-from-fp-constant)
441 (:args (x :scs (fp-constant)))
442 (:results (y :scs (descriptor-reg)))
444 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
445 (0f0 (load-symbol-value y *fp-constant-0f0*))
446 (1f0 (load-symbol-value y *fp-constant-1f0*))
447 (0d0 (load-symbol-value y *fp-constant-0d0*))
448 (1d0 (load-symbol-value y *fp-constant-1d0*))
450 (0l0 (load-symbol-value y *fp-constant-0l0*))
452 (1l0 (load-symbol-value y *fp-constant-1l0*))
454 (#.pi (load-symbol-value y *fp-constant-pi*))
456 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
458 (#.(log 2.718281828459045235360287471352662L0 2l0)
459 (load-symbol-value y *fp-constant-l2e*))
461 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
463 (#.(log 2l0 2.718281828459045235360287471352662L0)
464 (load-symbol-value y *fp-constant-ln2*)))))
465 (define-move-vop move-from-fp-constant :move
466 (fp-constant) (descriptor-reg))
468 ;;; Move from a descriptor to a float register.
469 (define-vop (move-to-single)
470 (:args (x :scs (descriptor-reg)))
471 (:results (y :scs (single-reg)))
472 (:note "pointer to float coercion")
474 (with-empty-tn@fp-top(y)
475 (inst fld (ea-for-sf-desc x)))))
476 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
478 (define-vop (move-to-double)
479 (:args (x :scs (descriptor-reg)))
480 (:results (y :scs (double-reg)))
481 (:note "pointer to float coercion")
483 (with-empty-tn@fp-top(y)
484 (inst fldd (ea-for-df-desc x)))))
485 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
488 (define-vop (move-to-long)
489 (:args (x :scs (descriptor-reg)))
490 (:results (y :scs (long-reg)))
491 (:note "pointer to float coercion")
493 (with-empty-tn@fp-top(y)
494 (inst fldl (ea-for-lf-desc x)))))
496 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
498 ;;; Move from complex float to a descriptor reg. allocating a new
499 ;;; complex float object in the process.
500 (define-vop (move-from-complex-single)
501 (:args (x :scs (complex-single-reg) :to :save))
502 (:results (y :scs (descriptor-reg)))
504 (:note "complex float to pointer coercion")
506 (with-fixed-allocation (y
507 complex-single-float-widetag
508 complex-single-float-size
510 (let ((real-tn (complex-single-reg-real-tn x)))
511 (with-tn@fp-top(real-tn)
512 (inst fst (ea-for-csf-real-desc y))))
513 (let ((imag-tn (complex-single-reg-imag-tn x)))
514 (with-tn@fp-top(imag-tn)
515 (inst fst (ea-for-csf-imag-desc y)))))))
516 (define-move-vop move-from-complex-single :move
517 (complex-single-reg) (descriptor-reg))
519 (define-vop (move-from-complex-double)
520 (:args (x :scs (complex-double-reg) :to :save))
521 (:results (y :scs (descriptor-reg)))
523 (:note "complex float to pointer coercion")
525 (with-fixed-allocation (y
526 complex-double-float-widetag
527 complex-double-float-size
529 (let ((real-tn (complex-double-reg-real-tn x)))
530 (with-tn@fp-top(real-tn)
531 (inst fstd (ea-for-cdf-real-desc y))))
532 (let ((imag-tn (complex-double-reg-imag-tn x)))
533 (with-tn@fp-top(imag-tn)
534 (inst fstd (ea-for-cdf-imag-desc y)))))))
535 (define-move-vop move-from-complex-double :move
536 (complex-double-reg) (descriptor-reg))
539 (define-vop (move-from-complex-long)
540 (:args (x :scs (complex-long-reg) :to :save))
541 (:results (y :scs (descriptor-reg)))
543 (:note "complex float to pointer coercion")
545 (with-fixed-allocation (y
546 complex-long-float-widetag
547 complex-long-float-size
549 (let ((real-tn (complex-long-reg-real-tn x)))
550 (with-tn@fp-top(real-tn)
551 (store-long-float (ea-for-clf-real-desc y))))
552 (let ((imag-tn (complex-long-reg-imag-tn x)))
553 (with-tn@fp-top(imag-tn)
554 (store-long-float (ea-for-clf-imag-desc y)))))))
556 (define-move-vop move-from-complex-long :move
557 (complex-long-reg) (descriptor-reg))
559 ;;; Move from a descriptor to a complex float register.
560 (macrolet ((frob (name sc format)
563 (:args (x :scs (descriptor-reg)))
564 (:results (y :scs (,sc)))
565 (:note "pointer to complex float coercion")
567 (let ((real-tn (complex-double-reg-real-tn y)))
568 (with-empty-tn@fp-top(real-tn)
570 (:single '((inst fld (ea-for-csf-real-desc x))))
571 (:double '((inst fldd (ea-for-cdf-real-desc x))))
573 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
574 (let ((imag-tn (complex-double-reg-imag-tn y)))
575 (with-empty-tn@fp-top(imag-tn)
577 (:single '((inst fld (ea-for-csf-imag-desc x))))
578 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
580 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
581 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
582 (frob move-to-complex-single complex-single-reg :single)
583 (frob move-to-complex-double complex-double-reg :double)
585 (frob move-to-complex-double complex-long-reg :long))
587 ;;;; the move argument vops
589 ;;;; Note these are also used to stuff fp numbers onto the c-call
590 ;;;; stack so the order is different than the lisp-stack.
592 ;;; the general MOVE-ARG VOP
593 (macrolet ((frob (name sc stack-sc format)
596 (:args (x :scs (,sc) :target y)
598 :load-if (not (sc-is y ,sc))))
600 (:note "float argument move")
601 (:generator ,(case format (:single 2) (:double 3) (:long 4))
604 (unless (location= x y)
605 (cond ((zerop (tn-offset y))
606 (copy-fp-reg-to-fr0 x))
607 ((zerop (tn-offset x))
614 (if (= (tn-offset fp) esp-offset)
615 (let* ((offset (* (tn-offset y) n-word-bytes))
616 (ea (make-ea :dword :base fp :disp offset)))
619 (:single '((inst fst ea)))
620 (:double '((inst fstd ea)))
622 (:long '((store-long-float ea))))))
625 :disp (- (* (+ (tn-offset y)
633 (:single '((inst fst ea)))
634 (:double '((inst fstd ea)))
636 (:long '((store-long-float ea)))))))))))
637 (define-move-vop ,name :move-arg
638 (,sc descriptor-reg) (,sc)))))
639 (frob move-single-float-arg single-reg single-stack :single)
640 (frob move-double-float-arg double-reg double-stack :double)
642 (frob move-long-float-arg long-reg long-stack :long))
644 ;;;; complex float MOVE-ARG VOP
645 (macrolet ((frob (name sc stack-sc format)
648 (:args (x :scs (,sc) :target y)
650 :load-if (not (sc-is y ,sc))))
652 (:note "complex float argument move")
653 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
656 (unless (location= x y)
657 (let ((x-real (complex-double-reg-real-tn x))
658 (y-real (complex-double-reg-real-tn y)))
659 (cond ((zerop (tn-offset y-real))
660 (copy-fp-reg-to-fr0 x-real))
661 ((zerop (tn-offset x-real))
666 (inst fxch x-real))))
667 (let ((x-imag (complex-double-reg-imag-tn x))
668 (y-imag (complex-double-reg-imag-tn y)))
671 (inst fxch x-imag))))
673 (let ((real-tn (complex-double-reg-real-tn x)))
674 (cond ((zerop (tn-offset real-tn))
678 (ea-for-csf-real-stack y fp))))
681 (ea-for-cdf-real-stack y fp))))
685 (ea-for-clf-real-stack y fp))))))
691 (ea-for-csf-real-stack y fp))))
694 (ea-for-cdf-real-stack y fp))))
698 (ea-for-clf-real-stack y fp)))))
699 (inst fxch real-tn))))
700 (let ((imag-tn (complex-double-reg-imag-tn x)))
704 '((inst fst (ea-for-csf-imag-stack y fp))))
706 '((inst fstd (ea-for-cdf-imag-stack y fp))))
710 (ea-for-clf-imag-stack y fp)))))
711 (inst fxch imag-tn))))))
712 (define-move-vop ,name :move-arg
713 (,sc descriptor-reg) (,sc)))))
714 (frob move-complex-single-float-arg
715 complex-single-reg complex-single-stack :single)
716 (frob move-complex-double-float-arg
717 complex-double-reg complex-double-stack :double)
719 (frob move-complex-long-float-arg
720 complex-long-reg complex-long-stack :long))
722 (define-move-vop move-arg :move-arg
723 (single-reg double-reg #!+long-float long-reg
724 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
730 ;;; dtc: the floating point arithmetic vops
732 ;;; Note: Although these can accept x and y on the stack or pointed to
733 ;;; from a descriptor register, they will work with register loading
734 ;;; without these. Same deal with the result - it need only be a
735 ;;; register. When load-tns are needed they will probably be in ST0
736 ;;; and the code below should be able to correctly handle all cases.
738 ;;; However it seems to produce better code if all arg. and result
739 ;;; options are used; on the P86 there is no extra cost in using a
740 ;;; memory operand to the FP instructions - not so on the PPro.
742 ;;; It may also be useful to handle constant args?
744 ;;; 22-Jul-97: descriptor args lose in some simple cases when
745 ;;; a function result computed in a loop. Then Python insists
746 ;;; on consing the intermediate values! For example
749 (declare (type (simple-array double-float (*)) a)
752 (declare (type double-float sum))
754 (incf sum (* (aref a i)(aref a i))))
757 ;;; So, disabling descriptor args until this can be fixed elsewhere.
759 ((frob (op fop-sti fopr-sti
761 fopd foprd dname dcost
763 #!-long-float (declare (ignore lcost lname))
767 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
769 (y :scs (single-reg single-stack #+nil descriptor-reg)
771 (:temporary (:sc single-reg :offset fr0-offset
772 :from :eval :to :result) fr0)
773 (:results (r :scs (single-reg single-stack)))
774 (:arg-types single-float single-float)
775 (:result-types single-float)
777 (:note "inline float arithmetic")
779 (:save-p :compute-only)
782 ;; Handle a few special cases
784 ;; x, y, and r are the same register.
785 ((and (sc-is x single-reg) (location= x r) (location= y r))
786 (cond ((zerop (tn-offset r))
791 ;; XX the source register will not be valid.
792 (note-next-instruction vop :internal-error)
795 ;; x and r are the same register.
796 ((and (sc-is x single-reg) (location= x r))
797 (cond ((zerop (tn-offset r))
800 ;; ST(0) = ST(0) op ST(y)
803 ;; ST(0) = ST(0) op Mem
804 (inst ,fop (ea-for-sf-stack y)))
806 (inst ,fop (ea-for-sf-desc y)))))
811 (unless (zerop (tn-offset y))
812 (copy-fp-reg-to-fr0 y)))
813 ((single-stack descriptor-reg)
815 (if (sc-is y single-stack)
816 (inst fld (ea-for-sf-stack y))
817 (inst fld (ea-for-sf-desc y)))))
818 ;; ST(i) = ST(i) op ST0
820 (maybe-fp-wait node vop))
821 ;; y and r are the same register.
822 ((and (sc-is y single-reg) (location= y r))
823 (cond ((zerop (tn-offset r))
826 ;; ST(0) = ST(x) op ST(0)
829 ;; ST(0) = Mem op ST(0)
830 (inst ,fopr (ea-for-sf-stack x)))
832 (inst ,fopr (ea-for-sf-desc x)))))
837 (unless (zerop (tn-offset x))
838 (copy-fp-reg-to-fr0 x)))
839 ((single-stack descriptor-reg)
841 (if (sc-is x single-stack)
842 (inst fld (ea-for-sf-stack x))
843 (inst fld (ea-for-sf-desc x)))))
844 ;; ST(i) = ST(0) op ST(i)
846 (maybe-fp-wait node vop))
849 ;; Get the result to ST0.
851 ;; Special handling is needed if x or y are in ST0, and
852 ;; simpler code is generated.
855 ((and (sc-is x single-reg) (zerop (tn-offset x)))
861 (inst ,fop (ea-for-sf-stack y)))
863 (inst ,fop (ea-for-sf-desc y)))))
865 ((and (sc-is y single-reg) (zerop (tn-offset y)))
871 (inst ,fopr (ea-for-sf-stack x)))
873 (inst ,fopr (ea-for-sf-desc x)))))
878 (copy-fp-reg-to-fr0 x))
881 (inst fld (ea-for-sf-stack x)))
884 (inst fld (ea-for-sf-desc x))))
890 (inst ,fop (ea-for-sf-stack y)))
892 (inst ,fop (ea-for-sf-desc y))))))
894 (note-next-instruction vop :internal-error)
896 ;; Finally save the result.
899 (cond ((zerop (tn-offset r))
900 (maybe-fp-wait node))
904 (inst fst (ea-for-sf-stack r))))))))
908 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
910 (y :scs (double-reg double-stack #+nil descriptor-reg)
912 (:temporary (:sc double-reg :offset fr0-offset
913 :from :eval :to :result) fr0)
914 (:results (r :scs (double-reg double-stack)))
915 (:arg-types double-float double-float)
916 (:result-types double-float)
918 (:note "inline float arithmetic")
920 (:save-p :compute-only)
923 ;; Handle a few special cases.
925 ;; x, y, and r are the same register.
926 ((and (sc-is x double-reg) (location= x r) (location= y r))
927 (cond ((zerop (tn-offset r))
932 ;; XX the source register will not be valid.
933 (note-next-instruction vop :internal-error)
936 ;; x and r are the same register.
937 ((and (sc-is x double-reg) (location= x r))
938 (cond ((zerop (tn-offset r))
941 ;; ST(0) = ST(0) op ST(y)
944 ;; ST(0) = ST(0) op Mem
945 (inst ,fopd (ea-for-df-stack y)))
947 (inst ,fopd (ea-for-df-desc y)))))
952 (unless (zerop (tn-offset y))
953 (copy-fp-reg-to-fr0 y)))
954 ((double-stack descriptor-reg)
956 (if (sc-is y double-stack)
957 (inst fldd (ea-for-df-stack y))
958 (inst fldd (ea-for-df-desc y)))))
959 ;; ST(i) = ST(i) op ST0
961 (maybe-fp-wait node vop))
962 ;; y and r are the same register.
963 ((and (sc-is y double-reg) (location= y r))
964 (cond ((zerop (tn-offset r))
967 ;; ST(0) = ST(x) op ST(0)
970 ;; ST(0) = Mem op ST(0)
971 (inst ,foprd (ea-for-df-stack x)))
973 (inst ,foprd (ea-for-df-desc x)))))
978 (unless (zerop (tn-offset x))
979 (copy-fp-reg-to-fr0 x)))
980 ((double-stack descriptor-reg)
982 (if (sc-is x double-stack)
983 (inst fldd (ea-for-df-stack x))
984 (inst fldd (ea-for-df-desc x)))))
985 ;; ST(i) = ST(0) op ST(i)
987 (maybe-fp-wait node vop))
990 ;; Get the result to ST0.
992 ;; Special handling is needed if x or y are in ST0, and
993 ;; simpler code is generated.
996 ((and (sc-is x double-reg) (zerop (tn-offset x)))
1002 (inst ,fopd (ea-for-df-stack y)))
1004 (inst ,fopd (ea-for-df-desc y)))))
1006 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1012 (inst ,foprd (ea-for-df-stack x)))
1014 (inst ,foprd (ea-for-df-desc x)))))
1019 (copy-fp-reg-to-fr0 x))
1022 (inst fldd (ea-for-df-stack x)))
1025 (inst fldd (ea-for-df-desc x))))
1031 (inst ,fopd (ea-for-df-stack y)))
1033 (inst ,fopd (ea-for-df-desc y))))))
1035 (note-next-instruction vop :internal-error)
1037 ;; Finally save the result.
1040 (cond ((zerop (tn-offset r))
1041 (maybe-fp-wait node))
1045 (inst fstd (ea-for-df-stack r))))))))
1048 (define-vop (,lname)
1050 (:args (x :scs (long-reg) :to :eval)
1051 (y :scs (long-reg) :to :eval))
1052 (:temporary (:sc long-reg :offset fr0-offset
1053 :from :eval :to :result) fr0)
1054 (:results (r :scs (long-reg)))
1055 (:arg-types long-float long-float)
1056 (:result-types long-float)
1057 (:policy :fast-safe)
1058 (:note "inline float arithmetic")
1060 (:save-p :compute-only)
1063 ;; Handle a few special cases.
1065 ;; x, y, and r are the same register.
1066 ((and (location= x r) (location= y r))
1067 (cond ((zerop (tn-offset r))
1072 ;; XX the source register will not be valid.
1073 (note-next-instruction vop :internal-error)
1076 ;; x and r are the same register.
1078 (cond ((zerop (tn-offset r))
1079 ;; ST(0) = ST(0) op ST(y)
1083 (unless (zerop (tn-offset y))
1084 (copy-fp-reg-to-fr0 y))
1085 ;; ST(i) = ST(i) op ST0
1087 (maybe-fp-wait node vop))
1088 ;; y and r are the same register.
1090 (cond ((zerop (tn-offset r))
1091 ;; ST(0) = ST(x) op ST(0)
1095 (unless (zerop (tn-offset x))
1096 (copy-fp-reg-to-fr0 x))
1097 ;; ST(i) = ST(0) op ST(i)
1098 (inst ,fopr-sti r)))
1099 (maybe-fp-wait node vop))
1102 ;; Get the result to ST0.
1104 ;; Special handling is needed if x or y are in ST0, and
1105 ;; simpler code is generated.
1108 ((zerop (tn-offset x))
1112 ((zerop (tn-offset y))
1117 (copy-fp-reg-to-fr0 x)
1121 (note-next-instruction vop :internal-error)
1123 ;; Finally save the result.
1124 (cond ((zerop (tn-offset r))
1125 (maybe-fp-wait node))
1127 (inst fst r))))))))))
1129 (frob + fadd-sti fadd-sti
1130 fadd fadd +/single-float 2
1131 faddd faddd +/double-float 2
1133 (frob - fsub-sti fsubr-sti
1134 fsub fsubr -/single-float 2
1135 fsubd fsubrd -/double-float 2
1137 (frob * fmul-sti fmul-sti
1138 fmul fmul */single-float 3
1139 fmuld fmuld */double-float 3
1141 (frob / fdiv-sti fdivr-sti
1142 fdiv fdivr //single-float 12
1143 fdivd fdivrd //double-float 12
1146 (macrolet ((frob (name inst translate sc type)
1147 `(define-vop (,name)
1148 (:args (x :scs (,sc) :target fr0))
1149 (:results (y :scs (,sc)))
1150 (:translate ,translate)
1151 (:policy :fast-safe)
1153 (:result-types ,type)
1154 (:temporary (:sc double-reg :offset fr0-offset
1155 :from :argument :to :result) fr0)
1157 (:note "inline float arithmetic")
1159 (:save-p :compute-only)
1161 (note-this-location vop :internal-error)
1162 (unless (zerop (tn-offset x))
1163 (inst fxch x) ; x to top of stack
1164 (unless (location= x y)
1165 (inst fst x))) ; Maybe save it.
1166 (inst ,inst) ; Clobber st0.
1167 (unless (zerop (tn-offset y))
1170 (frob abs/single-float fabs abs single-reg single-float)
1171 (frob abs/double-float fabs abs double-reg double-float)
1173 (frob abs/long-float fabs abs long-reg long-float)
1174 (frob %negate/single-float fchs %negate single-reg single-float)
1175 (frob %negate/double-float fchs %negate double-reg double-float)
1177 (frob %negate/long-float fchs %negate long-reg long-float))
1181 (define-vop (=/float)
1183 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1185 (:info target not-p)
1186 (:policy :fast-safe)
1188 (:save-p :compute-only)
1189 (:note "inline float comparison")
1192 (note-this-location vop :internal-error)
1194 ;; x is in ST0; y is in any reg.
1195 ((zerop (tn-offset x))
1197 ;; y is in ST0; x is in another reg.
1198 ((zerop (tn-offset y))
1200 ;; x and y are the same register, not ST0
1205 ;; x and y are different registers, neither ST0.
1210 (inst fnstsw) ; status word to ax
1211 (inst and ah-tn #x45) ; C3 C2 C0
1212 (inst cmp ah-tn #x40)
1213 (inst jmp (if not-p :ne :e) target)))
1215 (define-vop (=/single-float =/float)
1217 (:args (x :scs (single-reg))
1218 (y :scs (single-reg)))
1219 (:arg-types single-float single-float))
1221 (define-vop (=/double-float =/float)
1223 (:args (x :scs (double-reg))
1224 (y :scs (double-reg)))
1225 (:arg-types double-float double-float))
1228 (define-vop (=/long-float =/float)
1230 (:args (x :scs (long-reg))
1231 (y :scs (long-reg)))
1232 (:arg-types long-float long-float))
1234 (define-vop (<single-float)
1236 (:args (x :scs (single-reg single-stack descriptor-reg))
1237 (y :scs (single-reg single-stack descriptor-reg)))
1238 (:arg-types single-float single-float)
1239 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1240 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1242 (:info target not-p)
1243 (:policy :fast-safe)
1244 (:note "inline float comparison")
1247 ;; Handle a few special cases.
1250 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1254 ((single-stack descriptor-reg)
1255 (if (sc-is x single-stack)
1256 (inst fcom (ea-for-sf-stack x))
1257 (inst fcom (ea-for-sf-desc x)))))
1258 (inst fnstsw) ; status word to ax
1259 (inst and ah-tn #x45))
1261 ;; general case when y is not in ST0
1266 (unless (zerop (tn-offset x))
1267 (copy-fp-reg-to-fr0 x)))
1268 ((single-stack descriptor-reg)
1270 (if (sc-is x single-stack)
1271 (inst fld (ea-for-sf-stack x))
1272 (inst fld (ea-for-sf-desc x)))))
1276 ((single-stack descriptor-reg)
1277 (if (sc-is y single-stack)
1278 (inst fcom (ea-for-sf-stack y))
1279 (inst fcom (ea-for-sf-desc y)))))
1280 (inst fnstsw) ; status word to ax
1281 (inst and ah-tn #x45) ; C3 C2 C0
1282 (inst cmp ah-tn #x01)))
1283 (inst jmp (if not-p :ne :e) target)))
1285 (define-vop (<double-float)
1287 (:args (x :scs (double-reg double-stack descriptor-reg))
1288 (y :scs (double-reg double-stack descriptor-reg)))
1289 (:arg-types double-float double-float)
1290 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1291 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1293 (:info target not-p)
1294 (:policy :fast-safe)
1295 (:note "inline float comparison")
1298 ;; Handle a few special cases
1301 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1305 ((double-stack descriptor-reg)
1306 (if (sc-is x double-stack)
1307 (inst fcomd (ea-for-df-stack x))
1308 (inst fcomd (ea-for-df-desc x)))))
1309 (inst fnstsw) ; status word to ax
1310 (inst and ah-tn #x45))
1312 ;; General case when y is not in ST0.
1317 (unless (zerop (tn-offset x))
1318 (copy-fp-reg-to-fr0 x)))
1319 ((double-stack descriptor-reg)
1321 (if (sc-is x double-stack)
1322 (inst fldd (ea-for-df-stack x))
1323 (inst fldd (ea-for-df-desc x)))))
1327 ((double-stack descriptor-reg)
1328 (if (sc-is y double-stack)
1329 (inst fcomd (ea-for-df-stack y))
1330 (inst fcomd (ea-for-df-desc y)))))
1331 (inst fnstsw) ; status word to ax
1332 (inst and ah-tn #x45) ; C3 C2 C0
1333 (inst cmp ah-tn #x01)))
1334 (inst jmp (if not-p :ne :e) target)))
1337 (define-vop (<long-float)
1339 (:args (x :scs (long-reg))
1340 (y :scs (long-reg)))
1341 (:arg-types long-float long-float)
1342 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1344 (:info target not-p)
1345 (:policy :fast-safe)
1346 (:note "inline float comparison")
1350 ;; x is in ST0; y is in any reg.
1351 ((zerop (tn-offset x))
1353 (inst fnstsw) ; status word to ax
1354 (inst and ah-tn #x45) ; C3 C2 C0
1355 (inst cmp ah-tn #x01))
1356 ;; y is in ST0; x is in another reg.
1357 ((zerop (tn-offset y))
1359 (inst fnstsw) ; status word to ax
1360 (inst and ah-tn #x45))
1361 ;; x and y are the same register, not ST0
1362 ;; x and y are different registers, neither ST0.
1367 (inst fnstsw) ; status word to ax
1368 (inst and ah-tn #x45))) ; C3 C2 C0
1369 (inst jmp (if not-p :ne :e) target)))
1371 (define-vop (>single-float)
1373 (:args (x :scs (single-reg single-stack descriptor-reg))
1374 (y :scs (single-reg single-stack descriptor-reg)))
1375 (:arg-types single-float single-float)
1376 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1377 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1379 (:info target not-p)
1380 (:policy :fast-safe)
1381 (:note "inline float comparison")
1384 ;; Handle a few special cases.
1387 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1391 ((single-stack descriptor-reg)
1392 (if (sc-is x single-stack)
1393 (inst fcom (ea-for-sf-stack x))
1394 (inst fcom (ea-for-sf-desc x)))))
1395 (inst fnstsw) ; status word to ax
1396 (inst and ah-tn #x45)
1397 (inst cmp ah-tn #x01))
1399 ;; general case when y is not in ST0
1404 (unless (zerop (tn-offset x))
1405 (copy-fp-reg-to-fr0 x)))
1406 ((single-stack descriptor-reg)
1408 (if (sc-is x single-stack)
1409 (inst fld (ea-for-sf-stack x))
1410 (inst fld (ea-for-sf-desc x)))))
1414 ((single-stack descriptor-reg)
1415 (if (sc-is y single-stack)
1416 (inst fcom (ea-for-sf-stack y))
1417 (inst fcom (ea-for-sf-desc y)))))
1418 (inst fnstsw) ; status word to ax
1419 (inst and ah-tn #x45)))
1420 (inst jmp (if not-p :ne :e) target)))
1422 (define-vop (>double-float)
1424 (:args (x :scs (double-reg double-stack descriptor-reg))
1425 (y :scs (double-reg double-stack descriptor-reg)))
1426 (:arg-types double-float double-float)
1427 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1428 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1430 (:info target not-p)
1431 (:policy :fast-safe)
1432 (:note "inline float comparison")
1435 ;; Handle a few special cases.
1438 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1442 ((double-stack descriptor-reg)
1443 (if (sc-is x double-stack)
1444 (inst fcomd (ea-for-df-stack x))
1445 (inst fcomd (ea-for-df-desc x)))))
1446 (inst fnstsw) ; status word to ax
1447 (inst and ah-tn #x45)
1448 (inst cmp ah-tn #x01))
1450 ;; general case when y is not in ST0
1455 (unless (zerop (tn-offset x))
1456 (copy-fp-reg-to-fr0 x)))
1457 ((double-stack descriptor-reg)
1459 (if (sc-is x double-stack)
1460 (inst fldd (ea-for-df-stack x))
1461 (inst fldd (ea-for-df-desc x)))))
1465 ((double-stack descriptor-reg)
1466 (if (sc-is y double-stack)
1467 (inst fcomd (ea-for-df-stack y))
1468 (inst fcomd (ea-for-df-desc y)))))
1469 (inst fnstsw) ; status word to ax
1470 (inst and ah-tn #x45)))
1471 (inst jmp (if not-p :ne :e) target)))
1474 (define-vop (>long-float)
1476 (:args (x :scs (long-reg))
1477 (y :scs (long-reg)))
1478 (:arg-types long-float long-float)
1479 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1481 (:info target not-p)
1482 (:policy :fast-safe)
1483 (:note "inline float comparison")
1487 ;; y is in ST0; x is in any reg.
1488 ((zerop (tn-offset y))
1490 (inst fnstsw) ; status word to ax
1491 (inst and ah-tn #x45)
1492 (inst cmp ah-tn #x01))
1493 ;; x is in ST0; y is in another reg.
1494 ((zerop (tn-offset x))
1496 (inst fnstsw) ; status word to ax
1497 (inst and ah-tn #x45))
1498 ;; y and x are the same register, not ST0
1499 ;; y and x are different registers, neither ST0.
1504 (inst fnstsw) ; status word to ax
1505 (inst and ah-tn #x45)))
1506 (inst jmp (if not-p :ne :e) target)))
1508 ;;; Comparisons with 0 can use the FTST instruction.
1510 (define-vop (float-test)
1512 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1514 (:info target not-p y)
1515 (:variant-vars code)
1516 (:policy :fast-safe)
1518 (:save-p :compute-only)
1519 (:note "inline float comparison")
1522 (note-this-location vop :internal-error)
1525 ((zerop (tn-offset x))
1532 (inst fnstsw) ; status word to ax
1533 (inst and ah-tn #x45) ; C3 C2 C0
1534 (unless (zerop code)
1535 (inst cmp ah-tn code))
1536 (inst jmp (if not-p :ne :e) target)))
1538 (define-vop (=0/single-float float-test)
1540 (:args (x :scs (single-reg)))
1541 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1543 (define-vop (=0/double-float float-test)
1545 (:args (x :scs (double-reg)))
1546 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1549 (define-vop (=0/long-float float-test)
1551 (:args (x :scs (long-reg)))
1552 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1555 (define-vop (<0/single-float float-test)
1557 (:args (x :scs (single-reg)))
1558 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1560 (define-vop (<0/double-float float-test)
1562 (:args (x :scs (double-reg)))
1563 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1566 (define-vop (<0/long-float float-test)
1568 (:args (x :scs (long-reg)))
1569 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1572 (define-vop (>0/single-float float-test)
1574 (:args (x :scs (single-reg)))
1575 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1577 (define-vop (>0/double-float float-test)
1579 (:args (x :scs (double-reg)))
1580 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1583 (define-vop (>0/long-float float-test)
1585 (:args (x :scs (long-reg)))
1586 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1590 (deftransform eql ((x y) (long-float long-float))
1591 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1592 (= (long-float-high-bits x) (long-float-high-bits y))
1593 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1597 (macrolet ((frob (name translate to-sc to-type)
1598 `(define-vop (,name)
1599 (:args (x :scs (signed-stack signed-reg) :target temp))
1600 (:temporary (:sc signed-stack) temp)
1601 (:results (y :scs (,to-sc)))
1602 (:arg-types signed-num)
1603 (:result-types ,to-type)
1604 (:policy :fast-safe)
1605 (:note "inline float coercion")
1606 (:translate ,translate)
1608 (:save-p :compute-only)
1613 (with-empty-tn@fp-top(y)
1614 (note-this-location vop :internal-error)
1617 (with-empty-tn@fp-top(y)
1618 (note-this-location vop :internal-error)
1619 (inst fild x))))))))
1620 (frob %single-float/signed %single-float single-reg single-float)
1621 (frob %double-float/signed %double-float double-reg double-float)
1623 (frob %long-float/signed %long-float long-reg long-float))
1625 (macrolet ((frob (name translate to-sc to-type)
1626 `(define-vop (,name)
1627 (:args (x :scs (unsigned-reg)))
1628 (:results (y :scs (,to-sc)))
1629 (:arg-types unsigned-num)
1630 (:result-types ,to-type)
1631 (:policy :fast-safe)
1632 (:note "inline float coercion")
1633 (:translate ,translate)
1635 (:save-p :compute-only)
1639 (with-empty-tn@fp-top(y)
1640 (note-this-location vop :internal-error)
1641 (inst fildl (make-ea :dword :base esp-tn)))
1642 (inst add esp-tn 8)))))
1643 (frob %single-float/unsigned %single-float single-reg single-float)
1644 (frob %double-float/unsigned %double-float double-reg double-float)
1646 (frob %long-float/unsigned %long-float long-reg long-float))
1648 ;;; These should be no-ops but the compiler might want to move some
1650 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1651 `(define-vop (,name)
1652 (:args (x :scs (,from-sc) :target y))
1653 (:results (y :scs (,to-sc)))
1654 (:arg-types ,from-type)
1655 (:result-types ,to-type)
1656 (:policy :fast-safe)
1657 (:note "inline float coercion")
1658 (:translate ,translate)
1660 (:save-p :compute-only)
1662 (note-this-location vop :internal-error)
1663 (unless (location= x y)
1665 ((zerop (tn-offset x))
1666 ;; x is in ST0, y is in another reg. not ST0
1668 ((zerop (tn-offset y))
1669 ;; y is in ST0, x is in another reg. not ST0
1670 (copy-fp-reg-to-fr0 x))
1672 ;; Neither x or y are in ST0, and they are not in
1676 (inst fxch x))))))))
1678 (frob %single-float/double-float %single-float double-reg
1679 double-float single-reg single-float)
1681 (frob %single-float/long-float %single-float long-reg
1682 long-float single-reg single-float)
1683 (frob %double-float/single-float %double-float single-reg single-float
1684 double-reg double-float)
1686 (frob %double-float/long-float %double-float long-reg long-float
1687 double-reg double-float)
1689 (frob %long-float/single-float %long-float single-reg single-float
1690 long-reg long-float)
1692 (frob %long-float/double-float %long-float double-reg double-float
1693 long-reg long-float))
1695 (macrolet ((frob (trans from-sc from-type round-p)
1696 `(define-vop (,(symbolicate trans "/" from-type))
1697 (:args (x :scs (,from-sc)))
1698 (:temporary (:sc signed-stack) stack-temp)
1700 '((:temporary (:sc unsigned-stack) scw)
1701 (:temporary (:sc any-reg) rcw)))
1702 (:results (y :scs (signed-reg)))
1703 (:arg-types ,from-type)
1704 (:result-types signed-num)
1706 (:policy :fast-safe)
1707 (:note "inline float truncate")
1709 (:save-p :compute-only)
1712 '((note-this-location vop :internal-error)
1713 ;; Catch any pending FPE exceptions.
1715 (,(if round-p 'progn 'pseudo-atomic)
1716 ;; Normal mode (for now) is "round to best".
1719 '((inst fnstcw scw) ; save current control word
1720 (move rcw scw) ; into 16-bit register
1721 (inst or rcw (ash #b11 10)) ; CHOP
1722 (move stack-temp rcw)
1723 (inst fldcw stack-temp)))
1728 (inst fist stack-temp)
1729 (inst mov y stack-temp)))
1731 '((inst fldcw scw)))))))))
1732 (frob %unary-truncate single-reg single-float nil)
1733 (frob %unary-truncate double-reg double-float nil)
1735 (frob %unary-truncate long-reg long-float nil)
1736 (frob %unary-round single-reg single-float t)
1737 (frob %unary-round double-reg double-float t)
1739 (frob %unary-round long-reg long-float t))
1741 (macrolet ((frob (trans from-sc from-type round-p)
1742 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1743 (:args (x :scs (,from-sc) :target fr0))
1744 (:temporary (:sc double-reg :offset fr0-offset
1745 :from :argument :to :result) fr0)
1747 '((:temporary (:sc unsigned-stack) stack-temp)
1748 (:temporary (:sc unsigned-stack) scw)
1749 (:temporary (:sc any-reg) rcw)))
1750 (:results (y :scs (unsigned-reg)))
1751 (:arg-types ,from-type)
1752 (:result-types unsigned-num)
1754 (:policy :fast-safe)
1755 (:note "inline float truncate")
1757 (:save-p :compute-only)
1760 '((note-this-location vop :internal-error)
1761 ;; Catch any pending FPE exceptions.
1763 ;; Normal mode (for now) is "round to best".
1764 (unless (zerop (tn-offset x))
1765 (copy-fp-reg-to-fr0 x))
1767 '((inst fnstcw scw) ; save current control word
1768 (move rcw scw) ; into 16-bit register
1769 (inst or rcw (ash #b11 10)) ; CHOP
1770 (move stack-temp rcw)
1771 (inst fldcw stack-temp)))
1773 (inst fistpl (make-ea :dword :base esp-tn))
1775 (inst fld fr0) ; copy fr0 to at least restore stack.
1778 '((inst fldcw scw)))))))
1779 (frob %unary-truncate single-reg single-float nil)
1780 (frob %unary-truncate double-reg double-float nil)
1782 (frob %unary-truncate long-reg long-float nil)
1783 (frob %unary-round single-reg single-float t)
1784 (frob %unary-round double-reg double-float t)
1786 (frob %unary-round long-reg long-float t))
1788 (define-vop (make-single-float)
1789 (:args (bits :scs (signed-reg) :target res
1790 :load-if (not (or (and (sc-is bits signed-stack)
1791 (sc-is res single-reg))
1792 (and (sc-is bits signed-stack)
1793 (sc-is res single-stack)
1794 (location= bits res))))))
1795 (:results (res :scs (single-reg single-stack)))
1796 (:temporary (:sc signed-stack) stack-temp)
1797 (:arg-types signed-num)
1798 (:result-types single-float)
1799 (:translate make-single-float)
1800 (:policy :fast-safe)
1807 (inst mov res bits))
1809 (aver (location= bits res)))))
1813 ;; source must be in memory
1814 (inst mov stack-temp bits)
1815 (with-empty-tn@fp-top(res)
1816 (inst fld stack-temp)))
1818 (with-empty-tn@fp-top(res)
1819 (inst fld bits))))))))
1821 (define-vop (make-double-float)
1822 (:args (hi-bits :scs (signed-reg))
1823 (lo-bits :scs (unsigned-reg)))
1824 (:results (res :scs (double-reg)))
1825 (:temporary (:sc double-stack) temp)
1826 (:arg-types signed-num unsigned-num)
1827 (:result-types double-float)
1828 (:translate make-double-float)
1829 (:policy :fast-safe)
1832 (let ((offset (1+ (tn-offset temp))))
1833 (storew hi-bits ebp-tn (- offset))
1834 (storew lo-bits ebp-tn (- (1+ offset)))
1835 (with-empty-tn@fp-top(res)
1836 (inst fldd (make-ea :dword :base ebp-tn
1837 :disp (- (* (1+ offset) n-word-bytes))))))))
1840 (define-vop (make-long-float)
1841 (:args (exp-bits :scs (signed-reg))
1842 (hi-bits :scs (unsigned-reg))
1843 (lo-bits :scs (unsigned-reg)))
1844 (:results (res :scs (long-reg)))
1845 (:temporary (:sc long-stack) temp)
1846 (:arg-types signed-num unsigned-num unsigned-num)
1847 (:result-types long-float)
1848 (:translate make-long-float)
1849 (:policy :fast-safe)
1852 (let ((offset (1+ (tn-offset temp))))
1853 (storew exp-bits ebp-tn (- offset))
1854 (storew hi-bits ebp-tn (- (1+ offset)))
1855 (storew lo-bits ebp-tn (- (+ offset 2)))
1856 (with-empty-tn@fp-top(res)
1857 (inst fldl (make-ea :dword :base ebp-tn
1858 :disp (- (* (+ offset 2) n-word-bytes))))))))
1860 (define-vop (single-float-bits)
1861 (:args (float :scs (single-reg descriptor-reg)
1862 :load-if (not (sc-is float single-stack))))
1863 (:results (bits :scs (signed-reg)))
1864 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1865 (:arg-types single-float)
1866 (:result-types signed-num)
1867 (:translate single-float-bits)
1868 (:policy :fast-safe)
1875 (with-tn@fp-top(float)
1876 (inst fst stack-temp)
1877 (inst mov bits stack-temp)))
1879 (inst mov bits float))
1882 bits float single-float-value-slot
1883 other-pointer-lowtag))))
1887 (with-tn@fp-top(float)
1888 (inst fst bits))))))))
1890 (define-vop (double-float-high-bits)
1891 (:args (float :scs (double-reg descriptor-reg)
1892 :load-if (not (sc-is float double-stack))))
1893 (:results (hi-bits :scs (signed-reg)))
1894 (:temporary (:sc double-stack) temp)
1895 (:arg-types double-float)
1896 (:result-types signed-num)
1897 (:translate double-float-high-bits)
1898 (:policy :fast-safe)
1903 (with-tn@fp-top(float)
1904 (let ((where (make-ea :dword :base ebp-tn
1905 :disp (- (* (+ 2 (tn-offset temp))
1908 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1910 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1912 (loadw hi-bits float (1+ double-float-value-slot)
1913 other-pointer-lowtag)))))
1915 (define-vop (double-float-low-bits)
1916 (:args (float :scs (double-reg descriptor-reg)
1917 :load-if (not (sc-is float double-stack))))
1918 (:results (lo-bits :scs (unsigned-reg)))
1919 (:temporary (:sc double-stack) temp)
1920 (:arg-types double-float)
1921 (:result-types unsigned-num)
1922 (:translate double-float-low-bits)
1923 (:policy :fast-safe)
1928 (with-tn@fp-top(float)
1929 (let ((where (make-ea :dword :base ebp-tn
1930 :disp (- (* (+ 2 (tn-offset temp))
1933 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1935 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1937 (loadw lo-bits float double-float-value-slot
1938 other-pointer-lowtag)))))
1941 (define-vop (long-float-exp-bits)
1942 (:args (float :scs (long-reg descriptor-reg)
1943 :load-if (not (sc-is float long-stack))))
1944 (:results (exp-bits :scs (signed-reg)))
1945 (:temporary (:sc long-stack) temp)
1946 (:arg-types long-float)
1947 (:result-types signed-num)
1948 (:translate long-float-exp-bits)
1949 (:policy :fast-safe)
1954 (with-tn@fp-top(float)
1955 (let ((where (make-ea :dword :base ebp-tn
1956 :disp (- (* (+ 3 (tn-offset temp))
1958 (store-long-float where)))
1959 (inst movsx exp-bits
1960 (make-ea :word :base ebp-tn
1961 :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
1963 (inst movsx exp-bits
1964 (make-ea :word :base ebp-tn
1965 :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
1967 (inst movsx exp-bits
1968 (make-ea :word :base float
1969 :disp (- (* (+ 2 long-float-value-slot)
1971 other-pointer-lowtag)))))))
1974 (define-vop (long-float-high-bits)
1975 (:args (float :scs (long-reg descriptor-reg)
1976 :load-if (not (sc-is float long-stack))))
1977 (:results (hi-bits :scs (unsigned-reg)))
1978 (:temporary (:sc long-stack) temp)
1979 (:arg-types long-float)
1980 (:result-types unsigned-num)
1981 (:translate long-float-high-bits)
1982 (:policy :fast-safe)
1987 (with-tn@fp-top(float)
1988 (let ((where (make-ea :dword :base ebp-tn
1989 :disp (- (* (+ 3 (tn-offset temp))
1991 (store-long-float where)))
1992 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
1994 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
1996 (loadw hi-bits float (1+ long-float-value-slot)
1997 other-pointer-lowtag)))))
2000 (define-vop (long-float-low-bits)
2001 (:args (float :scs (long-reg descriptor-reg)
2002 :load-if (not (sc-is float long-stack))))
2003 (:results (lo-bits :scs (unsigned-reg)))
2004 (:temporary (:sc long-stack) temp)
2005 (:arg-types long-float)
2006 (:result-types unsigned-num)
2007 (:translate long-float-low-bits)
2008 (:policy :fast-safe)
2013 (with-tn@fp-top(float)
2014 (let ((where (make-ea :dword :base ebp-tn
2015 :disp (- (* (+ 3 (tn-offset temp))
2017 (store-long-float where)))
2018 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2020 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2022 (loadw lo-bits float long-float-value-slot
2023 other-pointer-lowtag)))))
2025 ;;;; float mode hackery
2027 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2028 (defknown floating-point-modes () float-modes (flushable))
2029 (defknown ((setf floating-point-modes)) (float-modes)
2032 (def!constant npx-env-size (* 7 n-word-bytes))
2033 (def!constant npx-cw-offset 0)
2034 (def!constant npx-sw-offset 4)
2036 (define-vop (floating-point-modes)
2037 (:results (res :scs (unsigned-reg)))
2038 (:result-types unsigned-num)
2039 (:translate floating-point-modes)
2040 (:policy :fast-safe)
2041 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2044 (inst sub esp-tn npx-env-size) ; Make space on stack.
2045 (inst wait) ; Catch any pending FPE exceptions
2046 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2047 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2048 ;; Move current status to high word.
2049 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2050 ;; Move exception mask to low word.
2051 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2052 (inst add esp-tn npx-env-size) ; Pop stack.
2053 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2056 (define-vop (set-floating-point-modes)
2057 (:args (new :scs (unsigned-reg) :to :result :target res))
2058 (:results (res :scs (unsigned-reg)))
2059 (:arg-types unsigned-num)
2060 (:result-types unsigned-num)
2061 (:translate (setf floating-point-modes))
2062 (:policy :fast-safe)
2063 (:temporary (:sc unsigned-reg :offset eax-offset
2064 :from :eval :to :result) eax)
2066 (inst sub esp-tn npx-env-size) ; Make space on stack.
2067 (inst wait) ; Catch any pending FPE exceptions.
2068 (inst fstenv (make-ea :dword :base esp-tn))
2070 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2071 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2072 (inst shr eax 16) ; position status word
2073 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2074 (inst fldenv (make-ea :dword :base esp-tn))
2075 (inst add esp-tn npx-env-size) ; Pop stack.
2081 ;;; Let's use some of the 80387 special functions.
2083 ;;; These defs will not take effect unless code/irrat.lisp is modified
2084 ;;; to remove the inlined alien routine def.
2086 (macrolet ((frob (func trans op)
2087 `(define-vop (,func)
2088 (:args (x :scs (double-reg) :target fr0))
2089 (:temporary (:sc double-reg :offset fr0-offset
2090 :from :argument :to :result) fr0)
2092 (:results (y :scs (double-reg)))
2093 (:arg-types double-float)
2094 (:result-types double-float)
2096 (:policy :fast-safe)
2097 (:note "inline NPX function")
2099 (:save-p :compute-only)
2102 (note-this-location vop :internal-error)
2103 (unless (zerop (tn-offset x))
2104 (inst fxch x) ; x to top of stack
2105 (unless (location= x y)
2106 (inst fst x))) ; maybe save it
2107 (inst ,op) ; clobber st0
2108 (cond ((zerop (tn-offset y))
2109 (maybe-fp-wait node))
2113 ;; Quick versions of fsin and fcos that require the argument to be
2114 ;; within range 2^63.
2115 (frob fsin-quick %sin-quick fsin)
2116 (frob fcos-quick %cos-quick fcos)
2117 (frob fsqrt %sqrt fsqrt))
2119 ;;; Quick version of ftan that requires the argument to be within
2121 (define-vop (ftan-quick)
2122 (:translate %tan-quick)
2123 (:args (x :scs (double-reg) :target fr0))
2124 (:temporary (:sc double-reg :offset fr0-offset
2125 :from :argument :to :result) fr0)
2126 (:temporary (:sc double-reg :offset fr1-offset
2127 :from :argument :to :result) fr1)
2128 (:results (y :scs (double-reg)))
2129 (:arg-types double-float)
2130 (:result-types double-float)
2131 (:policy :fast-safe)
2132 (:note "inline tan function")
2134 (:save-p :compute-only)
2136 (note-this-location vop :internal-error)
2145 (inst fldd (make-random-tn :kind :normal
2146 :sc (sc-or-lose 'double-reg)
2147 :offset (- (tn-offset x) 2)))))
2158 ;;; These versions of fsin, fcos, and ftan try to use argument
2159 ;;; reduction but to do this accurately requires greater precision and
2160 ;;; it is hopelessly inaccurate.
2162 (macrolet ((frob (func trans op)
2163 `(define-vop (,func)
2165 (:args (x :scs (double-reg) :target fr0))
2166 (:temporary (:sc unsigned-reg :offset eax-offset
2167 :from :eval :to :result) eax)
2168 (:temporary (:sc unsigned-reg :offset fr0-offset
2169 :from :argument :to :result) fr0)
2170 (:temporary (:sc unsigned-reg :offset fr1-offset
2171 :from :argument :to :result) fr1)
2172 (:results (y :scs (double-reg)))
2173 (:arg-types double-float)
2174 (:result-types double-float)
2175 (:policy :fast-safe)
2176 (:note "inline sin/cos function")
2178 (:save-p :compute-only)
2181 (note-this-location vop :internal-error)
2182 (unless (zerop (tn-offset x))
2183 (inst fxch x) ; x to top of stack
2184 (unless (location= x y)
2185 (inst fst x))) ; maybe save it
2187 (inst fnstsw) ; status word to ax
2188 (inst and ah-tn #x04) ; C2
2190 ;; Else x was out of range so reduce it; ST0 is unchanged.
2191 (inst fstp fr1) ; Load 2*PI
2197 (inst fnstsw) ; status word to ax
2198 (inst and ah-tn #x04) ; C2
2202 (unless (zerop (tn-offset y))
2204 (frob fsin %sin fsin)
2205 (frob fcos %cos fcos))
2210 (:args (x :scs (double-reg) :target fr0))
2211 (:temporary (:sc unsigned-reg :offset eax-offset
2212 :from :argument :to :result) eax)
2213 (:temporary (:sc double-reg :offset fr0-offset
2214 :from :argument :to :result) fr0)
2215 (:temporary (:sc double-reg :offset fr1-offset
2216 :from :argument :to :result) fr1)
2217 (:results (y :scs (double-reg)))
2218 (:arg-types double-float)
2219 (:result-types double-float)
2220 (:policy :fast-safe)
2221 (:note "inline tan function")
2223 (:save-p :compute-only)
2226 (note-this-location vop :internal-error)
2235 (inst fldd (make-random-tn :kind :normal
2236 :sc (sc-or-lose 'double-reg)
2237 :offset (- (tn-offset x) 2)))))
2239 (inst fnstsw) ; status word to ax
2240 (inst and ah-tn #x04) ; C2
2242 ;; Else x was out of range so reduce it; ST0 is unchanged.
2243 (inst fldpi) ; Load 2*PI
2248 (inst fnstsw) ; status word to ax
2249 (inst and ah-tn #x04) ; C2
2263 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2264 ;;; the argument is out of range 2^63 and would thus be hopelessly
2266 (macrolet ((frob (func trans op)
2267 `(define-vop (,func)
2269 (:args (x :scs (double-reg) :target fr0))
2270 (:temporary (:sc double-reg :offset fr0-offset
2271 :from :argument :to :result) fr0)
2272 (:temporary (:sc unsigned-reg :offset eax-offset
2273 :from :argument :to :result) eax)
2274 (:results (y :scs (double-reg)))
2275 (:arg-types double-float)
2276 (:result-types double-float)
2277 (:policy :fast-safe)
2278 (:note "inline sin/cos function")
2280 (:save-p :compute-only)
2283 (note-this-location vop :internal-error)
2284 (unless (zerop (tn-offset x))
2285 (inst fxch x) ; x to top of stack
2286 (unless (location= x y)
2287 (inst fst x))) ; maybe save it
2289 (inst fnstsw) ; status word to ax
2290 (inst and ah-tn #x04) ; C2
2292 ;; Else x was out of range so reduce it; ST0 is unchanged.
2293 (inst fstp fr0) ; Load 0.0
2296 (unless (zerop (tn-offset y))
2298 (frob fsin %sin fsin)
2299 (frob fcos %cos fcos))
2303 (:args (x :scs (double-reg) :target fr0))
2304 (:temporary (:sc double-reg :offset fr0-offset
2305 :from :argument :to :result) fr0)
2306 (:temporary (:sc double-reg :offset fr1-offset
2307 :from :argument :to :result) fr1)
2308 (:temporary (:sc unsigned-reg :offset eax-offset
2309 :from :argument :to :result) eax)
2310 (:results (y :scs (double-reg)))
2311 (:arg-types double-float)
2312 (:result-types double-float)
2314 (:policy :fast-safe)
2315 (:note "inline tan function")
2317 (:save-p :compute-only)
2320 (note-this-location vop :internal-error)
2329 (inst fldd (make-random-tn :kind :normal
2330 :sc (sc-or-lose 'double-reg)
2331 :offset (- (tn-offset x) 2)))))
2333 (inst fnstsw) ; status word to ax
2334 (inst and ah-tn #x04) ; C2
2336 ;; Else x was out of range so reduce it; ST0 is unchanged.
2337 (inst fldz) ; Load 0.0
2352 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2353 (:temporary (:sc double-reg :offset fr0-offset
2354 :from :argument :to :result) fr0)
2355 (:temporary (:sc double-reg :offset fr1-offset
2356 :from :argument :to :result) fr1)
2357 (:temporary (:sc double-reg :offset fr2-offset
2358 :from :argument :to :result) fr2)
2359 (:results (y :scs (double-reg)))
2360 (:arg-types double-float)
2361 (:result-types double-float)
2362 (:policy :fast-safe)
2363 (:note "inline exp function")
2365 (:save-p :compute-only)
2367 (note-this-location vop :internal-error)
2370 (cond ((zerop (tn-offset x))
2376 ;; x is in a FP reg, not fr0
2380 ((double-stack descriptor-reg)
2383 (if (sc-is x double-stack)
2384 (inst fmuld (ea-for-df-stack x))
2385 (inst fmuld (ea-for-df-desc x)))))
2386 ;; Now fr0=x log2(e)
2390 (inst fsubp-sti fr1)
2393 (inst faddp-sti fr1)
2398 (t (inst fstd y)))))
2400 ;;; Modified exp that handles the following special cases:
2401 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2404 (:args (x :scs (double-reg) :target fr0))
2405 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2406 (:temporary (:sc double-reg :offset fr0-offset
2407 :from :argument :to :result) fr0)
2408 (:temporary (:sc double-reg :offset fr1-offset
2409 :from :argument :to :result) fr1)
2410 (:temporary (:sc double-reg :offset fr2-offset
2411 :from :argument :to :result) fr2)
2412 (:results (y :scs (double-reg)))
2413 (:arg-types double-float)
2414 (:result-types double-float)
2415 (:policy :fast-safe)
2416 (:note "inline exp function")
2418 (:save-p :compute-only)
2421 (note-this-location vop :internal-error)
2422 (unless (zerop (tn-offset x))
2423 (inst fxch x) ; x to top of stack
2424 (unless (location= x y)
2425 (inst fst x))) ; maybe save it
2426 ;; Check for Inf or NaN
2430 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2431 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2432 (inst and ah-tn #x02) ; Test sign of Inf.
2433 (inst jmp :z DONE) ; +Inf gives +Inf.
2434 (inst fstp fr0) ; -Inf gives 0
2436 (inst jmp-short DONE)
2441 ;; Now fr0=x log2(e)
2445 (inst fsubp-sti fr1)
2448 (inst faddp-sti fr1)
2452 (unless (zerop (tn-offset y))
2455 ;;; Expm1 = exp(x) - 1.
2456 ;;; Handles the following special cases:
2457 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2458 (define-vop (fexpm1)
2460 (:args (x :scs (double-reg) :target fr0))
2461 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2462 (:temporary (:sc double-reg :offset fr0-offset
2463 :from :argument :to :result) fr0)
2464 (:temporary (:sc double-reg :offset fr1-offset
2465 :from :argument :to :result) fr1)
2466 (:temporary (:sc double-reg :offset fr2-offset
2467 :from :argument :to :result) fr2)
2468 (:results (y :scs (double-reg)))
2469 (:arg-types double-float)
2470 (:result-types double-float)
2471 (:policy :fast-safe)
2472 (:note "inline expm1 function")
2474 (:save-p :compute-only)
2477 (note-this-location vop :internal-error)
2478 (unless (zerop (tn-offset x))
2479 (inst fxch x) ; x to top of stack
2480 (unless (location= x y)
2481 (inst fst x))) ; maybe save it
2482 ;; Check for Inf or NaN
2486 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2487 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2488 (inst and ah-tn #x02) ; Test sign of Inf.
2489 (inst jmp :z DONE) ; +Inf gives +Inf.
2490 (inst fstp fr0) ; -Inf gives -1.0
2493 (inst jmp-short DONE)
2495 ;; Free two stack slots leaving the argument on top.
2499 (inst fmul fr1) ; Now fr0 = x log2(e)
2514 (unless (zerop (tn-offset y))
2519 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2520 (:temporary (:sc double-reg :offset fr0-offset
2521 :from :argument :to :result) fr0)
2522 (:temporary (:sc double-reg :offset fr1-offset
2523 :from :argument :to :result) fr1)
2524 (:results (y :scs (double-reg)))
2525 (:arg-types double-float)
2526 (:result-types double-float)
2527 (:policy :fast-safe)
2528 (:note "inline log function")
2530 (:save-p :compute-only)
2532 (note-this-location vop :internal-error)
2547 ;; x is in a FP reg, not fr0 or fr1
2551 (inst fldd (make-random-tn :kind :normal
2552 :sc (sc-or-lose 'double-reg)
2553 :offset (1- (tn-offset x))))))
2555 ((double-stack descriptor-reg)
2559 (if (sc-is x double-stack)
2560 (inst fldd (ea-for-df-stack x))
2561 (inst fldd (ea-for-df-desc x)))
2566 (t (inst fstd y)))))
2568 (define-vop (flog10)
2570 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2571 (:temporary (:sc double-reg :offset fr0-offset
2572 :from :argument :to :result) fr0)
2573 (:temporary (:sc double-reg :offset fr1-offset
2574 :from :argument :to :result) fr1)
2575 (:results (y :scs (double-reg)))
2576 (:arg-types double-float)
2577 (:result-types double-float)
2578 (:policy :fast-safe)
2579 (:note "inline log10 function")
2581 (:save-p :compute-only)
2583 (note-this-location vop :internal-error)
2598 ;; x is in a FP reg, not fr0 or fr1
2602 (inst fldd (make-random-tn :kind :normal
2603 :sc (sc-or-lose 'double-reg)
2604 :offset (1- (tn-offset x))))))
2606 ((double-stack descriptor-reg)
2610 (if (sc-is x double-stack)
2611 (inst fldd (ea-for-df-stack x))
2612 (inst fldd (ea-for-df-desc x)))
2617 (t (inst fstd y)))))
2621 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2622 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2623 (:temporary (:sc double-reg :offset fr0-offset
2624 :from (:argument 0) :to :result) fr0)
2625 (:temporary (:sc double-reg :offset fr1-offset
2626 :from (:argument 1) :to :result) fr1)
2627 (:temporary (:sc double-reg :offset fr2-offset
2628 :from :load :to :result) fr2)
2629 (:results (r :scs (double-reg)))
2630 (:arg-types double-float double-float)
2631 (:result-types double-float)
2632 (:policy :fast-safe)
2633 (:note "inline pow function")
2635 (:save-p :compute-only)
2637 (note-this-location vop :internal-error)
2638 ;; Setup x in fr0 and y in fr1
2640 ;; x in fr0; y in fr1
2641 ((and (sc-is x double-reg) (zerop (tn-offset x))
2642 (sc-is y double-reg) (= 1 (tn-offset y))))
2643 ;; y in fr1; x not in fr0
2644 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2648 (copy-fp-reg-to-fr0 x))
2651 (inst fldd (ea-for-df-stack x)))
2654 (inst fldd (ea-for-df-desc x)))))
2655 ;; x in fr0; y not in fr1
2656 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2658 ;; Now load y to fr0
2661 (copy-fp-reg-to-fr0 y))
2664 (inst fldd (ea-for-df-stack y)))
2667 (inst fldd (ea-for-df-desc y))))
2669 ;; x in fr1; y not in fr1
2670 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2674 (copy-fp-reg-to-fr0 y))
2677 (inst fldd (ea-for-df-stack y)))
2680 (inst fldd (ea-for-df-desc y))))
2683 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2685 ;; Now load x to fr0
2688 (copy-fp-reg-to-fr0 x))
2691 (inst fldd (ea-for-df-stack x)))
2694 (inst fldd (ea-for-df-desc x)))))
2695 ;; Neither x or y are in either fr0 or fr1
2702 (inst fldd (make-random-tn :kind :normal
2703 :sc (sc-or-lose 'double-reg)
2704 :offset (- (tn-offset y) 2))))
2706 (inst fldd (ea-for-df-stack y)))
2708 (inst fldd (ea-for-df-desc y))))
2712 (inst fldd (make-random-tn :kind :normal
2713 :sc (sc-or-lose 'double-reg)
2714 :offset (1- (tn-offset x)))))
2716 (inst fldd (ea-for-df-stack x)))
2718 (inst fldd (ea-for-df-desc x))))))
2720 ;; Now have x at fr0; and y at fr1
2722 ;; Now fr0=y log2(x)
2726 (inst fsubp-sti fr1)
2729 (inst faddp-sti fr1)
2734 (t (inst fstd r)))))
2736 (define-vop (fscalen)
2737 (:translate %scalbn)
2738 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2739 (y :scs (signed-stack signed-reg) :target temp))
2740 (:temporary (:sc double-reg :offset fr0-offset
2741 :from (:argument 0) :to :result) fr0)
2742 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2743 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2744 (:results (r :scs (double-reg)))
2745 (:arg-types double-float signed-num)
2746 (:result-types double-float)
2747 (:policy :fast-safe)
2748 (:note "inline scalbn function")
2750 ;; Setup x in fr0 and y in fr1
2781 (inst fld (make-random-tn :kind :normal
2782 :sc (sc-or-lose 'double-reg)
2783 :offset (1- (tn-offset x)))))))
2784 ((double-stack descriptor-reg)
2793 (if (sc-is x double-stack)
2794 (inst fldd (ea-for-df-stack x))
2795 (inst fldd (ea-for-df-desc x)))))
2797 (unless (zerop (tn-offset r))
2800 (define-vop (fscale)
2802 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2803 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2804 (:temporary (:sc double-reg :offset fr0-offset
2805 :from (:argument 0) :to :result) fr0)
2806 (:temporary (:sc double-reg :offset fr1-offset
2807 :from (:argument 1) :to :result) fr1)
2808 (:results (r :scs (double-reg)))
2809 (:arg-types double-float double-float)
2810 (:result-types double-float)
2811 (:policy :fast-safe)
2812 (:note "inline scalb function")
2814 (:save-p :compute-only)
2816 (note-this-location vop :internal-error)
2817 ;; Setup x in fr0 and y in fr1
2819 ;; x in fr0; y in fr1
2820 ((and (sc-is x double-reg) (zerop (tn-offset x))
2821 (sc-is y double-reg) (= 1 (tn-offset y))))
2822 ;; y in fr1; x not in fr0
2823 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2827 (copy-fp-reg-to-fr0 x))
2830 (inst fldd (ea-for-df-stack x)))
2833 (inst fldd (ea-for-df-desc x)))))
2834 ;; x in fr0; y not in fr1
2835 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2837 ;; Now load y to fr0
2840 (copy-fp-reg-to-fr0 y))
2843 (inst fldd (ea-for-df-stack y)))
2846 (inst fldd (ea-for-df-desc y))))
2848 ;; x in fr1; y not in fr1
2849 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2853 (copy-fp-reg-to-fr0 y))
2856 (inst fldd (ea-for-df-stack y)))
2859 (inst fldd (ea-for-df-desc y))))
2862 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2864 ;; Now load x to fr0
2867 (copy-fp-reg-to-fr0 x))
2870 (inst fldd (ea-for-df-stack x)))
2873 (inst fldd (ea-for-df-desc x)))))
2874 ;; Neither x or y are in either fr0 or fr1
2881 (inst fldd (make-random-tn :kind :normal
2882 :sc (sc-or-lose 'double-reg)
2883 :offset (- (tn-offset y) 2))))
2885 (inst fldd (ea-for-df-stack y)))
2887 (inst fldd (ea-for-df-desc y))))
2891 (inst fldd (make-random-tn :kind :normal
2892 :sc (sc-or-lose 'double-reg)
2893 :offset (1- (tn-offset x)))))
2895 (inst fldd (ea-for-df-stack x)))
2897 (inst fldd (ea-for-df-desc x))))))
2899 ;; Now have x at fr0; and y at fr1
2901 (unless (zerop (tn-offset r))
2904 (define-vop (flog1p)
2906 (:args (x :scs (double-reg) :to :result))
2907 (:temporary (:sc double-reg :offset fr0-offset
2908 :from :argument :to :result) fr0)
2909 (:temporary (:sc double-reg :offset fr1-offset
2910 :from :argument :to :result) fr1)
2911 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2912 (:results (y :scs (double-reg)))
2913 (:arg-types double-float)
2914 (:result-types double-float)
2915 (:policy :fast-safe)
2916 (:note "inline log1p function")
2919 ;; x is in a FP reg, not fr0, fr1.
2922 (inst fldd (make-random-tn :kind :normal
2923 :sc (sc-or-lose 'double-reg)
2924 :offset (- (tn-offset x) 2)))
2926 (inst push #x3e947ae1) ; Constant 0.29
2928 (inst fld (make-ea :dword :base esp-tn))
2931 (inst fnstsw) ; status word to ax
2932 (inst and ah-tn #x45)
2933 (inst jmp :z WITHIN-RANGE)
2934 ;; Out of range for fyl2xp1.
2936 (inst faddd (make-random-tn :kind :normal
2937 :sc (sc-or-lose 'double-reg)
2938 :offset (- (tn-offset x) 1)))
2946 (inst fldd (make-random-tn :kind :normal
2947 :sc (sc-or-lose 'double-reg)
2948 :offset (- (tn-offset x) 1)))
2954 (t (inst fstd y)))))
2956 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2957 ;;; instruction and a range check can be avoided.
2958 (define-vop (flog1p-pentium)
2960 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2961 (:temporary (:sc double-reg :offset fr0-offset
2962 :from :argument :to :result) fr0)
2963 (:temporary (:sc double-reg :offset fr1-offset
2964 :from :argument :to :result) fr1)
2965 (:results (y :scs (double-reg)))
2966 (:arg-types double-float)
2967 (:result-types double-float)
2968 (:policy :fast-safe)
2969 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2970 (:note "inline log1p with limited x range function")
2972 (:save-p :compute-only)
2974 (note-this-location vop :internal-error)
2989 ;; x is in a FP reg, not fr0 or fr1
2993 (inst fldd (make-random-tn :kind :normal
2994 :sc (sc-or-lose 'double-reg)
2995 :offset (1- (tn-offset x)))))))
2996 ((double-stack descriptor-reg)
3000 (if (sc-is x double-stack)
3001 (inst fldd (ea-for-df-stack x))
3002 (inst fldd (ea-for-df-desc x)))))
3007 (t (inst fstd y)))))
3011 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3012 (:temporary (:sc double-reg :offset fr0-offset
3013 :from :argument :to :result) fr0)
3014 (:temporary (:sc double-reg :offset fr1-offset
3015 :from :argument :to :result) fr1)
3016 (:results (y :scs (double-reg)))
3017 (:arg-types double-float)
3018 (:result-types double-float)
3019 (:policy :fast-safe)
3020 (:note "inline logb function")
3022 (:save-p :compute-only)
3024 (note-this-location vop :internal-error)
3035 ;; x is in a FP reg, not fr0 or fr1
3038 (inst fldd (make-random-tn :kind :normal
3039 :sc (sc-or-lose 'double-reg)
3040 :offset (- (tn-offset x) 2))))))
3041 ((double-stack descriptor-reg)
3044 (if (sc-is x double-stack)
3045 (inst fldd (ea-for-df-stack x))
3046 (inst fldd (ea-for-df-desc x)))))
3057 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3058 (:temporary (:sc double-reg :offset fr0-offset
3059 :from (:argument 0) :to :result) fr0)
3060 (:temporary (:sc double-reg :offset fr1-offset
3061 :from (:argument 0) :to :result) fr1)
3062 (:results (r :scs (double-reg)))
3063 (:arg-types double-float)
3064 (:result-types double-float)
3065 (:policy :fast-safe)
3066 (:note "inline atan function")
3068 (:save-p :compute-only)
3070 (note-this-location vop :internal-error)
3071 ;; Setup x in fr1 and 1.0 in fr0
3074 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3077 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3079 ;; x not in fr0 or fr1
3086 (inst fldd (make-random-tn :kind :normal
3087 :sc (sc-or-lose 'double-reg)
3088 :offset (- (tn-offset x) 2))))
3090 (inst fldd (ea-for-df-stack x)))
3092 (inst fldd (ea-for-df-desc x))))))
3094 ;; Now have x at fr1; and 1.0 at fr0
3099 (t (inst fstd r)))))
3101 (define-vop (fatan2)
3103 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3104 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3105 (:temporary (:sc double-reg :offset fr0-offset
3106 :from (:argument 1) :to :result) fr0)
3107 (:temporary (:sc double-reg :offset fr1-offset
3108 :from (:argument 0) :to :result) fr1)
3109 (:results (r :scs (double-reg)))
3110 (:arg-types double-float double-float)
3111 (:result-types double-float)
3112 (:policy :fast-safe)
3113 (:note "inline atan2 function")
3115 (:save-p :compute-only)
3117 (note-this-location vop :internal-error)
3118 ;; Setup x in fr1 and y in fr0
3120 ;; y in fr0; x in fr1
3121 ((and (sc-is y double-reg) (zerop (tn-offset y))
3122 (sc-is x double-reg) (= 1 (tn-offset x))))
3123 ;; x in fr1; y not in fr0
3124 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3128 (copy-fp-reg-to-fr0 y))
3131 (inst fldd (ea-for-df-stack y)))
3134 (inst fldd (ea-for-df-desc y)))))
3135 ((and (sc-is x double-reg) (zerop (tn-offset x))
3136 (sc-is y double-reg) (zerop (tn-offset x)))
3139 ;; y in fr0; x not in fr1
3140 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3142 ;; Now load x to fr0
3145 (copy-fp-reg-to-fr0 x))
3148 (inst fldd (ea-for-df-stack x)))
3151 (inst fldd (ea-for-df-desc x))))
3153 ;; y in fr1; x not in fr1
3154 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3158 (copy-fp-reg-to-fr0 x))
3161 (inst fldd (ea-for-df-stack x)))
3164 (inst fldd (ea-for-df-desc x))))
3167 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3169 ;; Now load y to fr0
3172 (copy-fp-reg-to-fr0 y))
3175 (inst fldd (ea-for-df-stack y)))
3178 (inst fldd (ea-for-df-desc y)))))
3179 ;; Neither y or x are in either fr0 or fr1
3186 (inst fldd (make-random-tn :kind :normal
3187 :sc (sc-or-lose 'double-reg)
3188 :offset (- (tn-offset x) 2))))
3190 (inst fldd (ea-for-df-stack x)))
3192 (inst fldd (ea-for-df-desc x))))
3196 (inst fldd (make-random-tn :kind :normal
3197 :sc (sc-or-lose 'double-reg)
3198 :offset (1- (tn-offset y)))))
3200 (inst fldd (ea-for-df-stack y)))
3202 (inst fldd (ea-for-df-desc y))))))
3204 ;; Now have y at fr0; and x at fr1
3209 (t (inst fstd r)))))
3210 ) ; PROGN #!-LONG-FLOAT
3215 ;;; Lets use some of the 80387 special functions.
3217 ;;; These defs will not take effect unless code/irrat.lisp is modified
3218 ;;; to remove the inlined alien routine def.
3220 (macrolet ((frob (func trans op)
3221 `(define-vop (,func)
3222 (:args (x :scs (long-reg) :target fr0))
3223 (:temporary (:sc long-reg :offset fr0-offset
3224 :from :argument :to :result) fr0)
3226 (:results (y :scs (long-reg)))
3227 (:arg-types long-float)
3228 (:result-types long-float)
3230 (:policy :fast-safe)
3231 (:note "inline NPX function")
3233 (:save-p :compute-only)
3236 (note-this-location vop :internal-error)
3237 (unless (zerop (tn-offset x))
3238 (inst fxch x) ; x to top of stack
3239 (unless (location= x y)
3240 (inst fst x))) ; maybe save it
3241 (inst ,op) ; clobber st0
3242 (cond ((zerop (tn-offset y))
3243 (maybe-fp-wait node))
3247 ;; Quick versions of FSIN and FCOS that require the argument to be
3248 ;; within range 2^63.
3249 (frob fsin-quick %sin-quick fsin)
3250 (frob fcos-quick %cos-quick fcos)
3251 (frob fsqrt %sqrt fsqrt))
3253 ;;; Quick version of ftan that requires the argument to be within
3255 (define-vop (ftan-quick)
3256 (:translate %tan-quick)
3257 (:args (x :scs (long-reg) :target fr0))
3258 (:temporary (:sc long-reg :offset fr0-offset
3259 :from :argument :to :result) fr0)
3260 (:temporary (:sc long-reg :offset fr1-offset
3261 :from :argument :to :result) fr1)
3262 (:results (y :scs (long-reg)))
3263 (:arg-types long-float)
3264 (:result-types long-float)
3265 (:policy :fast-safe)
3266 (:note "inline tan function")
3268 (:save-p :compute-only)
3270 (note-this-location vop :internal-error)
3279 (inst fldd (make-random-tn :kind :normal
3280 :sc (sc-or-lose 'double-reg)
3281 :offset (- (tn-offset x) 2)))))
3292 ;;; These versions of fsin, fcos, and ftan try to use argument
3293 ;;; reduction but to do this accurately requires greater precision and
3294 ;;; it is hopelessly inaccurate.
3296 (macrolet ((frob (func trans op)
3297 `(define-vop (,func)
3299 (:args (x :scs (long-reg) :target fr0))
3300 (:temporary (:sc unsigned-reg :offset eax-offset
3301 :from :eval :to :result) eax)
3302 (:temporary (:sc long-reg :offset fr0-offset
3303 :from :argument :to :result) fr0)
3304 (:temporary (:sc long-reg :offset fr1-offset
3305 :from :argument :to :result) fr1)
3306 (:results (y :scs (long-reg)))
3307 (:arg-types long-float)
3308 (:result-types long-float)
3309 (:policy :fast-safe)
3310 (:note "inline sin/cos function")
3312 (:save-p :compute-only)
3315 (note-this-location vop :internal-error)
3316 (unless (zerop (tn-offset x))
3317 (inst fxch x) ; x to top of stack
3318 (unless (location= x y)
3319 (inst fst x))) ; maybe save it
3321 (inst fnstsw) ; status word to ax
3322 (inst and ah-tn #x04) ; C2
3324 ;; Else x was out of range so reduce it; ST0 is unchanged.
3325 (inst fstp fr1) ; Load 2*PI
3331 (inst fnstsw) ; status word to ax
3332 (inst and ah-tn #x04) ; C2
3336 (unless (zerop (tn-offset y))
3338 (frob fsin %sin fsin)
3339 (frob fcos %cos fcos))
3344 (:args (x :scs (long-reg) :target fr0))
3345 (:temporary (:sc unsigned-reg :offset eax-offset
3346 :from :argument :to :result) eax)
3347 (:temporary (:sc long-reg :offset fr0-offset
3348 :from :argument :to :result) fr0)
3349 (:temporary (:sc long-reg :offset fr1-offset
3350 :from :argument :to :result) fr1)
3351 (:results (y :scs (long-reg)))
3352 (:arg-types long-float)
3353 (:result-types long-float)
3354 (:policy :fast-safe)
3355 (:note "inline tan function")
3357 (:save-p :compute-only)
3360 (note-this-location vop :internal-error)
3369 (inst fldd (make-random-tn :kind :normal
3370 :sc (sc-or-lose 'double-reg)
3371 :offset (- (tn-offset x) 2)))))
3373 (inst fnstsw) ; status word to ax
3374 (inst and ah-tn #x04) ; C2
3376 ;; Else x was out of range so reduce it; ST0 is unchanged.
3377 (inst fldpi) ; Load 2*PI
3382 (inst fnstsw) ; status word to ax
3383 (inst and ah-tn #x04) ; C2
3397 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3398 ;;; the argument is out of range 2^63 and would thus be hopelessly
3400 (macrolet ((frob (func trans op)
3401 `(define-vop (,func)
3403 (:args (x :scs (long-reg) :target fr0))
3404 (:temporary (:sc long-reg :offset fr0-offset
3405 :from :argument :to :result) fr0)
3406 (:temporary (:sc unsigned-reg :offset eax-offset
3407 :from :argument :to :result) eax)
3408 (:results (y :scs (long-reg)))
3409 (:arg-types long-float)
3410 (:result-types long-float)
3411 (:policy :fast-safe)
3412 (:note "inline sin/cos function")
3414 (:save-p :compute-only)
3417 (note-this-location vop :internal-error)
3418 (unless (zerop (tn-offset x))
3419 (inst fxch x) ; x to top of stack
3420 (unless (location= x y)
3421 (inst fst x))) ; maybe save it
3423 (inst fnstsw) ; status word to ax
3424 (inst and ah-tn #x04) ; C2
3426 ;; Else x was out of range so reduce it; ST0 is unchanged.
3427 (inst fstp fr0) ; Load 0.0
3430 (unless (zerop (tn-offset y))
3432 (frob fsin %sin fsin)
3433 (frob fcos %cos fcos))
3437 (:args (x :scs (long-reg) :target fr0))
3438 (:temporary (:sc long-reg :offset fr0-offset
3439 :from :argument :to :result) fr0)
3440 (:temporary (:sc long-reg :offset fr1-offset
3441 :from :argument :to :result) fr1)
3442 (:temporary (:sc unsigned-reg :offset eax-offset
3443 :from :argument :to :result) eax)
3444 (:results (y :scs (long-reg)))
3445 (:arg-types long-float)
3446 (:result-types long-float)
3448 (:policy :fast-safe)
3449 (:note "inline tan function")
3451 (:save-p :compute-only)
3454 (note-this-location vop :internal-error)
3463 (inst fldd (make-random-tn :kind :normal
3464 :sc (sc-or-lose 'double-reg)
3465 :offset (- (tn-offset x) 2)))))
3467 (inst fnstsw) ; status word to ax
3468 (inst and ah-tn #x04) ; C2
3470 ;; Else x was out of range so reduce it; ST0 is unchanged.
3471 (inst fldz) ; Load 0.0
3483 ;;; Modified exp that handles the following special cases:
3484 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3487 (:args (x :scs (long-reg) :target fr0))
3488 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3489 (:temporary (:sc long-reg :offset fr0-offset
3490 :from :argument :to :result) fr0)
3491 (:temporary (:sc long-reg :offset fr1-offset
3492 :from :argument :to :result) fr1)
3493 (:temporary (:sc long-reg :offset fr2-offset
3494 :from :argument :to :result) fr2)
3495 (:results (y :scs (long-reg)))
3496 (:arg-types long-float)
3497 (:result-types long-float)
3498 (:policy :fast-safe)
3499 (:note "inline exp function")
3501 (:save-p :compute-only)
3504 (note-this-location vop :internal-error)
3505 (unless (zerop (tn-offset x))
3506 (inst fxch x) ; x to top of stack
3507 (unless (location= x y)
3508 (inst fst x))) ; maybe save it
3509 ;; Check for Inf or NaN
3513 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3514 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3515 (inst and ah-tn #x02) ; Test sign of Inf.
3516 (inst jmp :z DONE) ; +Inf gives +Inf.
3517 (inst fstp fr0) ; -Inf gives 0
3519 (inst jmp-short DONE)
3524 ;; Now fr0=x log2(e)
3528 (inst fsubp-sti fr1)
3531 (inst faddp-sti fr1)
3535 (unless (zerop (tn-offset y))
3538 ;;; Expm1 = exp(x) - 1.
3539 ;;; Handles the following special cases:
3540 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3541 (define-vop (fexpm1)
3543 (:args (x :scs (long-reg) :target fr0))
3544 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3545 (:temporary (:sc long-reg :offset fr0-offset
3546 :from :argument :to :result) fr0)
3547 (:temporary (:sc long-reg :offset fr1-offset
3548 :from :argument :to :result) fr1)
3549 (:temporary (:sc long-reg :offset fr2-offset
3550 :from :argument :to :result) fr2)
3551 (:results (y :scs (long-reg)))
3552 (:arg-types long-float)
3553 (:result-types long-float)
3554 (:policy :fast-safe)
3555 (:note "inline expm1 function")
3557 (:save-p :compute-only)
3560 (note-this-location vop :internal-error)
3561 (unless (zerop (tn-offset x))
3562 (inst fxch x) ; x to top of stack
3563 (unless (location= x y)
3564 (inst fst x))) ; maybe save it
3565 ;; Check for Inf or NaN
3569 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3570 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3571 (inst and ah-tn #x02) ; Test sign of Inf.
3572 (inst jmp :z DONE) ; +Inf gives +Inf.
3573 (inst fstp fr0) ; -Inf gives -1.0
3576 (inst jmp-short DONE)
3578 ;; Free two stack slots leaving the argument on top.
3582 (inst fmul fr1) ; Now fr0 = x log2(e)
3597 (unless (zerop (tn-offset y))
3602 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3603 (:temporary (:sc long-reg :offset fr0-offset
3604 :from :argument :to :result) fr0)
3605 (:temporary (:sc long-reg :offset fr1-offset
3606 :from :argument :to :result) fr1)
3607 (:results (y :scs (long-reg)))
3608 (:arg-types long-float)
3609 (:result-types long-float)
3610 (:policy :fast-safe)
3611 (:note "inline log function")
3613 (:save-p :compute-only)
3615 (note-this-location vop :internal-error)
3630 ;; x is in a FP reg, not fr0 or fr1
3634 (inst fldd (make-random-tn :kind :normal
3635 :sc (sc-or-lose 'double-reg)
3636 :offset (1- (tn-offset x))))))
3638 ((long-stack descriptor-reg)
3642 (if (sc-is x long-stack)
3643 (inst fldl (ea-for-lf-stack x))
3644 (inst fldl (ea-for-lf-desc x)))
3649 (t (inst fstd y)))))
3651 (define-vop (flog10)
3653 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3654 (:temporary (:sc long-reg :offset fr0-offset
3655 :from :argument :to :result) fr0)
3656 (:temporary (:sc long-reg :offset fr1-offset
3657 :from :argument :to :result) fr1)
3658 (:results (y :scs (long-reg)))
3659 (:arg-types long-float)
3660 (:result-types long-float)
3661 (:policy :fast-safe)
3662 (:note "inline log10 function")
3664 (:save-p :compute-only)
3666 (note-this-location vop :internal-error)
3681 ;; x is in a FP reg, not fr0 or fr1
3685 (inst fldd (make-random-tn :kind :normal
3686 :sc (sc-or-lose 'double-reg)
3687 :offset (1- (tn-offset x))))))
3689 ((long-stack descriptor-reg)
3693 (if (sc-is x long-stack)
3694 (inst fldl (ea-for-lf-stack x))
3695 (inst fldl (ea-for-lf-desc x)))
3700 (t (inst fstd y)))))
3704 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3705 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3706 (:temporary (:sc long-reg :offset fr0-offset
3707 :from (:argument 0) :to :result) fr0)
3708 (:temporary (:sc long-reg :offset fr1-offset
3709 :from (:argument 1) :to :result) fr1)
3710 (:temporary (:sc long-reg :offset fr2-offset
3711 :from :load :to :result) fr2)
3712 (:results (r :scs (long-reg)))
3713 (:arg-types long-float long-float)
3714 (:result-types long-float)
3715 (:policy :fast-safe)
3716 (:note "inline pow function")
3718 (:save-p :compute-only)
3720 (note-this-location vop :internal-error)
3721 ;; Setup x in fr0 and y in fr1
3723 ;; x in fr0; y in fr1
3724 ((and (sc-is x long-reg) (zerop (tn-offset x))
3725 (sc-is y long-reg) (= 1 (tn-offset y))))
3726 ;; y in fr1; x not in fr0
3727 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3731 (copy-fp-reg-to-fr0 x))
3734 (inst fldl (ea-for-lf-stack x)))
3737 (inst fldl (ea-for-lf-desc x)))))
3738 ;; x in fr0; y not in fr1
3739 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3741 ;; Now load y to fr0
3744 (copy-fp-reg-to-fr0 y))
3747 (inst fldl (ea-for-lf-stack y)))
3750 (inst fldl (ea-for-lf-desc y))))
3752 ;; x in fr1; y not in fr1
3753 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3757 (copy-fp-reg-to-fr0 y))
3760 (inst fldl (ea-for-lf-stack y)))
3763 (inst fldl (ea-for-lf-desc y))))
3766 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3768 ;; Now load x to fr0
3771 (copy-fp-reg-to-fr0 x))
3774 (inst fldl (ea-for-lf-stack x)))
3777 (inst fldl (ea-for-lf-desc x)))))
3778 ;; Neither x or y are in either fr0 or fr1
3785 (inst fldd (make-random-tn :kind :normal
3786 :sc (sc-or-lose 'double-reg)
3787 :offset (- (tn-offset y) 2))))
3789 (inst fldl (ea-for-lf-stack y)))
3791 (inst fldl (ea-for-lf-desc y))))
3795 (inst fldd (make-random-tn :kind :normal
3796 :sc (sc-or-lose 'double-reg)
3797 :offset (1- (tn-offset x)))))
3799 (inst fldl (ea-for-lf-stack x)))
3801 (inst fldl (ea-for-lf-desc x))))))
3803 ;; Now have x at fr0; and y at fr1
3805 ;; Now fr0=y log2(x)
3809 (inst fsubp-sti fr1)
3812 (inst faddp-sti fr1)
3817 (t (inst fstd r)))))
3819 (define-vop (fscalen)
3820 (:translate %scalbn)
3821 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3822 (y :scs (signed-stack signed-reg) :target temp))
3823 (:temporary (:sc long-reg :offset fr0-offset
3824 :from (:argument 0) :to :result) fr0)
3825 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3826 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3827 (:results (r :scs (long-reg)))
3828 (:arg-types long-float signed-num)
3829 (:result-types long-float)
3830 (:policy :fast-safe)
3831 (:note "inline scalbn function")
3833 ;; Setup x in fr0 and y in fr1
3864 (inst fld (make-random-tn :kind :normal
3865 :sc (sc-or-lose 'double-reg)
3866 :offset (1- (tn-offset x)))))))
3867 ((long-stack descriptor-reg)
3876 (if (sc-is x long-stack)
3877 (inst fldl (ea-for-lf-stack x))
3878 (inst fldl (ea-for-lf-desc x)))))
3880 (unless (zerop (tn-offset r))
3883 (define-vop (fscale)
3885 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3886 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3887 (:temporary (:sc long-reg :offset fr0-offset
3888 :from (:argument 0) :to :result) fr0)
3889 (:temporary (:sc long-reg :offset fr1-offset
3890 :from (:argument 1) :to :result) fr1)
3891 (:results (r :scs (long-reg)))
3892 (:arg-types long-float long-float)
3893 (:result-types long-float)
3894 (:policy :fast-safe)
3895 (:note "inline scalb function")
3897 (:save-p :compute-only)
3899 (note-this-location vop :internal-error)
3900 ;; Setup x in fr0 and y in fr1
3902 ;; x in fr0; y in fr1
3903 ((and (sc-is x long-reg) (zerop (tn-offset x))
3904 (sc-is y long-reg) (= 1 (tn-offset y))))
3905 ;; y in fr1; x not in fr0
3906 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3910 (copy-fp-reg-to-fr0 x))
3913 (inst fldl (ea-for-lf-stack x)))
3916 (inst fldl (ea-for-lf-desc x)))))
3917 ;; x in fr0; y not in fr1
3918 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3920 ;; Now load y to fr0
3923 (copy-fp-reg-to-fr0 y))
3926 (inst fldl (ea-for-lf-stack y)))
3929 (inst fldl (ea-for-lf-desc y))))
3931 ;; x in fr1; y not in fr1
3932 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3936 (copy-fp-reg-to-fr0 y))
3939 (inst fldl (ea-for-lf-stack y)))
3942 (inst fldl (ea-for-lf-desc y))))
3945 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3947 ;; Now load x to fr0
3950 (copy-fp-reg-to-fr0 x))
3953 (inst fldl (ea-for-lf-stack x)))
3956 (inst fldl (ea-for-lf-desc x)))))
3957 ;; Neither x or y are in either fr0 or fr1
3964 (inst fldd (make-random-tn :kind :normal
3965 :sc (sc-or-lose 'double-reg)
3966 :offset (- (tn-offset y) 2))))
3968 (inst fldl (ea-for-lf-stack y)))
3970 (inst fldl (ea-for-lf-desc y))))
3974 (inst fldd (make-random-tn :kind :normal
3975 :sc (sc-or-lose 'double-reg)
3976 :offset (1- (tn-offset x)))))
3978 (inst fldl (ea-for-lf-stack x)))
3980 (inst fldl (ea-for-lf-desc x))))))
3982 ;; Now have x at fr0; and y at fr1
3984 (unless (zerop (tn-offset r))
3987 (define-vop (flog1p)
3989 (:args (x :scs (long-reg) :to :result))
3990 (:temporary (:sc long-reg :offset fr0-offset
3991 :from :argument :to :result) fr0)
3992 (:temporary (:sc long-reg :offset fr1-offset
3993 :from :argument :to :result) fr1)
3994 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3995 (:results (y :scs (long-reg)))
3996 (:arg-types long-float)
3997 (:result-types long-float)
3998 (:policy :fast-safe)
3999 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
4000 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
4001 ;; an enormous PROGN above. Still, it would be probably be good to
4002 ;; add some code to warn about redefining VOPs.
4003 (:note "inline log1p function")
4006 ;; x is in a FP reg, not fr0, fr1.
4009 (inst fldd (make-random-tn :kind :normal
4010 :sc (sc-or-lose 'double-reg)
4011 :offset (- (tn-offset x) 2)))
4013 (inst push #x3e947ae1) ; Constant 0.29
4015 (inst fld (make-ea :dword :base esp-tn))
4018 (inst fnstsw) ; status word to ax
4019 (inst and ah-tn #x45)
4020 (inst jmp :z WITHIN-RANGE)
4021 ;; Out of range for fyl2xp1.
4023 (inst faddd (make-random-tn :kind :normal
4024 :sc (sc-or-lose 'double-reg)
4025 :offset (- (tn-offset x) 1)))
4033 (inst fldd (make-random-tn :kind :normal
4034 :sc (sc-or-lose 'double-reg)
4035 :offset (- (tn-offset x) 1)))
4041 (t (inst fstd y)))))
4043 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4044 ;;; instruction and a range check can be avoided.
4045 (define-vop (flog1p-pentium)
4047 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4048 (:temporary (:sc long-reg :offset fr0-offset
4049 :from :argument :to :result) fr0)
4050 (:temporary (:sc long-reg :offset fr1-offset
4051 :from :argument :to :result) fr1)
4052 (:results (y :scs (long-reg)))
4053 (:arg-types long-float)
4054 (:result-types long-float)
4055 (:policy :fast-safe)
4056 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
4057 (:note "inline log1p function")
4073 ;; x is in a FP reg, not fr0 or fr1
4077 (inst fldd (make-random-tn :kind :normal
4078 :sc (sc-or-lose 'double-reg)
4079 :offset (1- (tn-offset x)))))))
4080 ((long-stack descriptor-reg)
4084 (if (sc-is x long-stack)
4085 (inst fldl (ea-for-lf-stack x))
4086 (inst fldl (ea-for-lf-desc x)))))
4091 (t (inst fstd y)))))
4095 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4096 (:temporary (:sc long-reg :offset fr0-offset
4097 :from :argument :to :result) fr0)
4098 (:temporary (:sc long-reg :offset fr1-offset
4099 :from :argument :to :result) fr1)
4100 (:results (y :scs (long-reg)))
4101 (:arg-types long-float)
4102 (:result-types long-float)
4103 (:policy :fast-safe)
4104 (:note "inline logb function")
4106 (:save-p :compute-only)
4108 (note-this-location vop :internal-error)
4119 ;; x is in a FP reg, not fr0 or fr1
4122 (inst fldd (make-random-tn :kind :normal
4123 :sc (sc-or-lose 'double-reg)
4124 :offset (- (tn-offset x) 2))))))
4125 ((long-stack descriptor-reg)
4128 (if (sc-is x long-stack)
4129 (inst fldl (ea-for-lf-stack x))
4130 (inst fldl (ea-for-lf-desc x)))))
4141 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4142 (:temporary (:sc long-reg :offset fr0-offset
4143 :from (:argument 0) :to :result) fr0)
4144 (:temporary (:sc long-reg :offset fr1-offset
4145 :from (:argument 0) :to :result) fr1)
4146 (:results (r :scs (long-reg)))
4147 (:arg-types long-float)
4148 (:result-types long-float)
4149 (:policy :fast-safe)
4150 (:note "inline atan function")
4152 (:save-p :compute-only)
4154 (note-this-location vop :internal-error)
4155 ;; Setup x in fr1 and 1.0 in fr0
4158 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4161 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4163 ;; x not in fr0 or fr1
4170 (inst fldd (make-random-tn :kind :normal
4171 :sc (sc-or-lose 'double-reg)
4172 :offset (- (tn-offset x) 2))))
4174 (inst fldl (ea-for-lf-stack x)))
4176 (inst fldl (ea-for-lf-desc x))))))
4178 ;; Now have x at fr1; and 1.0 at fr0
4183 (t (inst fstd r)))))
4185 (define-vop (fatan2)
4187 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4188 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4189 (:temporary (:sc long-reg :offset fr0-offset
4190 :from (:argument 1) :to :result) fr0)
4191 (:temporary (:sc long-reg :offset fr1-offset
4192 :from (:argument 0) :to :result) fr1)
4193 (:results (r :scs (long-reg)))
4194 (:arg-types long-float long-float)
4195 (:result-types long-float)
4196 (:policy :fast-safe)
4197 (:note "inline atan2 function")
4199 (:save-p :compute-only)
4201 (note-this-location vop :internal-error)
4202 ;; Setup x in fr1 and y in fr0
4204 ;; y in fr0; x in fr1
4205 ((and (sc-is y long-reg) (zerop (tn-offset y))
4206 (sc-is x long-reg) (= 1 (tn-offset x))))
4207 ;; x in fr1; y not in fr0
4208 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4212 (copy-fp-reg-to-fr0 y))
4215 (inst fldl (ea-for-lf-stack y)))
4218 (inst fldl (ea-for-lf-desc y)))))
4219 ;; y in fr0; x not in fr1
4220 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4222 ;; Now load x to fr0
4225 (copy-fp-reg-to-fr0 x))
4228 (inst fldl (ea-for-lf-stack x)))
4231 (inst fldl (ea-for-lf-desc x))))
4233 ;; y in fr1; x not in fr1
4234 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4238 (copy-fp-reg-to-fr0 x))
4241 (inst fldl (ea-for-lf-stack x)))
4244 (inst fldl (ea-for-lf-desc x))))
4247 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4249 ;; Now load y to fr0
4252 (copy-fp-reg-to-fr0 y))
4255 (inst fldl (ea-for-lf-stack y)))
4258 (inst fldl (ea-for-lf-desc y)))))
4259 ;; Neither y or x are in either fr0 or fr1
4266 (inst fldd (make-random-tn :kind :normal
4267 :sc (sc-or-lose 'double-reg)
4268 :offset (- (tn-offset x) 2))))
4270 (inst fldl (ea-for-lf-stack x)))
4272 (inst fldl (ea-for-lf-desc x))))
4276 (inst fldd (make-random-tn :kind :normal
4277 :sc (sc-or-lose 'double-reg)
4278 :offset (1- (tn-offset y)))))
4280 (inst fldl (ea-for-lf-stack y)))
4282 (inst fldl (ea-for-lf-desc y))))))
4284 ;; Now have y at fr0; and x at fr1
4289 (t (inst fstd r)))))
4291 ) ; PROGN #!+LONG-FLOAT
4293 ;;;; complex float VOPs
4295 (define-vop (make-complex-single-float)
4296 (:translate complex)
4297 (:args (real :scs (single-reg) :to :result :target r
4298 :load-if (not (location= real r)))
4299 (imag :scs (single-reg) :to :save))
4300 (:arg-types single-float single-float)
4301 (:results (r :scs (complex-single-reg) :from (:argument 0)
4302 :load-if (not (sc-is r complex-single-stack))))
4303 (:result-types complex-single-float)
4304 (:note "inline complex single-float creation")
4305 (:policy :fast-safe)
4309 (let ((r-real (complex-double-reg-real-tn r)))
4310 (unless (location= real r-real)
4311 (cond ((zerop (tn-offset r-real))
4312 (copy-fp-reg-to-fr0 real))
4313 ((zerop (tn-offset real))
4318 (inst fxch real)))))
4319 (let ((r-imag (complex-double-reg-imag-tn r)))
4320 (unless (location= imag r-imag)
4321 (cond ((zerop (tn-offset imag))
4326 (inst fxch imag))))))
4327 (complex-single-stack
4328 (unless (location= real r)
4329 (cond ((zerop (tn-offset real))
4330 (inst fst (ea-for-csf-real-stack r)))
4333 (inst fst (ea-for-csf-real-stack r))
4336 (inst fst (ea-for-csf-imag-stack r))
4337 (inst fxch imag)))))
4339 (define-vop (make-complex-double-float)
4340 (:translate complex)
4341 (:args (real :scs (double-reg) :target r
4342 :load-if (not (location= real r)))
4343 (imag :scs (double-reg) :to :save))
4344 (:arg-types double-float double-float)
4345 (:results (r :scs (complex-double-reg) :from (:argument 0)
4346 :load-if (not (sc-is r complex-double-stack))))
4347 (:result-types complex-double-float)
4348 (:note "inline complex double-float creation")
4349 (:policy :fast-safe)
4353 (let ((r-real (complex-double-reg-real-tn r)))
4354 (unless (location= real r-real)
4355 (cond ((zerop (tn-offset r-real))
4356 (copy-fp-reg-to-fr0 real))
4357 ((zerop (tn-offset real))
4362 (inst fxch real)))))
4363 (let ((r-imag (complex-double-reg-imag-tn r)))
4364 (unless (location= imag r-imag)
4365 (cond ((zerop (tn-offset imag))
4370 (inst fxch imag))))))
4371 (complex-double-stack
4372 (unless (location= real r)
4373 (cond ((zerop (tn-offset real))
4374 (inst fstd (ea-for-cdf-real-stack r)))
4377 (inst fstd (ea-for-cdf-real-stack r))
4380 (inst fstd (ea-for-cdf-imag-stack r))
4381 (inst fxch imag)))))
4384 (define-vop (make-complex-long-float)
4385 (:translate complex)
4386 (:args (real :scs (long-reg) :target r
4387 :load-if (not (location= real r)))
4388 (imag :scs (long-reg) :to :save))
4389 (:arg-types long-float long-float)
4390 (:results (r :scs (complex-long-reg) :from (:argument 0)
4391 :load-if (not (sc-is r complex-long-stack))))
4392 (:result-types complex-long-float)
4393 (:note "inline complex long-float creation")
4394 (:policy :fast-safe)
4398 (let ((r-real (complex-double-reg-real-tn r)))
4399 (unless (location= real r-real)
4400 (cond ((zerop (tn-offset r-real))
4401 (copy-fp-reg-to-fr0 real))
4402 ((zerop (tn-offset real))
4407 (inst fxch real)))))
4408 (let ((r-imag (complex-double-reg-imag-tn r)))
4409 (unless (location= imag r-imag)
4410 (cond ((zerop (tn-offset imag))
4415 (inst fxch imag))))))
4417 (unless (location= real r)
4418 (cond ((zerop (tn-offset real))
4419 (store-long-float (ea-for-clf-real-stack r)))
4422 (store-long-float (ea-for-clf-real-stack r))
4425 (store-long-float (ea-for-clf-imag-stack r))
4426 (inst fxch imag)))))
4429 (define-vop (complex-float-value)
4430 (:args (x :target r))
4432 (:variant-vars offset)
4433 (:policy :fast-safe)
4435 (cond ((sc-is x complex-single-reg complex-double-reg
4436 #!+long-float complex-long-reg)
4438 (make-random-tn :kind :normal
4439 :sc (sc-or-lose 'double-reg)
4440 :offset (+ offset (tn-offset x)))))
4441 (unless (location= value-tn r)
4442 (cond ((zerop (tn-offset r))
4443 (copy-fp-reg-to-fr0 value-tn))
4444 ((zerop (tn-offset value-tn))
4447 (inst fxch value-tn)
4449 (inst fxch value-tn))))))
4450 ((sc-is r single-reg)
4451 (let ((ea (sc-case x
4452 (complex-single-stack
4454 (0 (ea-for-csf-real-stack x))
4455 (1 (ea-for-csf-imag-stack x))))
4458 (0 (ea-for-csf-real-desc x))
4459 (1 (ea-for-csf-imag-desc x)))))))
4460 (with-empty-tn@fp-top(r)
4462 ((sc-is r double-reg)
4463 (let ((ea (sc-case x
4464 (complex-double-stack
4466 (0 (ea-for-cdf-real-stack x))
4467 (1 (ea-for-cdf-imag-stack x))))
4470 (0 (ea-for-cdf-real-desc x))
4471 (1 (ea-for-cdf-imag-desc x)))))))
4472 (with-empty-tn@fp-top(r)
4476 (let ((ea (sc-case x
4479 (0 (ea-for-clf-real-stack x))
4480 (1 (ea-for-clf-imag-stack x))))
4483 (0 (ea-for-clf-real-desc x))
4484 (1 (ea-for-clf-imag-desc x)))))))
4485 (with-empty-tn@fp-top(r)
4487 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4489 (define-vop (realpart/complex-single-float complex-float-value)
4490 (:translate realpart)
4491 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4493 (:arg-types complex-single-float)
4494 (:results (r :scs (single-reg)))
4495 (:result-types single-float)
4496 (:note "complex float realpart")
4499 (define-vop (realpart/complex-double-float complex-float-value)
4500 (:translate realpart)
4501 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4503 (:arg-types complex-double-float)
4504 (:results (r :scs (double-reg)))
4505 (:result-types double-float)
4506 (:note "complex float realpart")
4510 (define-vop (realpart/complex-long-float complex-float-value)
4511 (:translate realpart)
4512 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4514 (:arg-types complex-long-float)
4515 (:results (r :scs (long-reg)))
4516 (:result-types long-float)
4517 (:note "complex float realpart")
4520 (define-vop (imagpart/complex-single-float complex-float-value)
4521 (:translate imagpart)
4522 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4524 (:arg-types complex-single-float)
4525 (:results (r :scs (single-reg)))
4526 (:result-types single-float)
4527 (:note "complex float imagpart")
4530 (define-vop (imagpart/complex-double-float complex-float-value)
4531 (:translate imagpart)
4532 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4534 (:arg-types complex-double-float)
4535 (:results (r :scs (double-reg)))
4536 (:result-types double-float)
4537 (:note "complex float imagpart")
4541 (define-vop (imagpart/complex-long-float complex-float-value)
4542 (:translate imagpart)
4543 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4545 (:arg-types complex-long-float)
4546 (:results (r :scs (long-reg)))
4547 (:result-types long-float)
4548 (:note "complex float imagpart")
4551 ;;; hack dummy VOPs to bias the representation selection of their
4552 ;;; arguments towards a FP register, which can help avoid consing at
4553 ;;; inappropriate locations
4554 (defknown double-float-reg-bias (double-float) (values))
4555 (define-vop (double-float-reg-bias)
4556 (:translate double-float-reg-bias)
4557 (:args (x :scs (double-reg double-stack) :load-if nil))
4558 (:arg-types double-float)
4559 (:policy :fast-safe)
4560 (:note "inline dummy FP register bias")
4563 (defknown single-float-reg-bias (single-float) (values))
4564 (define-vop (single-float-reg-bias)
4565 (:translate single-float-reg-bias)
4566 (:args (x :scs (single-reg single-stack) :load-if nil))
4567 (:arg-types single-float)
4568 (:policy :fast-safe)
4569 (:note "inline dummy FP register bias")