1 ;;;; floating point support for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (macrolet ((ea-for-xf-desc (tn slot)
17 :disp (- (* ,slot sb!vm:word-bytes) sb!vm:other-pointer-type))))
18 (defun ea-for-sf-desc (tn)
19 (ea-for-xf-desc tn sb!vm:single-float-value-slot))
20 (defun ea-for-df-desc (tn)
21 (ea-for-xf-desc tn sb!vm:double-float-value-slot))
23 (defun ea-for-lf-desc (tn)
24 (ea-for-xf-desc tn sb!vm:long-float-value-slot))
26 (defun ea-for-csf-real-desc (tn)
27 (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot))
28 (defun ea-for-csf-imag-desc (tn)
29 (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot))
30 (defun ea-for-cdf-real-desc (tn)
31 (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot))
32 (defun ea-for-cdf-imag-desc (tn)
33 (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot))
35 (defun ea-for-clf-real-desc (tn)
36 (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot))
38 (defun ea-for-clf-imag-desc (tn)
39 (ea-for-xf-desc tn sb!vm:complex-long-float-imag-slot)))
41 (macrolet ((ea-for-xf-stack (tn kind)
44 :disp (- (* (+ (tn-offset ,tn)
45 (ecase ,kind (:single 1) (:double 2) (:long 3)))
47 (defun ea-for-sf-stack (tn)
48 (ea-for-xf-stack tn :single))
49 (defun ea-for-df-stack (tn)
50 (ea-for-xf-stack tn :double))
52 (defun ea-for-lf-stack (tn)
53 (ea-for-xf-stack tn :long)))
55 ;;; Complex float stack EAs
56 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
59 :disp (- (* (+ (tn-offset ,tn)
64 (ecase ,slot (:real 1) (:imag 2))))
66 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
67 (ea-for-cxf-stack tn :single :real base))
68 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
69 (ea-for-cxf-stack tn :single :imag base))
70 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
71 (ea-for-cxf-stack tn :double :real base))
72 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
73 (ea-for-cxf-stack tn :double :imag base))
75 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
76 (ea-for-cxf-stack tn :long :real base))
78 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
79 (ea-for-cxf-stack tn :long :imag base)))
81 ;;; Abstract out the copying of a FP register to the FP stack top, and
82 ;;; provide two alternatives for its implementation. Note: it's not
83 ;;; necessary to distinguish between a single or double register move
86 ;;; Using a Pop then load.
87 (defun copy-fp-reg-to-fr0 (reg)
88 (assert (not (zerop (tn-offset reg))))
90 (inst fld (make-random-tn :kind :normal
91 :sc (sc-or-lose 'double-reg)
92 :offset (1- (tn-offset reg)))))
93 ;;; Using Fxch then Fst to restore the original reg contents.
95 (defun copy-fp-reg-to-fr0 (reg)
96 (assert (not (zerop (tn-offset reg))))
100 ;;; The x86 can't store a long-float to memory without popping the
101 ;;; stack and marking a register as empty, so it is necessary to
102 ;;; restore the register from memory.
104 (defun store-long-float (ea)
110 ;;; x is source, y is destination
111 (define-move-function (load-single 2) (vop x y)
112 ((single-stack) (single-reg))
113 (with-empty-tn@fp-top(y)
114 (inst fld (ea-for-sf-stack x))))
116 (define-move-function (store-single 2) (vop x y)
117 ((single-reg) (single-stack))
118 (cond ((zerop (tn-offset x))
119 (inst fst (ea-for-sf-stack y)))
122 (inst fst (ea-for-sf-stack y))
123 ;; This may not be necessary as ST0 is likely invalid now.
126 (define-move-function (load-double 2) (vop x y)
127 ((double-stack) (double-reg))
128 (with-empty-tn@fp-top(y)
129 (inst fldd (ea-for-df-stack x))))
131 (define-move-function (store-double 2) (vop x y)
132 ((double-reg) (double-stack))
133 (cond ((zerop (tn-offset x))
134 (inst fstd (ea-for-df-stack y)))
137 (inst fstd (ea-for-df-stack y))
138 ;; This may not be necessary as ST0 is likely invalid now.
142 (define-move-function (load-long 2) (vop x y)
143 ((long-stack) (long-reg))
144 (with-empty-tn@fp-top(y)
145 (inst fldl (ea-for-lf-stack x))))
148 (define-move-function (store-long 2) (vop x y)
149 ((long-reg) (long-stack))
150 (cond ((zerop (tn-offset x))
151 (store-long-float (ea-for-lf-stack y)))
154 (store-long-float (ea-for-lf-stack y))
155 ;; This may not be necessary as ST0 is likely invalid now.
158 ;;; The i387 has instructions to load some useful constants.
159 ;;; This doesn't save much time but might cut down on memory
160 ;;; access and reduce the size of the constant vector (CV).
161 ;;; Intel claims they are stored in a more precise form on chip.
162 ;;; Anyhow, might as well use the feature. It can be turned
163 ;;; off by hacking the "immediate-constant-sc" in vm.lisp.
164 (define-move-function (load-fp-constant 2) (vop x y)
165 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
166 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
167 (with-empty-tn@fp-top(y)
174 ((= value (log 10l0 2l0))
176 ((= value (log 2.718281828459045235360287471352662L0 2l0))
178 ((= value (log 2l0 10l0))
180 ((= value (log 2l0 2.718281828459045235360287471352662L0))
182 (t (warn "Ignoring bogus i387 Constant ~A" value))))))
185 ;;;; complex float move functions
187 (defun complex-single-reg-real-tn (x)
188 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
189 :offset (tn-offset x)))
190 (defun complex-single-reg-imag-tn (x)
191 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
192 :offset (1+ (tn-offset x))))
194 (defun complex-double-reg-real-tn (x)
195 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
196 :offset (tn-offset x)))
197 (defun complex-double-reg-imag-tn (x)
198 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
199 :offset (1+ (tn-offset x))))
202 (defun complex-long-reg-real-tn (x)
203 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
204 :offset (tn-offset x)))
206 (defun complex-long-reg-imag-tn (x)
207 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
208 :offset (1+ (tn-offset x))))
210 ;;; x is source, y is destination
211 (define-move-function (load-complex-single 2) (vop x y)
212 ((complex-single-stack) (complex-single-reg))
213 (let ((real-tn (complex-single-reg-real-tn y)))
214 (with-empty-tn@fp-top (real-tn)
215 (inst fld (ea-for-csf-real-stack x))))
216 (let ((imag-tn (complex-single-reg-imag-tn y)))
217 (with-empty-tn@fp-top (imag-tn)
218 (inst fld (ea-for-csf-imag-stack x)))))
220 (define-move-function (store-complex-single 2) (vop x y)
221 ((complex-single-reg) (complex-single-stack))
222 (let ((real-tn (complex-single-reg-real-tn x)))
223 (cond ((zerop (tn-offset real-tn))
224 (inst fst (ea-for-csf-real-stack y)))
227 (inst fst (ea-for-csf-real-stack y))
228 (inst fxch real-tn))))
229 (let ((imag-tn (complex-single-reg-imag-tn x)))
231 (inst fst (ea-for-csf-imag-stack y))
232 (inst fxch imag-tn)))
234 (define-move-function (load-complex-double 2) (vop x y)
235 ((complex-double-stack) (complex-double-reg))
236 (let ((real-tn (complex-double-reg-real-tn y)))
237 (with-empty-tn@fp-top(real-tn)
238 (inst fldd (ea-for-cdf-real-stack x))))
239 (let ((imag-tn (complex-double-reg-imag-tn y)))
240 (with-empty-tn@fp-top(imag-tn)
241 (inst fldd (ea-for-cdf-imag-stack x)))))
243 (define-move-function (store-complex-double 2) (vop x y)
244 ((complex-double-reg) (complex-double-stack))
245 (let ((real-tn (complex-double-reg-real-tn x)))
246 (cond ((zerop (tn-offset real-tn))
247 (inst fstd (ea-for-cdf-real-stack y)))
250 (inst fstd (ea-for-cdf-real-stack y))
251 (inst fxch real-tn))))
252 (let ((imag-tn (complex-double-reg-imag-tn x)))
254 (inst fstd (ea-for-cdf-imag-stack y))
255 (inst fxch imag-tn)))
258 (define-move-function (load-complex-long 2) (vop x y)
259 ((complex-long-stack) (complex-long-reg))
260 (let ((real-tn (complex-long-reg-real-tn y)))
261 (with-empty-tn@fp-top(real-tn)
262 (inst fldl (ea-for-clf-real-stack x))))
263 (let ((imag-tn (complex-long-reg-imag-tn y)))
264 (with-empty-tn@fp-top(imag-tn)
265 (inst fldl (ea-for-clf-imag-stack x)))))
268 (define-move-function (store-complex-long 2) (vop x y)
269 ((complex-long-reg) (complex-long-stack))
270 (let ((real-tn (complex-long-reg-real-tn x)))
271 (cond ((zerop (tn-offset real-tn))
272 (store-long-float (ea-for-clf-real-stack y)))
275 (store-long-float (ea-for-clf-real-stack y))
276 (inst fxch real-tn))))
277 (let ((imag-tn (complex-long-reg-imag-tn x)))
279 (store-long-float (ea-for-clf-imag-stack y))
280 (inst fxch imag-tn)))
285 ;;; Float register to register moves.
286 (define-vop (float-move)
291 (unless (location= x y)
292 (cond ((zerop (tn-offset y))
293 (copy-fp-reg-to-fr0 x))
294 ((zerop (tn-offset x))
301 (define-vop (single-move float-move)
302 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
303 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
304 (define-move-vop single-move :move (single-reg) (single-reg))
306 (define-vop (double-move float-move)
307 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
308 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
309 (define-move-vop double-move :move (double-reg) (double-reg))
312 (define-vop (long-move float-move)
313 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
314 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
316 (define-move-vop long-move :move (long-reg) (long-reg))
318 ;;; complex float register to register moves
319 (define-vop (complex-float-move)
320 (:args (x :target y :load-if (not (location= x y))))
321 (:results (y :load-if (not (location= x y))))
322 (:note "complex float move")
324 (unless (location= x y)
325 ;; Note the complex-float-regs are aligned to every second
326 ;; float register so there is not need to worry about overlap.
327 (let ((x-real (complex-double-reg-real-tn x))
328 (y-real (complex-double-reg-real-tn y)))
329 (cond ((zerop (tn-offset y-real))
330 (copy-fp-reg-to-fr0 x-real))
331 ((zerop (tn-offset x-real))
336 (inst fxch x-real))))
337 (let ((x-imag (complex-double-reg-imag-tn x))
338 (y-imag (complex-double-reg-imag-tn y)))
341 (inst fxch x-imag)))))
343 (define-vop (complex-single-move complex-float-move)
344 (:args (x :scs (complex-single-reg) :target y
345 :load-if (not (location= x y))))
346 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
347 (define-move-vop complex-single-move :move
348 (complex-single-reg) (complex-single-reg))
350 (define-vop (complex-double-move complex-float-move)
351 (:args (x :scs (complex-double-reg)
352 :target y :load-if (not (location= x y))))
353 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
354 (define-move-vop complex-double-move :move
355 (complex-double-reg) (complex-double-reg))
358 (define-vop (complex-long-move complex-float-move)
359 (:args (x :scs (complex-long-reg)
360 :target y :load-if (not (location= x y))))
361 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
363 (define-move-vop complex-long-move :move
364 (complex-long-reg) (complex-long-reg))
366 ;;; Move from float to a descriptor reg. allocating a new float
367 ;;; object in the process.
368 (define-vop (move-from-single)
369 (:args (x :scs (single-reg) :to :save))
370 (:results (y :scs (descriptor-reg)))
372 (:note "float to pointer coercion")
374 (with-fixed-allocation (y
375 sb!vm:single-float-type
376 sb!vm:single-float-size node)
378 (inst fst (ea-for-sf-desc y))))))
379 (define-move-vop move-from-single :move
380 (single-reg) (descriptor-reg))
382 (define-vop (move-from-double)
383 (:args (x :scs (double-reg) :to :save))
384 (:results (y :scs (descriptor-reg)))
386 (:note "float to pointer coercion")
388 (with-fixed-allocation (y
389 sb!vm:double-float-type
390 sb!vm:double-float-size
393 (inst fstd (ea-for-df-desc y))))))
394 (define-move-vop move-from-double :move
395 (double-reg) (descriptor-reg))
398 (define-vop (move-from-long)
399 (:args (x :scs (long-reg) :to :save))
400 (:results (y :scs (descriptor-reg)))
402 (:note "float to pointer coercion")
404 (with-fixed-allocation (y
405 sb!vm:long-float-type
406 sb!vm:long-float-size
409 (store-long-float (ea-for-lf-desc y))))))
411 (define-move-vop move-from-long :move
412 (long-reg) (descriptor-reg))
414 (define-vop (move-from-fp-constant)
415 (:args (x :scs (fp-constant)))
416 (:results (y :scs (descriptor-reg)))
418 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
419 (0f0 (load-symbol-value y *fp-constant-0s0*))
420 (1f0 (load-symbol-value y *fp-constant-1s0*))
421 (0d0 (load-symbol-value y *fp-constant-0d0*))
422 (1d0 (load-symbol-value y *fp-constant-1d0*))
424 (0l0 (load-symbol-value y *fp-constant-0l0*))
426 (1l0 (load-symbol-value y *fp-constant-1l0*))
428 (#.pi (load-symbol-value y *fp-constant-pi*))
430 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
432 (#.(log 2.718281828459045235360287471352662L0 2l0)
433 (load-symbol-value y *fp-constant-l2e*))
435 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
437 (#.(log 2l0 2.718281828459045235360287471352662L0)
438 (load-symbol-value y *fp-constant-ln2*)))))
439 (define-move-vop move-from-fp-constant :move
440 (fp-constant) (descriptor-reg))
442 ;;; Move from a descriptor to a float register
443 (define-vop (move-to-single)
444 (:args (x :scs (descriptor-reg)))
445 (:results (y :scs (single-reg)))
446 (:note "pointer to float coercion")
448 (with-empty-tn@fp-top(y)
449 (inst fld (ea-for-sf-desc x)))))
450 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
452 (define-vop (move-to-double)
453 (:args (x :scs (descriptor-reg)))
454 (:results (y :scs (double-reg)))
455 (:note "pointer to float coercion")
457 (with-empty-tn@fp-top(y)
458 (inst fldd (ea-for-df-desc x)))))
459 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
462 (define-vop (move-to-long)
463 (:args (x :scs (descriptor-reg)))
464 (:results (y :scs (long-reg)))
465 (:note "pointer to float coercion")
467 (with-empty-tn@fp-top(y)
468 (inst fldl (ea-for-lf-desc x)))))
470 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
473 ;;; Move from complex float to a descriptor reg. allocating a new
474 ;;; complex float object in the process.
475 (define-vop (move-from-complex-single)
476 (:args (x :scs (complex-single-reg) :to :save))
477 (:results (y :scs (descriptor-reg)))
479 (:note "complex float to pointer coercion")
481 (with-fixed-allocation (y
482 sb!vm:complex-single-float-type
483 sb!vm:complex-single-float-size node)
484 (let ((real-tn (complex-single-reg-real-tn x)))
485 (with-tn@fp-top(real-tn)
486 (inst fst (ea-for-csf-real-desc y))))
487 (let ((imag-tn (complex-single-reg-imag-tn x)))
488 (with-tn@fp-top(imag-tn)
489 (inst fst (ea-for-csf-imag-desc y)))))))
490 (define-move-vop move-from-complex-single :move
491 (complex-single-reg) (descriptor-reg))
493 (define-vop (move-from-complex-double)
494 (:args (x :scs (complex-double-reg) :to :save))
495 (:results (y :scs (descriptor-reg)))
497 (:note "complex float to pointer coercion")
499 (with-fixed-allocation (y
500 sb!vm:complex-double-float-type
501 sb!vm:complex-double-float-size
503 (let ((real-tn (complex-double-reg-real-tn x)))
504 (with-tn@fp-top(real-tn)
505 (inst fstd (ea-for-cdf-real-desc y))))
506 (let ((imag-tn (complex-double-reg-imag-tn x)))
507 (with-tn@fp-top(imag-tn)
508 (inst fstd (ea-for-cdf-imag-desc y)))))))
509 (define-move-vop move-from-complex-double :move
510 (complex-double-reg) (descriptor-reg))
513 (define-vop (move-from-complex-long)
514 (:args (x :scs (complex-long-reg) :to :save))
515 (:results (y :scs (descriptor-reg)))
517 (:note "complex float to pointer coercion")
519 (with-fixed-allocation (y
520 sb!vm:complex-long-float-type
521 sb!vm:complex-long-float-size
523 (let ((real-tn (complex-long-reg-real-tn x)))
524 (with-tn@fp-top(real-tn)
525 (store-long-float (ea-for-clf-real-desc y))))
526 (let ((imag-tn (complex-long-reg-imag-tn x)))
527 (with-tn@fp-top(imag-tn)
528 (store-long-float (ea-for-clf-imag-desc y)))))))
530 (define-move-vop move-from-complex-long :move
531 (complex-long-reg) (descriptor-reg))
533 ;;; Move from a descriptor to a complex float register
534 (macrolet ((frob (name sc format)
537 (:args (x :scs (descriptor-reg)))
538 (:results (y :scs (,sc)))
539 (:note "pointer to complex float coercion")
541 (let ((real-tn (complex-double-reg-real-tn y)))
542 (with-empty-tn@fp-top(real-tn)
544 (:single '((inst fld (ea-for-csf-real-desc x))))
545 (:double '((inst fldd (ea-for-cdf-real-desc x))))
547 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
548 (let ((imag-tn (complex-double-reg-imag-tn y)))
549 (with-empty-tn@fp-top(imag-tn)
551 (:single '((inst fld (ea-for-csf-imag-desc x))))
552 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
554 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
555 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
556 (frob move-to-complex-single complex-single-reg :single)
557 (frob move-to-complex-double complex-double-reg :double)
559 (frob move-to-complex-double complex-long-reg :long))
562 ;;;; The move argument vops.
564 ;;;; Note these are also used to stuff fp numbers onto the c-call stack
565 ;;;; so the order is different than the lisp-stack.
567 ;;; The general move-argument vop
568 (macrolet ((frob (name sc stack-sc format)
571 (:args (x :scs (,sc) :target y)
573 :load-if (not (sc-is y ,sc))))
575 (:note "float argument move")
576 (:generator ,(case format (:single 2) (:double 3) (:long 4))
579 (unless (location= x y)
580 (cond ((zerop (tn-offset y))
581 (copy-fp-reg-to-fr0 x))
582 ((zerop (tn-offset x))
589 (if (= (tn-offset fp) esp-offset)
590 (let* ((offset (* (tn-offset y) word-bytes))
591 (ea (make-ea :dword :base fp :disp offset)))
594 (:single '((inst fst ea)))
595 (:double '((inst fstd ea)))
597 (:long '((store-long-float ea))))))
600 :disp (- (* (+ (tn-offset y)
605 sb!vm:word-bytes)))))
608 (:single '((inst fst ea)))
609 (:double '((inst fstd ea)))
611 (:long '((store-long-float ea)))))))))))
612 (define-move-vop ,name :move-argument
613 (,sc descriptor-reg) (,sc)))))
614 (frob move-single-float-argument single-reg single-stack :single)
615 (frob move-double-float-argument double-reg double-stack :double)
617 (frob move-long-float-argument long-reg long-stack :long))
619 ;;;; Complex float move-argument vop
620 (macrolet ((frob (name sc stack-sc format)
623 (:args (x :scs (,sc) :target y)
625 :load-if (not (sc-is y ,sc))))
627 (:note "complex float argument move")
628 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
631 (unless (location= x y)
632 (let ((x-real (complex-double-reg-real-tn x))
633 (y-real (complex-double-reg-real-tn y)))
634 (cond ((zerop (tn-offset y-real))
635 (copy-fp-reg-to-fr0 x-real))
636 ((zerop (tn-offset x-real))
641 (inst fxch x-real))))
642 (let ((x-imag (complex-double-reg-imag-tn x))
643 (y-imag (complex-double-reg-imag-tn y)))
646 (inst fxch x-imag))))
648 (let ((real-tn (complex-double-reg-real-tn x)))
649 (cond ((zerop (tn-offset real-tn))
653 (ea-for-csf-real-stack y fp))))
656 (ea-for-cdf-real-stack y fp))))
660 (ea-for-clf-real-stack y fp))))))
666 (ea-for-csf-real-stack y fp))))
669 (ea-for-cdf-real-stack y fp))))
673 (ea-for-clf-real-stack y fp)))))
674 (inst fxch real-tn))))
675 (let ((imag-tn (complex-double-reg-imag-tn x)))
679 '((inst fst (ea-for-csf-imag-stack y fp))))
681 '((inst fstd (ea-for-cdf-imag-stack y fp))))
685 (ea-for-clf-imag-stack y fp)))))
686 (inst fxch imag-tn))))))
687 (define-move-vop ,name :move-argument
688 (,sc descriptor-reg) (,sc)))))
689 (frob move-complex-single-float-argument
690 complex-single-reg complex-single-stack :single)
691 (frob move-complex-double-float-argument
692 complex-double-reg complex-double-stack :double)
694 (frob move-complex-long-float-argument
695 complex-long-reg complex-long-stack :long))
697 (define-move-vop move-argument :move-argument
698 (single-reg double-reg #!+long-float long-reg
699 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
705 ;;; dtc: The floating point arithmetic vops.
707 ;;; Note: Although these can accept x and y on the stack or pointed to
708 ;;; from a descriptor register, they will work with register loading
709 ;;; without these. Same deal with the result - it need only be a
710 ;;; register. When load-tns are needed they will probably be in ST0
711 ;;; and the code below should be able to correctly handle all cases.
713 ;;; However it seems to produce better code if all arg. and result
714 ;;; options are used; on the P86 there is no extra cost in using a
715 ;;; memory operand to the FP instructions - not so on the PPro.
717 ;;; It may also be useful to handle constant args?
719 ;;; 22-Jul-97: descriptor args lose in some simple cases when
720 ;;; a function result computed in a loop. Then Python insists
721 ;;; on consing the intermediate values! For example
724 (declare (type (simple-array double-float (*)) a)
727 (declare (type double-float sum))
729 (incf sum (* (aref a i)(aref a i))))
732 ;;; So, disabling descriptor args until this can be fixed elsewhere.
734 ((frob (op fop-sti fopr-sti
736 fopd foprd dname dcost
738 #!-long-float (declare (ignore lcost lname))
742 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
744 (y :scs (single-reg single-stack #+nil descriptor-reg)
746 (:temporary (:sc single-reg :offset fr0-offset
747 :from :eval :to :result) fr0)
748 (:results (r :scs (single-reg single-stack)))
749 (:arg-types single-float single-float)
750 (:result-types single-float)
752 (:note "inline float arithmetic")
754 (:save-p :compute-only)
757 ;; Handle a few special cases
759 ;; x, y, and r are the same register.
760 ((and (sc-is x single-reg) (location= x r) (location= y r))
761 (cond ((zerop (tn-offset r))
766 ;; XX the source register will not be valid.
767 (note-next-instruction vop :internal-error)
770 ;; x and r are the same register.
771 ((and (sc-is x single-reg) (location= x r))
772 (cond ((zerop (tn-offset r))
775 ;; ST(0) = ST(0) op ST(y)
778 ;; ST(0) = ST(0) op Mem
779 (inst ,fop (ea-for-sf-stack y)))
781 (inst ,fop (ea-for-sf-desc y)))))
786 (unless (zerop (tn-offset y))
787 (copy-fp-reg-to-fr0 y)))
788 ((single-stack descriptor-reg)
790 (if (sc-is y single-stack)
791 (inst fld (ea-for-sf-stack y))
792 (inst fld (ea-for-sf-desc y)))))
793 ;; ST(i) = ST(i) op ST0
795 (when (policy node (or (= debug 3) (> safety speed)))
796 (note-next-instruction vop :internal-error)
798 ;; y and r are the same register.
799 ((and (sc-is y single-reg) (location= y r))
800 (cond ((zerop (tn-offset r))
803 ;; ST(0) = ST(x) op ST(0)
806 ;; ST(0) = Mem op ST(0)
807 (inst ,fopr (ea-for-sf-stack x)))
809 (inst ,fopr (ea-for-sf-desc x)))))
814 (unless (zerop (tn-offset x))
815 (copy-fp-reg-to-fr0 x)))
816 ((single-stack descriptor-reg)
818 (if (sc-is x single-stack)
819 (inst fld (ea-for-sf-stack x))
820 (inst fld (ea-for-sf-desc x)))))
821 ;; ST(i) = ST(0) op ST(i)
823 (when (policy node (or (= debug 3) (> safety speed)))
824 (note-next-instruction vop :internal-error)
828 ;; Get the result to ST0.
830 ;; Special handling is needed if x or y are in ST0, and
831 ;; simpler code is generated.
834 ((and (sc-is x single-reg) (zerop (tn-offset x)))
840 (inst ,fop (ea-for-sf-stack y)))
842 (inst ,fop (ea-for-sf-desc y)))))
844 ((and (sc-is y single-reg) (zerop (tn-offset y)))
850 (inst ,fopr (ea-for-sf-stack x)))
852 (inst ,fopr (ea-for-sf-desc x)))))
857 (copy-fp-reg-to-fr0 x))
860 (inst fld (ea-for-sf-stack x)))
863 (inst fld (ea-for-sf-desc x))))
869 (inst ,fop (ea-for-sf-stack y)))
871 (inst ,fop (ea-for-sf-desc y))))))
873 (note-next-instruction vop :internal-error)
875 ;; Finally save the result
878 (cond ((zerop (tn-offset r))
879 (when (policy node (or (= debug 3) (> safety speed)))
884 (inst fst (ea-for-sf-stack r))))))))
888 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
890 (y :scs (double-reg double-stack #+nil descriptor-reg)
892 (:temporary (:sc double-reg :offset fr0-offset
893 :from :eval :to :result) fr0)
894 (:results (r :scs (double-reg double-stack)))
895 (:arg-types double-float double-float)
896 (:result-types double-float)
898 (:note "inline float arithmetic")
900 (:save-p :compute-only)
903 ;; Handle a few special cases
905 ;; x, y, and r are the same register.
906 ((and (sc-is x double-reg) (location= x r) (location= y r))
907 (cond ((zerop (tn-offset r))
912 ;; XX the source register will not be valid.
913 (note-next-instruction vop :internal-error)
916 ;; x and r are the same register.
917 ((and (sc-is x double-reg) (location= x r))
918 (cond ((zerop (tn-offset r))
921 ;; ST(0) = ST(0) op ST(y)
924 ;; ST(0) = ST(0) op Mem
925 (inst ,fopd (ea-for-df-stack y)))
927 (inst ,fopd (ea-for-df-desc y)))))
932 (unless (zerop (tn-offset y))
933 (copy-fp-reg-to-fr0 y)))
934 ((double-stack descriptor-reg)
936 (if (sc-is y double-stack)
937 (inst fldd (ea-for-df-stack y))
938 (inst fldd (ea-for-df-desc y)))))
939 ;; ST(i) = ST(i) op ST0
941 (when (policy node (or (= debug 3) (> safety speed)))
942 (note-next-instruction vop :internal-error)
944 ;; y and r are the same register.
945 ((and (sc-is y double-reg) (location= y r))
946 (cond ((zerop (tn-offset r))
949 ;; ST(0) = ST(x) op ST(0)
952 ;; ST(0) = Mem op ST(0)
953 (inst ,foprd (ea-for-df-stack x)))
955 (inst ,foprd (ea-for-df-desc x)))))
960 (unless (zerop (tn-offset x))
961 (copy-fp-reg-to-fr0 x)))
962 ((double-stack descriptor-reg)
964 (if (sc-is x double-stack)
965 (inst fldd (ea-for-df-stack x))
966 (inst fldd (ea-for-df-desc x)))))
967 ;; ST(i) = ST(0) op ST(i)
969 (when (policy node (or (= debug 3) (> safety speed)))
970 (note-next-instruction vop :internal-error)
974 ;; Get the result to ST0.
976 ;; Special handling is needed if x or y are in ST0, and
977 ;; simpler code is generated.
980 ((and (sc-is x double-reg) (zerop (tn-offset x)))
986 (inst ,fopd (ea-for-df-stack y)))
988 (inst ,fopd (ea-for-df-desc y)))))
990 ((and (sc-is y double-reg) (zerop (tn-offset y)))
996 (inst ,foprd (ea-for-df-stack x)))
998 (inst ,foprd (ea-for-df-desc x)))))
1003 (copy-fp-reg-to-fr0 x))
1006 (inst fldd (ea-for-df-stack x)))
1009 (inst fldd (ea-for-df-desc x))))
1015 (inst ,fopd (ea-for-df-stack y)))
1017 (inst ,fopd (ea-for-df-desc y))))))
1019 (note-next-instruction vop :internal-error)
1021 ;; Finally save the result
1024 (cond ((zerop (tn-offset r))
1025 (when (policy node (or (= debug 3) (> safety speed)))
1030 (inst fstd (ea-for-df-stack r))))))))
1033 (define-vop (,lname)
1035 (:args (x :scs (long-reg) :to :eval)
1036 (y :scs (long-reg) :to :eval))
1037 (:temporary (:sc long-reg :offset fr0-offset
1038 :from :eval :to :result) fr0)
1039 (:results (r :scs (long-reg)))
1040 (:arg-types long-float long-float)
1041 (:result-types long-float)
1042 (:policy :fast-safe)
1043 (:note "inline float arithmetic")
1045 (:save-p :compute-only)
1048 ;; Handle a few special cases
1050 ;; x, y, and r are the same register.
1051 ((and (location= x r) (location= y r))
1052 (cond ((zerop (tn-offset r))
1057 ;; XX the source register will not be valid.
1058 (note-next-instruction vop :internal-error)
1061 ;; x and r are the same register.
1063 (cond ((zerop (tn-offset r))
1064 ;; ST(0) = ST(0) op ST(y)
1068 (unless (zerop (tn-offset y))
1069 (copy-fp-reg-to-fr0 y))
1070 ;; ST(i) = ST(i) op ST0
1072 (when (policy node (or (= debug 3) (> safety speed)))
1073 (note-next-instruction vop :internal-error)
1075 ;; y and r are the same register.
1077 (cond ((zerop (tn-offset r))
1078 ;; ST(0) = ST(x) op ST(0)
1082 (unless (zerop (tn-offset x))
1083 (copy-fp-reg-to-fr0 x))
1084 ;; ST(i) = ST(0) op ST(i)
1085 (inst ,fopr-sti r)))
1086 (when (policy node (or (= debug 3) (> safety speed)))
1087 (note-next-instruction vop :internal-error)
1091 ;; Get the result to ST0.
1093 ;; Special handling is needed if x or y are in ST0, and
1094 ;; simpler code is generated.
1097 ((zerop (tn-offset x))
1101 ((zerop (tn-offset y))
1106 (copy-fp-reg-to-fr0 x)
1110 (note-next-instruction vop :internal-error)
1112 ;; Finally save the result.
1113 (cond ((zerop (tn-offset r))
1114 (when (policy node (or (= debug 3) (> safety speed)))
1117 (inst fst r))))))))))
1119 (frob + fadd-sti fadd-sti
1120 fadd fadd +/single-float 2
1121 faddd faddd +/double-float 2
1123 (frob - fsub-sti fsubr-sti
1124 fsub fsubr -/single-float 2
1125 fsubd fsubrd -/double-float 2
1127 (frob * fmul-sti fmul-sti
1128 fmul fmul */single-float 3
1129 fmuld fmuld */double-float 3
1131 (frob / fdiv-sti fdivr-sti
1132 fdiv fdivr //single-float 12
1133 fdivd fdivrd //double-float 12
1136 (macrolet ((frob (name inst translate sc type)
1137 `(define-vop (,name)
1138 (:args (x :scs (,sc) :target fr0))
1139 (:results (y :scs (,sc)))
1140 (:translate ,translate)
1141 (:policy :fast-safe)
1143 (:result-types ,type)
1144 (:temporary (:sc double-reg :offset fr0-offset
1145 :from :argument :to :result) fr0)
1147 (:note "inline float arithmetic")
1149 (:save-p :compute-only)
1151 (note-this-location vop :internal-error)
1152 (unless (zerop (tn-offset x))
1153 (inst fxch x) ; x to top of stack
1154 (unless (location= x y)
1155 (inst fst x))) ; maybe save it
1156 (inst ,inst) ; clobber st0
1157 (unless (zerop (tn-offset y))
1160 (frob abs/single-float fabs abs single-reg single-float)
1161 (frob abs/double-float fabs abs double-reg double-float)
1163 (frob abs/long-float fabs abs long-reg long-float)
1164 (frob %negate/single-float fchs %negate single-reg single-float)
1165 (frob %negate/double-float fchs %negate double-reg double-float)
1167 (frob %negate/long-float fchs %negate long-reg long-float))
1171 (define-vop (=/float)
1173 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1175 (:info target not-p)
1176 (:policy :fast-safe)
1178 (:save-p :compute-only)
1179 (:note "inline float comparison")
1182 (note-this-location vop :internal-error)
1184 ;; x is in ST0; y is in any reg.
1185 ((zerop (tn-offset x))
1187 ;; y is in ST0; x is in another reg.
1188 ((zerop (tn-offset y))
1190 ;; x and y are the same register, not ST0
1195 ;; x and y are different registers, neither ST0.
1200 (inst fnstsw) ; status word to ax
1201 (inst and ah-tn #x45) ; C3 C2 C0
1202 (inst cmp ah-tn #x40)
1203 (inst jmp (if not-p :ne :e) target)))
1205 (define-vop (=/single-float =/float)
1207 (:args (x :scs (single-reg))
1208 (y :scs (single-reg)))
1209 (:arg-types single-float single-float))
1211 (define-vop (=/double-float =/float)
1213 (:args (x :scs (double-reg))
1214 (y :scs (double-reg)))
1215 (:arg-types double-float double-float))
1218 (define-vop (=/long-float =/float)
1220 (:args (x :scs (long-reg))
1221 (y :scs (long-reg)))
1222 (:arg-types long-float long-float))
1225 (define-vop (<single-float)
1227 (:args (x :scs (single-reg single-stack descriptor-reg))
1228 (y :scs (single-reg single-stack descriptor-reg)))
1229 (:arg-types single-float single-float)
1230 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1231 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1233 (:info target not-p)
1234 (:policy :fast-safe)
1235 (:note "inline float comparison")
1238 ;; Handle a few special cases
1241 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1245 ((single-stack descriptor-reg)
1246 (if (sc-is x single-stack)
1247 (inst fcom (ea-for-sf-stack x))
1248 (inst fcom (ea-for-sf-desc x)))))
1249 (inst fnstsw) ; status word to ax
1250 (inst and ah-tn #x45))
1252 ;; General case when y is not in ST0.
1257 (unless (zerop (tn-offset x))
1258 (copy-fp-reg-to-fr0 x)))
1259 ((single-stack descriptor-reg)
1261 (if (sc-is x single-stack)
1262 (inst fld (ea-for-sf-stack x))
1263 (inst fld (ea-for-sf-desc x)))))
1267 ((single-stack descriptor-reg)
1268 (if (sc-is y single-stack)
1269 (inst fcom (ea-for-sf-stack y))
1270 (inst fcom (ea-for-sf-desc y)))))
1271 (inst fnstsw) ; status word to ax
1272 (inst and ah-tn #x45) ; C3 C2 C0
1273 (inst cmp ah-tn #x01)))
1274 (inst jmp (if not-p :ne :e) target)))
1276 (define-vop (<double-float)
1278 (:args (x :scs (double-reg double-stack descriptor-reg))
1279 (y :scs (double-reg double-stack descriptor-reg)))
1280 (:arg-types double-float double-float)
1281 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1282 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1284 (:info target not-p)
1285 (:policy :fast-safe)
1286 (:note "inline float comparison")
1289 ;; Handle a few special cases
1292 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1296 ((double-stack descriptor-reg)
1297 (if (sc-is x double-stack)
1298 (inst fcomd (ea-for-df-stack x))
1299 (inst fcomd (ea-for-df-desc x)))))
1300 (inst fnstsw) ; status word to ax
1301 (inst and ah-tn #x45))
1303 ;; General case when y is not in ST0.
1308 (unless (zerop (tn-offset x))
1309 (copy-fp-reg-to-fr0 x)))
1310 ((double-stack descriptor-reg)
1312 (if (sc-is x double-stack)
1313 (inst fldd (ea-for-df-stack x))
1314 (inst fldd (ea-for-df-desc x)))))
1318 ((double-stack descriptor-reg)
1319 (if (sc-is y double-stack)
1320 (inst fcomd (ea-for-df-stack y))
1321 (inst fcomd (ea-for-df-desc y)))))
1322 (inst fnstsw) ; status word to ax
1323 (inst and ah-tn #x45) ; C3 C2 C0
1324 (inst cmp ah-tn #x01)))
1325 (inst jmp (if not-p :ne :e) target)))
1328 (define-vop (<long-float)
1330 (:args (x :scs (long-reg))
1331 (y :scs (long-reg)))
1332 (:arg-types long-float long-float)
1333 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1335 (:info target not-p)
1336 (:policy :fast-safe)
1337 (:note "inline float comparison")
1341 ;; x is in ST0; y is in any reg.
1342 ((zerop (tn-offset x))
1344 (inst fnstsw) ; status word to ax
1345 (inst and ah-tn #x45) ; C3 C2 C0
1346 (inst cmp ah-tn #x01))
1347 ;; y is in ST0; x is in another reg.
1348 ((zerop (tn-offset y))
1350 (inst fnstsw) ; status word to ax
1351 (inst and ah-tn #x45))
1352 ;; x and y are the same register, not ST0
1353 ;; x and y are different registers, neither ST0.
1358 (inst fnstsw) ; status word to ax
1359 (inst and ah-tn #x45))) ; C3 C2 C0
1360 (inst jmp (if not-p :ne :e) target)))
1362 (define-vop (>single-float)
1364 (:args (x :scs (single-reg single-stack descriptor-reg))
1365 (y :scs (single-reg single-stack descriptor-reg)))
1366 (:arg-types single-float single-float)
1367 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1368 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1370 (:info target not-p)
1371 (:policy :fast-safe)
1372 (:note "inline float comparison")
1375 ;; Handle a few special cases
1378 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1382 ((single-stack descriptor-reg)
1383 (if (sc-is x single-stack)
1384 (inst fcom (ea-for-sf-stack x))
1385 (inst fcom (ea-for-sf-desc x)))))
1386 (inst fnstsw) ; status word to ax
1387 (inst and ah-tn #x45)
1388 (inst cmp ah-tn #x01))
1390 ;; General case when y is not in ST0.
1395 (unless (zerop (tn-offset x))
1396 (copy-fp-reg-to-fr0 x)))
1397 ((single-stack descriptor-reg)
1399 (if (sc-is x single-stack)
1400 (inst fld (ea-for-sf-stack x))
1401 (inst fld (ea-for-sf-desc x)))))
1405 ((single-stack descriptor-reg)
1406 (if (sc-is y single-stack)
1407 (inst fcom (ea-for-sf-stack y))
1408 (inst fcom (ea-for-sf-desc y)))))
1409 (inst fnstsw) ; status word to ax
1410 (inst and ah-tn #x45)))
1411 (inst jmp (if not-p :ne :e) target)))
1413 (define-vop (>double-float)
1415 (:args (x :scs (double-reg double-stack descriptor-reg))
1416 (y :scs (double-reg double-stack descriptor-reg)))
1417 (:arg-types double-float double-float)
1418 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1419 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1421 (:info target not-p)
1422 (:policy :fast-safe)
1423 (:note "inline float comparison")
1426 ;; Handle a few special cases
1429 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1433 ((double-stack descriptor-reg)
1434 (if (sc-is x double-stack)
1435 (inst fcomd (ea-for-df-stack x))
1436 (inst fcomd (ea-for-df-desc x)))))
1437 (inst fnstsw) ; status word to ax
1438 (inst and ah-tn #x45)
1439 (inst cmp ah-tn #x01))
1441 ;; General case when y is not in ST0.
1446 (unless (zerop (tn-offset x))
1447 (copy-fp-reg-to-fr0 x)))
1448 ((double-stack descriptor-reg)
1450 (if (sc-is x double-stack)
1451 (inst fldd (ea-for-df-stack x))
1452 (inst fldd (ea-for-df-desc x)))))
1456 ((double-stack descriptor-reg)
1457 (if (sc-is y double-stack)
1458 (inst fcomd (ea-for-df-stack y))
1459 (inst fcomd (ea-for-df-desc y)))))
1460 (inst fnstsw) ; status word to ax
1461 (inst and ah-tn #x45)))
1462 (inst jmp (if not-p :ne :e) target)))
1465 (define-vop (>long-float)
1467 (:args (x :scs (long-reg))
1468 (y :scs (long-reg)))
1469 (:arg-types long-float long-float)
1470 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1472 (:info target not-p)
1473 (:policy :fast-safe)
1474 (:note "inline float comparison")
1478 ;; y is in ST0; x is in any reg.
1479 ((zerop (tn-offset y))
1481 (inst fnstsw) ; status word to ax
1482 (inst and ah-tn #x45)
1483 (inst cmp ah-tn #x01))
1484 ;; x is in ST0; y is in another reg.
1485 ((zerop (tn-offset x))
1487 (inst fnstsw) ; status word to ax
1488 (inst and ah-tn #x45))
1489 ;; y and x are the same register, not ST0
1490 ;; y and x are different registers, neither ST0.
1495 (inst fnstsw) ; status word to ax
1496 (inst and ah-tn #x45)))
1497 (inst jmp (if not-p :ne :e) target)))
1499 ;;; Comparisons with 0 can use the FTST instruction.
1501 (define-vop (float-test)
1503 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1505 (:info target not-p y)
1506 (:variant-vars code)
1507 (:policy :fast-safe)
1509 (:save-p :compute-only)
1510 (:note "inline float comparison")
1513 (note-this-location vop :internal-error)
1516 ((zerop (tn-offset x))
1523 (inst fnstsw) ; status word to ax
1524 (inst and ah-tn #x45) ; C3 C2 C0
1525 (unless (zerop code)
1526 (inst cmp ah-tn code))
1527 (inst jmp (if not-p :ne :e) target)))
1529 (define-vop (=0/single-float float-test)
1531 (:args (x :scs (single-reg)))
1532 #!-negative-zero-is-not-zero
1533 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1534 #!+negative-zero-is-not-zero
1535 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1537 (define-vop (=0/double-float float-test)
1539 (:args (x :scs (double-reg)))
1540 #!-negative-zero-is-not-zero
1541 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1542 #!+negative-zero-is-not-zero
1543 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1546 (define-vop (=0/long-float float-test)
1548 (:args (x :scs (long-reg)))
1549 #!-negative-zero-is-not-zero
1550 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1551 #!+negative-zero-is-not-zero
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 #!-negative-zero-is-not-zero
1559 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1560 #!+negative-zero-is-not-zero
1561 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1563 (define-vop (<0/double-float float-test)
1565 (:args (x :scs (double-reg)))
1566 #!-negative-zero-is-not-zero
1567 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1568 #!+negative-zero-is-not-zero
1569 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1572 (define-vop (<0/long-float float-test)
1574 (:args (x :scs (long-reg)))
1575 #!-negative-zero-is-not-zero
1576 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1577 #!+negative-zero-is-not-zero
1578 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1581 (define-vop (>0/single-float float-test)
1583 (:args (x :scs (single-reg)))
1584 #!-negative-zero-is-not-zero
1585 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1586 #!+negative-zero-is-not-zero
1587 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1589 (define-vop (>0/double-float float-test)
1591 (:args (x :scs (double-reg)))
1592 #!-negative-zero-is-not-zero
1593 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1594 #!+negative-zero-is-not-zero
1595 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1598 (define-vop (>0/long-float float-test)
1600 (:args (x :scs (long-reg)))
1601 #!-negative-zero-is-not-zero
1602 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1603 #!+negative-zero-is-not-zero
1604 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1608 (deftransform eql ((x y) (long-float long-float))
1609 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1610 (= (long-float-high-bits x) (long-float-high-bits y))
1611 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1615 (macrolet ((frob (name translate to-sc to-type)
1616 `(define-vop (,name)
1617 (:args (x :scs (signed-stack signed-reg) :target temp))
1618 (:temporary (:sc signed-stack) temp)
1619 (:results (y :scs (,to-sc)))
1620 (:arg-types signed-num)
1621 (:result-types ,to-type)
1622 (:policy :fast-safe)
1623 (:note "inline float coercion")
1624 (:translate ,translate)
1626 (:save-p :compute-only)
1631 (with-empty-tn@fp-top(y)
1632 (note-this-location vop :internal-error)
1635 (with-empty-tn@fp-top(y)
1636 (note-this-location vop :internal-error)
1637 (inst fild x))))))))
1638 (frob %single-float/signed %single-float single-reg single-float)
1639 (frob %double-float/signed %double-float double-reg double-float)
1641 (frob %long-float/signed %long-float long-reg long-float))
1643 (macrolet ((frob (name translate to-sc to-type)
1644 `(define-vop (,name)
1645 (:args (x :scs (unsigned-reg)))
1646 (:results (y :scs (,to-sc)))
1647 (:arg-types unsigned-num)
1648 (:result-types ,to-type)
1649 (:policy :fast-safe)
1650 (:note "inline float coercion")
1651 (:translate ,translate)
1653 (:save-p :compute-only)
1657 (with-empty-tn@fp-top(y)
1658 (note-this-location vop :internal-error)
1659 (inst fildl (make-ea :dword :base esp-tn)))
1660 (inst add esp-tn 8)))))
1661 (frob %single-float/unsigned %single-float single-reg single-float)
1662 (frob %double-float/unsigned %double-float double-reg double-float)
1664 (frob %long-float/unsigned %long-float long-reg long-float))
1666 ;;; These should be no-ops but the compiler might want to move
1667 ;;; some things around
1668 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1669 `(define-vop (,name)
1670 (:args (x :scs (,from-sc) :target y))
1671 (:results (y :scs (,to-sc)))
1672 (:arg-types ,from-type)
1673 (:result-types ,to-type)
1674 (:policy :fast-safe)
1675 (:note "inline float coercion")
1676 (:translate ,translate)
1678 (:save-p :compute-only)
1680 (note-this-location vop :internal-error)
1681 (unless (location= x y)
1683 ((zerop (tn-offset x))
1684 ;; x is in ST0, y is in another reg. not ST0
1686 ((zerop (tn-offset y))
1687 ;; y is in ST0, x is in another reg. not ST0
1688 (copy-fp-reg-to-fr0 x))
1690 ;; Neither x or y are in ST0, and they are not in
1694 (inst fxch x))))))))
1696 (frob %single-float/double-float %single-float double-reg
1697 double-float single-reg single-float)
1699 (frob %single-float/long-float %single-float long-reg
1700 long-float single-reg single-float)
1701 (frob %double-float/single-float %double-float single-reg single-float
1702 double-reg double-float)
1704 (frob %double-float/long-float %double-float long-reg long-float
1705 double-reg double-float)
1707 (frob %long-float/single-float %long-float single-reg single-float
1708 long-reg long-float)
1710 (frob %long-float/double-float %long-float double-reg double-float
1711 long-reg long-float))
1713 (macrolet ((frob (trans from-sc from-type round-p)
1714 `(define-vop (,(symbolicate trans "/" from-type))
1715 (:args (x :scs (,from-sc)))
1716 (:temporary (:sc signed-stack) stack-temp)
1718 '((:temporary (:sc unsigned-stack) scw)
1719 (:temporary (:sc any-reg) rcw)))
1720 (:results (y :scs (signed-reg)))
1721 (:arg-types ,from-type)
1722 (:result-types signed-num)
1724 (:policy :fast-safe)
1725 (:note "inline float truncate")
1727 (:save-p :compute-only)
1730 '((note-this-location vop :internal-error)
1731 ;; Catch any pending FPE exceptions.
1733 (,(if round-p 'progn 'pseudo-atomic)
1734 ;; normal mode (for now) is "round to best"
1737 '((inst fnstcw scw) ; save current control word
1738 (move rcw scw) ; into 16-bit register
1739 (inst or rcw (ash #b11 10)) ; CHOP
1740 (move stack-temp rcw)
1741 (inst fldcw stack-temp)))
1746 (inst fist stack-temp)
1747 (inst mov y stack-temp)))
1749 '((inst fldcw scw)))))))))
1750 (frob %unary-truncate single-reg single-float nil)
1751 (frob %unary-truncate double-reg double-float nil)
1753 (frob %unary-truncate long-reg long-float nil)
1754 (frob %unary-round single-reg single-float t)
1755 (frob %unary-round double-reg double-float t)
1757 (frob %unary-round long-reg long-float t))
1759 (macrolet ((frob (trans from-sc from-type round-p)
1760 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1761 (:args (x :scs (,from-sc) :target fr0))
1762 (:temporary (:sc double-reg :offset fr0-offset
1763 :from :argument :to :result) fr0)
1765 '((:temporary (:sc unsigned-stack) stack-temp)
1766 (:temporary (:sc unsigned-stack) scw)
1767 (:temporary (:sc any-reg) rcw)))
1768 (:results (y :scs (unsigned-reg)))
1769 (:arg-types ,from-type)
1770 (:result-types unsigned-num)
1772 (:policy :fast-safe)
1773 (:note "inline float truncate")
1775 (:save-p :compute-only)
1778 '((note-this-location vop :internal-error)
1779 ;; Catch any pending FPE exceptions.
1781 ;; normal mode (for now) is "round to best"
1782 (unless (zerop (tn-offset x))
1783 (copy-fp-reg-to-fr0 x))
1785 '((inst fnstcw scw) ; save current control word
1786 (move rcw scw) ; into 16-bit register
1787 (inst or rcw (ash #b11 10)) ; CHOP
1788 (move stack-temp rcw)
1789 (inst fldcw stack-temp)))
1791 (inst fistpl (make-ea :dword :base esp-tn))
1793 (inst fld fr0) ; copy fr0 to at least restore stack.
1796 '((inst fldcw scw)))))))
1797 (frob %unary-truncate single-reg single-float nil)
1798 (frob %unary-truncate double-reg double-float nil)
1800 (frob %unary-truncate long-reg long-float nil)
1801 (frob %unary-round single-reg single-float t)
1802 (frob %unary-round double-reg double-float t)
1804 (frob %unary-round long-reg long-float t))
1806 (define-vop (make-single-float)
1807 (:args (bits :scs (signed-reg) :target res
1808 :load-if (not (or (and (sc-is bits signed-stack)
1809 (sc-is res single-reg))
1810 (and (sc-is bits signed-stack)
1811 (sc-is res single-stack)
1812 (location= bits res))))))
1813 (:results (res :scs (single-reg single-stack)))
1814 (:temporary (:sc signed-stack) stack-temp)
1815 (:arg-types signed-num)
1816 (:result-types single-float)
1817 (:translate make-single-float)
1818 (:policy :fast-safe)
1825 (inst mov res bits))
1827 (assert (location= bits res)))))
1831 ;; source must be in memory
1832 (inst mov stack-temp bits)
1833 (with-empty-tn@fp-top(res)
1834 (inst fld stack-temp)))
1836 (with-empty-tn@fp-top(res)
1837 (inst fld bits))))))))
1839 (define-vop (make-double-float)
1840 (:args (hi-bits :scs (signed-reg))
1841 (lo-bits :scs (unsigned-reg)))
1842 (:results (res :scs (double-reg)))
1843 (:temporary (:sc double-stack) temp)
1844 (:arg-types signed-num unsigned-num)
1845 (:result-types double-float)
1846 (:translate make-double-float)
1847 (:policy :fast-safe)
1850 (let ((offset (1+ (tn-offset temp))))
1851 (storew hi-bits ebp-tn (- offset))
1852 (storew lo-bits ebp-tn (- (1+ offset)))
1853 (with-empty-tn@fp-top(res)
1854 (inst fldd (make-ea :dword :base ebp-tn
1855 :disp (- (* (1+ offset) word-bytes))))))))
1858 (define-vop (make-long-float)
1859 (:args (exp-bits :scs (signed-reg))
1860 (hi-bits :scs (unsigned-reg))
1861 (lo-bits :scs (unsigned-reg)))
1862 (:results (res :scs (long-reg)))
1863 (:temporary (:sc long-stack) temp)
1864 (:arg-types signed-num unsigned-num unsigned-num)
1865 (:result-types long-float)
1866 (:translate make-long-float)
1867 (:policy :fast-safe)
1870 (let ((offset (1+ (tn-offset temp))))
1871 (storew exp-bits ebp-tn (- offset))
1872 (storew hi-bits ebp-tn (- (1+ offset)))
1873 (storew lo-bits ebp-tn (- (+ offset 2)))
1874 (with-empty-tn@fp-top(res)
1875 (inst fldl (make-ea :dword :base ebp-tn
1876 :disp (- (* (+ offset 2) word-bytes))))))))
1878 (define-vop (single-float-bits)
1879 (:args (float :scs (single-reg descriptor-reg)
1880 :load-if (not (sc-is float single-stack))))
1881 (:results (bits :scs (signed-reg)))
1882 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1883 (:arg-types single-float)
1884 (:result-types signed-num)
1885 (:translate single-float-bits)
1886 (:policy :fast-safe)
1893 (with-tn@fp-top(float)
1894 (inst fst stack-temp)
1895 (inst mov bits stack-temp)))
1897 (inst mov bits float))
1900 bits float sb!vm:single-float-value-slot
1901 sb!vm:other-pointer-type))))
1905 (with-tn@fp-top(float)
1906 (inst fst bits))))))))
1908 (define-vop (double-float-high-bits)
1909 (:args (float :scs (double-reg descriptor-reg)
1910 :load-if (not (sc-is float double-stack))))
1911 (:results (hi-bits :scs (signed-reg)))
1912 (:temporary (:sc double-stack) temp)
1913 (:arg-types double-float)
1914 (:result-types signed-num)
1915 (:translate double-float-high-bits)
1916 (:policy :fast-safe)
1921 (with-tn@fp-top(float)
1922 (let ((where (make-ea :dword :base ebp-tn
1923 :disp (- (* (+ 2 (tn-offset temp))
1926 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1928 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1930 (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
1931 sb!vm:other-pointer-type)))))
1933 (define-vop (double-float-low-bits)
1934 (:args (float :scs (double-reg descriptor-reg)
1935 :load-if (not (sc-is float double-stack))))
1936 (:results (lo-bits :scs (unsigned-reg)))
1937 (:temporary (:sc double-stack) temp)
1938 (:arg-types double-float)
1939 (:result-types unsigned-num)
1940 (:translate double-float-low-bits)
1941 (:policy :fast-safe)
1946 (with-tn@fp-top(float)
1947 (let ((where (make-ea :dword :base ebp-tn
1948 :disp (- (* (+ 2 (tn-offset temp))
1951 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1953 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1955 (loadw lo-bits float sb!vm:double-float-value-slot
1956 sb!vm:other-pointer-type)))))
1959 (define-vop (long-float-exp-bits)
1960 (:args (float :scs (long-reg descriptor-reg)
1961 :load-if (not (sc-is float long-stack))))
1962 (:results (exp-bits :scs (signed-reg)))
1963 (:temporary (:sc long-stack) temp)
1964 (:arg-types long-float)
1965 (:result-types signed-num)
1966 (:translate long-float-exp-bits)
1967 (:policy :fast-safe)
1972 (with-tn@fp-top(float)
1973 (let ((where (make-ea :dword :base ebp-tn
1974 :disp (- (* (+ 3 (tn-offset temp))
1976 (store-long-float where)))
1977 (inst movsx exp-bits
1978 (make-ea :word :base ebp-tn
1979 :disp (* (- (1+ (tn-offset temp))) word-bytes))))
1981 (inst movsx exp-bits
1982 (make-ea :word :base ebp-tn
1983 :disp (* (- (1+ (tn-offset float))) word-bytes))))
1985 (inst movsx exp-bits
1986 (make-ea :word :base float
1987 :disp (- (* (+ 2 sb!vm:long-float-value-slot)
1989 sb!vm:other-pointer-type)))))))
1992 (define-vop (long-float-high-bits)
1993 (:args (float :scs (long-reg descriptor-reg)
1994 :load-if (not (sc-is float long-stack))))
1995 (:results (hi-bits :scs (unsigned-reg)))
1996 (:temporary (:sc long-stack) temp)
1997 (:arg-types long-float)
1998 (:result-types unsigned-num)
1999 (:translate long-float-high-bits)
2000 (:policy :fast-safe)
2005 (with-tn@fp-top(float)
2006 (let ((where (make-ea :dword :base ebp-tn
2007 :disp (- (* (+ 3 (tn-offset temp))
2009 (store-long-float where)))
2010 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
2012 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
2014 (loadw hi-bits float (1+ sb!vm:long-float-value-slot)
2015 sb!vm:other-pointer-type)))))
2018 (define-vop (long-float-low-bits)
2019 (:args (float :scs (long-reg descriptor-reg)
2020 :load-if (not (sc-is float long-stack))))
2021 (:results (lo-bits :scs (unsigned-reg)))
2022 (:temporary (:sc long-stack) temp)
2023 (:arg-types long-float)
2024 (:result-types unsigned-num)
2025 (:translate long-float-low-bits)
2026 (:policy :fast-safe)
2031 (with-tn@fp-top(float)
2032 (let ((where (make-ea :dword :base ebp-tn
2033 :disp (- (* (+ 3 (tn-offset temp))
2035 (store-long-float where)))
2036 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2038 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2040 (loadw lo-bits float sb!vm:long-float-value-slot
2041 sb!vm:other-pointer-type)))))
2043 ;;;; float mode hackery
2045 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2046 (defknown floating-point-modes () float-modes (flushable))
2047 (defknown ((setf floating-point-modes)) (float-modes)
2050 (defconstant npx-env-size (* 7 sb!vm:word-bytes))
2051 (defconstant npx-cw-offset 0)
2052 (defconstant npx-sw-offset 4)
2054 (define-vop (floating-point-modes)
2055 (:results (res :scs (unsigned-reg)))
2056 (:result-types unsigned-num)
2057 (:translate floating-point-modes)
2058 (:policy :fast-safe)
2059 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2062 (inst sub esp-tn npx-env-size) ; make space on stack
2063 (inst wait) ; Catch any pending FPE exceptions
2064 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2065 (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
2066 ;; Current status to high word
2067 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2068 ;; Exception mask to low word
2069 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2070 (inst add esp-tn npx-env-size) ; Pop stack
2071 (inst xor eax #x3f) ; Flip exception mask to trap enable bits
2074 (define-vop (set-floating-point-modes)
2075 (:args (new :scs (unsigned-reg) :to :result :target res))
2076 (:results (res :scs (unsigned-reg)))
2077 (:arg-types unsigned-num)
2078 (:result-types unsigned-num)
2079 (:translate (setf floating-point-modes))
2080 (:policy :fast-safe)
2081 (:temporary (:sc unsigned-reg :offset eax-offset
2082 :from :eval :to :result) eax)
2084 (inst sub esp-tn npx-env-size) ; make space on stack
2085 (inst wait) ; Catch any pending FPE exceptions
2086 (inst fstenv (make-ea :dword :base esp-tn))
2088 (inst xor eax #x3f) ; turn trap enable bits into exception mask
2089 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2090 (inst shr eax 16) ; position status word
2091 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2092 (inst fldenv (make-ea :dword :base esp-tn))
2093 (inst add esp-tn npx-env-size) ; Pop stack
2099 ;;; Let's use some of the 80387 special functions.
2101 ;;; These defs will not take effect unless code/irrat.lisp is modified
2102 ;;; to remove the inlined alien routine def.
2104 (macrolet ((frob (func trans op)
2105 `(define-vop (,func)
2106 (:args (x :scs (double-reg) :target fr0))
2107 (:temporary (:sc double-reg :offset fr0-offset
2108 :from :argument :to :result) fr0)
2110 (:results (y :scs (double-reg)))
2111 (:arg-types double-float)
2112 (:result-types double-float)
2114 (:policy :fast-safe)
2115 (:note "inline NPX function")
2117 (:save-p :compute-only)
2120 (note-this-location vop :internal-error)
2121 (unless (zerop (tn-offset x))
2122 (inst fxch x) ; x to top of stack
2123 (unless (location= x y)
2124 (inst fst x))) ; maybe save it
2125 (inst ,op) ; clobber st0
2126 (cond ((zerop (tn-offset y))
2127 (when (policy node (or (= debug 3) (> safety speed)))
2132 ;; Quick versions of fsin and fcos that require the argument to be
2133 ;; within range 2^63.
2134 (frob fsin-quick %sin-quick fsin)
2135 (frob fcos-quick %cos-quick fcos)
2136 (frob fsqrt %sqrt fsqrt))
2138 ;;; Quick version of ftan that requires the argument to be within
2140 (define-vop (ftan-quick)
2141 (:translate %tan-quick)
2142 (:args (x :scs (double-reg) :target fr0))
2143 (:temporary (:sc double-reg :offset fr0-offset
2144 :from :argument :to :result) fr0)
2145 (:temporary (:sc double-reg :offset fr1-offset
2146 :from :argument :to :result) fr1)
2147 (:results (y :scs (double-reg)))
2148 (:arg-types double-float)
2149 (:result-types double-float)
2150 (:policy :fast-safe)
2151 (:note "inline tan function")
2153 (:save-p :compute-only)
2155 (note-this-location vop :internal-error)
2164 (inst fldd (make-random-tn :kind :normal
2165 :sc (sc-or-lose 'double-reg)
2166 :offset (- (tn-offset x) 2)))))
2177 ;;; These versions of fsin, fcos, and ftan try to use argument
2178 ;;; reduction but to do this accurately requires greater precision and
2179 ;;; it is hopelessly inaccurate.
2181 (macrolet ((frob (func trans op)
2182 `(define-vop (,func)
2184 (:args (x :scs (double-reg) :target fr0))
2185 (:temporary (:sc unsigned-reg :offset eax-offset
2186 :from :eval :to :result) eax)
2187 (:temporary (:sc unsigned-reg :offset fr0-offset
2188 :from :argument :to :result) fr0)
2189 (:temporary (:sc unsigned-reg :offset fr1-offset
2190 :from :argument :to :result) fr1)
2191 (:results (y :scs (double-reg)))
2192 (:arg-types double-float)
2193 (:result-types double-float)
2194 (:policy :fast-safe)
2195 (:note "inline sin/cos function")
2197 (:save-p :compute-only)
2200 (note-this-location vop :internal-error)
2201 (unless (zerop (tn-offset x))
2202 (inst fxch x) ; x to top of stack
2203 (unless (location= x y)
2204 (inst fst x))) ; maybe save it
2206 (inst fnstsw) ; status word to ax
2207 (inst and ah-tn #x04) ; C2
2209 ;; Else x was out of range so reduce it; ST0 is unchanged.
2210 (inst fstp fr1) ; Load 2*PI
2216 (inst fnstsw) ; status word to ax
2217 (inst and ah-tn #x04) ; C2
2221 (unless (zerop (tn-offset y))
2223 (frob fsin %sin fsin)
2224 (frob fcos %cos fcos))
2229 (:args (x :scs (double-reg) :target fr0))
2230 (:temporary (:sc unsigned-reg :offset eax-offset
2231 :from :argument :to :result) eax)
2232 (:temporary (:sc double-reg :offset fr0-offset
2233 :from :argument :to :result) fr0)
2234 (:temporary (:sc double-reg :offset fr1-offset
2235 :from :argument :to :result) fr1)
2236 (:results (y :scs (double-reg)))
2237 (:arg-types double-float)
2238 (:result-types double-float)
2239 (:policy :fast-safe)
2240 (:note "inline tan function")
2242 (:save-p :compute-only)
2245 (note-this-location vop :internal-error)
2254 (inst fldd (make-random-tn :kind :normal
2255 :sc (sc-or-lose 'double-reg)
2256 :offset (- (tn-offset x) 2)))))
2258 (inst fnstsw) ; status word to ax
2259 (inst and ah-tn #x04) ; C2
2261 ;; Else x was out of range so reduce it; ST0 is unchanged.
2262 (inst fldpi) ; Load 2*PI
2267 (inst fnstsw) ; status word to ax
2268 (inst and ah-tn #x04) ; C2
2282 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2283 ;;; the argument is out of range 2^63 and would thus be hopelessly
2285 (macrolet ((frob (func trans op)
2286 `(define-vop (,func)
2288 (:args (x :scs (double-reg) :target fr0))
2289 (:temporary (:sc double-reg :offset fr0-offset
2290 :from :argument :to :result) fr0)
2291 (:temporary (:sc unsigned-reg :offset eax-offset
2292 :from :argument :to :result) eax)
2293 (:results (y :scs (double-reg)))
2294 (:arg-types double-float)
2295 (:result-types double-float)
2296 (:policy :fast-safe)
2297 (:note "inline sin/cos function")
2299 (:save-p :compute-only)
2302 (note-this-location vop :internal-error)
2303 (unless (zerop (tn-offset x))
2304 (inst fxch x) ; x to top of stack
2305 (unless (location= x y)
2306 (inst fst x))) ; maybe save it
2308 (inst fnstsw) ; status word to ax
2309 (inst and ah-tn #x04) ; C2
2311 ;; Else x was out of range so reduce it; ST0 is unchanged.
2312 (inst fstp fr0) ; Load 0.0
2315 (unless (zerop (tn-offset y))
2317 (frob fsin %sin fsin)
2318 (frob fcos %cos fcos))
2322 (:args (x :scs (double-reg) :target fr0))
2323 (:temporary (:sc double-reg :offset fr0-offset
2324 :from :argument :to :result) fr0)
2325 (:temporary (:sc double-reg :offset fr1-offset
2326 :from :argument :to :result) fr1)
2327 (:temporary (:sc unsigned-reg :offset eax-offset
2328 :from :argument :to :result) eax)
2329 (:results (y :scs (double-reg)))
2330 (:arg-types double-float)
2331 (:result-types double-float)
2333 (:policy :fast-safe)
2334 (:note "inline tan function")
2336 (:save-p :compute-only)
2339 (note-this-location vop :internal-error)
2348 (inst fldd (make-random-tn :kind :normal
2349 :sc (sc-or-lose 'double-reg)
2350 :offset (- (tn-offset x) 2)))))
2352 (inst fnstsw) ; status word to ax
2353 (inst and ah-tn #x04) ; C2
2355 ;; Else x was out of range so reduce it; ST0 is unchanged.
2356 (inst fldz) ; Load 0.0
2371 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2372 (:temporary (:sc double-reg :offset fr0-offset
2373 :from :argument :to :result) fr0)
2374 (:temporary (:sc double-reg :offset fr1-offset
2375 :from :argument :to :result) fr1)
2376 (:temporary (:sc double-reg :offset fr2-offset
2377 :from :argument :to :result) fr2)
2378 (:results (y :scs (double-reg)))
2379 (:arg-types double-float)
2380 (:result-types double-float)
2381 (:policy :fast-safe)
2382 (:note "inline exp function")
2384 (:save-p :compute-only)
2386 (note-this-location vop :internal-error)
2389 (cond ((zerop (tn-offset x))
2395 ;; x is in a FP reg, not fr0
2399 ((double-stack descriptor-reg)
2402 (if (sc-is x double-stack)
2403 (inst fmuld (ea-for-df-stack x))
2404 (inst fmuld (ea-for-df-desc x)))))
2405 ;; Now fr0=x log2(e)
2409 (inst fsubp-sti fr1)
2412 (inst faddp-sti fr1)
2417 (t (inst fstd y)))))
2419 ;;; Modified exp that handles the following special cases:
2420 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2423 (:args (x :scs (double-reg) :target fr0))
2424 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2425 (:temporary (:sc double-reg :offset fr0-offset
2426 :from :argument :to :result) fr0)
2427 (:temporary (:sc double-reg :offset fr1-offset
2428 :from :argument :to :result) fr1)
2429 (:temporary (:sc double-reg :offset fr2-offset
2430 :from :argument :to :result) fr2)
2431 (:results (y :scs (double-reg)))
2432 (:arg-types double-float)
2433 (:result-types double-float)
2434 (:policy :fast-safe)
2435 (:note "inline exp function")
2437 (:save-p :compute-only)
2440 (note-this-location vop :internal-error)
2441 (unless (zerop (tn-offset x))
2442 (inst fxch x) ; x to top of stack
2443 (unless (location= x y)
2444 (inst fst x))) ; maybe save it
2445 ;; Check for Inf or NaN
2449 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2450 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2451 (inst and ah-tn #x02) ; Test sign of Inf.
2452 (inst jmp :z DONE) ; +Inf gives +Inf.
2453 (inst fstp fr0) ; -Inf gives 0
2455 (inst jmp-short DONE)
2460 ;; Now fr0=x log2(e)
2464 (inst fsubp-sti fr1)
2467 (inst faddp-sti fr1)
2471 (unless (zerop (tn-offset y))
2474 ;;; Expm1 = exp(x) - 1.
2475 ;;; Handles the following special cases:
2476 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2477 (define-vop (fexpm1)
2479 (:args (x :scs (double-reg) :target fr0))
2480 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2481 (:temporary (:sc double-reg :offset fr0-offset
2482 :from :argument :to :result) fr0)
2483 (:temporary (:sc double-reg :offset fr1-offset
2484 :from :argument :to :result) fr1)
2485 (:temporary (:sc double-reg :offset fr2-offset
2486 :from :argument :to :result) fr2)
2487 (:results (y :scs (double-reg)))
2488 (:arg-types double-float)
2489 (:result-types double-float)
2490 (:policy :fast-safe)
2491 (:note "inline expm1 function")
2493 (:save-p :compute-only)
2496 (note-this-location vop :internal-error)
2497 (unless (zerop (tn-offset x))
2498 (inst fxch x) ; x to top of stack
2499 (unless (location= x y)
2500 (inst fst x))) ; maybe save it
2501 ;; Check for Inf or NaN
2505 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2506 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2507 (inst and ah-tn #x02) ; Test sign of Inf.
2508 (inst jmp :z DONE) ; +Inf gives +Inf.
2509 (inst fstp fr0) ; -Inf gives -1.0
2512 (inst jmp-short DONE)
2514 ;; Free two stack slots leaving the argument on top.
2518 (inst fmul fr1) ; Now fr0 = x log2(e)
2533 (unless (zerop (tn-offset y))
2538 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2539 (:temporary (:sc double-reg :offset fr0-offset
2540 :from :argument :to :result) fr0)
2541 (:temporary (:sc double-reg :offset fr1-offset
2542 :from :argument :to :result) fr1)
2543 (:results (y :scs (double-reg)))
2544 (:arg-types double-float)
2545 (:result-types double-float)
2546 (:policy :fast-safe)
2547 (:note "inline log function")
2549 (:save-p :compute-only)
2551 (note-this-location vop :internal-error)
2566 ;; x is in a FP reg, not fr0 or fr1
2570 (inst fldd (make-random-tn :kind :normal
2571 :sc (sc-or-lose 'double-reg)
2572 :offset (1- (tn-offset x))))))
2574 ((double-stack descriptor-reg)
2578 (if (sc-is x double-stack)
2579 (inst fldd (ea-for-df-stack x))
2580 (inst fldd (ea-for-df-desc x)))
2585 (t (inst fstd y)))))
2587 (define-vop (flog10)
2589 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2590 (:temporary (:sc double-reg :offset fr0-offset
2591 :from :argument :to :result) fr0)
2592 (:temporary (:sc double-reg :offset fr1-offset
2593 :from :argument :to :result) fr1)
2594 (:results (y :scs (double-reg)))
2595 (:arg-types double-float)
2596 (:result-types double-float)
2597 (:policy :fast-safe)
2598 (:note "inline log10 function")
2600 (:save-p :compute-only)
2602 (note-this-location vop :internal-error)
2617 ;; x is in a FP reg, not fr0 or fr1
2621 (inst fldd (make-random-tn :kind :normal
2622 :sc (sc-or-lose 'double-reg)
2623 :offset (1- (tn-offset x))))))
2625 ((double-stack descriptor-reg)
2629 (if (sc-is x double-stack)
2630 (inst fldd (ea-for-df-stack x))
2631 (inst fldd (ea-for-df-desc x)))
2636 (t (inst fstd y)))))
2640 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2641 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2642 (:temporary (:sc double-reg :offset fr0-offset
2643 :from (:argument 0) :to :result) fr0)
2644 (:temporary (:sc double-reg :offset fr1-offset
2645 :from (:argument 1) :to :result) fr1)
2646 (:temporary (:sc double-reg :offset fr2-offset
2647 :from :load :to :result) fr2)
2648 (:results (r :scs (double-reg)))
2649 (:arg-types double-float double-float)
2650 (:result-types double-float)
2651 (:policy :fast-safe)
2652 (:note "inline pow function")
2654 (:save-p :compute-only)
2656 (note-this-location vop :internal-error)
2657 ;; Setup x in fr0 and y in fr1
2659 ;; x in fr0; y in fr1
2660 ((and (sc-is x double-reg) (zerop (tn-offset x))
2661 (sc-is y double-reg) (= 1 (tn-offset y))))
2662 ;; y in fr1; x not in fr0
2663 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2667 (copy-fp-reg-to-fr0 x))
2670 (inst fldd (ea-for-df-stack x)))
2673 (inst fldd (ea-for-df-desc x)))))
2674 ;; x in fr0; y not in fr1
2675 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2677 ;; Now load y to fr0
2680 (copy-fp-reg-to-fr0 y))
2683 (inst fldd (ea-for-df-stack y)))
2686 (inst fldd (ea-for-df-desc y))))
2688 ;; x in fr1; y not in fr1
2689 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2693 (copy-fp-reg-to-fr0 y))
2696 (inst fldd (ea-for-df-stack y)))
2699 (inst fldd (ea-for-df-desc y))))
2702 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2704 ;; Now load x to fr0
2707 (copy-fp-reg-to-fr0 x))
2710 (inst fldd (ea-for-df-stack x)))
2713 (inst fldd (ea-for-df-desc x)))))
2714 ;; Neither x or y are in either fr0 or fr1
2721 (inst fldd (make-random-tn :kind :normal
2722 :sc (sc-or-lose 'double-reg)
2723 :offset (- (tn-offset y) 2))))
2725 (inst fldd (ea-for-df-stack y)))
2727 (inst fldd (ea-for-df-desc y))))
2731 (inst fldd (make-random-tn :kind :normal
2732 :sc (sc-or-lose 'double-reg)
2733 :offset (1- (tn-offset x)))))
2735 (inst fldd (ea-for-df-stack x)))
2737 (inst fldd (ea-for-df-desc x))))))
2739 ;; Now have x at fr0; and y at fr1
2741 ;; Now fr0=y log2(x)
2745 (inst fsubp-sti fr1)
2748 (inst faddp-sti fr1)
2753 (t (inst fstd r)))))
2755 (define-vop (fscalen)
2756 (:translate %scalbn)
2757 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2758 (y :scs (signed-stack signed-reg) :target temp))
2759 (:temporary (:sc double-reg :offset fr0-offset
2760 :from (:argument 0) :to :result) fr0)
2761 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2762 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2763 (:results (r :scs (double-reg)))
2764 (:arg-types double-float signed-num)
2765 (:result-types double-float)
2766 (:policy :fast-safe)
2767 (:note "inline scalbn function")
2769 ;; Setup x in fr0 and y in fr1
2800 (inst fld (make-random-tn :kind :normal
2801 :sc (sc-or-lose 'double-reg)
2802 :offset (1- (tn-offset x)))))))
2803 ((double-stack descriptor-reg)
2812 (if (sc-is x double-stack)
2813 (inst fldd (ea-for-df-stack x))
2814 (inst fldd (ea-for-df-desc x)))))
2816 (unless (zerop (tn-offset r))
2819 (define-vop (fscale)
2821 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2822 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2823 (:temporary (:sc double-reg :offset fr0-offset
2824 :from (:argument 0) :to :result) fr0)
2825 (:temporary (:sc double-reg :offset fr1-offset
2826 :from (:argument 1) :to :result) fr1)
2827 (:results (r :scs (double-reg)))
2828 (:arg-types double-float double-float)
2829 (:result-types double-float)
2830 (:policy :fast-safe)
2831 (:note "inline scalb function")
2833 (:save-p :compute-only)
2835 (note-this-location vop :internal-error)
2836 ;; Setup x in fr0 and y in fr1
2838 ;; x in fr0; y in fr1
2839 ((and (sc-is x double-reg) (zerop (tn-offset x))
2840 (sc-is y double-reg) (= 1 (tn-offset y))))
2841 ;; y in fr1; x not in fr0
2842 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2846 (copy-fp-reg-to-fr0 x))
2849 (inst fldd (ea-for-df-stack x)))
2852 (inst fldd (ea-for-df-desc x)))))
2853 ;; x in fr0; y not in fr1
2854 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2856 ;; Now load y to fr0
2859 (copy-fp-reg-to-fr0 y))
2862 (inst fldd (ea-for-df-stack y)))
2865 (inst fldd (ea-for-df-desc y))))
2867 ;; x in fr1; y not in fr1
2868 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2872 (copy-fp-reg-to-fr0 y))
2875 (inst fldd (ea-for-df-stack y)))
2878 (inst fldd (ea-for-df-desc y))))
2881 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2883 ;; Now load x to fr0
2886 (copy-fp-reg-to-fr0 x))
2889 (inst fldd (ea-for-df-stack x)))
2892 (inst fldd (ea-for-df-desc x)))))
2893 ;; Neither x or y are in either fr0 or fr1
2900 (inst fldd (make-random-tn :kind :normal
2901 :sc (sc-or-lose 'double-reg)
2902 :offset (- (tn-offset y) 2))))
2904 (inst fldd (ea-for-df-stack y)))
2906 (inst fldd (ea-for-df-desc y))))
2910 (inst fldd (make-random-tn :kind :normal
2911 :sc (sc-or-lose 'double-reg)
2912 :offset (1- (tn-offset x)))))
2914 (inst fldd (ea-for-df-stack x)))
2916 (inst fldd (ea-for-df-desc x))))))
2918 ;; Now have x at fr0; and y at fr1
2920 (unless (zerop (tn-offset r))
2923 (define-vop (flog1p)
2925 (:args (x :scs (double-reg) :to :result))
2926 (:temporary (:sc double-reg :offset fr0-offset
2927 :from :argument :to :result) fr0)
2928 (:temporary (:sc double-reg :offset fr1-offset
2929 :from :argument :to :result) fr1)
2930 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2931 (:results (y :scs (double-reg)))
2932 (:arg-types double-float)
2933 (:result-types double-float)
2934 (:policy :fast-safe)
2935 ;; FIXME: PENTIUM isn't used on the *FEATURES* list of the CMU CL I based
2936 ;; SBCL on, even when it is running on a Pentium. Find out what's going
2937 ;; on here and see what the proper value should be. (Perhaps just use the
2938 ;; apparently-conservative value of T always?) For more confusion, see also
2939 ;; apparently-reversed-sense test for the FLOG1P-PENTIUM vop below.
2940 (:guard #!+pentium nil #!-pentium t)
2941 (:note "inline log1p function")
2944 ;; x is in a FP reg, not fr0, fr1.
2947 (inst fldd (make-random-tn :kind :normal
2948 :sc (sc-or-lose 'double-reg)
2949 :offset (- (tn-offset x) 2)))
2951 (inst push #x3e947ae1) ; Constant 0.29
2953 (inst fld (make-ea :dword :base esp-tn))
2956 (inst fnstsw) ; status word to ax
2957 (inst and ah-tn #x45)
2958 (inst jmp :z WITHIN-RANGE)
2959 ;; Out of range for fyl2xp1.
2961 (inst faddd (make-random-tn :kind :normal
2962 :sc (sc-or-lose 'double-reg)
2963 :offset (- (tn-offset x) 1)))
2971 (inst fldd (make-random-tn :kind :normal
2972 :sc (sc-or-lose 'double-reg)
2973 :offset (- (tn-offset x) 1)))
2979 (t (inst fstd y)))))
2981 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2982 ;;; instruction and a range check can be avoided.
2983 (define-vop (flog1p-pentium)
2985 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2986 (:temporary (:sc double-reg :offset fr0-offset
2987 :from :argument :to :result) fr0)
2988 (:temporary (:sc double-reg :offset fr1-offset
2989 :from :argument :to :result) fr1)
2990 (:results (y :scs (double-reg)))
2991 (:arg-types double-float)
2992 (:result-types double-float)
2993 (:policy :fast-safe)
2994 ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
2995 (:guard #!+pentium t #!-pentium nil)
2996 (:note "inline log1p with limited x range function")
2998 (:save-p :compute-only)
3000 (note-this-location vop :internal-error)
3015 ;; x is in a FP reg, not fr0 or fr1
3019 (inst fldd (make-random-tn :kind :normal
3020 :sc (sc-or-lose 'double-reg)
3021 :offset (1- (tn-offset x)))))))
3022 ((double-stack descriptor-reg)
3026 (if (sc-is x double-stack)
3027 (inst fldd (ea-for-df-stack x))
3028 (inst fldd (ea-for-df-desc x)))))
3033 (t (inst fstd y)))))
3037 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3038 (:temporary (:sc double-reg :offset fr0-offset
3039 :from :argument :to :result) fr0)
3040 (:temporary (:sc double-reg :offset fr1-offset
3041 :from :argument :to :result) fr1)
3042 (:results (y :scs (double-reg)))
3043 (:arg-types double-float)
3044 (:result-types double-float)
3045 (:policy :fast-safe)
3046 (:note "inline logb function")
3048 (:save-p :compute-only)
3050 (note-this-location vop :internal-error)
3061 ;; x is in a FP reg, not fr0 or fr1
3064 (inst fldd (make-random-tn :kind :normal
3065 :sc (sc-or-lose 'double-reg)
3066 :offset (- (tn-offset x) 2))))))
3067 ((double-stack descriptor-reg)
3070 (if (sc-is x double-stack)
3071 (inst fldd (ea-for-df-stack x))
3072 (inst fldd (ea-for-df-desc x)))))
3083 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3084 (:temporary (:sc double-reg :offset fr0-offset
3085 :from (:argument 0) :to :result) fr0)
3086 (:temporary (:sc double-reg :offset fr1-offset
3087 :from (:argument 0) :to :result) fr1)
3088 (:results (r :scs (double-reg)))
3089 (:arg-types double-float)
3090 (:result-types double-float)
3091 (:policy :fast-safe)
3092 (:note "inline atan function")
3094 (:save-p :compute-only)
3096 (note-this-location vop :internal-error)
3097 ;; Setup x in fr1 and 1.0 in fr0
3100 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3103 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3105 ;; x not in fr0 or fr1
3112 (inst fldd (make-random-tn :kind :normal
3113 :sc (sc-or-lose 'double-reg)
3114 :offset (- (tn-offset x) 2))))
3116 (inst fldd (ea-for-df-stack x)))
3118 (inst fldd (ea-for-df-desc x))))))
3120 ;; Now have x at fr1; and 1.0 at fr0
3125 (t (inst fstd r)))))
3127 (define-vop (fatan2)
3129 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3130 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3131 (:temporary (:sc double-reg :offset fr0-offset
3132 :from (:argument 1) :to :result) fr0)
3133 (:temporary (:sc double-reg :offset fr1-offset
3134 :from (:argument 0) :to :result) fr1)
3135 (:results (r :scs (double-reg)))
3136 (:arg-types double-float double-float)
3137 (:result-types double-float)
3138 (:policy :fast-safe)
3139 (:note "inline atan2 function")
3141 (:save-p :compute-only)
3143 (note-this-location vop :internal-error)
3144 ;; Setup x in fr1 and y in fr0
3146 ;; y in fr0; x in fr1
3147 ((and (sc-is y double-reg) (zerop (tn-offset y))
3148 (sc-is x double-reg) (= 1 (tn-offset x))))
3149 ;; x in fr1; y not in fr0
3150 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3154 (copy-fp-reg-to-fr0 y))
3157 (inst fldd (ea-for-df-stack y)))
3160 (inst fldd (ea-for-df-desc y)))))
3161 ;; y in fr0; x not in fr1
3162 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3164 ;; Now load x to fr0
3167 (copy-fp-reg-to-fr0 x))
3170 (inst fldd (ea-for-df-stack x)))
3173 (inst fldd (ea-for-df-desc x))))
3175 ;; y in fr1; x not in fr1
3176 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3180 (copy-fp-reg-to-fr0 x))
3183 (inst fldd (ea-for-df-stack x)))
3186 (inst fldd (ea-for-df-desc x))))
3189 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3191 ;; Now load y to fr0
3194 (copy-fp-reg-to-fr0 y))
3197 (inst fldd (ea-for-df-stack y)))
3200 (inst fldd (ea-for-df-desc y)))))
3201 ;; Neither y or x are in either fr0 or fr1
3208 (inst fldd (make-random-tn :kind :normal
3209 :sc (sc-or-lose 'double-reg)
3210 :offset (- (tn-offset x) 2))))
3212 (inst fldd (ea-for-df-stack x)))
3214 (inst fldd (ea-for-df-desc x))))
3218 (inst fldd (make-random-tn :kind :normal
3219 :sc (sc-or-lose 'double-reg)
3220 :offset (1- (tn-offset y)))))
3222 (inst fldd (ea-for-df-stack y)))
3224 (inst fldd (ea-for-df-desc y))))))
3226 ;; Now have y at fr0; and x at fr1
3231 (t (inst fstd r)))))
3233 ) ; progn #!-long-float
3240 ;;; Lets use some of the 80387 special functions.
3242 ;;; These defs will not take effect unless code/irrat.lisp is modified
3243 ;;; to remove the inlined alien routine def.
3245 (macrolet ((frob (func trans op)
3246 `(define-vop (,func)
3247 (:args (x :scs (long-reg) :target fr0))
3248 (:temporary (:sc long-reg :offset fr0-offset
3249 :from :argument :to :result) fr0)
3251 (:results (y :scs (long-reg)))
3252 (:arg-types long-float)
3253 (:result-types long-float)
3255 (:policy :fast-safe)
3256 (:note "inline NPX function")
3258 (:save-p :compute-only)
3261 (note-this-location vop :internal-error)
3262 (unless (zerop (tn-offset x))
3263 (inst fxch x) ; x to top of stack
3264 (unless (location= x y)
3265 (inst fst x))) ; maybe save it
3266 (inst ,op) ; clobber st0
3267 (cond ((zerop (tn-offset y))
3268 (when (policy node (or (= debug 3) (> safety speed)))
3273 ;; Quick versions of fsin and fcos that require the argument to be
3274 ;; within range 2^63.
3275 (frob fsin-quick %sin-quick fsin)
3276 (frob fcos-quick %cos-quick fcos)
3277 (frob fsqrt %sqrt fsqrt))
3279 ;;; Quick version of ftan that requires the argument to be within
3281 (define-vop (ftan-quick)
3282 (:translate %tan-quick)
3283 (:args (x :scs (long-reg) :target fr0))
3284 (:temporary (:sc long-reg :offset fr0-offset
3285 :from :argument :to :result) fr0)
3286 (:temporary (:sc long-reg :offset fr1-offset
3287 :from :argument :to :result) fr1)
3288 (:results (y :scs (long-reg)))
3289 (:arg-types long-float)
3290 (:result-types long-float)
3291 (:policy :fast-safe)
3292 (:note "inline tan function")
3294 (:save-p :compute-only)
3296 (note-this-location vop :internal-error)
3305 (inst fldd (make-random-tn :kind :normal
3306 :sc (sc-or-lose 'double-reg)
3307 :offset (- (tn-offset x) 2)))))
3318 ;;; These versions of fsin, fcos, and ftan try to use argument
3319 ;;; reduction but to do this accurately requires greater precision and
3320 ;;; it is hopelessly inaccurate.
3322 (macrolet ((frob (func trans op)
3323 `(define-vop (,func)
3325 (:args (x :scs (long-reg) :target fr0))
3326 (:temporary (:sc unsigned-reg :offset eax-offset
3327 :from :eval :to :result) eax)
3328 (:temporary (:sc long-reg :offset fr0-offset
3329 :from :argument :to :result) fr0)
3330 (:temporary (:sc long-reg :offset fr1-offset
3331 :from :argument :to :result) fr1)
3332 (:results (y :scs (long-reg)))
3333 (:arg-types long-float)
3334 (:result-types long-float)
3335 (:policy :fast-safe)
3336 (:note "inline sin/cos function")
3338 (:save-p :compute-only)
3341 (note-this-location vop :internal-error)
3342 (unless (zerop (tn-offset x))
3343 (inst fxch x) ; x to top of stack
3344 (unless (location= x y)
3345 (inst fst x))) ; maybe save it
3347 (inst fnstsw) ; status word to ax
3348 (inst and ah-tn #x04) ; C2
3350 ;; Else x was out of range so reduce it; ST0 is unchanged.
3351 (inst fstp fr1) ; Load 2*PI
3357 (inst fnstsw) ; status word to ax
3358 (inst and ah-tn #x04) ; C2
3362 (unless (zerop (tn-offset y))
3364 (frob fsin %sin fsin)
3365 (frob fcos %cos fcos))
3370 (:args (x :scs (long-reg) :target fr0))
3371 (:temporary (:sc unsigned-reg :offset eax-offset
3372 :from :argument :to :result) eax)
3373 (:temporary (:sc long-reg :offset fr0-offset
3374 :from :argument :to :result) fr0)
3375 (:temporary (:sc long-reg :offset fr1-offset
3376 :from :argument :to :result) fr1)
3377 (:results (y :scs (long-reg)))
3378 (:arg-types long-float)
3379 (:result-types long-float)
3380 (:policy :fast-safe)
3381 (:note "inline tan function")
3383 (:save-p :compute-only)
3386 (note-this-location vop :internal-error)
3395 (inst fldd (make-random-tn :kind :normal
3396 :sc (sc-or-lose 'double-reg)
3397 :offset (- (tn-offset x) 2)))))
3399 (inst fnstsw) ; status word to ax
3400 (inst and ah-tn #x04) ; C2
3402 ;; Else x was out of range so reduce it; ST0 is unchanged.
3403 (inst fldpi) ; Load 2*PI
3408 (inst fnstsw) ; status word to ax
3409 (inst and ah-tn #x04) ; C2
3423 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3424 ;;; the argument is out of range 2^63 and would thus be hopelessly
3426 (macrolet ((frob (func trans op)
3427 `(define-vop (,func)
3429 (:args (x :scs (long-reg) :target fr0))
3430 (:temporary (:sc long-reg :offset fr0-offset
3431 :from :argument :to :result) fr0)
3432 (:temporary (:sc unsigned-reg :offset eax-offset
3433 :from :argument :to :result) eax)
3434 (:results (y :scs (long-reg)))
3435 (:arg-types long-float)
3436 (:result-types long-float)
3437 (:policy :fast-safe)
3438 (:note "inline sin/cos function")
3440 (:save-p :compute-only)
3443 (note-this-location vop :internal-error)
3444 (unless (zerop (tn-offset x))
3445 (inst fxch x) ; x to top of stack
3446 (unless (location= x y)
3447 (inst fst x))) ; maybe save it
3449 (inst fnstsw) ; status word to ax
3450 (inst and ah-tn #x04) ; C2
3452 ;; Else x was out of range so reduce it; ST0 is unchanged.
3453 (inst fstp fr0) ; Load 0.0
3456 (unless (zerop (tn-offset y))
3458 (frob fsin %sin fsin)
3459 (frob fcos %cos fcos))
3463 (:args (x :scs (long-reg) :target fr0))
3464 (:temporary (:sc long-reg :offset fr0-offset
3465 :from :argument :to :result) fr0)
3466 (:temporary (:sc long-reg :offset fr1-offset
3467 :from :argument :to :result) fr1)
3468 (:temporary (:sc unsigned-reg :offset eax-offset
3469 :from :argument :to :result) eax)
3470 (:results (y :scs (long-reg)))
3471 (:arg-types long-float)
3472 (:result-types long-float)
3474 (:policy :fast-safe)
3475 (:note "inline tan function")
3477 (:save-p :compute-only)
3480 (note-this-location vop :internal-error)
3489 (inst fldd (make-random-tn :kind :normal
3490 :sc (sc-or-lose 'double-reg)
3491 :offset (- (tn-offset x) 2)))))
3493 (inst fnstsw) ; status word to ax
3494 (inst and ah-tn #x04) ; C2
3496 ;; Else x was out of range so reduce it; ST0 is unchanged.
3497 (inst fldz) ; Load 0.0
3509 ;;; Modified exp that handles the following special cases:
3510 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3513 (:args (x :scs (long-reg) :target fr0))
3514 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3515 (:temporary (:sc long-reg :offset fr0-offset
3516 :from :argument :to :result) fr0)
3517 (:temporary (:sc long-reg :offset fr1-offset
3518 :from :argument :to :result) fr1)
3519 (:temporary (:sc long-reg :offset fr2-offset
3520 :from :argument :to :result) fr2)
3521 (:results (y :scs (long-reg)))
3522 (:arg-types long-float)
3523 (:result-types long-float)
3524 (:policy :fast-safe)
3525 (:note "inline exp function")
3527 (:save-p :compute-only)
3530 (note-this-location vop :internal-error)
3531 (unless (zerop (tn-offset x))
3532 (inst fxch x) ; x to top of stack
3533 (unless (location= x y)
3534 (inst fst x))) ; maybe save it
3535 ;; Check for Inf or NaN
3539 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3540 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3541 (inst and ah-tn #x02) ; Test sign of Inf.
3542 (inst jmp :z DONE) ; +Inf gives +Inf.
3543 (inst fstp fr0) ; -Inf gives 0
3545 (inst jmp-short DONE)
3550 ;; Now fr0=x log2(e)
3554 (inst fsubp-sti fr1)
3557 (inst faddp-sti fr1)
3561 (unless (zerop (tn-offset y))
3564 ;;; Expm1 = exp(x) - 1.
3565 ;;; Handles the following special cases:
3566 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3567 (define-vop (fexpm1)
3569 (:args (x :scs (long-reg) :target fr0))
3570 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3571 (:temporary (:sc long-reg :offset fr0-offset
3572 :from :argument :to :result) fr0)
3573 (:temporary (:sc long-reg :offset fr1-offset
3574 :from :argument :to :result) fr1)
3575 (:temporary (:sc long-reg :offset fr2-offset
3576 :from :argument :to :result) fr2)
3577 (:results (y :scs (long-reg)))
3578 (:arg-types long-float)
3579 (:result-types long-float)
3580 (:policy :fast-safe)
3581 (:note "inline expm1 function")
3583 (:save-p :compute-only)
3586 (note-this-location vop :internal-error)
3587 (unless (zerop (tn-offset x))
3588 (inst fxch x) ; x to top of stack
3589 (unless (location= x y)
3590 (inst fst x))) ; maybe save it
3591 ;; Check for Inf or NaN
3595 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3596 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3597 (inst and ah-tn #x02) ; Test sign of Inf.
3598 (inst jmp :z DONE) ; +Inf gives +Inf.
3599 (inst fstp fr0) ; -Inf gives -1.0
3602 (inst jmp-short DONE)
3604 ;; Free two stack slots leaving the argument on top.
3608 (inst fmul fr1) ; Now fr0 = x log2(e)
3623 (unless (zerop (tn-offset y))
3628 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3629 (:temporary (:sc long-reg :offset fr0-offset
3630 :from :argument :to :result) fr0)
3631 (:temporary (:sc long-reg :offset fr1-offset
3632 :from :argument :to :result) fr1)
3633 (:results (y :scs (long-reg)))
3634 (:arg-types long-float)
3635 (:result-types long-float)
3636 (:policy :fast-safe)
3637 (:note "inline log function")
3639 (:save-p :compute-only)
3641 (note-this-location vop :internal-error)
3656 ;; x is in a FP reg, not fr0 or fr1
3660 (inst fldd (make-random-tn :kind :normal
3661 :sc (sc-or-lose 'double-reg)
3662 :offset (1- (tn-offset x))))))
3664 ((long-stack descriptor-reg)
3668 (if (sc-is x long-stack)
3669 (inst fldl (ea-for-lf-stack x))
3670 (inst fldl (ea-for-lf-desc x)))
3675 (t (inst fstd y)))))
3677 (define-vop (flog10)
3679 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3680 (:temporary (:sc long-reg :offset fr0-offset
3681 :from :argument :to :result) fr0)
3682 (:temporary (:sc long-reg :offset fr1-offset
3683 :from :argument :to :result) fr1)
3684 (:results (y :scs (long-reg)))
3685 (:arg-types long-float)
3686 (:result-types long-float)
3687 (:policy :fast-safe)
3688 (:note "inline log10 function")
3690 (:save-p :compute-only)
3692 (note-this-location vop :internal-error)
3707 ;; x is in a FP reg, not fr0 or fr1
3711 (inst fldd (make-random-tn :kind :normal
3712 :sc (sc-or-lose 'double-reg)
3713 :offset (1- (tn-offset x))))))
3715 ((long-stack descriptor-reg)
3719 (if (sc-is x long-stack)
3720 (inst fldl (ea-for-lf-stack x))
3721 (inst fldl (ea-for-lf-desc x)))
3726 (t (inst fstd y)))))
3730 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3731 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3732 (:temporary (:sc long-reg :offset fr0-offset
3733 :from (:argument 0) :to :result) fr0)
3734 (:temporary (:sc long-reg :offset fr1-offset
3735 :from (:argument 1) :to :result) fr1)
3736 (:temporary (:sc long-reg :offset fr2-offset
3737 :from :load :to :result) fr2)
3738 (:results (r :scs (long-reg)))
3739 (:arg-types long-float long-float)
3740 (:result-types long-float)
3741 (:policy :fast-safe)
3742 (:note "inline pow function")
3744 (:save-p :compute-only)
3746 (note-this-location vop :internal-error)
3747 ;; Setup x in fr0 and y in fr1
3749 ;; x in fr0; y in fr1
3750 ((and (sc-is x long-reg) (zerop (tn-offset x))
3751 (sc-is y long-reg) (= 1 (tn-offset y))))
3752 ;; y in fr1; x not in fr0
3753 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3757 (copy-fp-reg-to-fr0 x))
3760 (inst fldl (ea-for-lf-stack x)))
3763 (inst fldl (ea-for-lf-desc x)))))
3764 ;; x in fr0; y not in fr1
3765 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3767 ;; Now load y to fr0
3770 (copy-fp-reg-to-fr0 y))
3773 (inst fldl (ea-for-lf-stack y)))
3776 (inst fldl (ea-for-lf-desc y))))
3778 ;; x in fr1; y not in fr1
3779 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3783 (copy-fp-reg-to-fr0 y))
3786 (inst fldl (ea-for-lf-stack y)))
3789 (inst fldl (ea-for-lf-desc y))))
3792 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3794 ;; Now load x to fr0
3797 (copy-fp-reg-to-fr0 x))
3800 (inst fldl (ea-for-lf-stack x)))
3803 (inst fldl (ea-for-lf-desc x)))))
3804 ;; Neither x or y are in either fr0 or fr1
3811 (inst fldd (make-random-tn :kind :normal
3812 :sc (sc-or-lose 'double-reg)
3813 :offset (- (tn-offset y) 2))))
3815 (inst fldl (ea-for-lf-stack y)))
3817 (inst fldl (ea-for-lf-desc y))))
3821 (inst fldd (make-random-tn :kind :normal
3822 :sc (sc-or-lose 'double-reg)
3823 :offset (1- (tn-offset x)))))
3825 (inst fldl (ea-for-lf-stack x)))
3827 (inst fldl (ea-for-lf-desc x))))))
3829 ;; Now have x at fr0; and y at fr1
3831 ;; Now fr0=y log2(x)
3835 (inst fsubp-sti fr1)
3838 (inst faddp-sti fr1)
3843 (t (inst fstd r)))))
3845 (define-vop (fscalen)
3846 (:translate %scalbn)
3847 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3848 (y :scs (signed-stack signed-reg) :target temp))
3849 (:temporary (:sc long-reg :offset fr0-offset
3850 :from (:argument 0) :to :result) fr0)
3851 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3852 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3853 (:results (r :scs (long-reg)))
3854 (:arg-types long-float signed-num)
3855 (:result-types long-float)
3856 (:policy :fast-safe)
3857 (:note "inline scalbn function")
3859 ;; Setup x in fr0 and y in fr1
3890 (inst fld (make-random-tn :kind :normal
3891 :sc (sc-or-lose 'double-reg)
3892 :offset (1- (tn-offset x)))))))
3893 ((long-stack descriptor-reg)
3902 (if (sc-is x long-stack)
3903 (inst fldl (ea-for-lf-stack x))
3904 (inst fldl (ea-for-lf-desc x)))))
3906 (unless (zerop (tn-offset r))
3909 (define-vop (fscale)
3911 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3912 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3913 (:temporary (:sc long-reg :offset fr0-offset
3914 :from (:argument 0) :to :result) fr0)
3915 (:temporary (:sc long-reg :offset fr1-offset
3916 :from (:argument 1) :to :result) fr1)
3917 (:results (r :scs (long-reg)))
3918 (:arg-types long-float long-float)
3919 (:result-types long-float)
3920 (:policy :fast-safe)
3921 (:note "inline scalb function")
3923 (:save-p :compute-only)
3925 (note-this-location vop :internal-error)
3926 ;; Setup x in fr0 and y in fr1
3928 ;; x in fr0; y in fr1
3929 ((and (sc-is x long-reg) (zerop (tn-offset x))
3930 (sc-is y long-reg) (= 1 (tn-offset y))))
3931 ;; y in fr1; x not in fr0
3932 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3936 (copy-fp-reg-to-fr0 x))
3939 (inst fldl (ea-for-lf-stack x)))
3942 (inst fldl (ea-for-lf-desc x)))))
3943 ;; x in fr0; y not in fr1
3944 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3946 ;; Now load y to fr0
3949 (copy-fp-reg-to-fr0 y))
3952 (inst fldl (ea-for-lf-stack y)))
3955 (inst fldl (ea-for-lf-desc y))))
3957 ;; x in fr1; y not in fr1
3958 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3962 (copy-fp-reg-to-fr0 y))
3965 (inst fldl (ea-for-lf-stack y)))
3968 (inst fldl (ea-for-lf-desc y))))
3971 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3973 ;; Now load x to fr0
3976 (copy-fp-reg-to-fr0 x))
3979 (inst fldl (ea-for-lf-stack x)))
3982 (inst fldl (ea-for-lf-desc x)))))
3983 ;; Neither x or y are in either fr0 or fr1
3990 (inst fldd (make-random-tn :kind :normal
3991 :sc (sc-or-lose 'double-reg)
3992 :offset (- (tn-offset y) 2))))
3994 (inst fldl (ea-for-lf-stack y)))
3996 (inst fldl (ea-for-lf-desc y))))
4000 (inst fldd (make-random-tn :kind :normal
4001 :sc (sc-or-lose 'double-reg)
4002 :offset (1- (tn-offset x)))))
4004 (inst fldl (ea-for-lf-stack x)))
4006 (inst fldl (ea-for-lf-desc x))))))
4008 ;; Now have x at fr0; and y at fr1
4010 (unless (zerop (tn-offset r))
4013 (define-vop (flog1p)
4015 (:args (x :scs (long-reg) :to :result))
4016 (:temporary (:sc long-reg :offset fr0-offset
4017 :from :argument :to :result) fr0)
4018 (:temporary (:sc long-reg :offset fr1-offset
4019 :from :argument :to :result) fr1)
4020 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
4021 (:results (y :scs (long-reg)))
4022 (:arg-types long-float)
4023 (:result-types long-float)
4024 (:policy :fast-safe)
4025 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
4026 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
4027 ;; an enormous PROGN above. Still, it would be probably be good to
4028 ;; add some code to warn about redefining VOPs.
4029 ;; FIXME 2: See comments on DEFINE-VOP FLOG1P :GUARD above.
4030 (:guard #!+pentium nil #!-pentium t)
4031 (:note "inline log1p function")
4034 ;; x is in a FP reg, not fr0, fr1.
4037 (inst fldd (make-random-tn :kind :normal
4038 :sc (sc-or-lose 'double-reg)
4039 :offset (- (tn-offset x) 2)))
4041 (inst push #x3e947ae1) ; Constant 0.29
4043 (inst fld (make-ea :dword :base esp-tn))
4046 (inst fnstsw) ; status word to ax
4047 (inst and ah-tn #x45)
4048 (inst jmp :z WITHIN-RANGE)
4049 ;; Out of range for fyl2xp1.
4051 (inst faddd (make-random-tn :kind :normal
4052 :sc (sc-or-lose 'double-reg)
4053 :offset (- (tn-offset x) 1)))
4061 (inst fldd (make-random-tn :kind :normal
4062 :sc (sc-or-lose 'double-reg)
4063 :offset (- (tn-offset x) 1)))
4069 (t (inst fstd y)))))
4071 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4072 ;;; instruction and a range check can be avoided.
4073 (define-vop (flog1p-pentium)
4075 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4076 (:temporary (:sc long-reg :offset fr0-offset
4077 :from :argument :to :result) fr0)
4078 (:temporary (:sc long-reg :offset fr1-offset
4079 :from :argument :to :result) fr1)
4080 (:results (y :scs (long-reg)))
4081 (:arg-types long-float)
4082 (:result-types long-float)
4083 (:policy :fast-safe)
4084 ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
4085 (:guard #!+pentium t #!-pentium)
4086 (:note "inline log1p function")
4102 ;; x is in a FP reg, not fr0 or fr1
4106 (inst fldd (make-random-tn :kind :normal
4107 :sc (sc-or-lose 'double-reg)
4108 :offset (1- (tn-offset x)))))))
4109 ((long-stack descriptor-reg)
4113 (if (sc-is x long-stack)
4114 (inst fldl (ea-for-lf-stack x))
4115 (inst fldl (ea-for-lf-desc x)))))
4120 (t (inst fstd y)))))
4124 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4125 (:temporary (:sc long-reg :offset fr0-offset
4126 :from :argument :to :result) fr0)
4127 (:temporary (:sc long-reg :offset fr1-offset
4128 :from :argument :to :result) fr1)
4129 (:results (y :scs (long-reg)))
4130 (:arg-types long-float)
4131 (:result-types long-float)
4132 (:policy :fast-safe)
4133 (:note "inline logb function")
4135 (:save-p :compute-only)
4137 (note-this-location vop :internal-error)
4148 ;; x is in a FP reg, not fr0 or fr1
4151 (inst fldd (make-random-tn :kind :normal
4152 :sc (sc-or-lose 'double-reg)
4153 :offset (- (tn-offset x) 2))))))
4154 ((long-stack descriptor-reg)
4157 (if (sc-is x long-stack)
4158 (inst fldl (ea-for-lf-stack x))
4159 (inst fldl (ea-for-lf-desc x)))))
4170 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4171 (:temporary (:sc long-reg :offset fr0-offset
4172 :from (:argument 0) :to :result) fr0)
4173 (:temporary (:sc long-reg :offset fr1-offset
4174 :from (:argument 0) :to :result) fr1)
4175 (:results (r :scs (long-reg)))
4176 (:arg-types long-float)
4177 (:result-types long-float)
4178 (:policy :fast-safe)
4179 (:note "inline atan function")
4181 (:save-p :compute-only)
4183 (note-this-location vop :internal-error)
4184 ;; Setup x in fr1 and 1.0 in fr0
4187 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4190 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4192 ;; x not in fr0 or fr1
4199 (inst fldd (make-random-tn :kind :normal
4200 :sc (sc-or-lose 'double-reg)
4201 :offset (- (tn-offset x) 2))))
4203 (inst fldl (ea-for-lf-stack x)))
4205 (inst fldl (ea-for-lf-desc x))))))
4207 ;; Now have x at fr1; and 1.0 at fr0
4212 (t (inst fstd r)))))
4214 (define-vop (fatan2)
4216 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4217 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4218 (:temporary (:sc long-reg :offset fr0-offset
4219 :from (:argument 1) :to :result) fr0)
4220 (:temporary (:sc long-reg :offset fr1-offset
4221 :from (:argument 0) :to :result) fr1)
4222 (:results (r :scs (long-reg)))
4223 (:arg-types long-float long-float)
4224 (:result-types long-float)
4225 (:policy :fast-safe)
4226 (:note "inline atan2 function")
4228 (:save-p :compute-only)
4230 (note-this-location vop :internal-error)
4231 ;; Setup x in fr1 and y in fr0
4233 ;; y in fr0; x in fr1
4234 ((and (sc-is y long-reg) (zerop (tn-offset y))
4235 (sc-is x long-reg) (= 1 (tn-offset x))))
4236 ;; x in fr1; y not in fr0
4237 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4241 (copy-fp-reg-to-fr0 y))
4244 (inst fldl (ea-for-lf-stack y)))
4247 (inst fldl (ea-for-lf-desc y)))))
4248 ;; y in fr0; x not in fr1
4249 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4251 ;; Now load x to fr0
4254 (copy-fp-reg-to-fr0 x))
4257 (inst fldl (ea-for-lf-stack x)))
4260 (inst fldl (ea-for-lf-desc x))))
4262 ;; y in fr1; x not in fr1
4263 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4267 (copy-fp-reg-to-fr0 x))
4270 (inst fldl (ea-for-lf-stack x)))
4273 (inst fldl (ea-for-lf-desc x))))
4276 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4278 ;; Now load y to fr0
4281 (copy-fp-reg-to-fr0 y))
4284 (inst fldl (ea-for-lf-stack y)))
4287 (inst fldl (ea-for-lf-desc y)))))
4288 ;; Neither y or x are in either fr0 or fr1
4295 (inst fldd (make-random-tn :kind :normal
4296 :sc (sc-or-lose 'double-reg)
4297 :offset (- (tn-offset x) 2))))
4299 (inst fldl (ea-for-lf-stack x)))
4301 (inst fldl (ea-for-lf-desc x))))
4305 (inst fldd (make-random-tn :kind :normal
4306 :sc (sc-or-lose 'double-reg)
4307 :offset (1- (tn-offset y)))))
4309 (inst fldl (ea-for-lf-stack y)))
4311 (inst fldl (ea-for-lf-desc y))))))
4313 ;; Now have y at fr0; and x at fr1
4318 (t (inst fstd r)))))
4320 ) ; progn #!+long-float
4323 ;;;; Complex float VOPs
4325 (define-vop (make-complex-single-float)
4326 (:translate complex)
4327 (:args (real :scs (single-reg) :to :result :target r
4328 :load-if (not (location= real r)))
4329 (imag :scs (single-reg) :to :save))
4330 (:arg-types single-float single-float)
4331 (:results (r :scs (complex-single-reg) :from (:argument 0)
4332 :load-if (not (sc-is r complex-single-stack))))
4333 (:result-types complex-single-float)
4334 (:note "inline complex single-float creation")
4335 (:policy :fast-safe)
4339 (let ((r-real (complex-double-reg-real-tn r)))
4340 (unless (location= real r-real)
4341 (cond ((zerop (tn-offset r-real))
4342 (copy-fp-reg-to-fr0 real))
4343 ((zerop (tn-offset real))
4348 (inst fxch real)))))
4349 (let ((r-imag (complex-double-reg-imag-tn r)))
4350 (unless (location= imag r-imag)
4351 (cond ((zerop (tn-offset imag))
4356 (inst fxch imag))))))
4357 (complex-single-stack
4358 (unless (location= real r)
4359 (cond ((zerop (tn-offset real))
4360 (inst fst (ea-for-csf-real-stack r)))
4363 (inst fst (ea-for-csf-real-stack r))
4366 (inst fst (ea-for-csf-imag-stack r))
4367 (inst fxch imag)))))
4369 (define-vop (make-complex-double-float)
4370 (:translate complex)
4371 (:args (real :scs (double-reg) :target r
4372 :load-if (not (location= real r)))
4373 (imag :scs (double-reg) :to :save))
4374 (:arg-types double-float double-float)
4375 (:results (r :scs (complex-double-reg) :from (:argument 0)
4376 :load-if (not (sc-is r complex-double-stack))))
4377 (:result-types complex-double-float)
4378 (:note "inline complex double-float creation")
4379 (:policy :fast-safe)
4383 (let ((r-real (complex-double-reg-real-tn r)))
4384 (unless (location= real r-real)
4385 (cond ((zerop (tn-offset r-real))
4386 (copy-fp-reg-to-fr0 real))
4387 ((zerop (tn-offset real))
4392 (inst fxch real)))))
4393 (let ((r-imag (complex-double-reg-imag-tn r)))
4394 (unless (location= imag r-imag)
4395 (cond ((zerop (tn-offset imag))
4400 (inst fxch imag))))))
4401 (complex-double-stack
4402 (unless (location= real r)
4403 (cond ((zerop (tn-offset real))
4404 (inst fstd (ea-for-cdf-real-stack r)))
4407 (inst fstd (ea-for-cdf-real-stack r))
4410 (inst fstd (ea-for-cdf-imag-stack r))
4411 (inst fxch imag)))))
4414 (define-vop (make-complex-long-float)
4415 (:translate complex)
4416 (:args (real :scs (long-reg) :target r
4417 :load-if (not (location= real r)))
4418 (imag :scs (long-reg) :to :save))
4419 (:arg-types long-float long-float)
4420 (:results (r :scs (complex-long-reg) :from (:argument 0)
4421 :load-if (not (sc-is r complex-long-stack))))
4422 (:result-types complex-long-float)
4423 (:note "inline complex long-float creation")
4424 (:policy :fast-safe)
4428 (let ((r-real (complex-double-reg-real-tn r)))
4429 (unless (location= real r-real)
4430 (cond ((zerop (tn-offset r-real))
4431 (copy-fp-reg-to-fr0 real))
4432 ((zerop (tn-offset real))
4437 (inst fxch real)))))
4438 (let ((r-imag (complex-double-reg-imag-tn r)))
4439 (unless (location= imag r-imag)
4440 (cond ((zerop (tn-offset imag))
4445 (inst fxch imag))))))
4447 (unless (location= real r)
4448 (cond ((zerop (tn-offset real))
4449 (store-long-float (ea-for-clf-real-stack r)))
4452 (store-long-float (ea-for-clf-real-stack r))
4455 (store-long-float (ea-for-clf-imag-stack r))
4456 (inst fxch imag)))))
4459 (define-vop (complex-float-value)
4460 (:args (x :target r))
4462 (:variant-vars offset)
4463 (:policy :fast-safe)
4465 (cond ((sc-is x complex-single-reg complex-double-reg
4466 #!+long-float complex-long-reg)
4468 (make-random-tn :kind :normal
4469 :sc (sc-or-lose 'double-reg)
4470 :offset (+ offset (tn-offset x)))))
4471 (unless (location= value-tn r)
4472 (cond ((zerop (tn-offset r))
4473 (copy-fp-reg-to-fr0 value-tn))
4474 ((zerop (tn-offset value-tn))
4477 (inst fxch value-tn)
4479 (inst fxch value-tn))))))
4480 ((sc-is r single-reg)
4481 (let ((ea (sc-case x
4482 (complex-single-stack
4484 (0 (ea-for-csf-real-stack x))
4485 (1 (ea-for-csf-imag-stack x))))
4488 (0 (ea-for-csf-real-desc x))
4489 (1 (ea-for-csf-imag-desc x)))))))
4490 (with-empty-tn@fp-top(r)
4492 ((sc-is r double-reg)
4493 (let ((ea (sc-case x
4494 (complex-double-stack
4496 (0 (ea-for-cdf-real-stack x))
4497 (1 (ea-for-cdf-imag-stack x))))
4500 (0 (ea-for-cdf-real-desc x))
4501 (1 (ea-for-cdf-imag-desc x)))))))
4502 (with-empty-tn@fp-top(r)
4506 (let ((ea (sc-case x
4509 (0 (ea-for-clf-real-stack x))
4510 (1 (ea-for-clf-imag-stack x))))
4513 (0 (ea-for-clf-real-desc x))
4514 (1 (ea-for-clf-imag-desc x)))))))
4515 (with-empty-tn@fp-top(r)
4517 (t (error "Complex-float-value VOP failure")))))
4519 (define-vop (realpart/complex-single-float complex-float-value)
4520 (:translate realpart)
4521 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4523 (:arg-types complex-single-float)
4524 (:results (r :scs (single-reg)))
4525 (:result-types single-float)
4526 (:note "complex float realpart")
4529 (define-vop (realpart/complex-double-float complex-float-value)
4530 (:translate realpart)
4531 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4533 (:arg-types complex-double-float)
4534 (:results (r :scs (double-reg)))
4535 (:result-types double-float)
4536 (:note "complex float realpart")
4540 (define-vop (realpart/complex-long-float complex-float-value)
4541 (:translate realpart)
4542 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4544 (:arg-types complex-long-float)
4545 (:results (r :scs (long-reg)))
4546 (:result-types long-float)
4547 (:note "complex float realpart")
4550 (define-vop (imagpart/complex-single-float complex-float-value)
4551 (:translate imagpart)
4552 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4554 (:arg-types complex-single-float)
4555 (:results (r :scs (single-reg)))
4556 (:result-types single-float)
4557 (:note "complex float imagpart")
4560 (define-vop (imagpart/complex-double-float complex-float-value)
4561 (:translate imagpart)
4562 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4564 (:arg-types complex-double-float)
4565 (:results (r :scs (double-reg)))
4566 (:result-types double-float)
4567 (:note "complex float imagpart")
4571 (define-vop (imagpart/complex-long-float complex-float-value)
4572 (:translate imagpart)
4573 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4575 (:arg-types complex-long-float)
4576 (:results (r :scs (long-reg)))
4577 (:result-types long-float)
4578 (:note "complex float imagpart")
4582 ;;; A hack dummy VOP to bias the representation selection of its
4583 ;;; argument towards a FP register which can help avoid consing at
4584 ;;; inappropriate locations.
4586 (defknown double-float-reg-bias (double-float) (values))
4587 (define-vop (double-float-reg-bias)
4588 (:translate double-float-reg-bias)
4589 (:args (x :scs (double-reg double-stack) :load-if nil))
4590 (:arg-types double-float)
4591 (:policy :fast-safe)
4592 (:note "inline dummy FP register bias")
4596 (defknown single-float-reg-bias (single-float) (values))
4597 (define-vop (single-float-reg-bias)
4598 (:translate single-float-reg-bias)
4599 (:args (x :scs (single-reg single-stack) :load-if nil))
4600 (:arg-types single-float)
4601 (:policy :fast-safe)
4602 (:note "inline dummy FP register bias")