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.
17 (macrolet ((ea-for-xf-desc (tn slot)
20 :disp (- (* ,slot sb!vm:word-bytes) sb!vm:other-pointer-type))))
21 (defun ea-for-sf-desc (tn)
22 (ea-for-xf-desc tn sb!vm:single-float-value-slot))
23 (defun ea-for-df-desc (tn)
24 (ea-for-xf-desc tn sb!vm:double-float-value-slot))
26 (defun ea-for-lf-desc (tn)
27 (ea-for-xf-desc tn sb!vm:long-float-value-slot))
29 (defun ea-for-csf-real-desc (tn)
30 (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot))
31 (defun ea-for-csf-imag-desc (tn)
32 (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot))
33 (defun ea-for-cdf-real-desc (tn)
34 (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot))
35 (defun ea-for-cdf-imag-desc (tn)
36 (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot))
38 (defun ea-for-clf-real-desc (tn)
39 (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot))
41 (defun ea-for-clf-imag-desc (tn)
42 (ea-for-xf-desc tn sb!vm:complex-long-float-imag-slot)))
44 (macrolet ((ea-for-xf-stack (tn kind)
47 :disp (- (* (+ (tn-offset ,tn)
48 (ecase ,kind (:single 1) (:double 2) (:long 3)))
50 (defun ea-for-sf-stack (tn)
51 (ea-for-xf-stack tn :single))
52 (defun ea-for-df-stack (tn)
53 (ea-for-xf-stack tn :double))
55 (defun ea-for-lf-stack (tn)
56 (ea-for-xf-stack tn :long)))
58 ;;; Complex float stack EAs
59 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
62 :disp (- (* (+ (tn-offset ,tn)
67 (ecase ,slot (:real 1) (:imag 2))))
69 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
70 (ea-for-cxf-stack tn :single :real base))
71 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
72 (ea-for-cxf-stack tn :single :imag base))
73 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
74 (ea-for-cxf-stack tn :double :real base))
75 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
76 (ea-for-cxf-stack tn :double :imag base))
78 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
79 (ea-for-cxf-stack tn :long :real base))
81 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
82 (ea-for-cxf-stack tn :long :imag base)))
84 ;;; Abstract out the copying of a FP register to the FP stack top, and
85 ;;; provide two alternatives for its implementation. Note: it's not
86 ;;; necessary to distinguish between a single or double register move
89 ;;; Using a Pop then load.
90 (defun copy-fp-reg-to-fr0 (reg)
91 (assert (not (zerop (tn-offset reg))))
93 (inst fld (make-random-tn :kind :normal
94 :sc (sc-or-lose 'double-reg)
95 :offset (1- (tn-offset reg)))))
96 ;;; Using Fxch then Fst to restore the original reg contents.
98 (defun copy-fp-reg-to-fr0 (reg)
99 (assert (not (zerop (tn-offset reg))))
103 ;;; The x86 can't store a long-float to memory without popping the
104 ;;; stack and marking a register as empty, so it is necessary to
105 ;;; restore the register from memory.
107 (defun store-long-float (ea)
113 ;;; x is source, y is destination
114 (define-move-function (load-single 2) (vop x y)
115 ((single-stack) (single-reg))
116 (with-empty-tn@fp-top(y)
117 (inst fld (ea-for-sf-stack x))))
119 (define-move-function (store-single 2) (vop x y)
120 ((single-reg) (single-stack))
121 (cond ((zerop (tn-offset x))
122 (inst fst (ea-for-sf-stack y)))
125 (inst fst (ea-for-sf-stack y))
126 ;; This may not be necessary as ST0 is likely invalid now.
129 (define-move-function (load-double 2) (vop x y)
130 ((double-stack) (double-reg))
131 (with-empty-tn@fp-top(y)
132 (inst fldd (ea-for-df-stack x))))
134 (define-move-function (store-double 2) (vop x y)
135 ((double-reg) (double-stack))
136 (cond ((zerop (tn-offset x))
137 (inst fstd (ea-for-df-stack y)))
140 (inst fstd (ea-for-df-stack y))
141 ;; This may not be necessary as ST0 is likely invalid now.
145 (define-move-function (load-long 2) (vop x y)
146 ((long-stack) (long-reg))
147 (with-empty-tn@fp-top(y)
148 (inst fldl (ea-for-lf-stack x))))
151 (define-move-function (store-long 2) (vop x y)
152 ((long-reg) (long-stack))
153 (cond ((zerop (tn-offset x))
154 (store-long-float (ea-for-lf-stack y)))
157 (store-long-float (ea-for-lf-stack y))
158 ;; This may not be necessary as ST0 is likely invalid now.
161 ;;; The i387 has instructions to load some useful constants.
162 ;;; This doesn't save much time but might cut down on memory
163 ;;; access and reduce the size of the constant vector (CV).
164 ;;; Intel claims they are stored in a more precise form on chip.
165 ;;; Anyhow, might as well use the feature. It can be turned
166 ;;; off by hacking the "immediate-constant-sc" in vm.lisp.
167 (define-move-function (load-fp-constant 2) (vop x y)
168 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
169 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
170 (with-empty-tn@fp-top(y)
177 ((= value (log 10l0 2l0))
179 ((= value (log 2.718281828459045235360287471352662L0 2l0))
181 ((= value (log 2l0 10l0))
183 ((= value (log 2l0 2.718281828459045235360287471352662L0))
185 (t (warn "Ignoring bogus i387 Constant ~A" value))))))
188 ;;;; complex float move functions
190 (defun complex-single-reg-real-tn (x)
191 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
192 :offset (tn-offset x)))
193 (defun complex-single-reg-imag-tn (x)
194 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
195 :offset (1+ (tn-offset x))))
197 (defun complex-double-reg-real-tn (x)
198 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
199 :offset (tn-offset x)))
200 (defun complex-double-reg-imag-tn (x)
201 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
202 :offset (1+ (tn-offset x))))
205 (defun complex-long-reg-real-tn (x)
206 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
207 :offset (tn-offset x)))
209 (defun complex-long-reg-imag-tn (x)
210 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
211 :offset (1+ (tn-offset x))))
213 ;;; x is source, y is destination
214 (define-move-function (load-complex-single 2) (vop x y)
215 ((complex-single-stack) (complex-single-reg))
216 (let ((real-tn (complex-single-reg-real-tn y)))
217 (with-empty-tn@fp-top (real-tn)
218 (inst fld (ea-for-csf-real-stack x))))
219 (let ((imag-tn (complex-single-reg-imag-tn y)))
220 (with-empty-tn@fp-top (imag-tn)
221 (inst fld (ea-for-csf-imag-stack x)))))
223 (define-move-function (store-complex-single 2) (vop x y)
224 ((complex-single-reg) (complex-single-stack))
225 (let ((real-tn (complex-single-reg-real-tn x)))
226 (cond ((zerop (tn-offset real-tn))
227 (inst fst (ea-for-csf-real-stack y)))
230 (inst fst (ea-for-csf-real-stack y))
231 (inst fxch real-tn))))
232 (let ((imag-tn (complex-single-reg-imag-tn x)))
234 (inst fst (ea-for-csf-imag-stack y))
235 (inst fxch imag-tn)))
237 (define-move-function (load-complex-double 2) (vop x y)
238 ((complex-double-stack) (complex-double-reg))
239 (let ((real-tn (complex-double-reg-real-tn y)))
240 (with-empty-tn@fp-top(real-tn)
241 (inst fldd (ea-for-cdf-real-stack x))))
242 (let ((imag-tn (complex-double-reg-imag-tn y)))
243 (with-empty-tn@fp-top(imag-tn)
244 (inst fldd (ea-for-cdf-imag-stack x)))))
246 (define-move-function (store-complex-double 2) (vop x y)
247 ((complex-double-reg) (complex-double-stack))
248 (let ((real-tn (complex-double-reg-real-tn x)))
249 (cond ((zerop (tn-offset real-tn))
250 (inst fstd (ea-for-cdf-real-stack y)))
253 (inst fstd (ea-for-cdf-real-stack y))
254 (inst fxch real-tn))))
255 (let ((imag-tn (complex-double-reg-imag-tn x)))
257 (inst fstd (ea-for-cdf-imag-stack y))
258 (inst fxch imag-tn)))
261 (define-move-function (load-complex-long 2) (vop x y)
262 ((complex-long-stack) (complex-long-reg))
263 (let ((real-tn (complex-long-reg-real-tn y)))
264 (with-empty-tn@fp-top(real-tn)
265 (inst fldl (ea-for-clf-real-stack x))))
266 (let ((imag-tn (complex-long-reg-imag-tn y)))
267 (with-empty-tn@fp-top(imag-tn)
268 (inst fldl (ea-for-clf-imag-stack x)))))
271 (define-move-function (store-complex-long 2) (vop x y)
272 ((complex-long-reg) (complex-long-stack))
273 (let ((real-tn (complex-long-reg-real-tn x)))
274 (cond ((zerop (tn-offset real-tn))
275 (store-long-float (ea-for-clf-real-stack y)))
278 (store-long-float (ea-for-clf-real-stack y))
279 (inst fxch real-tn))))
280 (let ((imag-tn (complex-long-reg-imag-tn x)))
282 (store-long-float (ea-for-clf-imag-stack y))
283 (inst fxch imag-tn)))
288 ;;; Float register to register moves.
289 (define-vop (float-move)
294 (unless (location= x y)
295 (cond ((zerop (tn-offset y))
296 (copy-fp-reg-to-fr0 x))
297 ((zerop (tn-offset x))
304 (define-vop (single-move float-move)
305 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
306 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
307 (define-move-vop single-move :move (single-reg) (single-reg))
309 (define-vop (double-move float-move)
310 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
311 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
312 (define-move-vop double-move :move (double-reg) (double-reg))
315 (define-vop (long-move float-move)
316 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
317 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
319 (define-move-vop long-move :move (long-reg) (long-reg))
321 ;;; complex float register to register moves
322 (define-vop (complex-float-move)
323 (:args (x :target y :load-if (not (location= x y))))
324 (:results (y :load-if (not (location= x y))))
325 (:note "complex float move")
327 (unless (location= x y)
328 ;; Note the complex-float-regs are aligned to every second
329 ;; float register so there is not need to worry about overlap.
330 (let ((x-real (complex-double-reg-real-tn x))
331 (y-real (complex-double-reg-real-tn y)))
332 (cond ((zerop (tn-offset y-real))
333 (copy-fp-reg-to-fr0 x-real))
334 ((zerop (tn-offset x-real))
339 (inst fxch x-real))))
340 (let ((x-imag (complex-double-reg-imag-tn x))
341 (y-imag (complex-double-reg-imag-tn y)))
344 (inst fxch x-imag)))))
346 (define-vop (complex-single-move complex-float-move)
347 (:args (x :scs (complex-single-reg) :target y
348 :load-if (not (location= x y))))
349 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
350 (define-move-vop complex-single-move :move
351 (complex-single-reg) (complex-single-reg))
353 (define-vop (complex-double-move complex-float-move)
354 (:args (x :scs (complex-double-reg)
355 :target y :load-if (not (location= x y))))
356 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
357 (define-move-vop complex-double-move :move
358 (complex-double-reg) (complex-double-reg))
361 (define-vop (complex-long-move complex-float-move)
362 (:args (x :scs (complex-long-reg)
363 :target y :load-if (not (location= x y))))
364 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
366 (define-move-vop complex-long-move :move
367 (complex-long-reg) (complex-long-reg))
369 ;;; Move from float to a descriptor reg. allocating a new float
370 ;;; object in the process.
371 (define-vop (move-from-single)
372 (:args (x :scs (single-reg) :to :save))
373 (:results (y :scs (descriptor-reg)))
375 (:note "float to pointer coercion")
377 (with-fixed-allocation (y
378 sb!vm:single-float-type
379 sb!vm:single-float-size node)
381 (inst fst (ea-for-sf-desc y))))))
382 (define-move-vop move-from-single :move
383 (single-reg) (descriptor-reg))
385 (define-vop (move-from-double)
386 (:args (x :scs (double-reg) :to :save))
387 (:results (y :scs (descriptor-reg)))
389 (:note "float to pointer coercion")
391 (with-fixed-allocation (y
392 sb!vm:double-float-type
393 sb!vm:double-float-size
396 (inst fstd (ea-for-df-desc y))))))
397 (define-move-vop move-from-double :move
398 (double-reg) (descriptor-reg))
401 (define-vop (move-from-long)
402 (:args (x :scs (long-reg) :to :save))
403 (:results (y :scs (descriptor-reg)))
405 (:note "float to pointer coercion")
407 (with-fixed-allocation (y
408 sb!vm:long-float-type
409 sb!vm:long-float-size
412 (store-long-float (ea-for-lf-desc y))))))
414 (define-move-vop move-from-long :move
415 (long-reg) (descriptor-reg))
417 (define-vop (move-from-fp-constant)
418 (:args (x :scs (fp-constant)))
419 (:results (y :scs (descriptor-reg)))
421 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
422 (0f0 (load-symbol-value y *fp-constant-0s0*))
423 (1f0 (load-symbol-value y *fp-constant-1s0*))
424 (0d0 (load-symbol-value y *fp-constant-0d0*))
425 (1d0 (load-symbol-value y *fp-constant-1d0*))
427 (0l0 (load-symbol-value y *fp-constant-0l0*))
429 (1l0 (load-symbol-value y *fp-constant-1l0*))
431 (#.pi (load-symbol-value y *fp-constant-pi*))
433 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
435 (#.(log 2.718281828459045235360287471352662L0 2l0)
436 (load-symbol-value y *fp-constant-l2e*))
438 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
440 (#.(log 2l0 2.718281828459045235360287471352662L0)
441 (load-symbol-value y *fp-constant-ln2*)))))
442 (define-move-vop move-from-fp-constant :move
443 (fp-constant) (descriptor-reg))
445 ;;; Move from a descriptor to a float register
446 (define-vop (move-to-single)
447 (:args (x :scs (descriptor-reg)))
448 (:results (y :scs (single-reg)))
449 (:note "pointer to float coercion")
451 (with-empty-tn@fp-top(y)
452 (inst fld (ea-for-sf-desc x)))))
453 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
455 (define-vop (move-to-double)
456 (:args (x :scs (descriptor-reg)))
457 (:results (y :scs (double-reg)))
458 (:note "pointer to float coercion")
460 (with-empty-tn@fp-top(y)
461 (inst fldd (ea-for-df-desc x)))))
462 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
465 (define-vop (move-to-long)
466 (:args (x :scs (descriptor-reg)))
467 (:results (y :scs (long-reg)))
468 (:note "pointer to float coercion")
470 (with-empty-tn@fp-top(y)
471 (inst fldl (ea-for-lf-desc x)))))
473 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
476 ;;; Move from complex float to a descriptor reg. allocating a new
477 ;;; complex float object in the process.
478 (define-vop (move-from-complex-single)
479 (:args (x :scs (complex-single-reg) :to :save))
480 (:results (y :scs (descriptor-reg)))
482 (:note "complex float to pointer coercion")
484 (with-fixed-allocation (y
485 sb!vm:complex-single-float-type
486 sb!vm:complex-single-float-size node)
487 (let ((real-tn (complex-single-reg-real-tn x)))
488 (with-tn@fp-top(real-tn)
489 (inst fst (ea-for-csf-real-desc y))))
490 (let ((imag-tn (complex-single-reg-imag-tn x)))
491 (with-tn@fp-top(imag-tn)
492 (inst fst (ea-for-csf-imag-desc y)))))))
493 (define-move-vop move-from-complex-single :move
494 (complex-single-reg) (descriptor-reg))
496 (define-vop (move-from-complex-double)
497 (:args (x :scs (complex-double-reg) :to :save))
498 (:results (y :scs (descriptor-reg)))
500 (:note "complex float to pointer coercion")
502 (with-fixed-allocation (y
503 sb!vm:complex-double-float-type
504 sb!vm:complex-double-float-size
506 (let ((real-tn (complex-double-reg-real-tn x)))
507 (with-tn@fp-top(real-tn)
508 (inst fstd (ea-for-cdf-real-desc y))))
509 (let ((imag-tn (complex-double-reg-imag-tn x)))
510 (with-tn@fp-top(imag-tn)
511 (inst fstd (ea-for-cdf-imag-desc y)))))))
512 (define-move-vop move-from-complex-double :move
513 (complex-double-reg) (descriptor-reg))
516 (define-vop (move-from-complex-long)
517 (:args (x :scs (complex-long-reg) :to :save))
518 (:results (y :scs (descriptor-reg)))
520 (:note "complex float to pointer coercion")
522 (with-fixed-allocation (y
523 sb!vm:complex-long-float-type
524 sb!vm:complex-long-float-size
526 (let ((real-tn (complex-long-reg-real-tn x)))
527 (with-tn@fp-top(real-tn)
528 (store-long-float (ea-for-clf-real-desc y))))
529 (let ((imag-tn (complex-long-reg-imag-tn x)))
530 (with-tn@fp-top(imag-tn)
531 (store-long-float (ea-for-clf-imag-desc y)))))))
533 (define-move-vop move-from-complex-long :move
534 (complex-long-reg) (descriptor-reg))
536 ;;; Move from a descriptor to a complex float register
537 (macrolet ((frob (name sc format)
540 (:args (x :scs (descriptor-reg)))
541 (:results (y :scs (,sc)))
542 (:note "pointer to complex float coercion")
544 (let ((real-tn (complex-double-reg-real-tn y)))
545 (with-empty-tn@fp-top(real-tn)
547 (:single '((inst fld (ea-for-csf-real-desc x))))
548 (:double '((inst fldd (ea-for-cdf-real-desc x))))
550 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
551 (let ((imag-tn (complex-double-reg-imag-tn y)))
552 (with-empty-tn@fp-top(imag-tn)
554 (:single '((inst fld (ea-for-csf-imag-desc x))))
555 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
557 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
558 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
559 (frob move-to-complex-single complex-single-reg :single)
560 (frob move-to-complex-double complex-double-reg :double)
562 (frob move-to-complex-double complex-long-reg :long))
565 ;;;; The move argument vops.
567 ;;;; Note these are also used to stuff fp numbers onto the c-call stack
568 ;;;; so the order is different than the lisp-stack.
570 ;;; The general move-argument vop
571 (macrolet ((frob (name sc stack-sc format)
574 (:args (x :scs (,sc) :target y)
576 :load-if (not (sc-is y ,sc))))
578 (:note "float argument move")
579 (:generator ,(case format (:single 2) (:double 3) (:long 4))
582 (unless (location= x y)
583 (cond ((zerop (tn-offset y))
584 (copy-fp-reg-to-fr0 x))
585 ((zerop (tn-offset x))
592 (if (= (tn-offset fp) esp-offset)
593 (let* ((offset (* (tn-offset y) word-bytes))
594 (ea (make-ea :dword :base fp :disp offset)))
597 (:single '((inst fst ea)))
598 (:double '((inst fstd ea)))
600 (:long '((store-long-float ea))))))
603 :disp (- (* (+ (tn-offset y)
608 sb!vm:word-bytes)))))
611 (:single '((inst fst ea)))
612 (:double '((inst fstd ea)))
614 (:long '((store-long-float ea)))))))))))
615 (define-move-vop ,name :move-argument
616 (,sc descriptor-reg) (,sc)))))
617 (frob move-single-float-argument single-reg single-stack :single)
618 (frob move-double-float-argument double-reg double-stack :double)
620 (frob move-long-float-argument long-reg long-stack :long))
622 ;;;; Complex float move-argument vop
623 (macrolet ((frob (name sc stack-sc format)
626 (:args (x :scs (,sc) :target y)
628 :load-if (not (sc-is y ,sc))))
630 (:note "complex float argument move")
631 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
634 (unless (location= x y)
635 (let ((x-real (complex-double-reg-real-tn x))
636 (y-real (complex-double-reg-real-tn y)))
637 (cond ((zerop (tn-offset y-real))
638 (copy-fp-reg-to-fr0 x-real))
639 ((zerop (tn-offset x-real))
644 (inst fxch x-real))))
645 (let ((x-imag (complex-double-reg-imag-tn x))
646 (y-imag (complex-double-reg-imag-tn y)))
649 (inst fxch x-imag))))
651 (let ((real-tn (complex-double-reg-real-tn x)))
652 (cond ((zerop (tn-offset real-tn))
656 (ea-for-csf-real-stack y fp))))
659 (ea-for-cdf-real-stack y fp))))
663 (ea-for-clf-real-stack y fp))))))
669 (ea-for-csf-real-stack y fp))))
672 (ea-for-cdf-real-stack y fp))))
676 (ea-for-clf-real-stack y fp)))))
677 (inst fxch real-tn))))
678 (let ((imag-tn (complex-double-reg-imag-tn x)))
682 '((inst fst (ea-for-csf-imag-stack y fp))))
684 '((inst fstd (ea-for-cdf-imag-stack y fp))))
688 (ea-for-clf-imag-stack y fp)))))
689 (inst fxch imag-tn))))))
690 (define-move-vop ,name :move-argument
691 (,sc descriptor-reg) (,sc)))))
692 (frob move-complex-single-float-argument
693 complex-single-reg complex-single-stack :single)
694 (frob move-complex-double-float-argument
695 complex-double-reg complex-double-stack :double)
697 (frob move-complex-long-float-argument
698 complex-long-reg complex-long-stack :long))
700 (define-move-vop move-argument :move-argument
701 (single-reg double-reg #!+long-float long-reg
702 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
708 ;;; dtc: The floating point arithmetic vops.
710 ;;; Note: Although these can accept x and y on the stack or pointed to
711 ;;; from a descriptor register, they will work with register loading
712 ;;; without these. Same deal with the result - it need only be a
713 ;;; register. When load-tns are needed they will probably be in ST0
714 ;;; and the code below should be able to correctly handle all cases.
716 ;;; However it seems to produce better code if all arg. and result
717 ;;; options are used; on the P86 there is no extra cost in using a
718 ;;; memory operand to the FP instructions - not so on the PPro.
720 ;;; It may also be useful to handle constant args?
722 ;;; 22-Jul-97: descriptor args lose in some simple cases when
723 ;;; a function result computed in a loop. Then Python insists
724 ;;; on consing the intermediate values! For example
727 (declare (type (simple-array double-float (*)) a)
730 (declare (type double-float sum))
732 (incf sum (* (aref a i)(aref a i))))
735 ;;; So, disabling descriptor args until this can be fixed elsewhere.
737 ((frob (op fop-sti fopr-sti
739 fopd foprd dname dcost
741 #!-long-float (declare (ignore lcost lname))
745 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
747 (y :scs (single-reg single-stack #+nil descriptor-reg)
749 (:temporary (:sc single-reg :offset fr0-offset
750 :from :eval :to :result) fr0)
751 (:results (r :scs (single-reg single-stack)))
752 (:arg-types single-float single-float)
753 (:result-types single-float)
755 (:note "inline float arithmetic")
757 (:save-p :compute-only)
760 ;; Handle a few special cases
762 ;; x, y, and r are the same register.
763 ((and (sc-is x single-reg) (location= x r) (location= y r))
764 (cond ((zerop (tn-offset r))
769 ;; XX the source register will not be valid.
770 (note-next-instruction vop :internal-error)
773 ;; x and r are the same register.
774 ((and (sc-is x single-reg) (location= x r))
775 (cond ((zerop (tn-offset r))
778 ;; ST(0) = ST(0) op ST(y)
781 ;; ST(0) = ST(0) op Mem
782 (inst ,fop (ea-for-sf-stack y)))
784 (inst ,fop (ea-for-sf-desc y)))))
789 (unless (zerop (tn-offset y))
790 (copy-fp-reg-to-fr0 y)))
791 ((single-stack descriptor-reg)
793 (if (sc-is y single-stack)
794 (inst fld (ea-for-sf-stack y))
795 (inst fld (ea-for-sf-desc y)))))
796 ;; ST(i) = ST(i) op ST0
798 (when (policy node (or (= debug 3) (> safety speed)))
799 (note-next-instruction vop :internal-error)
801 ;; y and r are the same register.
802 ((and (sc-is y single-reg) (location= y r))
803 (cond ((zerop (tn-offset r))
806 ;; ST(0) = ST(x) op ST(0)
809 ;; ST(0) = Mem op ST(0)
810 (inst ,fopr (ea-for-sf-stack x)))
812 (inst ,fopr (ea-for-sf-desc x)))))
817 (unless (zerop (tn-offset x))
818 (copy-fp-reg-to-fr0 x)))
819 ((single-stack descriptor-reg)
821 (if (sc-is x single-stack)
822 (inst fld (ea-for-sf-stack x))
823 (inst fld (ea-for-sf-desc x)))))
824 ;; ST(i) = ST(0) op ST(i)
826 (when (policy node (or (= debug 3) (> safety speed)))
827 (note-next-instruction vop :internal-error)
831 ;; Get the result to ST0.
833 ;; Special handling is needed if x or y are in ST0, and
834 ;; simpler code is generated.
837 ((and (sc-is x single-reg) (zerop (tn-offset x)))
843 (inst ,fop (ea-for-sf-stack y)))
845 (inst ,fop (ea-for-sf-desc y)))))
847 ((and (sc-is y single-reg) (zerop (tn-offset y)))
853 (inst ,fopr (ea-for-sf-stack x)))
855 (inst ,fopr (ea-for-sf-desc x)))))
860 (copy-fp-reg-to-fr0 x))
863 (inst fld (ea-for-sf-stack x)))
866 (inst fld (ea-for-sf-desc x))))
872 (inst ,fop (ea-for-sf-stack y)))
874 (inst ,fop (ea-for-sf-desc y))))))
876 (note-next-instruction vop :internal-error)
878 ;; Finally save the result
881 (cond ((zerop (tn-offset r))
882 (when (policy node (or (= debug 3) (> safety speed)))
887 (inst fst (ea-for-sf-stack r))))))))
891 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
893 (y :scs (double-reg double-stack #+nil descriptor-reg)
895 (:temporary (:sc double-reg :offset fr0-offset
896 :from :eval :to :result) fr0)
897 (:results (r :scs (double-reg double-stack)))
898 (:arg-types double-float double-float)
899 (:result-types double-float)
901 (:note "inline float arithmetic")
903 (:save-p :compute-only)
906 ;; Handle a few special cases
908 ;; x, y, and r are the same register.
909 ((and (sc-is x double-reg) (location= x r) (location= y r))
910 (cond ((zerop (tn-offset r))
915 ;; XX the source register will not be valid.
916 (note-next-instruction vop :internal-error)
919 ;; x and r are the same register.
920 ((and (sc-is x double-reg) (location= x r))
921 (cond ((zerop (tn-offset r))
924 ;; ST(0) = ST(0) op ST(y)
927 ;; ST(0) = ST(0) op Mem
928 (inst ,fopd (ea-for-df-stack y)))
930 (inst ,fopd (ea-for-df-desc y)))))
935 (unless (zerop (tn-offset y))
936 (copy-fp-reg-to-fr0 y)))
937 ((double-stack descriptor-reg)
939 (if (sc-is y double-stack)
940 (inst fldd (ea-for-df-stack y))
941 (inst fldd (ea-for-df-desc y)))))
942 ;; ST(i) = ST(i) op ST0
944 (when (policy node (or (= debug 3) (> safety speed)))
945 (note-next-instruction vop :internal-error)
947 ;; y and r are the same register.
948 ((and (sc-is y double-reg) (location= y r))
949 (cond ((zerop (tn-offset r))
952 ;; ST(0) = ST(x) op ST(0)
955 ;; ST(0) = Mem op ST(0)
956 (inst ,foprd (ea-for-df-stack x)))
958 (inst ,foprd (ea-for-df-desc x)))))
963 (unless (zerop (tn-offset x))
964 (copy-fp-reg-to-fr0 x)))
965 ((double-stack descriptor-reg)
967 (if (sc-is x double-stack)
968 (inst fldd (ea-for-df-stack x))
969 (inst fldd (ea-for-df-desc x)))))
970 ;; ST(i) = ST(0) op ST(i)
972 (when (policy node (or (= debug 3) (> safety speed)))
973 (note-next-instruction vop :internal-error)
977 ;; Get the result to ST0.
979 ;; Special handling is needed if x or y are in ST0, and
980 ;; simpler code is generated.
983 ((and (sc-is x double-reg) (zerop (tn-offset x)))
989 (inst ,fopd (ea-for-df-stack y)))
991 (inst ,fopd (ea-for-df-desc y)))))
993 ((and (sc-is y double-reg) (zerop (tn-offset y)))
999 (inst ,foprd (ea-for-df-stack x)))
1001 (inst ,foprd (ea-for-df-desc x)))))
1006 (copy-fp-reg-to-fr0 x))
1009 (inst fldd (ea-for-df-stack x)))
1012 (inst fldd (ea-for-df-desc x))))
1018 (inst ,fopd (ea-for-df-stack y)))
1020 (inst ,fopd (ea-for-df-desc y))))))
1022 (note-next-instruction vop :internal-error)
1024 ;; Finally save the result
1027 (cond ((zerop (tn-offset r))
1028 (when (policy node (or (= debug 3) (> safety speed)))
1033 (inst fstd (ea-for-df-stack r))))))))
1036 (define-vop (,lname)
1038 (:args (x :scs (long-reg) :to :eval)
1039 (y :scs (long-reg) :to :eval))
1040 (:temporary (:sc long-reg :offset fr0-offset
1041 :from :eval :to :result) fr0)
1042 (:results (r :scs (long-reg)))
1043 (:arg-types long-float long-float)
1044 (:result-types long-float)
1045 (:policy :fast-safe)
1046 (:note "inline float arithmetic")
1048 (:save-p :compute-only)
1051 ;; Handle a few special cases
1053 ;; x, y, and r are the same register.
1054 ((and (location= x r) (location= y r))
1055 (cond ((zerop (tn-offset r))
1060 ;; XX the source register will not be valid.
1061 (note-next-instruction vop :internal-error)
1064 ;; x and r are the same register.
1066 (cond ((zerop (tn-offset r))
1067 ;; ST(0) = ST(0) op ST(y)
1071 (unless (zerop (tn-offset y))
1072 (copy-fp-reg-to-fr0 y))
1073 ;; ST(i) = ST(i) op ST0
1075 (when (policy node (or (= debug 3) (> safety speed)))
1076 (note-next-instruction vop :internal-error)
1078 ;; y and r are the same register.
1080 (cond ((zerop (tn-offset r))
1081 ;; ST(0) = ST(x) op ST(0)
1085 (unless (zerop (tn-offset x))
1086 (copy-fp-reg-to-fr0 x))
1087 ;; ST(i) = ST(0) op ST(i)
1088 (inst ,fopr-sti r)))
1089 (when (policy node (or (= debug 3) (> safety speed)))
1090 (note-next-instruction vop :internal-error)
1094 ;; Get the result to ST0.
1096 ;; Special handling is needed if x or y are in ST0, and
1097 ;; simpler code is generated.
1100 ((zerop (tn-offset x))
1104 ((zerop (tn-offset y))
1109 (copy-fp-reg-to-fr0 x)
1113 (note-next-instruction vop :internal-error)
1115 ;; Finally save the result.
1116 (cond ((zerop (tn-offset r))
1117 (when (policy node (or (= debug 3) (> safety speed)))
1120 (inst fst r))))))))))
1122 (frob + fadd-sti fadd-sti
1123 fadd fadd +/single-float 2
1124 faddd faddd +/double-float 2
1126 (frob - fsub-sti fsubr-sti
1127 fsub fsubr -/single-float 2
1128 fsubd fsubrd -/double-float 2
1130 (frob * fmul-sti fmul-sti
1131 fmul fmul */single-float 3
1132 fmuld fmuld */double-float 3
1134 (frob / fdiv-sti fdivr-sti
1135 fdiv fdivr //single-float 12
1136 fdivd fdivrd //double-float 12
1139 (macrolet ((frob (name inst translate sc type)
1140 `(define-vop (,name)
1141 (:args (x :scs (,sc) :target fr0))
1142 (:results (y :scs (,sc)))
1143 (:translate ,translate)
1144 (:policy :fast-safe)
1146 (:result-types ,type)
1147 (:temporary (:sc double-reg :offset fr0-offset
1148 :from :argument :to :result) fr0)
1150 (:note "inline float arithmetic")
1152 (:save-p :compute-only)
1154 (note-this-location vop :internal-error)
1155 (unless (zerop (tn-offset x))
1156 (inst fxch x) ; x to top of stack
1157 (unless (location= x y)
1158 (inst fst x))) ; maybe save it
1159 (inst ,inst) ; clobber st0
1160 (unless (zerop (tn-offset y))
1163 (frob abs/single-float fabs abs single-reg single-float)
1164 (frob abs/double-float fabs abs double-reg double-float)
1166 (frob abs/long-float fabs abs long-reg long-float)
1167 (frob %negate/single-float fchs %negate single-reg single-float)
1168 (frob %negate/double-float fchs %negate double-reg double-float)
1170 (frob %negate/long-float fchs %negate long-reg long-float))
1174 (define-vop (=/float)
1176 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1178 (:info target not-p)
1179 (:policy :fast-safe)
1181 (:save-p :compute-only)
1182 (:note "inline float comparison")
1185 (note-this-location vop :internal-error)
1187 ;; x is in ST0; y is in any reg.
1188 ((zerop (tn-offset x))
1190 ;; y is in ST0; x is in another reg.
1191 ((zerop (tn-offset y))
1193 ;; x and y are the same register, not ST0
1198 ;; x and y are different registers, neither ST0.
1203 (inst fnstsw) ; status word to ax
1204 (inst and ah-tn #x45) ; C3 C2 C0
1205 (inst cmp ah-tn #x40)
1206 (inst jmp (if not-p :ne :e) target)))
1208 (define-vop (=/single-float =/float)
1210 (:args (x :scs (single-reg))
1211 (y :scs (single-reg)))
1212 (:arg-types single-float single-float))
1214 (define-vop (=/double-float =/float)
1216 (:args (x :scs (double-reg))
1217 (y :scs (double-reg)))
1218 (:arg-types double-float double-float))
1221 (define-vop (=/long-float =/float)
1223 (:args (x :scs (long-reg))
1224 (y :scs (long-reg)))
1225 (:arg-types long-float long-float))
1228 (define-vop (<single-float)
1230 (:args (x :scs (single-reg single-stack descriptor-reg))
1231 (y :scs (single-reg single-stack descriptor-reg)))
1232 (:arg-types single-float single-float)
1233 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1234 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1236 (:info target not-p)
1237 (:policy :fast-safe)
1238 (:note "inline float comparison")
1241 ;; Handle a few special cases
1244 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1248 ((single-stack descriptor-reg)
1249 (if (sc-is x single-stack)
1250 (inst fcom (ea-for-sf-stack x))
1251 (inst fcom (ea-for-sf-desc x)))))
1252 (inst fnstsw) ; status word to ax
1253 (inst and ah-tn #x45))
1255 ;; General case when y is not in ST0.
1260 (unless (zerop (tn-offset x))
1261 (copy-fp-reg-to-fr0 x)))
1262 ((single-stack descriptor-reg)
1264 (if (sc-is x single-stack)
1265 (inst fld (ea-for-sf-stack x))
1266 (inst fld (ea-for-sf-desc x)))))
1270 ((single-stack descriptor-reg)
1271 (if (sc-is y single-stack)
1272 (inst fcom (ea-for-sf-stack y))
1273 (inst fcom (ea-for-sf-desc y)))))
1274 (inst fnstsw) ; status word to ax
1275 (inst and ah-tn #x45) ; C3 C2 C0
1276 (inst cmp ah-tn #x01)))
1277 (inst jmp (if not-p :ne :e) target)))
1279 (define-vop (<double-float)
1281 (:args (x :scs (double-reg double-stack descriptor-reg))
1282 (y :scs (double-reg double-stack descriptor-reg)))
1283 (:arg-types double-float double-float)
1284 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1285 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1287 (:info target not-p)
1288 (:policy :fast-safe)
1289 (:note "inline float comparison")
1292 ;; Handle a few special cases
1295 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1299 ((double-stack descriptor-reg)
1300 (if (sc-is x double-stack)
1301 (inst fcomd (ea-for-df-stack x))
1302 (inst fcomd (ea-for-df-desc x)))))
1303 (inst fnstsw) ; status word to ax
1304 (inst and ah-tn #x45))
1306 ;; General case when y is not in ST0.
1311 (unless (zerop (tn-offset x))
1312 (copy-fp-reg-to-fr0 x)))
1313 ((double-stack descriptor-reg)
1315 (if (sc-is x double-stack)
1316 (inst fldd (ea-for-df-stack x))
1317 (inst fldd (ea-for-df-desc x)))))
1321 ((double-stack descriptor-reg)
1322 (if (sc-is y double-stack)
1323 (inst fcomd (ea-for-df-stack y))
1324 (inst fcomd (ea-for-df-desc y)))))
1325 (inst fnstsw) ; status word to ax
1326 (inst and ah-tn #x45) ; C3 C2 C0
1327 (inst cmp ah-tn #x01)))
1328 (inst jmp (if not-p :ne :e) target)))
1331 (define-vop (<long-float)
1333 (:args (x :scs (long-reg))
1334 (y :scs (long-reg)))
1335 (:arg-types long-float long-float)
1336 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1338 (:info target not-p)
1339 (:policy :fast-safe)
1340 (:note "inline float comparison")
1344 ;; x is in ST0; y is in any reg.
1345 ((zerop (tn-offset x))
1347 (inst fnstsw) ; status word to ax
1348 (inst and ah-tn #x45) ; C3 C2 C0
1349 (inst cmp ah-tn #x01))
1350 ;; y is in ST0; x is in another reg.
1351 ((zerop (tn-offset y))
1353 (inst fnstsw) ; status word to ax
1354 (inst and ah-tn #x45))
1355 ;; x and y are the same register, not ST0
1356 ;; x and y are different registers, neither ST0.
1361 (inst fnstsw) ; status word to ax
1362 (inst and ah-tn #x45))) ; C3 C2 C0
1363 (inst jmp (if not-p :ne :e) target)))
1365 (define-vop (>single-float)
1367 (:args (x :scs (single-reg single-stack descriptor-reg))
1368 (y :scs (single-reg single-stack descriptor-reg)))
1369 (:arg-types single-float single-float)
1370 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1371 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1373 (:info target not-p)
1374 (:policy :fast-safe)
1375 (:note "inline float comparison")
1378 ;; Handle a few special cases
1381 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1385 ((single-stack descriptor-reg)
1386 (if (sc-is x single-stack)
1387 (inst fcom (ea-for-sf-stack x))
1388 (inst fcom (ea-for-sf-desc x)))))
1389 (inst fnstsw) ; status word to ax
1390 (inst and ah-tn #x45)
1391 (inst cmp ah-tn #x01))
1393 ;; General case when y is not in ST0.
1398 (unless (zerop (tn-offset x))
1399 (copy-fp-reg-to-fr0 x)))
1400 ((single-stack descriptor-reg)
1402 (if (sc-is x single-stack)
1403 (inst fld (ea-for-sf-stack x))
1404 (inst fld (ea-for-sf-desc x)))))
1408 ((single-stack descriptor-reg)
1409 (if (sc-is y single-stack)
1410 (inst fcom (ea-for-sf-stack y))
1411 (inst fcom (ea-for-sf-desc y)))))
1412 (inst fnstsw) ; status word to ax
1413 (inst and ah-tn #x45)))
1414 (inst jmp (if not-p :ne :e) target)))
1416 (define-vop (>double-float)
1418 (:args (x :scs (double-reg double-stack descriptor-reg))
1419 (y :scs (double-reg double-stack descriptor-reg)))
1420 (:arg-types double-float double-float)
1421 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1422 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1424 (:info target not-p)
1425 (:policy :fast-safe)
1426 (:note "inline float comparison")
1429 ;; Handle a few special cases
1432 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1436 ((double-stack descriptor-reg)
1437 (if (sc-is x double-stack)
1438 (inst fcomd (ea-for-df-stack x))
1439 (inst fcomd (ea-for-df-desc x)))))
1440 (inst fnstsw) ; status word to ax
1441 (inst and ah-tn #x45)
1442 (inst cmp ah-tn #x01))
1444 ;; General case when y is not in ST0.
1449 (unless (zerop (tn-offset x))
1450 (copy-fp-reg-to-fr0 x)))
1451 ((double-stack descriptor-reg)
1453 (if (sc-is x double-stack)
1454 (inst fldd (ea-for-df-stack x))
1455 (inst fldd (ea-for-df-desc x)))))
1459 ((double-stack descriptor-reg)
1460 (if (sc-is y double-stack)
1461 (inst fcomd (ea-for-df-stack y))
1462 (inst fcomd (ea-for-df-desc y)))))
1463 (inst fnstsw) ; status word to ax
1464 (inst and ah-tn #x45)))
1465 (inst jmp (if not-p :ne :e) target)))
1468 (define-vop (>long-float)
1470 (:args (x :scs (long-reg))
1471 (y :scs (long-reg)))
1472 (:arg-types long-float long-float)
1473 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1475 (:info target not-p)
1476 (:policy :fast-safe)
1477 (:note "inline float comparison")
1481 ;; y is in ST0; x is in any reg.
1482 ((zerop (tn-offset y))
1484 (inst fnstsw) ; status word to ax
1485 (inst and ah-tn #x45)
1486 (inst cmp ah-tn #x01))
1487 ;; x is in ST0; y is in another reg.
1488 ((zerop (tn-offset x))
1490 (inst fnstsw) ; status word to ax
1491 (inst and ah-tn #x45))
1492 ;; y and x are the same register, not ST0
1493 ;; y and x are different registers, neither ST0.
1498 (inst fnstsw) ; status word to ax
1499 (inst and ah-tn #x45)))
1500 (inst jmp (if not-p :ne :e) target)))
1502 ;;; Comparisons with 0 can use the FTST instruction.
1504 (define-vop (float-test)
1506 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1508 (:info target not-p y)
1509 (:variant-vars code)
1510 (:policy :fast-safe)
1512 (:save-p :compute-only)
1513 (:note "inline float comparison")
1516 (note-this-location vop :internal-error)
1519 ((zerop (tn-offset x))
1526 (inst fnstsw) ; status word to ax
1527 (inst and ah-tn #x45) ; C3 C2 C0
1528 (unless (zerop code)
1529 (inst cmp ah-tn code))
1530 (inst jmp (if not-p :ne :e) target)))
1532 (define-vop (=0/single-float float-test)
1534 (:args (x :scs (single-reg)))
1535 #!-negative-zero-is-not-zero
1536 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1537 #!+negative-zero-is-not-zero
1538 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1540 (define-vop (=0/double-float float-test)
1542 (:args (x :scs (double-reg)))
1543 #!-negative-zero-is-not-zero
1544 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1545 #!+negative-zero-is-not-zero
1546 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1549 (define-vop (=0/long-float float-test)
1551 (:args (x :scs (long-reg)))
1552 #!-negative-zero-is-not-zero
1553 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1554 #!+negative-zero-is-not-zero
1555 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1558 (define-vop (<0/single-float float-test)
1560 (:args (x :scs (single-reg)))
1561 #!-negative-zero-is-not-zero
1562 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1563 #!+negative-zero-is-not-zero
1564 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1566 (define-vop (<0/double-float float-test)
1568 (:args (x :scs (double-reg)))
1569 #!-negative-zero-is-not-zero
1570 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1571 #!+negative-zero-is-not-zero
1572 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1575 (define-vop (<0/long-float float-test)
1577 (:args (x :scs (long-reg)))
1578 #!-negative-zero-is-not-zero
1579 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1580 #!+negative-zero-is-not-zero
1581 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1584 (define-vop (>0/single-float float-test)
1586 (:args (x :scs (single-reg)))
1587 #!-negative-zero-is-not-zero
1588 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1589 #!+negative-zero-is-not-zero
1590 (:arg-types single-float (:constant (single-float -0f0 0f0)))
1592 (define-vop (>0/double-float float-test)
1594 (:args (x :scs (double-reg)))
1595 #!-negative-zero-is-not-zero
1596 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1597 #!+negative-zero-is-not-zero
1598 (:arg-types double-float (:constant (double-float -0d0 0d0)))
1601 (define-vop (>0/long-float float-test)
1603 (:args (x :scs (long-reg)))
1604 #!-negative-zero-is-not-zero
1605 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1606 #!+negative-zero-is-not-zero
1607 (:arg-types long-float (:constant (long-float -0l0 0l0)))
1611 (deftransform eql ((x y) (long-float long-float))
1612 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1613 (= (long-float-high-bits x) (long-float-high-bits y))
1614 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1618 (macrolet ((frob (name translate to-sc to-type)
1619 `(define-vop (,name)
1620 (:args (x :scs (signed-stack signed-reg) :target temp))
1621 (:temporary (:sc signed-stack) temp)
1622 (:results (y :scs (,to-sc)))
1623 (:arg-types signed-num)
1624 (:result-types ,to-type)
1625 (:policy :fast-safe)
1626 (:note "inline float coercion")
1627 (:translate ,translate)
1629 (:save-p :compute-only)
1634 (with-empty-tn@fp-top(y)
1635 (note-this-location vop :internal-error)
1638 (with-empty-tn@fp-top(y)
1639 (note-this-location vop :internal-error)
1640 (inst fild x))))))))
1641 (frob %single-float/signed %single-float single-reg single-float)
1642 (frob %double-float/signed %double-float double-reg double-float)
1644 (frob %long-float/signed %long-float long-reg long-float))
1646 (macrolet ((frob (name translate to-sc to-type)
1647 `(define-vop (,name)
1648 (:args (x :scs (unsigned-reg)))
1649 (:results (y :scs (,to-sc)))
1650 (:arg-types unsigned-num)
1651 (:result-types ,to-type)
1652 (:policy :fast-safe)
1653 (:note "inline float coercion")
1654 (:translate ,translate)
1656 (:save-p :compute-only)
1660 (with-empty-tn@fp-top(y)
1661 (note-this-location vop :internal-error)
1662 (inst fildl (make-ea :dword :base esp-tn)))
1663 (inst add esp-tn 8)))))
1664 (frob %single-float/unsigned %single-float single-reg single-float)
1665 (frob %double-float/unsigned %double-float double-reg double-float)
1667 (frob %long-float/unsigned %long-float long-reg long-float))
1669 ;;; These should be no-ops but the compiler might want to move
1670 ;;; some things around
1671 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1672 `(define-vop (,name)
1673 (:args (x :scs (,from-sc) :target y))
1674 (:results (y :scs (,to-sc)))
1675 (:arg-types ,from-type)
1676 (:result-types ,to-type)
1677 (:policy :fast-safe)
1678 (:note "inline float coercion")
1679 (:translate ,translate)
1681 (:save-p :compute-only)
1683 (note-this-location vop :internal-error)
1684 (unless (location= x y)
1686 ((zerop (tn-offset x))
1687 ;; x is in ST0, y is in another reg. not ST0
1689 ((zerop (tn-offset y))
1690 ;; y is in ST0, x is in another reg. not ST0
1691 (copy-fp-reg-to-fr0 x))
1693 ;; Neither x or y are in ST0, and they are not in
1697 (inst fxch x))))))))
1699 (frob %single-float/double-float %single-float double-reg
1700 double-float single-reg single-float)
1702 (frob %single-float/long-float %single-float long-reg
1703 long-float single-reg single-float)
1704 (frob %double-float/single-float %double-float single-reg single-float
1705 double-reg double-float)
1707 (frob %double-float/long-float %double-float long-reg long-float
1708 double-reg double-float)
1710 (frob %long-float/single-float %long-float single-reg single-float
1711 long-reg long-float)
1713 (frob %long-float/double-float %long-float double-reg double-float
1714 long-reg long-float))
1716 (macrolet ((frob (trans from-sc from-type round-p)
1717 `(define-vop (,(symbolicate trans "/" from-type))
1718 (:args (x :scs (,from-sc)))
1719 (:temporary (:sc signed-stack) stack-temp)
1721 '((:temporary (:sc unsigned-stack) scw)
1722 (:temporary (:sc any-reg) rcw)))
1723 (:results (y :scs (signed-reg)))
1724 (:arg-types ,from-type)
1725 (:result-types signed-num)
1727 (:policy :fast-safe)
1728 (:note "inline float truncate")
1730 (:save-p :compute-only)
1733 '((note-this-location vop :internal-error)
1734 ;; Catch any pending FPE exceptions.
1736 (,(if round-p 'progn 'pseudo-atomic)
1737 ;; normal mode (for now) is "round to best"
1740 '((inst fnstcw scw) ; save current control word
1741 (move rcw scw) ; into 16-bit register
1742 (inst or rcw (ash #b11 10)) ; CHOP
1743 (move stack-temp rcw)
1744 (inst fldcw stack-temp)))
1749 (inst fist stack-temp)
1750 (inst mov y stack-temp)))
1752 '((inst fldcw scw)))))))))
1753 (frob %unary-truncate single-reg single-float nil)
1754 (frob %unary-truncate double-reg double-float nil)
1756 (frob %unary-truncate long-reg long-float nil)
1757 (frob %unary-round single-reg single-float t)
1758 (frob %unary-round double-reg double-float t)
1760 (frob %unary-round long-reg long-float t))
1762 (macrolet ((frob (trans from-sc from-type round-p)
1763 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1764 (:args (x :scs (,from-sc) :target fr0))
1765 (:temporary (:sc double-reg :offset fr0-offset
1766 :from :argument :to :result) fr0)
1768 '((:temporary (:sc unsigned-stack) stack-temp)
1769 (:temporary (:sc unsigned-stack) scw)
1770 (:temporary (:sc any-reg) rcw)))
1771 (:results (y :scs (unsigned-reg)))
1772 (:arg-types ,from-type)
1773 (:result-types unsigned-num)
1775 (:policy :fast-safe)
1776 (:note "inline float truncate")
1778 (:save-p :compute-only)
1781 '((note-this-location vop :internal-error)
1782 ;; Catch any pending FPE exceptions.
1784 ;; normal mode (for now) is "round to best"
1785 (unless (zerop (tn-offset x))
1786 (copy-fp-reg-to-fr0 x))
1788 '((inst fnstcw scw) ; save current control word
1789 (move rcw scw) ; into 16-bit register
1790 (inst or rcw (ash #b11 10)) ; CHOP
1791 (move stack-temp rcw)
1792 (inst fldcw stack-temp)))
1794 (inst fistpl (make-ea :dword :base esp-tn))
1796 (inst fld fr0) ; copy fr0 to at least restore stack.
1799 '((inst fldcw scw)))))))
1800 (frob %unary-truncate single-reg single-float nil)
1801 (frob %unary-truncate double-reg double-float nil)
1803 (frob %unary-truncate long-reg long-float nil)
1804 (frob %unary-round single-reg single-float t)
1805 (frob %unary-round double-reg double-float t)
1807 (frob %unary-round long-reg long-float t))
1809 (define-vop (make-single-float)
1810 (:args (bits :scs (signed-reg) :target res
1811 :load-if (not (or (and (sc-is bits signed-stack)
1812 (sc-is res single-reg))
1813 (and (sc-is bits signed-stack)
1814 (sc-is res single-stack)
1815 (location= bits res))))))
1816 (:results (res :scs (single-reg single-stack)))
1817 (:temporary (:sc signed-stack) stack-temp)
1818 (:arg-types signed-num)
1819 (:result-types single-float)
1820 (:translate make-single-float)
1821 (:policy :fast-safe)
1828 (inst mov res bits))
1830 (assert (location= bits res)))))
1834 ;; source must be in memory
1835 (inst mov stack-temp bits)
1836 (with-empty-tn@fp-top(res)
1837 (inst fld stack-temp)))
1839 (with-empty-tn@fp-top(res)
1840 (inst fld bits))))))))
1842 (define-vop (make-double-float)
1843 (:args (hi-bits :scs (signed-reg))
1844 (lo-bits :scs (unsigned-reg)))
1845 (:results (res :scs (double-reg)))
1846 (:temporary (:sc double-stack) temp)
1847 (:arg-types signed-num unsigned-num)
1848 (:result-types double-float)
1849 (:translate make-double-float)
1850 (:policy :fast-safe)
1853 (let ((offset (1+ (tn-offset temp))))
1854 (storew hi-bits ebp-tn (- offset))
1855 (storew lo-bits ebp-tn (- (1+ offset)))
1856 (with-empty-tn@fp-top(res)
1857 (inst fldd (make-ea :dword :base ebp-tn
1858 :disp (- (* (1+ offset) word-bytes))))))))
1861 (define-vop (make-long-float)
1862 (:args (exp-bits :scs (signed-reg))
1863 (hi-bits :scs (unsigned-reg))
1864 (lo-bits :scs (unsigned-reg)))
1865 (:results (res :scs (long-reg)))
1866 (:temporary (:sc long-stack) temp)
1867 (:arg-types signed-num unsigned-num unsigned-num)
1868 (:result-types long-float)
1869 (:translate make-long-float)
1870 (:policy :fast-safe)
1873 (let ((offset (1+ (tn-offset temp))))
1874 (storew exp-bits ebp-tn (- offset))
1875 (storew hi-bits ebp-tn (- (1+ offset)))
1876 (storew lo-bits ebp-tn (- (+ offset 2)))
1877 (with-empty-tn@fp-top(res)
1878 (inst fldl (make-ea :dword :base ebp-tn
1879 :disp (- (* (+ offset 2) word-bytes))))))))
1881 (define-vop (single-float-bits)
1882 (:args (float :scs (single-reg descriptor-reg)
1883 :load-if (not (sc-is float single-stack))))
1884 (:results (bits :scs (signed-reg)))
1885 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1886 (:arg-types single-float)
1887 (:result-types signed-num)
1888 (:translate single-float-bits)
1889 (:policy :fast-safe)
1896 (with-tn@fp-top(float)
1897 (inst fst stack-temp)
1898 (inst mov bits stack-temp)))
1900 (inst mov bits float))
1903 bits float sb!vm:single-float-value-slot
1904 sb!vm:other-pointer-type))))
1908 (with-tn@fp-top(float)
1909 (inst fst bits))))))))
1911 (define-vop (double-float-high-bits)
1912 (:args (float :scs (double-reg descriptor-reg)
1913 :load-if (not (sc-is float double-stack))))
1914 (:results (hi-bits :scs (signed-reg)))
1915 (:temporary (:sc double-stack) temp)
1916 (:arg-types double-float)
1917 (:result-types signed-num)
1918 (:translate double-float-high-bits)
1919 (:policy :fast-safe)
1924 (with-tn@fp-top(float)
1925 (let ((where (make-ea :dword :base ebp-tn
1926 :disp (- (* (+ 2 (tn-offset temp))
1929 (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
1931 (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
1933 (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
1934 sb!vm:other-pointer-type)))))
1936 (define-vop (double-float-low-bits)
1937 (:args (float :scs (double-reg descriptor-reg)
1938 :load-if (not (sc-is float double-stack))))
1939 (:results (lo-bits :scs (unsigned-reg)))
1940 (:temporary (:sc double-stack) temp)
1941 (:arg-types double-float)
1942 (:result-types unsigned-num)
1943 (:translate double-float-low-bits)
1944 (:policy :fast-safe)
1949 (with-tn@fp-top(float)
1950 (let ((where (make-ea :dword :base ebp-tn
1951 :disp (- (* (+ 2 (tn-offset temp))
1954 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
1956 (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
1958 (loadw lo-bits float sb!vm:double-float-value-slot
1959 sb!vm:other-pointer-type)))))
1962 (define-vop (long-float-exp-bits)
1963 (:args (float :scs (long-reg descriptor-reg)
1964 :load-if (not (sc-is float long-stack))))
1965 (:results (exp-bits :scs (signed-reg)))
1966 (:temporary (:sc long-stack) temp)
1967 (:arg-types long-float)
1968 (:result-types signed-num)
1969 (:translate long-float-exp-bits)
1970 (:policy :fast-safe)
1975 (with-tn@fp-top(float)
1976 (let ((where (make-ea :dword :base ebp-tn
1977 :disp (- (* (+ 3 (tn-offset temp))
1979 (store-long-float where)))
1980 (inst movsx exp-bits
1981 (make-ea :word :base ebp-tn
1982 :disp (* (- (1+ (tn-offset temp))) word-bytes))))
1984 (inst movsx exp-bits
1985 (make-ea :word :base ebp-tn
1986 :disp (* (- (1+ (tn-offset float))) word-bytes))))
1988 (inst movsx exp-bits
1989 (make-ea :word :base float
1990 :disp (- (* (+ 2 sb!vm:long-float-value-slot)
1992 sb!vm:other-pointer-type)))))))
1995 (define-vop (long-float-high-bits)
1996 (:args (float :scs (long-reg descriptor-reg)
1997 :load-if (not (sc-is float long-stack))))
1998 (:results (hi-bits :scs (unsigned-reg)))
1999 (:temporary (:sc long-stack) temp)
2000 (:arg-types long-float)
2001 (:result-types unsigned-num)
2002 (:translate long-float-high-bits)
2003 (:policy :fast-safe)
2008 (with-tn@fp-top(float)
2009 (let ((where (make-ea :dword :base ebp-tn
2010 :disp (- (* (+ 3 (tn-offset temp))
2012 (store-long-float where)))
2013 (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
2015 (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
2017 (loadw hi-bits float (1+ sb!vm:long-float-value-slot)
2018 sb!vm:other-pointer-type)))))
2021 (define-vop (long-float-low-bits)
2022 (:args (float :scs (long-reg descriptor-reg)
2023 :load-if (not (sc-is float long-stack))))
2024 (:results (lo-bits :scs (unsigned-reg)))
2025 (:temporary (:sc long-stack) temp)
2026 (:arg-types long-float)
2027 (:result-types unsigned-num)
2028 (:translate long-float-low-bits)
2029 (:policy :fast-safe)
2034 (with-tn@fp-top(float)
2035 (let ((where (make-ea :dword :base ebp-tn
2036 :disp (- (* (+ 3 (tn-offset temp))
2038 (store-long-float where)))
2039 (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
2041 (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
2043 (loadw lo-bits float sb!vm:long-float-value-slot
2044 sb!vm:other-pointer-type)))))
2046 ;;;; float mode hackery
2048 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2049 (defknown floating-point-modes () float-modes (flushable))
2050 (defknown ((setf floating-point-modes)) (float-modes)
2053 (defconstant npx-env-size (* 7 sb!vm:word-bytes))
2054 (defconstant npx-cw-offset 0)
2055 (defconstant npx-sw-offset 4)
2057 (define-vop (floating-point-modes)
2058 (:results (res :scs (unsigned-reg)))
2059 (:result-types unsigned-num)
2060 (:translate floating-point-modes)
2061 (:policy :fast-safe)
2062 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2065 (inst sub esp-tn npx-env-size) ; make space on stack
2066 (inst wait) ; Catch any pending FPE exceptions
2067 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2068 (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
2069 ;; Current status to high word
2070 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2071 ;; Exception mask to low word
2072 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2073 (inst add esp-tn npx-env-size) ; Pop stack
2074 (inst xor eax #x3f) ; Flip exception mask to trap enable bits
2077 (define-vop (set-floating-point-modes)
2078 (:args (new :scs (unsigned-reg) :to :result :target res))
2079 (:results (res :scs (unsigned-reg)))
2080 (:arg-types unsigned-num)
2081 (:result-types unsigned-num)
2082 (:translate (setf floating-point-modes))
2083 (:policy :fast-safe)
2084 (:temporary (:sc unsigned-reg :offset eax-offset
2085 :from :eval :to :result) eax)
2087 (inst sub esp-tn npx-env-size) ; make space on stack
2088 (inst wait) ; Catch any pending FPE exceptions
2089 (inst fstenv (make-ea :dword :base esp-tn))
2091 (inst xor eax #x3f) ; turn trap enable bits into exception mask
2092 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2093 (inst shr eax 16) ; position status word
2094 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2095 (inst fldenv (make-ea :dword :base esp-tn))
2096 (inst add esp-tn npx-env-size) ; Pop stack
2102 ;;; Let's use some of the 80387 special functions.
2104 ;;; These defs will not take effect unless code/irrat.lisp is modified
2105 ;;; to remove the inlined alien routine def.
2107 (macrolet ((frob (func trans op)
2108 `(define-vop (,func)
2109 (:args (x :scs (double-reg) :target fr0))
2110 (:temporary (:sc double-reg :offset fr0-offset
2111 :from :argument :to :result) fr0)
2113 (:results (y :scs (double-reg)))
2114 (:arg-types double-float)
2115 (:result-types double-float)
2117 (:policy :fast-safe)
2118 (:note "inline NPX function")
2120 (:save-p :compute-only)
2123 (note-this-location vop :internal-error)
2124 (unless (zerop (tn-offset x))
2125 (inst fxch x) ; x to top of stack
2126 (unless (location= x y)
2127 (inst fst x))) ; maybe save it
2128 (inst ,op) ; clobber st0
2129 (cond ((zerop (tn-offset y))
2130 (when (policy node (or (= debug 3) (> safety speed)))
2135 ;; Quick versions of fsin and fcos that require the argument to be
2136 ;; within range 2^63.
2137 (frob fsin-quick %sin-quick fsin)
2138 (frob fcos-quick %cos-quick fcos)
2139 (frob fsqrt %sqrt fsqrt))
2141 ;;; Quick version of ftan that requires the argument to be within
2143 (define-vop (ftan-quick)
2144 (:translate %tan-quick)
2145 (:args (x :scs (double-reg) :target fr0))
2146 (:temporary (:sc double-reg :offset fr0-offset
2147 :from :argument :to :result) fr0)
2148 (:temporary (:sc double-reg :offset fr1-offset
2149 :from :argument :to :result) fr1)
2150 (:results (y :scs (double-reg)))
2151 (:arg-types double-float)
2152 (:result-types double-float)
2153 (:policy :fast-safe)
2154 (:note "inline tan function")
2156 (:save-p :compute-only)
2158 (note-this-location vop :internal-error)
2167 (inst fldd (make-random-tn :kind :normal
2168 :sc (sc-or-lose 'double-reg)
2169 :offset (- (tn-offset x) 2)))))
2180 ;;; These versions of fsin, fcos, and ftan try to use argument
2181 ;;; reduction but to do this accurately requires greater precision and
2182 ;;; it is hopelessly inaccurate.
2184 (macrolet ((frob (func trans op)
2185 `(define-vop (,func)
2187 (:args (x :scs (double-reg) :target fr0))
2188 (:temporary (:sc unsigned-reg :offset eax-offset
2189 :from :eval :to :result) eax)
2190 (:temporary (:sc unsigned-reg :offset fr0-offset
2191 :from :argument :to :result) fr0)
2192 (:temporary (:sc unsigned-reg :offset fr1-offset
2193 :from :argument :to :result) fr1)
2194 (:results (y :scs (double-reg)))
2195 (:arg-types double-float)
2196 (:result-types double-float)
2197 (:policy :fast-safe)
2198 (:note "inline sin/cos function")
2200 (:save-p :compute-only)
2203 (note-this-location vop :internal-error)
2204 (unless (zerop (tn-offset x))
2205 (inst fxch x) ; x to top of stack
2206 (unless (location= x y)
2207 (inst fst x))) ; maybe save it
2209 (inst fnstsw) ; status word to ax
2210 (inst and ah-tn #x04) ; C2
2212 ;; Else x was out of range so reduce it; ST0 is unchanged.
2213 (inst fstp fr1) ; Load 2*PI
2219 (inst fnstsw) ; status word to ax
2220 (inst and ah-tn #x04) ; C2
2224 (unless (zerop (tn-offset y))
2226 (frob fsin %sin fsin)
2227 (frob fcos %cos fcos))
2232 (:args (x :scs (double-reg) :target fr0))
2233 (:temporary (:sc unsigned-reg :offset eax-offset
2234 :from :argument :to :result) eax)
2235 (:temporary (:sc double-reg :offset fr0-offset
2236 :from :argument :to :result) fr0)
2237 (:temporary (:sc double-reg :offset fr1-offset
2238 :from :argument :to :result) fr1)
2239 (:results (y :scs (double-reg)))
2240 (:arg-types double-float)
2241 (:result-types double-float)
2242 (:policy :fast-safe)
2243 (:note "inline tan function")
2245 (:save-p :compute-only)
2248 (note-this-location vop :internal-error)
2257 (inst fldd (make-random-tn :kind :normal
2258 :sc (sc-or-lose 'double-reg)
2259 :offset (- (tn-offset x) 2)))))
2261 (inst fnstsw) ; status word to ax
2262 (inst and ah-tn #x04) ; C2
2264 ;; Else x was out of range so reduce it; ST0 is unchanged.
2265 (inst fldpi) ; Load 2*PI
2270 (inst fnstsw) ; status word to ax
2271 (inst and ah-tn #x04) ; C2
2285 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
2286 ;;; the argument is out of range 2^63 and would thus be hopelessly
2288 (macrolet ((frob (func trans op)
2289 `(define-vop (,func)
2291 (:args (x :scs (double-reg) :target fr0))
2292 (:temporary (:sc double-reg :offset fr0-offset
2293 :from :argument :to :result) fr0)
2294 (:temporary (:sc unsigned-reg :offset eax-offset
2295 :from :argument :to :result) eax)
2296 (:results (y :scs (double-reg)))
2297 (:arg-types double-float)
2298 (:result-types double-float)
2299 (:policy :fast-safe)
2300 (:note "inline sin/cos function")
2302 (:save-p :compute-only)
2305 (note-this-location vop :internal-error)
2306 (unless (zerop (tn-offset x))
2307 (inst fxch x) ; x to top of stack
2308 (unless (location= x y)
2309 (inst fst x))) ; maybe save it
2311 (inst fnstsw) ; status word to ax
2312 (inst and ah-tn #x04) ; C2
2314 ;; Else x was out of range so reduce it; ST0 is unchanged.
2315 (inst fstp fr0) ; Load 0.0
2318 (unless (zerop (tn-offset y))
2320 (frob fsin %sin fsin)
2321 (frob fcos %cos fcos))
2325 (:args (x :scs (double-reg) :target fr0))
2326 (:temporary (:sc double-reg :offset fr0-offset
2327 :from :argument :to :result) fr0)
2328 (:temporary (:sc double-reg :offset fr1-offset
2329 :from :argument :to :result) fr1)
2330 (:temporary (:sc unsigned-reg :offset eax-offset
2331 :from :argument :to :result) eax)
2332 (:results (y :scs (double-reg)))
2333 (:arg-types double-float)
2334 (:result-types double-float)
2336 (:policy :fast-safe)
2337 (:note "inline tan function")
2339 (:save-p :compute-only)
2342 (note-this-location vop :internal-error)
2351 (inst fldd (make-random-tn :kind :normal
2352 :sc (sc-or-lose 'double-reg)
2353 :offset (- (tn-offset x) 2)))))
2355 (inst fnstsw) ; status word to ax
2356 (inst and ah-tn #x04) ; C2
2358 ;; Else x was out of range so reduce it; ST0 is unchanged.
2359 (inst fldz) ; Load 0.0
2374 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2375 (:temporary (:sc double-reg :offset fr0-offset
2376 :from :argument :to :result) fr0)
2377 (:temporary (:sc double-reg :offset fr1-offset
2378 :from :argument :to :result) fr1)
2379 (:temporary (:sc double-reg :offset fr2-offset
2380 :from :argument :to :result) fr2)
2381 (:results (y :scs (double-reg)))
2382 (:arg-types double-float)
2383 (:result-types double-float)
2384 (:policy :fast-safe)
2385 (:note "inline exp function")
2387 (:save-p :compute-only)
2389 (note-this-location vop :internal-error)
2392 (cond ((zerop (tn-offset x))
2398 ;; x is in a FP reg, not fr0
2402 ((double-stack descriptor-reg)
2405 (if (sc-is x double-stack)
2406 (inst fmuld (ea-for-df-stack x))
2407 (inst fmuld (ea-for-df-desc x)))))
2408 ;; Now fr0=x log2(e)
2412 (inst fsubp-sti fr1)
2415 (inst faddp-sti fr1)
2420 (t (inst fstd y)))))
2422 ;;; Modified exp that handles the following special cases:
2423 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
2426 (:args (x :scs (double-reg) :target fr0))
2427 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2428 (:temporary (:sc double-reg :offset fr0-offset
2429 :from :argument :to :result) fr0)
2430 (:temporary (:sc double-reg :offset fr1-offset
2431 :from :argument :to :result) fr1)
2432 (:temporary (:sc double-reg :offset fr2-offset
2433 :from :argument :to :result) fr2)
2434 (:results (y :scs (double-reg)))
2435 (:arg-types double-float)
2436 (:result-types double-float)
2437 (:policy :fast-safe)
2438 (:note "inline exp function")
2440 (:save-p :compute-only)
2443 (note-this-location vop :internal-error)
2444 (unless (zerop (tn-offset x))
2445 (inst fxch x) ; x to top of stack
2446 (unless (location= x y)
2447 (inst fst x))) ; maybe save it
2448 ;; Check for Inf or NaN
2452 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2453 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2454 (inst and ah-tn #x02) ; Test sign of Inf.
2455 (inst jmp :z DONE) ; +Inf gives +Inf.
2456 (inst fstp fr0) ; -Inf gives 0
2458 (inst jmp-short DONE)
2463 ;; Now fr0=x log2(e)
2467 (inst fsubp-sti fr1)
2470 (inst faddp-sti fr1)
2474 (unless (zerop (tn-offset y))
2477 ;;; Expm1 = exp(x) - 1.
2478 ;;; Handles the following special cases:
2479 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2480 (define-vop (fexpm1)
2482 (:args (x :scs (double-reg) :target fr0))
2483 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2484 (:temporary (:sc double-reg :offset fr0-offset
2485 :from :argument :to :result) fr0)
2486 (:temporary (:sc double-reg :offset fr1-offset
2487 :from :argument :to :result) fr1)
2488 (:temporary (:sc double-reg :offset fr2-offset
2489 :from :argument :to :result) fr2)
2490 (:results (y :scs (double-reg)))
2491 (:arg-types double-float)
2492 (:result-types double-float)
2493 (:policy :fast-safe)
2494 (:note "inline expm1 function")
2496 (:save-p :compute-only)
2499 (note-this-location vop :internal-error)
2500 (unless (zerop (tn-offset x))
2501 (inst fxch x) ; x to top of stack
2502 (unless (location= x y)
2503 (inst fst x))) ; maybe save it
2504 ;; Check for Inf or NaN
2508 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2509 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2510 (inst and ah-tn #x02) ; Test sign of Inf.
2511 (inst jmp :z DONE) ; +Inf gives +Inf.
2512 (inst fstp fr0) ; -Inf gives -1.0
2515 (inst jmp-short DONE)
2517 ;; Free two stack slots leaving the argument on top.
2521 (inst fmul fr1) ; Now fr0 = x log2(e)
2536 (unless (zerop (tn-offset y))
2541 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2542 (:temporary (:sc double-reg :offset fr0-offset
2543 :from :argument :to :result) fr0)
2544 (:temporary (:sc double-reg :offset fr1-offset
2545 :from :argument :to :result) fr1)
2546 (:results (y :scs (double-reg)))
2547 (:arg-types double-float)
2548 (:result-types double-float)
2549 (:policy :fast-safe)
2550 (:note "inline log function")
2552 (:save-p :compute-only)
2554 (note-this-location vop :internal-error)
2569 ;; x is in a FP reg, not fr0 or fr1
2573 (inst fldd (make-random-tn :kind :normal
2574 :sc (sc-or-lose 'double-reg)
2575 :offset (1- (tn-offset x))))))
2577 ((double-stack descriptor-reg)
2581 (if (sc-is x double-stack)
2582 (inst fldd (ea-for-df-stack x))
2583 (inst fldd (ea-for-df-desc x)))
2588 (t (inst fstd y)))))
2590 (define-vop (flog10)
2592 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2593 (:temporary (:sc double-reg :offset fr0-offset
2594 :from :argument :to :result) fr0)
2595 (:temporary (:sc double-reg :offset fr1-offset
2596 :from :argument :to :result) fr1)
2597 (:results (y :scs (double-reg)))
2598 (:arg-types double-float)
2599 (:result-types double-float)
2600 (:policy :fast-safe)
2601 (:note "inline log10 function")
2603 (:save-p :compute-only)
2605 (note-this-location vop :internal-error)
2620 ;; x is in a FP reg, not fr0 or fr1
2624 (inst fldd (make-random-tn :kind :normal
2625 :sc (sc-or-lose 'double-reg)
2626 :offset (1- (tn-offset x))))))
2628 ((double-stack descriptor-reg)
2632 (if (sc-is x double-stack)
2633 (inst fldd (ea-for-df-stack x))
2634 (inst fldd (ea-for-df-desc x)))
2639 (t (inst fstd y)))))
2643 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2644 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2645 (:temporary (:sc double-reg :offset fr0-offset
2646 :from (:argument 0) :to :result) fr0)
2647 (:temporary (:sc double-reg :offset fr1-offset
2648 :from (:argument 1) :to :result) fr1)
2649 (:temporary (:sc double-reg :offset fr2-offset
2650 :from :load :to :result) fr2)
2651 (:results (r :scs (double-reg)))
2652 (:arg-types double-float double-float)
2653 (:result-types double-float)
2654 (:policy :fast-safe)
2655 (:note "inline pow function")
2657 (:save-p :compute-only)
2659 (note-this-location vop :internal-error)
2660 ;; Setup x in fr0 and y in fr1
2662 ;; x in fr0; y in fr1
2663 ((and (sc-is x double-reg) (zerop (tn-offset x))
2664 (sc-is y double-reg) (= 1 (tn-offset y))))
2665 ;; y in fr1; x not in fr0
2666 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2670 (copy-fp-reg-to-fr0 x))
2673 (inst fldd (ea-for-df-stack x)))
2676 (inst fldd (ea-for-df-desc x)))))
2677 ;; x in fr0; y not in fr1
2678 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2680 ;; Now load y to fr0
2683 (copy-fp-reg-to-fr0 y))
2686 (inst fldd (ea-for-df-stack y)))
2689 (inst fldd (ea-for-df-desc y))))
2691 ;; x in fr1; y not in fr1
2692 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2696 (copy-fp-reg-to-fr0 y))
2699 (inst fldd (ea-for-df-stack y)))
2702 (inst fldd (ea-for-df-desc y))))
2705 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2707 ;; Now load x to fr0
2710 (copy-fp-reg-to-fr0 x))
2713 (inst fldd (ea-for-df-stack x)))
2716 (inst fldd (ea-for-df-desc x)))))
2717 ;; Neither x or y are in either fr0 or fr1
2724 (inst fldd (make-random-tn :kind :normal
2725 :sc (sc-or-lose 'double-reg)
2726 :offset (- (tn-offset y) 2))))
2728 (inst fldd (ea-for-df-stack y)))
2730 (inst fldd (ea-for-df-desc y))))
2734 (inst fldd (make-random-tn :kind :normal
2735 :sc (sc-or-lose 'double-reg)
2736 :offset (1- (tn-offset x)))))
2738 (inst fldd (ea-for-df-stack x)))
2740 (inst fldd (ea-for-df-desc x))))))
2742 ;; Now have x at fr0; and y at fr1
2744 ;; Now fr0=y log2(x)
2748 (inst fsubp-sti fr1)
2751 (inst faddp-sti fr1)
2756 (t (inst fstd r)))))
2758 (define-vop (fscalen)
2759 (:translate %scalbn)
2760 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2761 (y :scs (signed-stack signed-reg) :target temp))
2762 (:temporary (:sc double-reg :offset fr0-offset
2763 :from (:argument 0) :to :result) fr0)
2764 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2765 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2766 (:results (r :scs (double-reg)))
2767 (:arg-types double-float signed-num)
2768 (:result-types double-float)
2769 (:policy :fast-safe)
2770 (:note "inline scalbn function")
2772 ;; Setup x in fr0 and y in fr1
2803 (inst fld (make-random-tn :kind :normal
2804 :sc (sc-or-lose 'double-reg)
2805 :offset (1- (tn-offset x)))))))
2806 ((double-stack descriptor-reg)
2815 (if (sc-is x double-stack)
2816 (inst fldd (ea-for-df-stack x))
2817 (inst fldd (ea-for-df-desc x)))))
2819 (unless (zerop (tn-offset r))
2822 (define-vop (fscale)
2824 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2825 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2826 (:temporary (:sc double-reg :offset fr0-offset
2827 :from (:argument 0) :to :result) fr0)
2828 (:temporary (:sc double-reg :offset fr1-offset
2829 :from (:argument 1) :to :result) fr1)
2830 (:results (r :scs (double-reg)))
2831 (:arg-types double-float double-float)
2832 (:result-types double-float)
2833 (:policy :fast-safe)
2834 (:note "inline scalb function")
2836 (:save-p :compute-only)
2838 (note-this-location vop :internal-error)
2839 ;; Setup x in fr0 and y in fr1
2841 ;; x in fr0; y in fr1
2842 ((and (sc-is x double-reg) (zerop (tn-offset x))
2843 (sc-is y double-reg) (= 1 (tn-offset y))))
2844 ;; y in fr1; x not in fr0
2845 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2849 (copy-fp-reg-to-fr0 x))
2852 (inst fldd (ea-for-df-stack x)))
2855 (inst fldd (ea-for-df-desc x)))))
2856 ;; x in fr0; y not in fr1
2857 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2859 ;; Now load y to fr0
2862 (copy-fp-reg-to-fr0 y))
2865 (inst fldd (ea-for-df-stack y)))
2868 (inst fldd (ea-for-df-desc y))))
2870 ;; x in fr1; y not in fr1
2871 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2875 (copy-fp-reg-to-fr0 y))
2878 (inst fldd (ea-for-df-stack y)))
2881 (inst fldd (ea-for-df-desc y))))
2884 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2886 ;; Now load x to fr0
2889 (copy-fp-reg-to-fr0 x))
2892 (inst fldd (ea-for-df-stack x)))
2895 (inst fldd (ea-for-df-desc x)))))
2896 ;; Neither x or y are in either fr0 or fr1
2903 (inst fldd (make-random-tn :kind :normal
2904 :sc (sc-or-lose 'double-reg)
2905 :offset (- (tn-offset y) 2))))
2907 (inst fldd (ea-for-df-stack y)))
2909 (inst fldd (ea-for-df-desc y))))
2913 (inst fldd (make-random-tn :kind :normal
2914 :sc (sc-or-lose 'double-reg)
2915 :offset (1- (tn-offset x)))))
2917 (inst fldd (ea-for-df-stack x)))
2919 (inst fldd (ea-for-df-desc x))))))
2921 ;; Now have x at fr0; and y at fr1
2923 (unless (zerop (tn-offset r))
2926 (define-vop (flog1p)
2928 (:args (x :scs (double-reg) :to :result))
2929 (:temporary (:sc double-reg :offset fr0-offset
2930 :from :argument :to :result) fr0)
2931 (:temporary (:sc double-reg :offset fr1-offset
2932 :from :argument :to :result) fr1)
2933 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2934 (:results (y :scs (double-reg)))
2935 (:arg-types double-float)
2936 (:result-types double-float)
2937 (:policy :fast-safe)
2938 ;; FIXME: PENTIUM isn't used on the *FEATURES* list of the CMU CL I based
2939 ;; SBCL on, even when it is running on a Pentium. Find out what's going
2940 ;; on here and see what the proper value should be. (Perhaps just use the
2941 ;; apparently-conservative value of T always?) For more confusion, see also
2942 ;; apparently-reversed-sense test for the FLOG1P-PENTIUM vop below.
2943 (:guard #!+pentium nil #!-pentium t)
2944 (:note "inline log1p function")
2947 ;; x is in a FP reg, not fr0, fr1.
2950 (inst fldd (make-random-tn :kind :normal
2951 :sc (sc-or-lose 'double-reg)
2952 :offset (- (tn-offset x) 2)))
2954 (inst push #x3e947ae1) ; Constant 0.29
2956 (inst fld (make-ea :dword :base esp-tn))
2959 (inst fnstsw) ; status word to ax
2960 (inst and ah-tn #x45)
2961 (inst jmp :z WITHIN-RANGE)
2962 ;; Out of range for fyl2xp1.
2964 (inst faddd (make-random-tn :kind :normal
2965 :sc (sc-or-lose 'double-reg)
2966 :offset (- (tn-offset x) 1)))
2974 (inst fldd (make-random-tn :kind :normal
2975 :sc (sc-or-lose 'double-reg)
2976 :offset (- (tn-offset x) 1)))
2982 (t (inst fstd y)))))
2984 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2985 ;;; instruction and a range check can be avoided.
2986 (define-vop (flog1p-pentium)
2988 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2989 (:temporary (:sc double-reg :offset fr0-offset
2990 :from :argument :to :result) fr0)
2991 (:temporary (:sc double-reg :offset fr1-offset
2992 :from :argument :to :result) fr1)
2993 (:results (y :scs (double-reg)))
2994 (:arg-types double-float)
2995 (:result-types double-float)
2996 (:policy :fast-safe)
2997 ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
2998 (:guard #!+pentium t #!-pentium nil)
2999 (:note "inline log1p with limited x range function")
3001 (:save-p :compute-only)
3003 (note-this-location vop :internal-error)
3018 ;; x is in a FP reg, not fr0 or fr1
3022 (inst fldd (make-random-tn :kind :normal
3023 :sc (sc-or-lose 'double-reg)
3024 :offset (1- (tn-offset x)))))))
3025 ((double-stack descriptor-reg)
3029 (if (sc-is x double-stack)
3030 (inst fldd (ea-for-df-stack x))
3031 (inst fldd (ea-for-df-desc x)))))
3036 (t (inst fstd y)))))
3040 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3041 (:temporary (:sc double-reg :offset fr0-offset
3042 :from :argument :to :result) fr0)
3043 (:temporary (:sc double-reg :offset fr1-offset
3044 :from :argument :to :result) fr1)
3045 (:results (y :scs (double-reg)))
3046 (:arg-types double-float)
3047 (:result-types double-float)
3048 (:policy :fast-safe)
3049 (:note "inline logb function")
3051 (:save-p :compute-only)
3053 (note-this-location vop :internal-error)
3064 ;; x is in a FP reg, not fr0 or fr1
3067 (inst fldd (make-random-tn :kind :normal
3068 :sc (sc-or-lose 'double-reg)
3069 :offset (- (tn-offset x) 2))))))
3070 ((double-stack descriptor-reg)
3073 (if (sc-is x double-stack)
3074 (inst fldd (ea-for-df-stack x))
3075 (inst fldd (ea-for-df-desc x)))))
3086 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
3087 (:temporary (:sc double-reg :offset fr0-offset
3088 :from (:argument 0) :to :result) fr0)
3089 (:temporary (:sc double-reg :offset fr1-offset
3090 :from (:argument 0) :to :result) fr1)
3091 (:results (r :scs (double-reg)))
3092 (:arg-types double-float)
3093 (:result-types double-float)
3094 (:policy :fast-safe)
3095 (:note "inline atan function")
3097 (:save-p :compute-only)
3099 (note-this-location vop :internal-error)
3100 ;; Setup x in fr1 and 1.0 in fr0
3103 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3106 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3108 ;; x not in fr0 or fr1
3115 (inst fldd (make-random-tn :kind :normal
3116 :sc (sc-or-lose 'double-reg)
3117 :offset (- (tn-offset x) 2))))
3119 (inst fldd (ea-for-df-stack x)))
3121 (inst fldd (ea-for-df-desc x))))))
3123 ;; Now have x at fr1; and 1.0 at fr0
3128 (t (inst fstd r)))))
3130 (define-vop (fatan2)
3132 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3133 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3134 (:temporary (:sc double-reg :offset fr0-offset
3135 :from (:argument 1) :to :result) fr0)
3136 (:temporary (:sc double-reg :offset fr1-offset
3137 :from (:argument 0) :to :result) fr1)
3138 (:results (r :scs (double-reg)))
3139 (:arg-types double-float double-float)
3140 (:result-types double-float)
3141 (:policy :fast-safe)
3142 (:note "inline atan2 function")
3144 (:save-p :compute-only)
3146 (note-this-location vop :internal-error)
3147 ;; Setup x in fr1 and y in fr0
3149 ;; y in fr0; x in fr1
3150 ((and (sc-is y double-reg) (zerop (tn-offset y))
3151 (sc-is x double-reg) (= 1 (tn-offset x))))
3152 ;; x in fr1; y not in fr0
3153 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3157 (copy-fp-reg-to-fr0 y))
3160 (inst fldd (ea-for-df-stack y)))
3163 (inst fldd (ea-for-df-desc y)))))
3164 ;; y in fr0; x not in fr1
3165 ((and (sc-is y double-reg) (zerop (tn-offset y)))
3167 ;; Now load x to fr0
3170 (copy-fp-reg-to-fr0 x))
3173 (inst fldd (ea-for-df-stack x)))
3176 (inst fldd (ea-for-df-desc x))))
3178 ;; y in fr1; x not in fr1
3179 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3183 (copy-fp-reg-to-fr0 x))
3186 (inst fldd (ea-for-df-stack x)))
3189 (inst fldd (ea-for-df-desc x))))
3192 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3194 ;; Now load y to fr0
3197 (copy-fp-reg-to-fr0 y))
3200 (inst fldd (ea-for-df-stack y)))
3203 (inst fldd (ea-for-df-desc y)))))
3204 ;; Neither y or x are in either fr0 or fr1
3211 (inst fldd (make-random-tn :kind :normal
3212 :sc (sc-or-lose 'double-reg)
3213 :offset (- (tn-offset x) 2))))
3215 (inst fldd (ea-for-df-stack x)))
3217 (inst fldd (ea-for-df-desc x))))
3221 (inst fldd (make-random-tn :kind :normal
3222 :sc (sc-or-lose 'double-reg)
3223 :offset (1- (tn-offset y)))))
3225 (inst fldd (ea-for-df-stack y)))
3227 (inst fldd (ea-for-df-desc y))))))
3229 ;; Now have y at fr0; and x at fr1
3234 (t (inst fstd r)))))
3236 ) ; progn #!-long-float
3243 ;;; Lets use some of the 80387 special functions.
3245 ;;; These defs will not take effect unless code/irrat.lisp is modified
3246 ;;; to remove the inlined alien routine def.
3248 (macrolet ((frob (func trans op)
3249 `(define-vop (,func)
3250 (:args (x :scs (long-reg) :target fr0))
3251 (:temporary (:sc long-reg :offset fr0-offset
3252 :from :argument :to :result) fr0)
3254 (:results (y :scs (long-reg)))
3255 (:arg-types long-float)
3256 (:result-types long-float)
3258 (:policy :fast-safe)
3259 (:note "inline NPX function")
3261 (:save-p :compute-only)
3264 (note-this-location vop :internal-error)
3265 (unless (zerop (tn-offset x))
3266 (inst fxch x) ; x to top of stack
3267 (unless (location= x y)
3268 (inst fst x))) ; maybe save it
3269 (inst ,op) ; clobber st0
3270 (cond ((zerop (tn-offset y))
3271 (when (policy node (or (= debug 3) (> safety speed)))
3276 ;; Quick versions of fsin and fcos that require the argument to be
3277 ;; within range 2^63.
3278 (frob fsin-quick %sin-quick fsin)
3279 (frob fcos-quick %cos-quick fcos)
3280 (frob fsqrt %sqrt fsqrt))
3282 ;;; Quick version of ftan that requires the argument to be within
3284 (define-vop (ftan-quick)
3285 (:translate %tan-quick)
3286 (:args (x :scs (long-reg) :target fr0))
3287 (:temporary (:sc long-reg :offset fr0-offset
3288 :from :argument :to :result) fr0)
3289 (:temporary (:sc long-reg :offset fr1-offset
3290 :from :argument :to :result) fr1)
3291 (:results (y :scs (long-reg)))
3292 (:arg-types long-float)
3293 (:result-types long-float)
3294 (:policy :fast-safe)
3295 (:note "inline tan function")
3297 (:save-p :compute-only)
3299 (note-this-location vop :internal-error)
3308 (inst fldd (make-random-tn :kind :normal
3309 :sc (sc-or-lose 'double-reg)
3310 :offset (- (tn-offset x) 2)))))
3321 ;;; These versions of fsin, fcos, and ftan try to use argument
3322 ;;; reduction but to do this accurately requires greater precision and
3323 ;;; it is hopelessly inaccurate.
3325 (macrolet ((frob (func trans op)
3326 `(define-vop (,func)
3328 (:args (x :scs (long-reg) :target fr0))
3329 (:temporary (:sc unsigned-reg :offset eax-offset
3330 :from :eval :to :result) eax)
3331 (:temporary (:sc long-reg :offset fr0-offset
3332 :from :argument :to :result) fr0)
3333 (:temporary (:sc long-reg :offset fr1-offset
3334 :from :argument :to :result) fr1)
3335 (:results (y :scs (long-reg)))
3336 (:arg-types long-float)
3337 (:result-types long-float)
3338 (:policy :fast-safe)
3339 (:note "inline sin/cos function")
3341 (:save-p :compute-only)
3344 (note-this-location vop :internal-error)
3345 (unless (zerop (tn-offset x))
3346 (inst fxch x) ; x to top of stack
3347 (unless (location= x y)
3348 (inst fst x))) ; maybe save it
3350 (inst fnstsw) ; status word to ax
3351 (inst and ah-tn #x04) ; C2
3353 ;; Else x was out of range so reduce it; ST0 is unchanged.
3354 (inst fstp fr1) ; Load 2*PI
3360 (inst fnstsw) ; status word to ax
3361 (inst and ah-tn #x04) ; C2
3365 (unless (zerop (tn-offset y))
3367 (frob fsin %sin fsin)
3368 (frob fcos %cos fcos))
3373 (:args (x :scs (long-reg) :target fr0))
3374 (:temporary (:sc unsigned-reg :offset eax-offset
3375 :from :argument :to :result) eax)
3376 (:temporary (:sc long-reg :offset fr0-offset
3377 :from :argument :to :result) fr0)
3378 (:temporary (:sc long-reg :offset fr1-offset
3379 :from :argument :to :result) fr1)
3380 (:results (y :scs (long-reg)))
3381 (:arg-types long-float)
3382 (:result-types long-float)
3383 (:policy :fast-safe)
3384 (:note "inline tan function")
3386 (:save-p :compute-only)
3389 (note-this-location vop :internal-error)
3398 (inst fldd (make-random-tn :kind :normal
3399 :sc (sc-or-lose 'double-reg)
3400 :offset (- (tn-offset x) 2)))))
3402 (inst fnstsw) ; status word to ax
3403 (inst and ah-tn #x04) ; C2
3405 ;; Else x was out of range so reduce it; ST0 is unchanged.
3406 (inst fldpi) ; Load 2*PI
3411 (inst fnstsw) ; status word to ax
3412 (inst and ah-tn #x04) ; C2
3426 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3427 ;;; the argument is out of range 2^63 and would thus be hopelessly
3429 (macrolet ((frob (func trans op)
3430 `(define-vop (,func)
3432 (:args (x :scs (long-reg) :target fr0))
3433 (:temporary (:sc long-reg :offset fr0-offset
3434 :from :argument :to :result) fr0)
3435 (:temporary (:sc unsigned-reg :offset eax-offset
3436 :from :argument :to :result) eax)
3437 (:results (y :scs (long-reg)))
3438 (:arg-types long-float)
3439 (:result-types long-float)
3440 (:policy :fast-safe)
3441 (:note "inline sin/cos function")
3443 (:save-p :compute-only)
3446 (note-this-location vop :internal-error)
3447 (unless (zerop (tn-offset x))
3448 (inst fxch x) ; x to top of stack
3449 (unless (location= x y)
3450 (inst fst x))) ; maybe save it
3452 (inst fnstsw) ; status word to ax
3453 (inst and ah-tn #x04) ; C2
3455 ;; Else x was out of range so reduce it; ST0 is unchanged.
3456 (inst fstp fr0) ; Load 0.0
3459 (unless (zerop (tn-offset y))
3461 (frob fsin %sin fsin)
3462 (frob fcos %cos fcos))
3466 (:args (x :scs (long-reg) :target fr0))
3467 (:temporary (:sc long-reg :offset fr0-offset
3468 :from :argument :to :result) fr0)
3469 (:temporary (:sc long-reg :offset fr1-offset
3470 :from :argument :to :result) fr1)
3471 (:temporary (:sc unsigned-reg :offset eax-offset
3472 :from :argument :to :result) eax)
3473 (:results (y :scs (long-reg)))
3474 (:arg-types long-float)
3475 (:result-types long-float)
3477 (:policy :fast-safe)
3478 (:note "inline tan function")
3480 (:save-p :compute-only)
3483 (note-this-location vop :internal-error)
3492 (inst fldd (make-random-tn :kind :normal
3493 :sc (sc-or-lose 'double-reg)
3494 :offset (- (tn-offset x) 2)))))
3496 (inst fnstsw) ; status word to ax
3497 (inst and ah-tn #x04) ; C2
3499 ;; Else x was out of range so reduce it; ST0 is unchanged.
3500 (inst fldz) ; Load 0.0
3512 ;;; Modified exp that handles the following special cases:
3513 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3516 (:args (x :scs (long-reg) :target fr0))
3517 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3518 (:temporary (:sc long-reg :offset fr0-offset
3519 :from :argument :to :result) fr0)
3520 (:temporary (:sc long-reg :offset fr1-offset
3521 :from :argument :to :result) fr1)
3522 (:temporary (:sc long-reg :offset fr2-offset
3523 :from :argument :to :result) fr2)
3524 (:results (y :scs (long-reg)))
3525 (:arg-types long-float)
3526 (:result-types long-float)
3527 (:policy :fast-safe)
3528 (:note "inline exp function")
3530 (:save-p :compute-only)
3533 (note-this-location vop :internal-error)
3534 (unless (zerop (tn-offset x))
3535 (inst fxch x) ; x to top of stack
3536 (unless (location= x y)
3537 (inst fst x))) ; maybe save it
3538 ;; Check for Inf or NaN
3542 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3543 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3544 (inst and ah-tn #x02) ; Test sign of Inf.
3545 (inst jmp :z DONE) ; +Inf gives +Inf.
3546 (inst fstp fr0) ; -Inf gives 0
3548 (inst jmp-short DONE)
3553 ;; Now fr0=x log2(e)
3557 (inst fsubp-sti fr1)
3560 (inst faddp-sti fr1)
3564 (unless (zerop (tn-offset y))
3567 ;;; Expm1 = exp(x) - 1.
3568 ;;; Handles the following special cases:
3569 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3570 (define-vop (fexpm1)
3572 (:args (x :scs (long-reg) :target fr0))
3573 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3574 (:temporary (:sc long-reg :offset fr0-offset
3575 :from :argument :to :result) fr0)
3576 (:temporary (:sc long-reg :offset fr1-offset
3577 :from :argument :to :result) fr1)
3578 (:temporary (:sc long-reg :offset fr2-offset
3579 :from :argument :to :result) fr2)
3580 (:results (y :scs (long-reg)))
3581 (:arg-types long-float)
3582 (:result-types long-float)
3583 (:policy :fast-safe)
3584 (:note "inline expm1 function")
3586 (:save-p :compute-only)
3589 (note-this-location vop :internal-error)
3590 (unless (zerop (tn-offset x))
3591 (inst fxch x) ; x to top of stack
3592 (unless (location= x y)
3593 (inst fst x))) ; maybe save it
3594 ;; Check for Inf or NaN
3598 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3599 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3600 (inst and ah-tn #x02) ; Test sign of Inf.
3601 (inst jmp :z DONE) ; +Inf gives +Inf.
3602 (inst fstp fr0) ; -Inf gives -1.0
3605 (inst jmp-short DONE)
3607 ;; Free two stack slots leaving the argument on top.
3611 (inst fmul fr1) ; Now fr0 = x log2(e)
3626 (unless (zerop (tn-offset y))
3631 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3632 (:temporary (:sc long-reg :offset fr0-offset
3633 :from :argument :to :result) fr0)
3634 (:temporary (:sc long-reg :offset fr1-offset
3635 :from :argument :to :result) fr1)
3636 (:results (y :scs (long-reg)))
3637 (:arg-types long-float)
3638 (:result-types long-float)
3639 (:policy :fast-safe)
3640 (:note "inline log function")
3642 (:save-p :compute-only)
3644 (note-this-location vop :internal-error)
3659 ;; x is in a FP reg, not fr0 or fr1
3663 (inst fldd (make-random-tn :kind :normal
3664 :sc (sc-or-lose 'double-reg)
3665 :offset (1- (tn-offset x))))))
3667 ((long-stack descriptor-reg)
3671 (if (sc-is x long-stack)
3672 (inst fldl (ea-for-lf-stack x))
3673 (inst fldl (ea-for-lf-desc x)))
3678 (t (inst fstd y)))))
3680 (define-vop (flog10)
3682 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3683 (:temporary (:sc long-reg :offset fr0-offset
3684 :from :argument :to :result) fr0)
3685 (:temporary (:sc long-reg :offset fr1-offset
3686 :from :argument :to :result) fr1)
3687 (:results (y :scs (long-reg)))
3688 (:arg-types long-float)
3689 (:result-types long-float)
3690 (:policy :fast-safe)
3691 (:note "inline log10 function")
3693 (:save-p :compute-only)
3695 (note-this-location vop :internal-error)
3710 ;; x is in a FP reg, not fr0 or fr1
3714 (inst fldd (make-random-tn :kind :normal
3715 :sc (sc-or-lose 'double-reg)
3716 :offset (1- (tn-offset x))))))
3718 ((long-stack descriptor-reg)
3722 (if (sc-is x long-stack)
3723 (inst fldl (ea-for-lf-stack x))
3724 (inst fldl (ea-for-lf-desc x)))
3729 (t (inst fstd y)))))
3733 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3734 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3735 (:temporary (:sc long-reg :offset fr0-offset
3736 :from (:argument 0) :to :result) fr0)
3737 (:temporary (:sc long-reg :offset fr1-offset
3738 :from (:argument 1) :to :result) fr1)
3739 (:temporary (:sc long-reg :offset fr2-offset
3740 :from :load :to :result) fr2)
3741 (:results (r :scs (long-reg)))
3742 (:arg-types long-float long-float)
3743 (:result-types long-float)
3744 (:policy :fast-safe)
3745 (:note "inline pow function")
3747 (:save-p :compute-only)
3749 (note-this-location vop :internal-error)
3750 ;; Setup x in fr0 and y in fr1
3752 ;; x in fr0; y in fr1
3753 ((and (sc-is x long-reg) (zerop (tn-offset x))
3754 (sc-is y long-reg) (= 1 (tn-offset y))))
3755 ;; y in fr1; x not in fr0
3756 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3760 (copy-fp-reg-to-fr0 x))
3763 (inst fldl (ea-for-lf-stack x)))
3766 (inst fldl (ea-for-lf-desc x)))))
3767 ;; x in fr0; y not in fr1
3768 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3770 ;; Now load y to fr0
3773 (copy-fp-reg-to-fr0 y))
3776 (inst fldl (ea-for-lf-stack y)))
3779 (inst fldl (ea-for-lf-desc y))))
3781 ;; x in fr1; y not in fr1
3782 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3786 (copy-fp-reg-to-fr0 y))
3789 (inst fldl (ea-for-lf-stack y)))
3792 (inst fldl (ea-for-lf-desc y))))
3795 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3797 ;; Now load x to fr0
3800 (copy-fp-reg-to-fr0 x))
3803 (inst fldl (ea-for-lf-stack x)))
3806 (inst fldl (ea-for-lf-desc x)))))
3807 ;; Neither x or y are in either fr0 or fr1
3814 (inst fldd (make-random-tn :kind :normal
3815 :sc (sc-or-lose 'double-reg)
3816 :offset (- (tn-offset y) 2))))
3818 (inst fldl (ea-for-lf-stack y)))
3820 (inst fldl (ea-for-lf-desc y))))
3824 (inst fldd (make-random-tn :kind :normal
3825 :sc (sc-or-lose 'double-reg)
3826 :offset (1- (tn-offset x)))))
3828 (inst fldl (ea-for-lf-stack x)))
3830 (inst fldl (ea-for-lf-desc x))))))
3832 ;; Now have x at fr0; and y at fr1
3834 ;; Now fr0=y log2(x)
3838 (inst fsubp-sti fr1)
3841 (inst faddp-sti fr1)
3846 (t (inst fstd r)))))
3848 (define-vop (fscalen)
3849 (:translate %scalbn)
3850 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3851 (y :scs (signed-stack signed-reg) :target temp))
3852 (:temporary (:sc long-reg :offset fr0-offset
3853 :from (:argument 0) :to :result) fr0)
3854 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3855 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3856 (:results (r :scs (long-reg)))
3857 (:arg-types long-float signed-num)
3858 (:result-types long-float)
3859 (:policy :fast-safe)
3860 (:note "inline scalbn function")
3862 ;; Setup x in fr0 and y in fr1
3893 (inst fld (make-random-tn :kind :normal
3894 :sc (sc-or-lose 'double-reg)
3895 :offset (1- (tn-offset x)))))))
3896 ((long-stack descriptor-reg)
3905 (if (sc-is x long-stack)
3906 (inst fldl (ea-for-lf-stack x))
3907 (inst fldl (ea-for-lf-desc x)))))
3909 (unless (zerop (tn-offset r))
3912 (define-vop (fscale)
3914 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3915 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3916 (:temporary (:sc long-reg :offset fr0-offset
3917 :from (:argument 0) :to :result) fr0)
3918 (:temporary (:sc long-reg :offset fr1-offset
3919 :from (:argument 1) :to :result) fr1)
3920 (:results (r :scs (long-reg)))
3921 (:arg-types long-float long-float)
3922 (:result-types long-float)
3923 (:policy :fast-safe)
3924 (:note "inline scalb function")
3926 (:save-p :compute-only)
3928 (note-this-location vop :internal-error)
3929 ;; Setup x in fr0 and y in fr1
3931 ;; x in fr0; y in fr1
3932 ((and (sc-is x long-reg) (zerop (tn-offset x))
3933 (sc-is y long-reg) (= 1 (tn-offset y))))
3934 ;; y in fr1; x not in fr0
3935 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3939 (copy-fp-reg-to-fr0 x))
3942 (inst fldl (ea-for-lf-stack x)))
3945 (inst fldl (ea-for-lf-desc x)))))
3946 ;; x in fr0; y not in fr1
3947 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3949 ;; Now load y to fr0
3952 (copy-fp-reg-to-fr0 y))
3955 (inst fldl (ea-for-lf-stack y)))
3958 (inst fldl (ea-for-lf-desc y))))
3960 ;; x in fr1; y not in fr1
3961 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3965 (copy-fp-reg-to-fr0 y))
3968 (inst fldl (ea-for-lf-stack y)))
3971 (inst fldl (ea-for-lf-desc y))))
3974 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3976 ;; Now load x to fr0
3979 (copy-fp-reg-to-fr0 x))
3982 (inst fldl (ea-for-lf-stack x)))
3985 (inst fldl (ea-for-lf-desc x)))))
3986 ;; Neither x or y are in either fr0 or fr1
3993 (inst fldd (make-random-tn :kind :normal
3994 :sc (sc-or-lose 'double-reg)
3995 :offset (- (tn-offset y) 2))))
3997 (inst fldl (ea-for-lf-stack y)))
3999 (inst fldl (ea-for-lf-desc y))))
4003 (inst fldd (make-random-tn :kind :normal
4004 :sc (sc-or-lose 'double-reg)
4005 :offset (1- (tn-offset x)))))
4007 (inst fldl (ea-for-lf-stack x)))
4009 (inst fldl (ea-for-lf-desc x))))))
4011 ;; Now have x at fr0; and y at fr1
4013 (unless (zerop (tn-offset r))
4016 (define-vop (flog1p)
4018 (:args (x :scs (long-reg) :to :result))
4019 (:temporary (:sc long-reg :offset fr0-offset
4020 :from :argument :to :result) fr0)
4021 (:temporary (:sc long-reg :offset fr1-offset
4022 :from :argument :to :result) fr1)
4023 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
4024 (:results (y :scs (long-reg)))
4025 (:arg-types long-float)
4026 (:result-types long-float)
4027 (:policy :fast-safe)
4028 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
4029 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
4030 ;; an enormous PROGN above. Still, it would be probably be good to
4031 ;; add some code to warn about redefining VOPs.
4032 ;; FIXME 2: See comments on DEFINE-VOP FLOG1P :GUARD above.
4033 (:guard #!+pentium nil #!-pentium t)
4034 (:note "inline log1p function")
4037 ;; x is in a FP reg, not fr0, fr1.
4040 (inst fldd (make-random-tn :kind :normal
4041 :sc (sc-or-lose 'double-reg)
4042 :offset (- (tn-offset x) 2)))
4044 (inst push #x3e947ae1) ; Constant 0.29
4046 (inst fld (make-ea :dword :base esp-tn))
4049 (inst fnstsw) ; status word to ax
4050 (inst and ah-tn #x45)
4051 (inst jmp :z WITHIN-RANGE)
4052 ;; Out of range for fyl2xp1.
4054 (inst faddd (make-random-tn :kind :normal
4055 :sc (sc-or-lose 'double-reg)
4056 :offset (- (tn-offset x) 1)))
4064 (inst fldd (make-random-tn :kind :normal
4065 :sc (sc-or-lose 'double-reg)
4066 :offset (- (tn-offset x) 1)))
4072 (t (inst fstd y)))))
4074 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4075 ;;; instruction and a range check can be avoided.
4076 (define-vop (flog1p-pentium)
4078 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4079 (:temporary (:sc long-reg :offset fr0-offset
4080 :from :argument :to :result) fr0)
4081 (:temporary (:sc long-reg :offset fr1-offset
4082 :from :argument :to :result) fr1)
4083 (:results (y :scs (long-reg)))
4084 (:arg-types long-float)
4085 (:result-types long-float)
4086 (:policy :fast-safe)
4087 ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
4088 (:guard #!+pentium t #!-pentium)
4089 (:note "inline log1p function")
4105 ;; x is in a FP reg, not fr0 or fr1
4109 (inst fldd (make-random-tn :kind :normal
4110 :sc (sc-or-lose 'double-reg)
4111 :offset (1- (tn-offset x)))))))
4112 ((long-stack descriptor-reg)
4116 (if (sc-is x long-stack)
4117 (inst fldl (ea-for-lf-stack x))
4118 (inst fldl (ea-for-lf-desc x)))))
4123 (t (inst fstd y)))))
4127 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4128 (:temporary (:sc long-reg :offset fr0-offset
4129 :from :argument :to :result) fr0)
4130 (:temporary (:sc long-reg :offset fr1-offset
4131 :from :argument :to :result) fr1)
4132 (:results (y :scs (long-reg)))
4133 (:arg-types long-float)
4134 (:result-types long-float)
4135 (:policy :fast-safe)
4136 (:note "inline logb function")
4138 (:save-p :compute-only)
4140 (note-this-location vop :internal-error)
4151 ;; x is in a FP reg, not fr0 or fr1
4154 (inst fldd (make-random-tn :kind :normal
4155 :sc (sc-or-lose 'double-reg)
4156 :offset (- (tn-offset x) 2))))))
4157 ((long-stack descriptor-reg)
4160 (if (sc-is x long-stack)
4161 (inst fldl (ea-for-lf-stack x))
4162 (inst fldl (ea-for-lf-desc x)))))
4173 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4174 (:temporary (:sc long-reg :offset fr0-offset
4175 :from (:argument 0) :to :result) fr0)
4176 (:temporary (:sc long-reg :offset fr1-offset
4177 :from (:argument 0) :to :result) fr1)
4178 (:results (r :scs (long-reg)))
4179 (:arg-types long-float)
4180 (:result-types long-float)
4181 (:policy :fast-safe)
4182 (:note "inline atan function")
4184 (:save-p :compute-only)
4186 (note-this-location vop :internal-error)
4187 ;; Setup x in fr1 and 1.0 in fr0
4190 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4193 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4195 ;; x not in fr0 or fr1
4202 (inst fldd (make-random-tn :kind :normal
4203 :sc (sc-or-lose 'double-reg)
4204 :offset (- (tn-offset x) 2))))
4206 (inst fldl (ea-for-lf-stack x)))
4208 (inst fldl (ea-for-lf-desc x))))))
4210 ;; Now have x at fr1; and 1.0 at fr0
4215 (t (inst fstd r)))))
4217 (define-vop (fatan2)
4219 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4220 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4221 (:temporary (:sc long-reg :offset fr0-offset
4222 :from (:argument 1) :to :result) fr0)
4223 (:temporary (:sc long-reg :offset fr1-offset
4224 :from (:argument 0) :to :result) fr1)
4225 (:results (r :scs (long-reg)))
4226 (:arg-types long-float long-float)
4227 (:result-types long-float)
4228 (:policy :fast-safe)
4229 (:note "inline atan2 function")
4231 (:save-p :compute-only)
4233 (note-this-location vop :internal-error)
4234 ;; Setup x in fr1 and y in fr0
4236 ;; y in fr0; x in fr1
4237 ((and (sc-is y long-reg) (zerop (tn-offset y))
4238 (sc-is x long-reg) (= 1 (tn-offset x))))
4239 ;; x in fr1; y not in fr0
4240 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4244 (copy-fp-reg-to-fr0 y))
4247 (inst fldl (ea-for-lf-stack y)))
4250 (inst fldl (ea-for-lf-desc y)))))
4251 ;; y in fr0; x not in fr1
4252 ((and (sc-is y long-reg) (zerop (tn-offset y)))
4254 ;; Now load x to fr0
4257 (copy-fp-reg-to-fr0 x))
4260 (inst fldl (ea-for-lf-stack x)))
4263 (inst fldl (ea-for-lf-desc x))))
4265 ;; y in fr1; x not in fr1
4266 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4270 (copy-fp-reg-to-fr0 x))
4273 (inst fldl (ea-for-lf-stack x)))
4276 (inst fldl (ea-for-lf-desc x))))
4279 ((and (sc-is x long-reg) (zerop (tn-offset x)))
4281 ;; Now load y to fr0
4284 (copy-fp-reg-to-fr0 y))
4287 (inst fldl (ea-for-lf-stack y)))
4290 (inst fldl (ea-for-lf-desc y)))))
4291 ;; Neither y or x are in either fr0 or fr1
4298 (inst fldd (make-random-tn :kind :normal
4299 :sc (sc-or-lose 'double-reg)
4300 :offset (- (tn-offset x) 2))))
4302 (inst fldl (ea-for-lf-stack x)))
4304 (inst fldl (ea-for-lf-desc x))))
4308 (inst fldd (make-random-tn :kind :normal
4309 :sc (sc-or-lose 'double-reg)
4310 :offset (1- (tn-offset y)))))
4312 (inst fldl (ea-for-lf-stack y)))
4314 (inst fldl (ea-for-lf-desc y))))))
4316 ;; Now have y at fr0; and x at fr1
4321 (t (inst fstd r)))))
4323 ) ; progn #!+long-float
4326 ;;;; Complex float VOPs
4328 (define-vop (make-complex-single-float)
4329 (:translate complex)
4330 (:args (real :scs (single-reg) :to :result :target r
4331 :load-if (not (location= real r)))
4332 (imag :scs (single-reg) :to :save))
4333 (:arg-types single-float single-float)
4334 (:results (r :scs (complex-single-reg) :from (:argument 0)
4335 :load-if (not (sc-is r complex-single-stack))))
4336 (:result-types complex-single-float)
4337 (:note "inline complex single-float creation")
4338 (:policy :fast-safe)
4342 (let ((r-real (complex-double-reg-real-tn r)))
4343 (unless (location= real r-real)
4344 (cond ((zerop (tn-offset r-real))
4345 (copy-fp-reg-to-fr0 real))
4346 ((zerop (tn-offset real))
4351 (inst fxch real)))))
4352 (let ((r-imag (complex-double-reg-imag-tn r)))
4353 (unless (location= imag r-imag)
4354 (cond ((zerop (tn-offset imag))
4359 (inst fxch imag))))))
4360 (complex-single-stack
4361 (unless (location= real r)
4362 (cond ((zerop (tn-offset real))
4363 (inst fst (ea-for-csf-real-stack r)))
4366 (inst fst (ea-for-csf-real-stack r))
4369 (inst fst (ea-for-csf-imag-stack r))
4370 (inst fxch imag)))))
4372 (define-vop (make-complex-double-float)
4373 (:translate complex)
4374 (:args (real :scs (double-reg) :target r
4375 :load-if (not (location= real r)))
4376 (imag :scs (double-reg) :to :save))
4377 (:arg-types double-float double-float)
4378 (:results (r :scs (complex-double-reg) :from (:argument 0)
4379 :load-if (not (sc-is r complex-double-stack))))
4380 (:result-types complex-double-float)
4381 (:note "inline complex double-float creation")
4382 (:policy :fast-safe)
4386 (let ((r-real (complex-double-reg-real-tn r)))
4387 (unless (location= real r-real)
4388 (cond ((zerop (tn-offset r-real))
4389 (copy-fp-reg-to-fr0 real))
4390 ((zerop (tn-offset real))
4395 (inst fxch real)))))
4396 (let ((r-imag (complex-double-reg-imag-tn r)))
4397 (unless (location= imag r-imag)
4398 (cond ((zerop (tn-offset imag))
4403 (inst fxch imag))))))
4404 (complex-double-stack
4405 (unless (location= real r)
4406 (cond ((zerop (tn-offset real))
4407 (inst fstd (ea-for-cdf-real-stack r)))
4410 (inst fstd (ea-for-cdf-real-stack r))
4413 (inst fstd (ea-for-cdf-imag-stack r))
4414 (inst fxch imag)))))
4417 (define-vop (make-complex-long-float)
4418 (:translate complex)
4419 (:args (real :scs (long-reg) :target r
4420 :load-if (not (location= real r)))
4421 (imag :scs (long-reg) :to :save))
4422 (:arg-types long-float long-float)
4423 (:results (r :scs (complex-long-reg) :from (:argument 0)
4424 :load-if (not (sc-is r complex-long-stack))))
4425 (:result-types complex-long-float)
4426 (:note "inline complex long-float creation")
4427 (:policy :fast-safe)
4431 (let ((r-real (complex-double-reg-real-tn r)))
4432 (unless (location= real r-real)
4433 (cond ((zerop (tn-offset r-real))
4434 (copy-fp-reg-to-fr0 real))
4435 ((zerop (tn-offset real))
4440 (inst fxch real)))))
4441 (let ((r-imag (complex-double-reg-imag-tn r)))
4442 (unless (location= imag r-imag)
4443 (cond ((zerop (tn-offset imag))
4448 (inst fxch imag))))))
4450 (unless (location= real r)
4451 (cond ((zerop (tn-offset real))
4452 (store-long-float (ea-for-clf-real-stack r)))
4455 (store-long-float (ea-for-clf-real-stack r))
4458 (store-long-float (ea-for-clf-imag-stack r))
4459 (inst fxch imag)))))
4462 (define-vop (complex-float-value)
4463 (:args (x :target r))
4465 (:variant-vars offset)
4466 (:policy :fast-safe)
4468 (cond ((sc-is x complex-single-reg complex-double-reg
4469 #!+long-float complex-long-reg)
4471 (make-random-tn :kind :normal
4472 :sc (sc-or-lose 'double-reg)
4473 :offset (+ offset (tn-offset x)))))
4474 (unless (location= value-tn r)
4475 (cond ((zerop (tn-offset r))
4476 (copy-fp-reg-to-fr0 value-tn))
4477 ((zerop (tn-offset value-tn))
4480 (inst fxch value-tn)
4482 (inst fxch value-tn))))))
4483 ((sc-is r single-reg)
4484 (let ((ea (sc-case x
4485 (complex-single-stack
4487 (0 (ea-for-csf-real-stack x))
4488 (1 (ea-for-csf-imag-stack x))))
4491 (0 (ea-for-csf-real-desc x))
4492 (1 (ea-for-csf-imag-desc x)))))))
4493 (with-empty-tn@fp-top(r)
4495 ((sc-is r double-reg)
4496 (let ((ea (sc-case x
4497 (complex-double-stack
4499 (0 (ea-for-cdf-real-stack x))
4500 (1 (ea-for-cdf-imag-stack x))))
4503 (0 (ea-for-cdf-real-desc x))
4504 (1 (ea-for-cdf-imag-desc x)))))))
4505 (with-empty-tn@fp-top(r)
4509 (let ((ea (sc-case x
4512 (0 (ea-for-clf-real-stack x))
4513 (1 (ea-for-clf-imag-stack x))))
4516 (0 (ea-for-clf-real-desc x))
4517 (1 (ea-for-clf-imag-desc x)))))))
4518 (with-empty-tn@fp-top(r)
4520 (t (error "Complex-float-value VOP failure")))))
4522 (define-vop (realpart/complex-single-float complex-float-value)
4523 (:translate realpart)
4524 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4526 (:arg-types complex-single-float)
4527 (:results (r :scs (single-reg)))
4528 (:result-types single-float)
4529 (:note "complex float realpart")
4532 (define-vop (realpart/complex-double-float complex-float-value)
4533 (:translate realpart)
4534 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4536 (:arg-types complex-double-float)
4537 (:results (r :scs (double-reg)))
4538 (:result-types double-float)
4539 (:note "complex float realpart")
4543 (define-vop (realpart/complex-long-float complex-float-value)
4544 (:translate realpart)
4545 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4547 (:arg-types complex-long-float)
4548 (:results (r :scs (long-reg)))
4549 (:result-types long-float)
4550 (:note "complex float realpart")
4553 (define-vop (imagpart/complex-single-float complex-float-value)
4554 (:translate imagpart)
4555 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4557 (:arg-types complex-single-float)
4558 (:results (r :scs (single-reg)))
4559 (:result-types single-float)
4560 (:note "complex float imagpart")
4563 (define-vop (imagpart/complex-double-float complex-float-value)
4564 (:translate imagpart)
4565 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4567 (:arg-types complex-double-float)
4568 (:results (r :scs (double-reg)))
4569 (:result-types double-float)
4570 (:note "complex float imagpart")
4574 (define-vop (imagpart/complex-long-float complex-float-value)
4575 (:translate imagpart)
4576 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4578 (:arg-types complex-long-float)
4579 (:results (r :scs (long-reg)))
4580 (:result-types long-float)
4581 (:note "complex float imagpart")
4585 ;;; A hack dummy VOP to bias the representation selection of its
4586 ;;; argument towards a FP register which can help avoid consing at
4587 ;;; inappropriate locations.
4589 (defknown double-float-reg-bias (double-float) (values))
4590 (define-vop (double-float-reg-bias)
4591 (:translate double-float-reg-bias)
4592 (:args (x :scs (double-reg double-stack) :load-if nil))
4593 (:arg-types double-float)
4594 (:policy :fast-safe)
4595 (:note "inline dummy FP register bias")
4599 (defknown single-float-reg-bias (single-float) (values))
4600 (define-vop (single-float-reg-bias)
4601 (:translate single-float-reg-bias)
4602 (:args (x :scs (single-reg single-stack) :load-if nil))
4603 (:arg-types single-float)
4604 (:policy :fast-safe)
4605 (:note "inline dummy FP register bias")