1 ;;;; floating point support for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (macrolet ((ea-for-xf-desc (tn slot)
15 `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag)))
16 (defun ea-for-sf-desc (tn)
17 (ea-for-xf-desc tn single-float-value-slot))
18 (defun ea-for-df-desc (tn)
19 (ea-for-xf-desc tn double-float-value-slot))
21 (defun ea-for-lf-desc (tn)
22 (ea-for-xf-desc tn long-float-value-slot))
24 (defun ea-for-csf-real-desc (tn)
25 (ea-for-xf-desc tn complex-single-float-real-slot))
26 (defun ea-for-csf-imag-desc (tn)
27 (ea-for-xf-desc tn complex-single-float-imag-slot))
28 (defun ea-for-cdf-real-desc (tn)
29 (ea-for-xf-desc tn complex-double-float-real-slot))
30 (defun ea-for-cdf-imag-desc (tn)
31 (ea-for-xf-desc tn complex-double-float-imag-slot))
33 (defun ea-for-clf-real-desc (tn)
34 (ea-for-xf-desc tn complex-long-float-real-slot))
36 (defun ea-for-clf-imag-desc (tn)
37 (ea-for-xf-desc tn complex-long-float-imag-slot)))
39 (macrolet ((ea-for-xf-stack (tn kind)
42 :disp (frame-byte-offset
44 (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
45 (defun ea-for-sf-stack (tn)
46 (ea-for-xf-stack tn :single))
47 (defun ea-for-df-stack (tn)
48 (ea-for-xf-stack tn :double))
50 (defun ea-for-lf-stack (tn)
51 (ea-for-xf-stack tn :long)))
53 ;;; Telling the FPU to wait is required in order to make signals occur
54 ;;; at the expected place, but naturally slows things down.
56 ;;; NODE is the node whose compilation policy controls the decision
57 ;;; whether to just blast through carelessly or carefully emit wait
58 ;;; instructions and whatnot.
60 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
61 ;;; #'NOTE-NEXT-INSTRUCTION.
63 ;;; Until 2004-03-15, the implementation of this was buggy; it
64 ;;; unconditionally emitted the WAIT instruction. It turns out that
65 ;;; this is the right thing to do anyway; omitting them can lead to
66 ;;; system corruption on conforming code. -- CSR
67 (defun maybe-fp-wait (node &optional note-next-instruction)
68 (declare (ignore node))
70 (when (policy node (or (= debug 3) (> safety speed))))
71 (when note-next-instruction
72 (note-next-instruction note-next-instruction :internal-error))
75 ;;; complex float stack EAs
76 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
79 :disp (frame-byte-offset
86 (ecase ,slot (:real 1) (:imag 2))))))))
87 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
88 (ea-for-cxf-stack tn :single :real base))
89 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
90 (ea-for-cxf-stack tn :single :imag base))
91 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
92 (ea-for-cxf-stack tn :double :real base))
93 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
94 (ea-for-cxf-stack tn :double :imag base))
96 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
97 (ea-for-cxf-stack tn :long :real base))
99 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
100 (ea-for-cxf-stack tn :long :imag base)))
102 ;;; Abstract out the copying of a FP register to the FP stack top, and
103 ;;; provide two alternatives for its implementation. Note: it's not
104 ;;; necessary to distinguish between a single or double register move
107 ;;; Using a Pop then load.
108 (defun copy-fp-reg-to-fr0 (reg)
109 (aver (not (zerop (tn-offset reg))))
111 (inst fld (make-random-tn :kind :normal
112 :sc (sc-or-lose 'double-reg)
113 :offset (1- (tn-offset reg)))))
114 ;;; Using Fxch then Fst to restore the original reg contents.
116 (defun copy-fp-reg-to-fr0 (reg)
117 (aver (not (zerop (tn-offset reg))))
121 ;;; The x86 can't store a long-float to memory without popping the
122 ;;; stack and marking a register as empty, so it is necessary to
123 ;;; restore the register from memory.
125 (defun store-long-float (ea)
131 ;;; X is source, Y is destination.
132 (define-move-fun (load-single 2) (vop x y)
133 ((single-stack) (single-reg))
134 (with-empty-tn@fp-top(y)
135 (inst fld (ea-for-sf-stack x))))
137 (define-move-fun (store-single 2) (vop x y)
138 ((single-reg) (single-stack))
139 (cond ((zerop (tn-offset x))
140 (inst fst (ea-for-sf-stack y)))
143 (inst fst (ea-for-sf-stack y))
144 ;; This may not be necessary as ST0 is likely invalid now.
147 (define-move-fun (load-double 2) (vop x y)
148 ((double-stack) (double-reg))
149 (with-empty-tn@fp-top(y)
150 (inst fldd (ea-for-df-stack x))))
152 (define-move-fun (store-double 2) (vop x y)
153 ((double-reg) (double-stack))
154 (cond ((zerop (tn-offset x))
155 (inst fstd (ea-for-df-stack y)))
158 (inst fstd (ea-for-df-stack y))
159 ;; This may not be necessary as ST0 is likely invalid now.
163 (define-move-fun (load-long 2) (vop x y)
164 ((long-stack) (long-reg))
165 (with-empty-tn@fp-top(y)
166 (inst fldl (ea-for-lf-stack x))))
169 (define-move-fun (store-long 2) (vop x y)
170 ((long-reg) (long-stack))
171 (cond ((zerop (tn-offset x))
172 (store-long-float (ea-for-lf-stack y)))
175 (store-long-float (ea-for-lf-stack y))
176 ;; This may not be necessary as ST0 is likely invalid now.
179 ;;; The i387 has instructions to load some useful constants. This
180 ;;; doesn't save much time but might cut down on memory access and
181 ;;; reduce the size of the constant vector (CV). Intel claims they are
182 ;;; stored in a more precise form on chip. Anyhow, might as well use
183 ;;; the feature. It can be turned off by hacking the
184 ;;; "immediate-constant-sc" in vm.lisp.
185 (eval-when (:compile-toplevel :execute)
186 (setf *read-default-float-format*
187 #!+long-float 'long-float #!-long-float 'double-float))
188 (define-move-fun (load-fp-constant 2) (vop x y)
189 ((fp-constant) (single-reg double-reg #!+long-float long-reg))
190 (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
191 (with-empty-tn@fp-top(y)
196 ((= value (coerce pi *read-default-float-format*))
198 ((= value (log 10e0 2e0))
200 ((= value (log 2.718281828459045235360287471352662e0 2e0))
202 ((= value (log 2e0 10e0))
204 ((= value (log 2e0 2.718281828459045235360287471352662e0))
206 (t (warn "ignoring bogus i387 constant ~A" value))))))
207 (eval-when (:compile-toplevel :execute)
208 (setf *read-default-float-format* 'single-float))
210 ;;;; complex float move functions
212 (defun complex-single-reg-real-tn (x)
213 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
214 :offset (tn-offset x)))
215 (defun complex-single-reg-imag-tn (x)
216 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
217 :offset (1+ (tn-offset x))))
219 (defun complex-double-reg-real-tn (x)
220 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
221 :offset (tn-offset x)))
222 (defun complex-double-reg-imag-tn (x)
223 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
224 :offset (1+ (tn-offset x))))
227 (defun complex-long-reg-real-tn (x)
228 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
229 :offset (tn-offset x)))
231 (defun complex-long-reg-imag-tn (x)
232 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
233 :offset (1+ (tn-offset x))))
235 ;;; X is source, Y is destination.
236 (define-move-fun (load-complex-single 2) (vop x y)
237 ((complex-single-stack) (complex-single-reg))
238 (let ((real-tn (complex-single-reg-real-tn y)))
239 (with-empty-tn@fp-top (real-tn)
240 (inst fld (ea-for-csf-real-stack x))))
241 (let ((imag-tn (complex-single-reg-imag-tn y)))
242 (with-empty-tn@fp-top (imag-tn)
243 (inst fld (ea-for-csf-imag-stack x)))))
245 (define-move-fun (store-complex-single 2) (vop x y)
246 ((complex-single-reg) (complex-single-stack))
247 (let ((real-tn (complex-single-reg-real-tn x)))
248 (cond ((zerop (tn-offset real-tn))
249 (inst fst (ea-for-csf-real-stack y)))
252 (inst fst (ea-for-csf-real-stack y))
253 (inst fxch real-tn))))
254 (let ((imag-tn (complex-single-reg-imag-tn x)))
256 (inst fst (ea-for-csf-imag-stack y))
257 (inst fxch imag-tn)))
259 (define-move-fun (load-complex-double 2) (vop x y)
260 ((complex-double-stack) (complex-double-reg))
261 (let ((real-tn (complex-double-reg-real-tn y)))
262 (with-empty-tn@fp-top(real-tn)
263 (inst fldd (ea-for-cdf-real-stack x))))
264 (let ((imag-tn (complex-double-reg-imag-tn y)))
265 (with-empty-tn@fp-top(imag-tn)
266 (inst fldd (ea-for-cdf-imag-stack x)))))
268 (define-move-fun (store-complex-double 2) (vop x y)
269 ((complex-double-reg) (complex-double-stack))
270 (let ((real-tn (complex-double-reg-real-tn x)))
271 (cond ((zerop (tn-offset real-tn))
272 (inst fstd (ea-for-cdf-real-stack y)))
275 (inst fstd (ea-for-cdf-real-stack y))
276 (inst fxch real-tn))))
277 (let ((imag-tn (complex-double-reg-imag-tn x)))
279 (inst fstd (ea-for-cdf-imag-stack y))
280 (inst fxch imag-tn)))
283 (define-move-fun (load-complex-long 2) (vop x y)
284 ((complex-long-stack) (complex-long-reg))
285 (let ((real-tn (complex-long-reg-real-tn y)))
286 (with-empty-tn@fp-top(real-tn)
287 (inst fldl (ea-for-clf-real-stack x))))
288 (let ((imag-tn (complex-long-reg-imag-tn y)))
289 (with-empty-tn@fp-top(imag-tn)
290 (inst fldl (ea-for-clf-imag-stack x)))))
293 (define-move-fun (store-complex-long 2) (vop x y)
294 ((complex-long-reg) (complex-long-stack))
295 (let ((real-tn (complex-long-reg-real-tn x)))
296 (cond ((zerop (tn-offset real-tn))
297 (store-long-float (ea-for-clf-real-stack y)))
300 (store-long-float (ea-for-clf-real-stack y))
301 (inst fxch real-tn))))
302 (let ((imag-tn (complex-long-reg-imag-tn x)))
304 (store-long-float (ea-for-clf-imag-stack y))
305 (inst fxch imag-tn)))
310 ;;; float register to register moves
311 (define-vop (float-move)
316 (unless (location= x y)
317 (cond ((zerop (tn-offset y))
318 (copy-fp-reg-to-fr0 x))
319 ((zerop (tn-offset x))
326 (define-vop (single-move float-move)
327 (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
328 (:results (y :scs (single-reg) :load-if (not (location= x y)))))
329 (define-move-vop single-move :move (single-reg) (single-reg))
331 (define-vop (double-move float-move)
332 (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
333 (:results (y :scs (double-reg) :load-if (not (location= x y)))))
334 (define-move-vop double-move :move (double-reg) (double-reg))
337 (define-vop (long-move float-move)
338 (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
339 (:results (y :scs (long-reg) :load-if (not (location= x y)))))
341 (define-move-vop long-move :move (long-reg) (long-reg))
343 ;;; complex float register to register moves
344 (define-vop (complex-float-move)
345 (:args (x :target y :load-if (not (location= x y))))
346 (:results (y :load-if (not (location= x y))))
347 (:note "complex float move")
349 (unless (location= x y)
350 ;; Note the complex-float-regs are aligned to every second
351 ;; float register so there is not need to worry about overlap.
352 (let ((x-real (complex-double-reg-real-tn x))
353 (y-real (complex-double-reg-real-tn y)))
354 (cond ((zerop (tn-offset y-real))
355 (copy-fp-reg-to-fr0 x-real))
356 ((zerop (tn-offset x-real))
361 (inst fxch x-real))))
362 (let ((x-imag (complex-double-reg-imag-tn x))
363 (y-imag (complex-double-reg-imag-tn y)))
366 (inst fxch x-imag)))))
368 (define-vop (complex-single-move complex-float-move)
369 (:args (x :scs (complex-single-reg) :target y
370 :load-if (not (location= x y))))
371 (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
372 (define-move-vop complex-single-move :move
373 (complex-single-reg) (complex-single-reg))
375 (define-vop (complex-double-move complex-float-move)
376 (:args (x :scs (complex-double-reg)
377 :target y :load-if (not (location= x y))))
378 (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
379 (define-move-vop complex-double-move :move
380 (complex-double-reg) (complex-double-reg))
383 (define-vop (complex-long-move complex-float-move)
384 (:args (x :scs (complex-long-reg)
385 :target y :load-if (not (location= x y))))
386 (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
388 (define-move-vop complex-long-move :move
389 (complex-long-reg) (complex-long-reg))
391 ;;; Move from float to a descriptor reg. allocating a new float
392 ;;; object in the process.
393 (define-vop (move-from-single)
394 (:args (x :scs (single-reg) :to :save))
395 (:results (y :scs (descriptor-reg)))
397 (:note "float to pointer coercion")
399 (with-fixed-allocation (y
401 single-float-size node)
403 (inst fst (ea-for-sf-desc y))))))
404 (define-move-vop move-from-single :move
405 (single-reg) (descriptor-reg))
407 (define-vop (move-from-double)
408 (:args (x :scs (double-reg) :to :save))
409 (:results (y :scs (descriptor-reg)))
411 (:note "float to pointer coercion")
413 (with-fixed-allocation (y
418 (inst fstd (ea-for-df-desc y))))))
419 (define-move-vop move-from-double :move
420 (double-reg) (descriptor-reg))
423 (define-vop (move-from-long)
424 (:args (x :scs (long-reg) :to :save))
425 (:results (y :scs (descriptor-reg)))
427 (:note "float to pointer coercion")
429 (with-fixed-allocation (y
434 (store-long-float (ea-for-lf-desc y))))))
436 (define-move-vop move-from-long :move
437 (long-reg) (descriptor-reg))
439 (define-vop (move-from-fp-constant)
440 (:args (x :scs (fp-constant)))
441 (:results (y :scs (descriptor-reg)))
443 (ecase (sb!c::constant-value (sb!c::tn-leaf x))
444 (0f0 (load-symbol-value y *fp-constant-0f0*))
445 (1f0 (load-symbol-value y *fp-constant-1f0*))
446 (0d0 (load-symbol-value y *fp-constant-0d0*))
447 (1d0 (load-symbol-value y *fp-constant-1d0*))
449 (0l0 (load-symbol-value y *fp-constant-0l0*))
451 (1l0 (load-symbol-value y *fp-constant-1l0*))
453 (#.pi (load-symbol-value y *fp-constant-pi*))
455 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
457 (#.(log 2.718281828459045235360287471352662L0 2l0)
458 (load-symbol-value y *fp-constant-l2e*))
460 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
462 (#.(log 2l0 2.718281828459045235360287471352662L0)
463 (load-symbol-value y *fp-constant-ln2*)))))
464 (define-move-vop move-from-fp-constant :move
465 (fp-constant) (descriptor-reg))
467 ;;; Move from a descriptor to a float register.
468 (define-vop (move-to-single)
469 (:args (x :scs (descriptor-reg)))
470 (:results (y :scs (single-reg)))
471 (:note "pointer to float coercion")
473 (with-empty-tn@fp-top(y)
474 (inst fld (ea-for-sf-desc x)))))
475 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
477 (define-vop (move-to-double)
478 (:args (x :scs (descriptor-reg)))
479 (:results (y :scs (double-reg)))
480 (:note "pointer to float coercion")
482 (with-empty-tn@fp-top(y)
483 (inst fldd (ea-for-df-desc x)))))
484 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
487 (define-vop (move-to-long)
488 (:args (x :scs (descriptor-reg)))
489 (:results (y :scs (long-reg)))
490 (:note "pointer to float coercion")
492 (with-empty-tn@fp-top(y)
493 (inst fldl (ea-for-lf-desc x)))))
495 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
497 ;;; Move from complex float to a descriptor reg. allocating a new
498 ;;; complex float object in the process.
499 (define-vop (move-from-complex-single)
500 (:args (x :scs (complex-single-reg) :to :save))
501 (:results (y :scs (descriptor-reg)))
503 (:note "complex float to pointer coercion")
505 (with-fixed-allocation (y
506 complex-single-float-widetag
507 complex-single-float-size
509 (let ((real-tn (complex-single-reg-real-tn x)))
510 (with-tn@fp-top(real-tn)
511 (inst fst (ea-for-csf-real-desc y))))
512 (let ((imag-tn (complex-single-reg-imag-tn x)))
513 (with-tn@fp-top(imag-tn)
514 (inst fst (ea-for-csf-imag-desc y)))))))
515 (define-move-vop move-from-complex-single :move
516 (complex-single-reg) (descriptor-reg))
518 (define-vop (move-from-complex-double)
519 (:args (x :scs (complex-double-reg) :to :save))
520 (:results (y :scs (descriptor-reg)))
522 (:note "complex float to pointer coercion")
524 (with-fixed-allocation (y
525 complex-double-float-widetag
526 complex-double-float-size
528 (let ((real-tn (complex-double-reg-real-tn x)))
529 (with-tn@fp-top(real-tn)
530 (inst fstd (ea-for-cdf-real-desc y))))
531 (let ((imag-tn (complex-double-reg-imag-tn x)))
532 (with-tn@fp-top(imag-tn)
533 (inst fstd (ea-for-cdf-imag-desc y)))))))
534 (define-move-vop move-from-complex-double :move
535 (complex-double-reg) (descriptor-reg))
538 (define-vop (move-from-complex-long)
539 (:args (x :scs (complex-long-reg) :to :save))
540 (:results (y :scs (descriptor-reg)))
542 (:note "complex float to pointer coercion")
544 (with-fixed-allocation (y
545 complex-long-float-widetag
546 complex-long-float-size
548 (let ((real-tn (complex-long-reg-real-tn x)))
549 (with-tn@fp-top(real-tn)
550 (store-long-float (ea-for-clf-real-desc y))))
551 (let ((imag-tn (complex-long-reg-imag-tn x)))
552 (with-tn@fp-top(imag-tn)
553 (store-long-float (ea-for-clf-imag-desc y)))))))
555 (define-move-vop move-from-complex-long :move
556 (complex-long-reg) (descriptor-reg))
558 ;;; Move from a descriptor to a complex float register.
559 (macrolet ((frob (name sc format)
562 (:args (x :scs (descriptor-reg)))
563 (:results (y :scs (,sc)))
564 (:note "pointer to complex float coercion")
566 (let ((real-tn (complex-double-reg-real-tn y)))
567 (with-empty-tn@fp-top(real-tn)
569 (:single '((inst fld (ea-for-csf-real-desc x))))
570 (:double '((inst fldd (ea-for-cdf-real-desc x))))
572 (:long '((inst fldl (ea-for-clf-real-desc x)))))))
573 (let ((imag-tn (complex-double-reg-imag-tn y)))
574 (with-empty-tn@fp-top(imag-tn)
576 (:single '((inst fld (ea-for-csf-imag-desc x))))
577 (:double '((inst fldd (ea-for-cdf-imag-desc x))))
579 (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
580 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
581 (frob move-to-complex-single complex-single-reg :single)
582 (frob move-to-complex-double complex-double-reg :double)
584 (frob move-to-complex-double complex-long-reg :long))
586 ;;;; the move argument vops
588 ;;;; Note these are also used to stuff fp numbers onto the c-call
589 ;;;; stack so the order is different than the lisp-stack.
591 ;;; the general MOVE-ARG VOP
592 (macrolet ((frob (name sc stack-sc format)
595 (:args (x :scs (,sc) :target y)
597 :load-if (not (sc-is y ,sc))))
599 (:note "float argument move")
600 (:generator ,(case format (:single 2) (:double 3) (:long 4))
603 (unless (location= x y)
604 (cond ((zerop (tn-offset y))
605 (copy-fp-reg-to-fr0 x))
606 ((zerop (tn-offset x))
613 (if (= (tn-offset fp) esp-offset)
615 (let* ((offset (* (tn-offset y) n-word-bytes))
616 (ea (make-ea :dword :base fp :disp offset)))
619 (:single '((inst fst ea)))
620 (:double '((inst fstd ea)))
622 (:long '((store-long-float ea))))))
626 :disp (frame-byte-offset
634 (:single '((inst fst ea)))
635 (:double '((inst fstd ea)))
637 (:long '((store-long-float ea)))))))))))
638 (define-move-vop ,name :move-arg
639 (,sc descriptor-reg) (,sc)))))
640 (frob move-single-float-arg single-reg single-stack :single)
641 (frob move-double-float-arg double-reg double-stack :double)
643 (frob move-long-float-arg long-reg long-stack :long))
645 ;;;; complex float MOVE-ARG VOP
646 (macrolet ((frob (name sc stack-sc format)
649 (:args (x :scs (,sc) :target y)
651 :load-if (not (sc-is y ,sc))))
653 (:note "complex float argument move")
654 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
657 (unless (location= x y)
658 (let ((x-real (complex-double-reg-real-tn x))
659 (y-real (complex-double-reg-real-tn y)))
660 (cond ((zerop (tn-offset y-real))
661 (copy-fp-reg-to-fr0 x-real))
662 ((zerop (tn-offset x-real))
667 (inst fxch x-real))))
668 (let ((x-imag (complex-double-reg-imag-tn x))
669 (y-imag (complex-double-reg-imag-tn y)))
672 (inst fxch x-imag))))
674 (let ((real-tn (complex-double-reg-real-tn x)))
675 (cond ((zerop (tn-offset real-tn))
679 (ea-for-csf-real-stack y fp))))
682 (ea-for-cdf-real-stack y fp))))
686 (ea-for-clf-real-stack y fp))))))
692 (ea-for-csf-real-stack y fp))))
695 (ea-for-cdf-real-stack y fp))))
699 (ea-for-clf-real-stack y fp)))))
700 (inst fxch real-tn))))
701 (let ((imag-tn (complex-double-reg-imag-tn x)))
705 '((inst fst (ea-for-csf-imag-stack y fp))))
707 '((inst fstd (ea-for-cdf-imag-stack y fp))))
711 (ea-for-clf-imag-stack y fp)))))
712 (inst fxch imag-tn))))))
713 (define-move-vop ,name :move-arg
714 (,sc descriptor-reg) (,sc)))))
715 (frob move-complex-single-float-arg
716 complex-single-reg complex-single-stack :single)
717 (frob move-complex-double-float-arg
718 complex-double-reg complex-double-stack :double)
720 (frob move-complex-long-float-arg
721 complex-long-reg complex-long-stack :long))
723 (define-move-vop move-arg :move-arg
724 (single-reg double-reg #!+long-float long-reg
725 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
731 ;;; dtc: the floating point arithmetic vops
733 ;;; Note: Although these can accept x and y on the stack or pointed to
734 ;;; from a descriptor register, they will work with register loading
735 ;;; without these. Same deal with the result - it need only be a
736 ;;; register. When load-tns are needed they will probably be in ST0
737 ;;; and the code below should be able to correctly handle all cases.
739 ;;; However it seems to produce better code if all arg. and result
740 ;;; options are used; on the P86 there is no extra cost in using a
741 ;;; memory operand to the FP instructions - not so on the PPro.
743 ;;; It may also be useful to handle constant args?
745 ;;; 22-Jul-97: descriptor args lose in some simple cases when
746 ;;; a function result computed in a loop. Then Python insists
747 ;;; on consing the intermediate values! For example
750 ;;; (declare (type (simple-array double-float (*)) a)
753 ;;; (declare (type double-float sum))
755 ;;; (incf sum (* (aref a i)(aref a i))))
758 ;;; So, disabling descriptor args until this can be fixed elsewhere.
760 ((frob (op fop-sti fopr-sti
762 fopd foprd dname dcost
764 #!-long-float (declare (ignore lcost lname))
768 (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
770 (y :scs (single-reg single-stack #+nil descriptor-reg)
772 (:temporary (:sc single-reg :offset fr0-offset
773 :from :eval :to :result) fr0)
774 (:results (r :scs (single-reg single-stack)))
775 (:arg-types single-float single-float)
776 (:result-types single-float)
778 (:note "inline float arithmetic")
780 (:save-p :compute-only)
783 ;; Handle a few special cases
785 ;; x, y, and r are the same register.
786 ((and (sc-is x single-reg) (location= x r) (location= y r))
787 (cond ((zerop (tn-offset r))
792 ;; XX the source register will not be valid.
793 (note-next-instruction vop :internal-error)
796 ;; x and r are the same register.
797 ((and (sc-is x single-reg) (location= x r))
798 (cond ((zerop (tn-offset r))
801 ;; ST(0) = ST(0) op ST(y)
804 ;; ST(0) = ST(0) op Mem
805 (inst ,fop (ea-for-sf-stack y)))
807 (inst ,fop (ea-for-sf-desc y)))))
812 (unless (zerop (tn-offset y))
813 (copy-fp-reg-to-fr0 y)))
814 ((single-stack descriptor-reg)
816 (if (sc-is y single-stack)
817 (inst fld (ea-for-sf-stack y))
818 (inst fld (ea-for-sf-desc y)))))
819 ;; ST(i) = ST(i) op ST0
821 (maybe-fp-wait node vop))
822 ;; y and r are the same register.
823 ((and (sc-is y single-reg) (location= y r))
824 (cond ((zerop (tn-offset r))
827 ;; ST(0) = ST(x) op ST(0)
830 ;; ST(0) = Mem op ST(0)
831 (inst ,fopr (ea-for-sf-stack x)))
833 (inst ,fopr (ea-for-sf-desc x)))))
838 (unless (zerop (tn-offset x))
839 (copy-fp-reg-to-fr0 x)))
840 ((single-stack descriptor-reg)
842 (if (sc-is x single-stack)
843 (inst fld (ea-for-sf-stack x))
844 (inst fld (ea-for-sf-desc x)))))
845 ;; ST(i) = ST(0) op ST(i)
847 (maybe-fp-wait node vop))
850 ;; Get the result to ST0.
852 ;; Special handling is needed if x or y are in ST0, and
853 ;; simpler code is generated.
856 ((and (sc-is x single-reg) (zerop (tn-offset x)))
862 (inst ,fop (ea-for-sf-stack y)))
864 (inst ,fop (ea-for-sf-desc y)))))
866 ((and (sc-is y single-reg) (zerop (tn-offset y)))
872 (inst ,fopr (ea-for-sf-stack x)))
874 (inst ,fopr (ea-for-sf-desc x)))))
879 (copy-fp-reg-to-fr0 x))
882 (inst fld (ea-for-sf-stack x)))
885 (inst fld (ea-for-sf-desc x))))
891 (inst ,fop (ea-for-sf-stack y)))
893 (inst ,fop (ea-for-sf-desc y))))))
895 (note-next-instruction vop :internal-error)
897 ;; Finally save the result.
900 (cond ((zerop (tn-offset r))
901 (maybe-fp-wait node))
905 (inst fst (ea-for-sf-stack r))))))))
909 (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
911 (y :scs (double-reg double-stack #+nil descriptor-reg)
913 (:temporary (:sc double-reg :offset fr0-offset
914 :from :eval :to :result) fr0)
915 (:results (r :scs (double-reg double-stack)))
916 (:arg-types double-float double-float)
917 (:result-types double-float)
919 (:note "inline float arithmetic")
921 (:save-p :compute-only)
924 ;; Handle a few special cases.
926 ;; x, y, and r are the same register.
927 ((and (sc-is x double-reg) (location= x r) (location= y r))
928 (cond ((zerop (tn-offset r))
933 ;; XX the source register will not be valid.
934 (note-next-instruction vop :internal-error)
937 ;; x and r are the same register.
938 ((and (sc-is x double-reg) (location= x r))
939 (cond ((zerop (tn-offset r))
942 ;; ST(0) = ST(0) op ST(y)
945 ;; ST(0) = ST(0) op Mem
946 (inst ,fopd (ea-for-df-stack y)))
948 (inst ,fopd (ea-for-df-desc y)))))
953 (unless (zerop (tn-offset y))
954 (copy-fp-reg-to-fr0 y)))
955 ((double-stack descriptor-reg)
957 (if (sc-is y double-stack)
958 (inst fldd (ea-for-df-stack y))
959 (inst fldd (ea-for-df-desc y)))))
960 ;; ST(i) = ST(i) op ST0
962 (maybe-fp-wait node vop))
963 ;; y and r are the same register.
964 ((and (sc-is y double-reg) (location= y r))
965 (cond ((zerop (tn-offset r))
968 ;; ST(0) = ST(x) op ST(0)
971 ;; ST(0) = Mem op ST(0)
972 (inst ,foprd (ea-for-df-stack x)))
974 (inst ,foprd (ea-for-df-desc x)))))
979 (unless (zerop (tn-offset x))
980 (copy-fp-reg-to-fr0 x)))
981 ((double-stack descriptor-reg)
983 (if (sc-is x double-stack)
984 (inst fldd (ea-for-df-stack x))
985 (inst fldd (ea-for-df-desc x)))))
986 ;; ST(i) = ST(0) op ST(i)
988 (maybe-fp-wait node vop))
991 ;; Get the result to ST0.
993 ;; Special handling is needed if x or y are in ST0, and
994 ;; simpler code is generated.
997 ((and (sc-is x double-reg) (zerop (tn-offset x)))
1003 (inst ,fopd (ea-for-df-stack y)))
1005 (inst ,fopd (ea-for-df-desc y)))))
1007 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1013 (inst ,foprd (ea-for-df-stack x)))
1015 (inst ,foprd (ea-for-df-desc x)))))
1020 (copy-fp-reg-to-fr0 x))
1023 (inst fldd (ea-for-df-stack x)))
1026 (inst fldd (ea-for-df-desc x))))
1032 (inst ,fopd (ea-for-df-stack y)))
1034 (inst ,fopd (ea-for-df-desc y))))))
1036 (note-next-instruction vop :internal-error)
1038 ;; Finally save the result.
1041 (cond ((zerop (tn-offset r))
1042 (maybe-fp-wait node))
1046 (inst fstd (ea-for-df-stack r))))))))
1049 (define-vop (,lname)
1051 (:args (x :scs (long-reg) :to :eval)
1052 (y :scs (long-reg) :to :eval))
1053 (:temporary (:sc long-reg :offset fr0-offset
1054 :from :eval :to :result) fr0)
1055 (:results (r :scs (long-reg)))
1056 (:arg-types long-float long-float)
1057 (:result-types long-float)
1058 (:policy :fast-safe)
1059 (:note "inline float arithmetic")
1061 (:save-p :compute-only)
1064 ;; Handle a few special cases.
1066 ;; x, y, and r are the same register.
1067 ((and (location= x r) (location= y r))
1068 (cond ((zerop (tn-offset r))
1073 ;; XX the source register will not be valid.
1074 (note-next-instruction vop :internal-error)
1077 ;; x and r are the same register.
1079 (cond ((zerop (tn-offset r))
1080 ;; ST(0) = ST(0) op ST(y)
1084 (unless (zerop (tn-offset y))
1085 (copy-fp-reg-to-fr0 y))
1086 ;; ST(i) = ST(i) op ST0
1088 (maybe-fp-wait node vop))
1089 ;; y and r are the same register.
1091 (cond ((zerop (tn-offset r))
1092 ;; ST(0) = ST(x) op ST(0)
1096 (unless (zerop (tn-offset x))
1097 (copy-fp-reg-to-fr0 x))
1098 ;; ST(i) = ST(0) op ST(i)
1099 (inst ,fopr-sti r)))
1100 (maybe-fp-wait node vop))
1103 ;; Get the result to ST0.
1105 ;; Special handling is needed if x or y are in ST0, and
1106 ;; simpler code is generated.
1109 ((zerop (tn-offset x))
1113 ((zerop (tn-offset y))
1118 (copy-fp-reg-to-fr0 x)
1122 (note-next-instruction vop :internal-error)
1124 ;; Finally save the result.
1125 (cond ((zerop (tn-offset r))
1126 (maybe-fp-wait node))
1128 (inst fst r))))))))))
1130 (frob + fadd-sti fadd-sti
1131 fadd fadd +/single-float 2
1132 faddd faddd +/double-float 2
1134 (frob - fsub-sti fsubr-sti
1135 fsub fsubr -/single-float 2
1136 fsubd fsubrd -/double-float 2
1138 (frob * fmul-sti fmul-sti
1139 fmul fmul */single-float 3
1140 fmuld fmuld */double-float 3
1142 (frob / fdiv-sti fdivr-sti
1143 fdiv fdivr //single-float 12
1144 fdivd fdivrd //double-float 12
1147 (macrolet ((frob (name inst translate sc type)
1148 `(define-vop (,name)
1149 (:args (x :scs (,sc) :target fr0))
1150 (:results (y :scs (,sc)))
1151 (:translate ,translate)
1152 (:policy :fast-safe)
1154 (:result-types ,type)
1155 (:temporary (:sc double-reg :offset fr0-offset
1156 :from :argument :to :result) fr0)
1158 (:note "inline float arithmetic")
1160 (:save-p :compute-only)
1162 (note-this-location vop :internal-error)
1163 (unless (zerop (tn-offset x))
1164 (inst fxch x) ; x to top of stack
1165 (unless (location= x y)
1166 (inst fst x))) ; Maybe save it.
1167 (inst ,inst) ; Clobber st0.
1168 (unless (zerop (tn-offset y))
1171 (frob abs/single-float fabs abs single-reg single-float)
1172 (frob abs/double-float fabs abs double-reg double-float)
1174 (frob abs/long-float fabs abs long-reg long-float)
1175 (frob %negate/single-float fchs %negate single-reg single-float)
1176 (frob %negate/double-float fchs %negate double-reg double-float)
1178 (frob %negate/long-float fchs %negate long-reg long-float))
1182 (define-vop (=/float)
1184 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1186 (:info target not-p)
1187 (:policy :fast-safe)
1189 (:save-p :compute-only)
1190 (:note "inline float comparison")
1193 (note-this-location vop :internal-error)
1195 ;; x is in ST0; y is in any reg.
1196 ((zerop (tn-offset x))
1198 ;; y is in ST0; x is in another reg.
1199 ((zerop (tn-offset y))
1201 ;; x and y are the same register, not ST0
1206 ;; x and y are different registers, neither ST0.
1211 (inst fnstsw) ; status word to ax
1212 (inst and ah-tn #x45) ; C3 C2 C0
1213 (inst cmp ah-tn #x40)
1214 (inst jmp (if not-p :ne :e) target)))
1216 (define-vop (=/single-float =/float)
1218 (:args (x :scs (single-reg))
1219 (y :scs (single-reg)))
1220 (:arg-types single-float single-float))
1222 (define-vop (=/double-float =/float)
1224 (:args (x :scs (double-reg))
1225 (y :scs (double-reg)))
1226 (:arg-types double-float double-float))
1229 (define-vop (=/long-float =/float)
1231 (:args (x :scs (long-reg))
1232 (y :scs (long-reg)))
1233 (:arg-types long-float long-float))
1235 (define-vop (<single-float)
1237 (:args (x :scs (single-reg single-stack descriptor-reg))
1238 (y :scs (single-reg single-stack descriptor-reg)))
1239 (:arg-types single-float single-float)
1240 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1241 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1243 (:info target not-p)
1244 (:policy :fast-safe)
1245 (:note "inline float comparison")
1248 ;; Handle a few special cases.
1251 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1255 ((single-stack descriptor-reg)
1256 (if (sc-is x single-stack)
1257 (inst fcom (ea-for-sf-stack x))
1258 (inst fcom (ea-for-sf-desc x)))))
1259 (inst fnstsw) ; status word to ax
1260 (inst and ah-tn #x45))
1262 ;; general case when y is not in ST0
1267 (unless (zerop (tn-offset x))
1268 (copy-fp-reg-to-fr0 x)))
1269 ((single-stack descriptor-reg)
1271 (if (sc-is x single-stack)
1272 (inst fld (ea-for-sf-stack x))
1273 (inst fld (ea-for-sf-desc x)))))
1277 ((single-stack descriptor-reg)
1278 (if (sc-is y single-stack)
1279 (inst fcom (ea-for-sf-stack y))
1280 (inst fcom (ea-for-sf-desc y)))))
1281 (inst fnstsw) ; status word to ax
1282 (inst and ah-tn #x45) ; C3 C2 C0
1283 (inst cmp ah-tn #x01)))
1284 (inst jmp (if not-p :ne :e) target)))
1286 (define-vop (<double-float)
1288 (:args (x :scs (double-reg double-stack descriptor-reg))
1289 (y :scs (double-reg double-stack descriptor-reg)))
1290 (:arg-types double-float double-float)
1291 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1292 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1294 (:info target not-p)
1295 (:policy :fast-safe)
1296 (:note "inline float comparison")
1299 ;; Handle a few special cases
1302 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1306 ((double-stack descriptor-reg)
1307 (if (sc-is x double-stack)
1308 (inst fcomd (ea-for-df-stack x))
1309 (inst fcomd (ea-for-df-desc x)))))
1310 (inst fnstsw) ; status word to ax
1311 (inst and ah-tn #x45))
1313 ;; General case when y is not in ST0.
1318 (unless (zerop (tn-offset x))
1319 (copy-fp-reg-to-fr0 x)))
1320 ((double-stack descriptor-reg)
1322 (if (sc-is x double-stack)
1323 (inst fldd (ea-for-df-stack x))
1324 (inst fldd (ea-for-df-desc x)))))
1328 ((double-stack descriptor-reg)
1329 (if (sc-is y double-stack)
1330 (inst fcomd (ea-for-df-stack y))
1331 (inst fcomd (ea-for-df-desc y)))))
1332 (inst fnstsw) ; status word to ax
1333 (inst and ah-tn #x45) ; C3 C2 C0
1334 (inst cmp ah-tn #x01)))
1335 (inst jmp (if not-p :ne :e) target)))
1338 (define-vop (<long-float)
1340 (:args (x :scs (long-reg))
1341 (y :scs (long-reg)))
1342 (:arg-types long-float long-float)
1343 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1345 (:info target not-p)
1346 (:policy :fast-safe)
1347 (:note "inline float comparison")
1351 ;; x is in ST0; y is in any reg.
1352 ((zerop (tn-offset x))
1354 (inst fnstsw) ; status word to ax
1355 (inst and ah-tn #x45) ; C3 C2 C0
1356 (inst cmp ah-tn #x01))
1357 ;; y is in ST0; x is in another reg.
1358 ((zerop (tn-offset y))
1360 (inst fnstsw) ; status word to ax
1361 (inst and ah-tn #x45))
1362 ;; x and y are the same register, not ST0
1363 ;; x and y are different registers, neither ST0.
1368 (inst fnstsw) ; status word to ax
1369 (inst and ah-tn #x45))) ; C3 C2 C0
1370 (inst jmp (if not-p :ne :e) target)))
1372 (define-vop (>single-float)
1374 (:args (x :scs (single-reg single-stack descriptor-reg))
1375 (y :scs (single-reg single-stack descriptor-reg)))
1376 (:arg-types single-float single-float)
1377 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1378 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1380 (:info target not-p)
1381 (:policy :fast-safe)
1382 (:note "inline float comparison")
1385 ;; Handle a few special cases.
1388 ((and (sc-is y single-reg) (zerop (tn-offset y)))
1392 ((single-stack descriptor-reg)
1393 (if (sc-is x single-stack)
1394 (inst fcom (ea-for-sf-stack x))
1395 (inst fcom (ea-for-sf-desc x)))))
1396 (inst fnstsw) ; status word to ax
1397 (inst and ah-tn #x45)
1398 (inst cmp ah-tn #x01))
1400 ;; general case when y is not in ST0
1405 (unless (zerop (tn-offset x))
1406 (copy-fp-reg-to-fr0 x)))
1407 ((single-stack descriptor-reg)
1409 (if (sc-is x single-stack)
1410 (inst fld (ea-for-sf-stack x))
1411 (inst fld (ea-for-sf-desc x)))))
1415 ((single-stack descriptor-reg)
1416 (if (sc-is y single-stack)
1417 (inst fcom (ea-for-sf-stack y))
1418 (inst fcom (ea-for-sf-desc y)))))
1419 (inst fnstsw) ; status word to ax
1420 (inst and ah-tn #x45)))
1421 (inst jmp (if not-p :ne :e) target)))
1423 (define-vop (>double-float)
1425 (:args (x :scs (double-reg double-stack descriptor-reg))
1426 (y :scs (double-reg double-stack descriptor-reg)))
1427 (:arg-types double-float double-float)
1428 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1429 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1431 (:info target not-p)
1432 (:policy :fast-safe)
1433 (:note "inline float comparison")
1436 ;; Handle a few special cases.
1439 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1443 ((double-stack descriptor-reg)
1444 (if (sc-is x double-stack)
1445 (inst fcomd (ea-for-df-stack x))
1446 (inst fcomd (ea-for-df-desc x)))))
1447 (inst fnstsw) ; status word to ax
1448 (inst and ah-tn #x45)
1449 (inst cmp ah-tn #x01))
1451 ;; general case when y is not in ST0
1456 (unless (zerop (tn-offset x))
1457 (copy-fp-reg-to-fr0 x)))
1458 ((double-stack descriptor-reg)
1460 (if (sc-is x double-stack)
1461 (inst fldd (ea-for-df-stack x))
1462 (inst fldd (ea-for-df-desc x)))))
1466 ((double-stack descriptor-reg)
1467 (if (sc-is y double-stack)
1468 (inst fcomd (ea-for-df-stack y))
1469 (inst fcomd (ea-for-df-desc y)))))
1470 (inst fnstsw) ; status word to ax
1471 (inst and ah-tn #x45)))
1472 (inst jmp (if not-p :ne :e) target)))
1475 (define-vop (>long-float)
1477 (:args (x :scs (long-reg))
1478 (y :scs (long-reg)))
1479 (:arg-types long-float long-float)
1480 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1482 (:info target not-p)
1483 (:policy :fast-safe)
1484 (:note "inline float comparison")
1488 ;; y is in ST0; x is in any reg.
1489 ((zerop (tn-offset y))
1491 (inst fnstsw) ; status word to ax
1492 (inst and ah-tn #x45)
1493 (inst cmp ah-tn #x01))
1494 ;; x is in ST0; y is in another reg.
1495 ((zerop (tn-offset x))
1497 (inst fnstsw) ; status word to ax
1498 (inst and ah-tn #x45))
1499 ;; y and x are the same register, not ST0
1500 ;; y and x are different registers, neither ST0.
1505 (inst fnstsw) ; status word to ax
1506 (inst and ah-tn #x45)))
1507 (inst jmp (if not-p :ne :e) target)))
1509 ;;; Comparisons with 0 can use the FTST instruction.
1511 (define-vop (float-test)
1513 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1515 (:info target not-p y)
1516 (:variant-vars code)
1517 (:policy :fast-safe)
1519 (:save-p :compute-only)
1520 (:note "inline float comparison")
1523 (note-this-location vop :internal-error)
1526 ((zerop (tn-offset x))
1533 (inst fnstsw) ; status word to ax
1534 (inst and ah-tn #x45) ; C3 C2 C0
1535 (unless (zerop code)
1536 (inst cmp ah-tn code))
1537 (inst jmp (if not-p :ne :e) target)))
1539 (define-vop (=0/single-float float-test)
1541 (:args (x :scs (single-reg)))
1542 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1544 (define-vop (=0/double-float float-test)
1546 (:args (x :scs (double-reg)))
1547 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1550 (define-vop (=0/long-float float-test)
1552 (:args (x :scs (long-reg)))
1553 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1556 (define-vop (<0/single-float float-test)
1558 (:args (x :scs (single-reg)))
1559 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1561 (define-vop (<0/double-float float-test)
1563 (:args (x :scs (double-reg)))
1564 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1567 (define-vop (<0/long-float float-test)
1569 (:args (x :scs (long-reg)))
1570 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1573 (define-vop (>0/single-float float-test)
1575 (:args (x :scs (single-reg)))
1576 (:arg-types single-float (:constant (single-float 0f0 0f0)))
1578 (define-vop (>0/double-float float-test)
1580 (:args (x :scs (double-reg)))
1581 (:arg-types double-float (:constant (double-float 0d0 0d0)))
1584 (define-vop (>0/long-float float-test)
1586 (:args (x :scs (long-reg)))
1587 (:arg-types long-float (:constant (long-float 0l0 0l0)))
1591 (deftransform eql ((x y) (long-float long-float))
1592 `(and (= (long-float-low-bits x) (long-float-low-bits y))
1593 (= (long-float-high-bits x) (long-float-high-bits y))
1594 (= (long-float-exp-bits x) (long-float-exp-bits y))))
1598 (macrolet ((frob (name translate to-sc to-type)
1599 `(define-vop (,name)
1600 (:args (x :scs (signed-stack signed-reg) :target temp))
1601 (:temporary (:sc signed-stack) temp)
1602 (:results (y :scs (,to-sc)))
1603 (:arg-types signed-num)
1604 (:result-types ,to-type)
1605 (:policy :fast-safe)
1606 (:note "inline float coercion")
1607 (:translate ,translate)
1609 (:save-p :compute-only)
1614 (with-empty-tn@fp-top(y)
1615 (note-this-location vop :internal-error)
1618 (with-empty-tn@fp-top(y)
1619 (note-this-location vop :internal-error)
1620 (inst fild x))))))))
1621 (frob %single-float/signed %single-float single-reg single-float)
1622 (frob %double-float/signed %double-float double-reg double-float)
1624 (frob %long-float/signed %long-float long-reg long-float))
1626 (macrolet ((frob (name translate to-sc to-type)
1627 `(define-vop (,name)
1628 (:args (x :scs (unsigned-reg)))
1629 (:results (y :scs (,to-sc)))
1630 (:arg-types unsigned-num)
1631 (:result-types ,to-type)
1632 (:policy :fast-safe)
1633 (:note "inline float coercion")
1634 (:translate ,translate)
1636 (:save-p :compute-only)
1640 (with-empty-tn@fp-top(y)
1641 (note-this-location vop :internal-error)
1642 (inst fildl (make-ea :dword :base esp-tn)))
1643 (inst add esp-tn 8)))))
1644 (frob %single-float/unsigned %single-float single-reg single-float)
1645 (frob %double-float/unsigned %double-float double-reg double-float)
1647 (frob %long-float/unsigned %long-float long-reg long-float))
1649 ;;; These should be no-ops but the compiler might want to move some
1651 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1652 `(define-vop (,name)
1653 (:args (x :scs (,from-sc) :target y))
1654 (:results (y :scs (,to-sc)))
1655 (:arg-types ,from-type)
1656 (:result-types ,to-type)
1657 (:policy :fast-safe)
1658 (:note "inline float coercion")
1659 (:translate ,translate)
1661 (:save-p :compute-only)
1663 (note-this-location vop :internal-error)
1664 (unless (location= x y)
1666 ((zerop (tn-offset x))
1667 ;; x is in ST0, y is in another reg. not ST0
1669 ((zerop (tn-offset y))
1670 ;; y is in ST0, x is in another reg. not ST0
1671 (copy-fp-reg-to-fr0 x))
1673 ;; Neither x or y are in ST0, and they are not in
1677 (inst fxch x))))))))
1679 (frob %single-float/double-float %single-float double-reg
1680 double-float single-reg single-float)
1682 (frob %single-float/long-float %single-float long-reg
1683 long-float single-reg single-float)
1684 (frob %double-float/single-float %double-float single-reg single-float
1685 double-reg double-float)
1687 (frob %double-float/long-float %double-float long-reg long-float
1688 double-reg double-float)
1690 (frob %long-float/single-float %long-float single-reg single-float
1691 long-reg long-float)
1693 (frob %long-float/double-float %long-float double-reg double-float
1694 long-reg long-float))
1696 (macrolet ((frob (trans from-sc from-type round-p)
1697 `(define-vop (,(symbolicate trans "/" from-type))
1698 (:args (x :scs (,from-sc)))
1699 (:temporary (:sc signed-stack) stack-temp)
1701 '((:temporary (:sc unsigned-stack) scw)
1702 (:temporary (:sc any-reg) rcw)))
1703 (:results (y :scs (signed-reg)))
1704 (:arg-types ,from-type)
1705 (:result-types signed-num)
1707 (:policy :fast-safe)
1708 (:note "inline float truncate")
1710 (:save-p :compute-only)
1713 '((note-this-location vop :internal-error)
1714 ;; Catch any pending FPE exceptions.
1716 (,(if round-p 'progn 'pseudo-atomic)
1717 ;; Normal mode (for now) is "round to best".
1720 '((inst fnstcw scw) ; save current control word
1721 (move rcw scw) ; into 16-bit register
1722 (inst or rcw (ash #b11 10)) ; CHOP
1723 (move stack-temp rcw)
1724 (inst fldcw stack-temp)))
1729 (inst fist stack-temp)
1730 (inst mov y stack-temp)))
1732 '((inst fldcw scw)))))))))
1733 (frob %unary-truncate single-reg single-float nil)
1734 (frob %unary-truncate double-reg double-float nil)
1736 (frob %unary-truncate long-reg long-float nil)
1737 (frob %unary-round single-reg single-float t)
1738 (frob %unary-round double-reg double-float t)
1740 (frob %unary-round long-reg long-float t))
1742 (macrolet ((frob (trans from-sc from-type round-p)
1743 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1744 (:args (x :scs (,from-sc) :target fr0))
1745 (:temporary (:sc double-reg :offset fr0-offset
1746 :from :argument :to :result) fr0)
1748 '((:temporary (:sc unsigned-stack) stack-temp)
1749 (:temporary (:sc unsigned-stack) scw)
1750 (:temporary (:sc any-reg) rcw)))
1751 (:results (y :scs (unsigned-reg)))
1752 (:arg-types ,from-type)
1753 (:result-types unsigned-num)
1755 (:policy :fast-safe)
1756 (:note "inline float truncate")
1758 (:save-p :compute-only)
1761 '((note-this-location vop :internal-error)
1762 ;; Catch any pending FPE exceptions.
1764 ;; Normal mode (for now) is "round to best".
1765 (unless (zerop (tn-offset x))
1766 (copy-fp-reg-to-fr0 x))
1768 '((inst fnstcw scw) ; save current control word
1769 (move rcw scw) ; into 16-bit register
1770 (inst or rcw (ash #b11 10)) ; CHOP
1771 (move stack-temp rcw)
1772 (inst fldcw stack-temp)))
1774 (inst fistpl (make-ea :dword :base esp-tn))
1776 (inst fld fr0) ; copy fr0 to at least restore stack.
1779 '((inst fldcw scw)))))))
1780 (frob %unary-truncate single-reg single-float nil)
1781 (frob %unary-truncate double-reg double-float nil)
1783 (frob %unary-truncate long-reg long-float nil)
1784 (frob %unary-round single-reg single-float t)
1785 (frob %unary-round double-reg double-float t)
1787 (frob %unary-round long-reg long-float t))
1789 (define-vop (make-single-float)
1790 (:args (bits :scs (signed-reg) :target res
1791 :load-if (not (or (and (sc-is bits signed-stack)
1792 (sc-is res single-reg))
1793 (and (sc-is bits signed-stack)
1794 (sc-is res single-stack)
1795 (location= bits res))))))
1796 (:results (res :scs (single-reg single-stack)))
1797 (:temporary (:sc signed-stack) stack-temp)
1798 (:arg-types signed-num)
1799 (:result-types single-float)
1800 (:translate make-single-float)
1801 (:policy :fast-safe)
1808 (inst mov res bits))
1810 (aver (location= bits res)))))
1814 ;; source must be in memory
1815 (inst mov stack-temp bits)
1816 (with-empty-tn@fp-top(res)
1817 (inst fld stack-temp)))
1819 (with-empty-tn@fp-top(res)
1820 (inst fld bits))))))))
1822 (define-vop (make-double-float)
1823 (:args (hi-bits :scs (signed-reg))
1824 (lo-bits :scs (unsigned-reg)))
1825 (:results (res :scs (double-reg)))
1826 (:temporary (:sc double-stack) temp)
1827 (:arg-types signed-num unsigned-num)
1828 (:result-types double-float)
1829 (:translate make-double-float)
1830 (:policy :fast-safe)
1833 (let ((offset (tn-offset temp)))
1834 (storew hi-bits ebp-tn (frame-word-offset offset))
1835 (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
1836 (with-empty-tn@fp-top(res)
1837 (inst fldd (make-ea :dword :base ebp-tn
1838 :disp (frame-byte-offset (1+ offset))))))))
1841 (define-vop (make-long-float)
1842 (:args (exp-bits :scs (signed-reg))
1843 (hi-bits :scs (unsigned-reg))
1844 (lo-bits :scs (unsigned-reg)))
1845 (:results (res :scs (long-reg)))
1846 (:temporary (:sc long-stack) temp)
1847 (:arg-types signed-num unsigned-num unsigned-num)
1848 (:result-types long-float)
1849 (:translate make-long-float)
1850 (:policy :fast-safe)
1853 (let ((offset (tn-offset temp)))
1854 (storew exp-bits ebp-tn (frame-word-offset offset))
1855 (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
1856 (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
1857 (with-empty-tn@fp-top(res)
1858 (inst fldl (make-ea :dword :base ebp-tn
1859 :disp (frame-byte-offset (+ offset 2))))))))
1861 (define-vop (single-float-bits)
1862 (:args (float :scs (single-reg descriptor-reg)
1863 :load-if (not (sc-is float single-stack))))
1864 (:results (bits :scs (signed-reg)))
1865 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1866 (:arg-types single-float)
1867 (:result-types signed-num)
1868 (:translate single-float-bits)
1869 (:policy :fast-safe)
1876 (with-tn@fp-top(float)
1877 (inst fst stack-temp)
1878 (inst mov bits stack-temp)))
1880 (inst mov bits float))
1883 bits float single-float-value-slot
1884 other-pointer-lowtag))))
1888 (with-tn@fp-top(float)
1889 (inst fst bits))))))))
1891 (define-vop (double-float-high-bits)
1892 (:args (float :scs (double-reg descriptor-reg)
1893 :load-if (not (sc-is float double-stack))))
1894 (:results (hi-bits :scs (signed-reg)))
1895 (:temporary (:sc double-stack) temp)
1896 (:arg-types double-float)
1897 (:result-types signed-num)
1898 (:translate double-float-high-bits)
1899 (:policy :fast-safe)
1904 (with-tn@fp-top(float)
1905 (let ((where (make-ea :dword :base ebp-tn
1906 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1908 (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
1910 (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
1912 (loadw hi-bits float (1+ double-float-value-slot)
1913 other-pointer-lowtag)))))
1915 (define-vop (double-float-low-bits)
1916 (:args (float :scs (double-reg descriptor-reg)
1917 :load-if (not (sc-is float double-stack))))
1918 (:results (lo-bits :scs (unsigned-reg)))
1919 (:temporary (:sc double-stack) temp)
1920 (:arg-types double-float)
1921 (:result-types unsigned-num)
1922 (:translate double-float-low-bits)
1923 (:policy :fast-safe)
1928 (with-tn@fp-top(float)
1929 (let ((where (make-ea :dword :base ebp-tn
1930 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1932 (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1934 (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
1936 (loadw lo-bits float double-float-value-slot
1937 other-pointer-lowtag)))))
1940 (define-vop (long-float-exp-bits)
1941 (:args (float :scs (long-reg descriptor-reg)
1942 :load-if (not (sc-is float long-stack))))
1943 (:results (exp-bits :scs (signed-reg)))
1944 (:temporary (:sc long-stack) temp)
1945 (:arg-types long-float)
1946 (:result-types signed-num)
1947 (:translate long-float-exp-bits)
1948 (:policy :fast-safe)
1953 (with-tn@fp-top(float)
1954 (let ((where (make-ea :dword :base ebp-tn
1955 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
1956 (store-long-float where)))
1957 (inst movsx exp-bits
1958 (make-ea :word :base ebp-tn
1959 :disp (frame-byte-offset (tn-offset temp)))))
1961 (inst movsx exp-bits
1962 (make-ea :word :base ebp-tn
1963 :disp (frame-byte-offset (tn-offset temp)))))
1965 (inst movsx exp-bits
1966 (make-ea-for-object-slot float (+ 2 long-float-value-slot)
1967 other-pointer-lowtag :word))))))
1970 (define-vop (long-float-high-bits)
1971 (:args (float :scs (long-reg descriptor-reg)
1972 :load-if (not (sc-is float long-stack))))
1973 (:results (hi-bits :scs (unsigned-reg)))
1974 (:temporary (:sc long-stack) temp)
1975 (:arg-types long-float)
1976 (:result-types unsigned-num)
1977 (:translate long-float-high-bits)
1978 (:policy :fast-safe)
1983 (with-tn@fp-top(float)
1984 (let ((where (make-ea :dword :base ebp-tn
1985 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
1986 (store-long-float where)))
1987 (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1989 (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1991 (loadw hi-bits float (1+ long-float-value-slot)
1992 other-pointer-lowtag)))))
1995 (define-vop (long-float-low-bits)
1996 (:args (float :scs (long-reg descriptor-reg)
1997 :load-if (not (sc-is float long-stack))))
1998 (:results (lo-bits :scs (unsigned-reg)))
1999 (:temporary (:sc long-stack) temp)
2000 (:arg-types long-float)
2001 (:result-types unsigned-num)
2002 (:translate long-float-low-bits)
2003 (:policy :fast-safe)
2008 (with-tn@fp-top(float)
2009 (let ((where (make-ea :dword :base ebp-tn
2010 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2011 (store-long-float where)))
2012 (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
2014 (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
2016 (loadw lo-bits float long-float-value-slot
2017 other-pointer-lowtag)))))
2019 ;;;; float mode hackery
2021 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2022 (defknown floating-point-modes () float-modes (flushable))
2023 (defknown ((setf floating-point-modes)) (float-modes)
2026 (def!constant npx-env-size (* 7 n-word-bytes))
2027 (def!constant npx-cw-offset 0)
2028 (def!constant npx-sw-offset 4)
2030 (define-vop (floating-point-modes)
2031 (:results (res :scs (unsigned-reg)))
2032 (:result-types unsigned-num)
2033 (:translate floating-point-modes)
2034 (:policy :fast-safe)
2035 (:temporary (:sc unsigned-reg :offset eax-offset :target res
2038 (inst sub esp-tn npx-env-size) ; Make space on stack.
2039 (inst wait) ; Catch any pending FPE exceptions
2040 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2041 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2042 ;; Move current status to high word.
2043 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2044 ;; Move exception mask to low word.
2045 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2046 (inst add esp-tn npx-env-size) ; Pop stack.
2047 (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
2050 (define-vop (set-floating-point-modes)
2051 (:args (new :scs (unsigned-reg) :to :result :target res))
2052 (:results (res :scs (unsigned-reg)))
2053 (:arg-types unsigned-num)
2054 (:result-types unsigned-num)
2055 (:translate (setf floating-point-modes))
2056 (:policy :fast-safe)
2057 (:temporary (:sc unsigned-reg :offset eax-offset
2058 :from :eval :to :result) eax)
2060 (inst sub esp-tn npx-env-size) ; Make space on stack.
2061 (inst wait) ; Catch any pending FPE exceptions.
2062 (inst fstenv (make-ea :dword :base esp-tn))
2064 (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
2065 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2066 (inst shr eax 16) ; position status word
2067 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2068 (inst fldenv (make-ea :dword :base esp-tn))
2069 (inst add esp-tn npx-env-size) ; Pop stack.
2075 ;;; Let's use some of the 80387 special functions.
2077 ;;; These defs will not take effect unless code/irrat.lisp is modified
2078 ;;; to remove the inlined alien routine def.
2080 (macrolet ((frob (func trans op)
2081 `(define-vop (,func)
2082 (:args (x :scs (double-reg) :target fr0))
2083 (:temporary (:sc double-reg :offset fr0-offset
2084 :from :argument :to :result) fr0)
2086 (:results (y :scs (double-reg)))
2087 (:arg-types double-float)
2088 (:result-types double-float)
2090 (:policy :fast-safe)
2091 (:note "inline NPX function")
2093 (:save-p :compute-only)
2096 (note-this-location vop :internal-error)
2097 (unless (zerop (tn-offset x))
2098 (inst fxch x) ; x to top of stack
2099 (unless (location= x y)
2100 (inst fst x))) ; maybe save it
2101 (inst ,op) ; clobber st0
2102 (cond ((zerop (tn-offset y))
2103 (maybe-fp-wait node))
2107 ;; Quick versions of fsin and fcos that require the argument to be
2108 ;; within range 2^63.
2109 (frob fsin-quick %sin-quick fsin)
2110 (frob fcos-quick %cos-quick fcos)
2111 (frob fsqrt %sqrt fsqrt))
2113 ;;; Quick version of ftan that requires the argument to be within
2115 (define-vop (ftan-quick)
2116 (:translate %tan-quick)
2117 (:args (x :scs (double-reg) :target fr0))
2118 (:temporary (:sc double-reg :offset fr0-offset
2119 :from :argument :to :result) fr0)
2120 (:temporary (:sc double-reg :offset fr1-offset
2121 :from :argument :to :result) fr1)
2122 (:results (y :scs (double-reg)))
2123 (:arg-types double-float)
2124 (:result-types double-float)
2125 (:policy :fast-safe)
2126 (:note "inline tan function")
2128 (:save-p :compute-only)
2130 (note-this-location vop :internal-error)
2139 (inst fldd (make-random-tn :kind :normal
2140 :sc (sc-or-lose 'double-reg)
2141 :offset (- (tn-offset x) 2)))))
2152 ;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
2153 ;;; result if the argument is out of range 2^63 and would thus be
2154 ;;; hopelessly inaccurate.
2155 (macrolet ((frob (func trans op)
2156 `(define-vop (,func)
2158 (:args (x :scs (double-reg) :target fr0))
2159 (:temporary (:sc double-reg :offset fr0-offset
2160 :from :argument :to :result) fr0)
2161 (:temporary (:sc unsigned-reg :offset eax-offset
2162 :from :argument :to :result) eax)
2163 (:results (y :scs (double-reg)))
2164 (:arg-types double-float)
2165 (:result-types double-float)
2166 (:policy :fast-safe)
2167 (:note "inline sin/cos function")
2169 (:save-p :compute-only)
2172 (note-this-location vop :internal-error)
2173 (unless (zerop (tn-offset x))
2174 (inst fxch x) ; x to top of stack
2175 (unless (location= x y)
2176 (inst fst x))) ; maybe save it
2178 (inst fnstsw) ; status word to ax
2179 (inst and ah-tn #x04) ; C2
2181 ;; Else x was out of range so reduce it; ST0 is unchanged.
2182 (inst fstp fr0) ; Load 0.0
2185 (unless (zerop (tn-offset y))
2187 (frob fsin %sin fsin)
2188 (frob fcos %cos fcos))
2192 (:args (x :scs (double-reg) :target fr0))
2193 (:temporary (:sc double-reg :offset fr0-offset
2194 :from :argument :to :result) fr0)
2195 (:temporary (:sc double-reg :offset fr1-offset
2196 :from :argument :to :result) fr1)
2197 (:temporary (:sc unsigned-reg :offset eax-offset
2198 :from :argument :to :result) eax)
2199 (:results (y :scs (double-reg)))
2200 (:arg-types double-float)
2201 (:result-types double-float)
2203 (:policy :fast-safe)
2204 (:note "inline tan function")
2206 (:save-p :compute-only)
2209 (note-this-location vop :internal-error)
2218 (inst fldd (make-random-tn :kind :normal
2219 :sc (sc-or-lose 'double-reg)
2220 :offset (- (tn-offset x) 2)))))
2222 (inst fnstsw) ; status word to ax
2223 (inst and ah-tn #x04) ; C2
2225 ;; Else x was out of range so load 0.0
2237 ;;; %exp that handles the following special cases: exp(+Inf) is +Inf;
2238 ;;; exp(-Inf) is 0; exp(NaN) is NaN.
2241 (:args (x :scs (double-reg) :target fr0))
2242 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2243 (:temporary (:sc double-reg :offset fr0-offset
2244 :from :argument :to :result) fr0)
2245 (:temporary (:sc double-reg :offset fr1-offset
2246 :from :argument :to :result) fr1)
2247 (:temporary (:sc double-reg :offset fr2-offset
2248 :from :argument :to :result) fr2)
2249 (:results (y :scs (double-reg)))
2250 (:arg-types double-float)
2251 (:result-types double-float)
2252 (:policy :fast-safe)
2253 (:note "inline exp function")
2255 (:save-p :compute-only)
2258 (note-this-location vop :internal-error)
2259 (unless (zerop (tn-offset x))
2260 (inst fxch x) ; x to top of stack
2261 (unless (location= x y)
2262 (inst fst x))) ; maybe save it
2263 ;; Check for Inf or NaN
2267 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2268 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2269 (inst and ah-tn #x02) ; Test sign of Inf.
2270 (inst jmp :z DONE) ; +Inf gives +Inf.
2271 (inst fstp fr0) ; -Inf gives 0
2273 (inst jmp-short DONE)
2278 ;; Now fr0=x log2(e)
2282 (inst fsubp-sti fr1)
2285 (inst faddp-sti fr1)
2289 (unless (zerop (tn-offset y))
2292 ;;; Expm1 = exp(x) - 1.
2293 ;;; Handles the following special cases:
2294 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2295 (define-vop (fexpm1)
2297 (:args (x :scs (double-reg) :target fr0))
2298 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2299 (:temporary (:sc double-reg :offset fr0-offset
2300 :from :argument :to :result) fr0)
2301 (:temporary (:sc double-reg :offset fr1-offset
2302 :from :argument :to :result) fr1)
2303 (:temporary (:sc double-reg :offset fr2-offset
2304 :from :argument :to :result) fr2)
2305 (:results (y :scs (double-reg)))
2306 (:arg-types double-float)
2307 (:result-types double-float)
2308 (:policy :fast-safe)
2309 (:note "inline expm1 function")
2311 (:save-p :compute-only)
2314 (note-this-location vop :internal-error)
2315 (unless (zerop (tn-offset x))
2316 (inst fxch x) ; x to top of stack
2317 (unless (location= x y)
2318 (inst fst x))) ; maybe save it
2319 ;; Check for Inf or NaN
2323 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
2324 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
2325 (inst and ah-tn #x02) ; Test sign of Inf.
2326 (inst jmp :z DONE) ; +Inf gives +Inf.
2327 (inst fstp fr0) ; -Inf gives -1.0
2330 (inst jmp-short DONE)
2332 ;; Free two stack slots leaving the argument on top.
2336 (inst fmul fr1) ; Now fr0 = x log2(e)
2351 (unless (zerop (tn-offset y))
2356 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2357 (:temporary (:sc double-reg :offset fr0-offset
2358 :from :argument :to :result) fr0)
2359 (:temporary (:sc double-reg :offset fr1-offset
2360 :from :argument :to :result) fr1)
2361 (:results (y :scs (double-reg)))
2362 (:arg-types double-float)
2363 (:result-types double-float)
2364 (:policy :fast-safe)
2365 (:note "inline log function")
2367 (:save-p :compute-only)
2369 (note-this-location vop :internal-error)
2384 ;; x is in a FP reg, not fr0 or fr1
2388 (inst fldd (make-random-tn :kind :normal
2389 :sc (sc-or-lose 'double-reg)
2390 :offset (1- (tn-offset x))))))
2392 ((double-stack descriptor-reg)
2396 (if (sc-is x double-stack)
2397 (inst fldd (ea-for-df-stack x))
2398 (inst fldd (ea-for-df-desc x)))
2403 (t (inst fstd y)))))
2405 (define-vop (flog10)
2407 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2408 (:temporary (:sc double-reg :offset fr0-offset
2409 :from :argument :to :result) fr0)
2410 (:temporary (:sc double-reg :offset fr1-offset
2411 :from :argument :to :result) fr1)
2412 (:results (y :scs (double-reg)))
2413 (:arg-types double-float)
2414 (:result-types double-float)
2415 (:policy :fast-safe)
2416 (:note "inline log10 function")
2418 (:save-p :compute-only)
2420 (note-this-location vop :internal-error)
2435 ;; x is in a FP reg, not fr0 or fr1
2439 (inst fldd (make-random-tn :kind :normal
2440 :sc (sc-or-lose 'double-reg)
2441 :offset (1- (tn-offset x))))))
2443 ((double-stack descriptor-reg)
2447 (if (sc-is x double-stack)
2448 (inst fldd (ea-for-df-stack x))
2449 (inst fldd (ea-for-df-desc x)))
2454 (t (inst fstd y)))))
2458 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2459 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2460 (:temporary (:sc double-reg :offset fr0-offset
2461 :from (:argument 0) :to :result) fr0)
2462 (:temporary (:sc double-reg :offset fr1-offset
2463 :from (:argument 1) :to :result) fr1)
2464 (:temporary (:sc double-reg :offset fr2-offset
2465 :from :load :to :result) fr2)
2466 (:results (r :scs (double-reg)))
2467 (:arg-types double-float double-float)
2468 (:result-types double-float)
2469 (:policy :fast-safe)
2470 (:note "inline pow function")
2472 (:save-p :compute-only)
2474 (note-this-location vop :internal-error)
2475 ;; Setup x in fr0 and y in fr1
2477 ;; x in fr0; y in fr1
2478 ((and (sc-is x double-reg) (zerop (tn-offset x))
2479 (sc-is y double-reg) (= 1 (tn-offset y))))
2480 ;; y in fr1; x not in fr0
2481 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2485 (copy-fp-reg-to-fr0 x))
2488 (inst fldd (ea-for-df-stack x)))
2491 (inst fldd (ea-for-df-desc x)))))
2492 ;; x in fr0; y not in fr1
2493 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2495 ;; Now load y to fr0
2498 (copy-fp-reg-to-fr0 y))
2501 (inst fldd (ea-for-df-stack y)))
2504 (inst fldd (ea-for-df-desc y))))
2506 ;; x in fr1; y not in fr1
2507 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2511 (copy-fp-reg-to-fr0 y))
2514 (inst fldd (ea-for-df-stack y)))
2517 (inst fldd (ea-for-df-desc y))))
2520 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2522 ;; Now load x to fr0
2525 (copy-fp-reg-to-fr0 x))
2528 (inst fldd (ea-for-df-stack x)))
2531 (inst fldd (ea-for-df-desc x)))))
2532 ;; Neither x or y are in either fr0 or fr1
2539 (inst fldd (make-random-tn :kind :normal
2540 :sc (sc-or-lose 'double-reg)
2541 :offset (- (tn-offset y) 2))))
2543 (inst fldd (ea-for-df-stack y)))
2545 (inst fldd (ea-for-df-desc y))))
2549 (inst fldd (make-random-tn :kind :normal
2550 :sc (sc-or-lose 'double-reg)
2551 :offset (1- (tn-offset x)))))
2553 (inst fldd (ea-for-df-stack x)))
2555 (inst fldd (ea-for-df-desc x))))))
2557 ;; Now have x at fr0; and y at fr1
2559 ;; Now fr0=y log2(x)
2563 (inst fsubp-sti fr1)
2566 (inst faddp-sti fr1)
2571 (t (inst fstd r)))))
2573 (define-vop (fscalen)
2574 (:translate %scalbn)
2575 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2576 (y :scs (signed-stack signed-reg) :target temp))
2577 (:temporary (:sc double-reg :offset fr0-offset
2578 :from (:argument 0) :to :result) fr0)
2579 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2580 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2581 (:results (r :scs (double-reg)))
2582 (:arg-types double-float signed-num)
2583 (:result-types double-float)
2584 (:policy :fast-safe)
2585 (:note "inline scalbn function")
2587 ;; Setup x in fr0 and y in fr1
2618 (inst fld (make-random-tn :kind :normal
2619 :sc (sc-or-lose 'double-reg)
2620 :offset (1- (tn-offset x)))))))
2621 ((double-stack descriptor-reg)
2630 (if (sc-is x double-stack)
2631 (inst fldd (ea-for-df-stack x))
2632 (inst fldd (ea-for-df-desc x)))))
2634 (unless (zerop (tn-offset r))
2637 (define-vop (fscale)
2639 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2640 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2641 (:temporary (:sc double-reg :offset fr0-offset
2642 :from (:argument 0) :to :result) fr0)
2643 (:temporary (:sc double-reg :offset fr1-offset
2644 :from (:argument 1) :to :result) fr1)
2645 (:results (r :scs (double-reg)))
2646 (:arg-types double-float double-float)
2647 (:result-types double-float)
2648 (:policy :fast-safe)
2649 (:note "inline scalb function")
2651 (:save-p :compute-only)
2653 (note-this-location vop :internal-error)
2654 ;; Setup x in fr0 and y in fr1
2656 ;; x in fr0; y in fr1
2657 ((and (sc-is x double-reg) (zerop (tn-offset x))
2658 (sc-is y double-reg) (= 1 (tn-offset y))))
2659 ;; y in fr1; x not in fr0
2660 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2664 (copy-fp-reg-to-fr0 x))
2667 (inst fldd (ea-for-df-stack x)))
2670 (inst fldd (ea-for-df-desc x)))))
2671 ;; x in fr0; y not in fr1
2672 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2674 ;; Now load y to fr0
2677 (copy-fp-reg-to-fr0 y))
2680 (inst fldd (ea-for-df-stack y)))
2683 (inst fldd (ea-for-df-desc y))))
2685 ;; x in fr1; y not in fr1
2686 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2690 (copy-fp-reg-to-fr0 y))
2693 (inst fldd (ea-for-df-stack y)))
2696 (inst fldd (ea-for-df-desc y))))
2699 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2701 ;; Now load x to fr0
2704 (copy-fp-reg-to-fr0 x))
2707 (inst fldd (ea-for-df-stack x)))
2710 (inst fldd (ea-for-df-desc x)))))
2711 ;; Neither x or y are in either fr0 or fr1
2718 (inst fldd (make-random-tn :kind :normal
2719 :sc (sc-or-lose 'double-reg)
2720 :offset (- (tn-offset y) 2))))
2722 (inst fldd (ea-for-df-stack y)))
2724 (inst fldd (ea-for-df-desc y))))
2728 (inst fldd (make-random-tn :kind :normal
2729 :sc (sc-or-lose 'double-reg)
2730 :offset (1- (tn-offset x)))))
2732 (inst fldd (ea-for-df-stack x)))
2734 (inst fldd (ea-for-df-desc x))))))
2736 ;; Now have x at fr0; and y at fr1
2738 (unless (zerop (tn-offset r))
2741 (define-vop (flog1p)
2743 (:args (x :scs (double-reg) :to :result))
2744 (:temporary (:sc double-reg :offset fr0-offset
2745 :from :argument :to :result) fr0)
2746 (:temporary (:sc double-reg :offset fr1-offset
2747 :from :argument :to :result) fr1)
2748 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2749 (:results (y :scs (double-reg)))
2750 (:arg-types double-float)
2751 (:result-types double-float)
2752 (:policy :fast-safe)
2753 (:note "inline log1p function")
2756 ;; x is in a FP reg, not fr0, fr1.
2759 (inst fldd (make-random-tn :kind :normal
2760 :sc (sc-or-lose 'double-reg)
2761 :offset (- (tn-offset x) 2)))
2763 (inst push #x3e947ae1) ; Constant 0.29
2765 (inst fld (make-ea :dword :base esp-tn))
2768 (inst fnstsw) ; status word to ax
2769 (inst and ah-tn #x45)
2770 (inst jmp :z WITHIN-RANGE)
2771 ;; Out of range for fyl2xp1.
2773 (inst faddd (make-random-tn :kind :normal
2774 :sc (sc-or-lose 'double-reg)
2775 :offset (- (tn-offset x) 1)))
2783 (inst fldd (make-random-tn :kind :normal
2784 :sc (sc-or-lose 'double-reg)
2785 :offset (- (tn-offset x) 1)))
2791 (t (inst fstd y)))))
2793 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2794 ;;; instruction and a range check can be avoided.
2795 (define-vop (flog1p-pentium)
2797 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2798 (:temporary (:sc double-reg :offset fr0-offset
2799 :from :argument :to :result) fr0)
2800 (:temporary (:sc double-reg :offset fr1-offset
2801 :from :argument :to :result) fr1)
2802 (:results (y :scs (double-reg)))
2803 (:arg-types double-float)
2804 (:result-types double-float)
2805 (:policy :fast-safe)
2806 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2807 (:note "inline log1p with limited x range function")
2809 (:save-p :compute-only)
2811 (note-this-location vop :internal-error)
2826 ;; x is in a FP reg, not fr0 or fr1
2830 (inst fldd (make-random-tn :kind :normal
2831 :sc (sc-or-lose 'double-reg)
2832 :offset (1- (tn-offset x)))))))
2833 ((double-stack descriptor-reg)
2837 (if (sc-is x double-stack)
2838 (inst fldd (ea-for-df-stack x))
2839 (inst fldd (ea-for-df-desc x)))))
2844 (t (inst fstd y)))))
2848 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2849 (:temporary (:sc double-reg :offset fr0-offset
2850 :from :argument :to :result) fr0)
2851 (:temporary (:sc double-reg :offset fr1-offset
2852 :from :argument :to :result) fr1)
2853 (:results (y :scs (double-reg)))
2854 (:arg-types double-float)
2855 (:result-types double-float)
2856 (:policy :fast-safe)
2857 (:note "inline logb function")
2859 (:save-p :compute-only)
2861 (note-this-location vop :internal-error)
2872 ;; x is in a FP reg, not fr0 or fr1
2875 (inst fldd (make-random-tn :kind :normal
2876 :sc (sc-or-lose 'double-reg)
2877 :offset (- (tn-offset x) 2))))))
2878 ((double-stack descriptor-reg)
2881 (if (sc-is x double-stack)
2882 (inst fldd (ea-for-df-stack x))
2883 (inst fldd (ea-for-df-desc x)))))
2894 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2895 (:temporary (:sc double-reg :offset fr0-offset
2896 :from (:argument 0) :to :result) fr0)
2897 (:temporary (:sc double-reg :offset fr1-offset
2898 :from (:argument 0) :to :result) fr1)
2899 (:results (r :scs (double-reg)))
2900 (:arg-types double-float)
2901 (:result-types double-float)
2902 (:policy :fast-safe)
2903 (:note "inline atan function")
2905 (:save-p :compute-only)
2907 (note-this-location vop :internal-error)
2908 ;; Setup x in fr1 and 1.0 in fr0
2911 ((and (sc-is x double-reg) (zerop (tn-offset x)))
2914 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2916 ;; x not in fr0 or fr1
2923 (inst fldd (make-random-tn :kind :normal
2924 :sc (sc-or-lose 'double-reg)
2925 :offset (- (tn-offset x) 2))))
2927 (inst fldd (ea-for-df-stack x)))
2929 (inst fldd (ea-for-df-desc x))))))
2931 ;; Now have x at fr1; and 1.0 at fr0
2936 (t (inst fstd r)))))
2938 (define-vop (fatan2)
2940 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
2941 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
2942 (:temporary (:sc double-reg :offset fr0-offset
2943 :from (:argument 1) :to :result) fr0)
2944 (:temporary (:sc double-reg :offset fr1-offset
2945 :from (:argument 0) :to :result) fr1)
2946 (:results (r :scs (double-reg)))
2947 (:arg-types double-float double-float)
2948 (:result-types double-float)
2949 (:policy :fast-safe)
2950 (:note "inline atan2 function")
2952 (:save-p :compute-only)
2954 (note-this-location vop :internal-error)
2955 ;; Setup x in fr1 and y in fr0
2957 ;; y in fr0; x in fr1
2958 ((and (sc-is y double-reg) (zerop (tn-offset y))
2959 (sc-is x double-reg) (= 1 (tn-offset x))))
2960 ;; x in fr1; y not in fr0
2961 ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2965 (copy-fp-reg-to-fr0 y))
2968 (inst fldd (ea-for-df-stack y)))
2971 (inst fldd (ea-for-df-desc y)))))
2972 ((and (sc-is x double-reg) (zerop (tn-offset x))
2973 (sc-is y double-reg) (zerop (tn-offset x)))
2976 ;; y in fr0; x not in fr1
2977 ((and (sc-is y double-reg) (zerop (tn-offset y)))
2979 ;; Now load x to fr0
2982 (copy-fp-reg-to-fr0 x))
2985 (inst fldd (ea-for-df-stack x)))
2988 (inst fldd (ea-for-df-desc x))))
2990 ;; y in fr1; x not in fr1
2991 ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2995 (copy-fp-reg-to-fr0 x))
2998 (inst fldd (ea-for-df-stack x)))
3001 (inst fldd (ea-for-df-desc x))))
3004 ((and (sc-is x double-reg) (zerop (tn-offset x)))
3006 ;; Now load y to fr0
3009 (copy-fp-reg-to-fr0 y))
3012 (inst fldd (ea-for-df-stack y)))
3015 (inst fldd (ea-for-df-desc y)))))
3016 ;; Neither y or x are in either fr0 or fr1
3023 (inst fldd (make-random-tn :kind :normal
3024 :sc (sc-or-lose 'double-reg)
3025 :offset (- (tn-offset x) 2))))
3027 (inst fldd (ea-for-df-stack x)))
3029 (inst fldd (ea-for-df-desc x))))
3033 (inst fldd (make-random-tn :kind :normal
3034 :sc (sc-or-lose 'double-reg)
3035 :offset (1- (tn-offset y)))))
3037 (inst fldd (ea-for-df-stack y)))
3039 (inst fldd (ea-for-df-desc y))))))
3041 ;; Now have y at fr0; and x at fr1
3046 (t (inst fstd r)))))
3047 ) ; PROGN #!-LONG-FLOAT
3052 ;;; Lets use some of the 80387 special functions.
3054 ;;; These defs will not take effect unless code/irrat.lisp is modified
3055 ;;; to remove the inlined alien routine def.
3057 (macrolet ((frob (func trans op)
3058 `(define-vop (,func)
3059 (:args (x :scs (long-reg) :target fr0))
3060 (:temporary (:sc long-reg :offset fr0-offset
3061 :from :argument :to :result) fr0)
3063 (:results (y :scs (long-reg)))
3064 (:arg-types long-float)
3065 (:result-types long-float)
3067 (:policy :fast-safe)
3068 (:note "inline NPX function")
3070 (:save-p :compute-only)
3073 (note-this-location vop :internal-error)
3074 (unless (zerop (tn-offset x))
3075 (inst fxch x) ; x to top of stack
3076 (unless (location= x y)
3077 (inst fst x))) ; maybe save it
3078 (inst ,op) ; clobber st0
3079 (cond ((zerop (tn-offset y))
3080 (maybe-fp-wait node))
3084 ;; Quick versions of FSIN and FCOS that require the argument to be
3085 ;; within range 2^63.
3086 (frob fsin-quick %sin-quick fsin)
3087 (frob fcos-quick %cos-quick fcos)
3088 (frob fsqrt %sqrt fsqrt))
3090 ;;; Quick version of ftan that requires the argument to be within
3092 (define-vop (ftan-quick)
3093 (:translate %tan-quick)
3094 (:args (x :scs (long-reg) :target fr0))
3095 (:temporary (:sc long-reg :offset fr0-offset
3096 :from :argument :to :result) fr0)
3097 (:temporary (:sc long-reg :offset fr1-offset
3098 :from :argument :to :result) fr1)
3099 (:results (y :scs (long-reg)))
3100 (:arg-types long-float)
3101 (:result-types long-float)
3102 (:policy :fast-safe)
3103 (:note "inline tan function")
3105 (:save-p :compute-only)
3107 (note-this-location vop :internal-error)
3116 (inst fldd (make-random-tn :kind :normal
3117 :sc (sc-or-lose 'double-reg)
3118 :offset (- (tn-offset x) 2)))))
3129 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3130 ;;; the argument is out of range 2^63 and would thus be hopelessly
3132 (macrolet ((frob (func trans op)
3133 `(define-vop (,func)
3135 (:args (x :scs (long-reg) :target fr0))
3136 (:temporary (:sc long-reg :offset fr0-offset
3137 :from :argument :to :result) fr0)
3138 (:temporary (:sc unsigned-reg :offset eax-offset
3139 :from :argument :to :result) eax)
3140 (:results (y :scs (long-reg)))
3141 (:arg-types long-float)
3142 (:result-types long-float)
3143 (:policy :fast-safe)
3144 (:note "inline sin/cos function")
3146 (:save-p :compute-only)
3149 (note-this-location vop :internal-error)
3150 (unless (zerop (tn-offset x))
3151 (inst fxch x) ; x to top of stack
3152 (unless (location= x y)
3153 (inst fst x))) ; maybe save it
3155 (inst fnstsw) ; status word to ax
3156 (inst and ah-tn #x04) ; C2
3158 ;; Else x was out of range so reduce it; ST0 is unchanged.
3159 (inst fstp fr0) ; Load 0.0
3162 (unless (zerop (tn-offset y))
3164 (frob fsin %sin fsin)
3165 (frob fcos %cos fcos))
3169 (:args (x :scs (long-reg) :target fr0))
3170 (:temporary (:sc long-reg :offset fr0-offset
3171 :from :argument :to :result) fr0)
3172 (:temporary (:sc long-reg :offset fr1-offset
3173 :from :argument :to :result) fr1)
3174 (:temporary (:sc unsigned-reg :offset eax-offset
3175 :from :argument :to :result) eax)
3176 (:results (y :scs (long-reg)))
3177 (:arg-types long-float)
3178 (:result-types long-float)
3180 (:policy :fast-safe)
3181 (:note "inline tan function")
3183 (:save-p :compute-only)
3186 (note-this-location vop :internal-error)
3195 (inst fldd (make-random-tn :kind :normal
3196 :sc (sc-or-lose 'double-reg)
3197 :offset (- (tn-offset x) 2)))))
3199 (inst fnstsw) ; status word to ax
3200 (inst and ah-tn #x04) ; C2
3202 ;; Else x was out of range so reduce it; ST0 is unchanged.
3203 (inst fldz) ; Load 0.0
3215 ;;; Modified exp that handles the following special cases:
3216 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3219 (:args (x :scs (long-reg) :target fr0))
3220 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3221 (:temporary (:sc long-reg :offset fr0-offset
3222 :from :argument :to :result) fr0)
3223 (:temporary (:sc long-reg :offset fr1-offset
3224 :from :argument :to :result) fr1)
3225 (:temporary (:sc long-reg :offset fr2-offset
3226 :from :argument :to :result) fr2)
3227 (:results (y :scs (long-reg)))
3228 (:arg-types long-float)
3229 (:result-types long-float)
3230 (:policy :fast-safe)
3231 (:note "inline exp function")
3233 (:save-p :compute-only)
3236 (note-this-location vop :internal-error)
3237 (unless (zerop (tn-offset x))
3238 (inst fxch x) ; x to top of stack
3239 (unless (location= x y)
3240 (inst fst x))) ; maybe save it
3241 ;; Check for Inf or NaN
3245 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3246 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3247 (inst and ah-tn #x02) ; Test sign of Inf.
3248 (inst jmp :z DONE) ; +Inf gives +Inf.
3249 (inst fstp fr0) ; -Inf gives 0
3251 (inst jmp-short DONE)
3256 ;; Now fr0=x log2(e)
3260 (inst fsubp-sti fr1)
3263 (inst faddp-sti fr1)
3267 (unless (zerop (tn-offset y))
3270 ;;; Expm1 = exp(x) - 1.
3271 ;;; Handles the following special cases:
3272 ;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3273 (define-vop (fexpm1)
3275 (:args (x :scs (long-reg) :target fr0))
3276 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3277 (:temporary (:sc long-reg :offset fr0-offset
3278 :from :argument :to :result) fr0)
3279 (:temporary (:sc long-reg :offset fr1-offset
3280 :from :argument :to :result) fr1)
3281 (:temporary (:sc long-reg :offset fr2-offset
3282 :from :argument :to :result) fr2)
3283 (:results (y :scs (long-reg)))
3284 (:arg-types long-float)
3285 (:result-types long-float)
3286 (:policy :fast-safe)
3287 (:note "inline expm1 function")
3289 (:save-p :compute-only)
3292 (note-this-location vop :internal-error)
3293 (unless (zerop (tn-offset x))
3294 (inst fxch x) ; x to top of stack
3295 (unless (location= x y)
3296 (inst fst x))) ; maybe save it
3297 ;; Check for Inf or NaN
3301 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
3302 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
3303 (inst and ah-tn #x02) ; Test sign of Inf.
3304 (inst jmp :z DONE) ; +Inf gives +Inf.
3305 (inst fstp fr0) ; -Inf gives -1.0
3308 (inst jmp-short DONE)
3310 ;; Free two stack slots leaving the argument on top.
3314 (inst fmul fr1) ; Now fr0 = x log2(e)
3329 (unless (zerop (tn-offset y))
3334 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3335 (:temporary (:sc long-reg :offset fr0-offset
3336 :from :argument :to :result) fr0)
3337 (:temporary (:sc long-reg :offset fr1-offset
3338 :from :argument :to :result) fr1)
3339 (:results (y :scs (long-reg)))
3340 (:arg-types long-float)
3341 (:result-types long-float)
3342 (:policy :fast-safe)
3343 (:note "inline log function")
3345 (:save-p :compute-only)
3347 (note-this-location vop :internal-error)
3362 ;; x is in a FP reg, not fr0 or fr1
3366 (inst fldd (make-random-tn :kind :normal
3367 :sc (sc-or-lose 'double-reg)
3368 :offset (1- (tn-offset x))))))
3370 ((long-stack descriptor-reg)
3374 (if (sc-is x long-stack)
3375 (inst fldl (ea-for-lf-stack x))
3376 (inst fldl (ea-for-lf-desc x)))
3381 (t (inst fstd y)))))
3383 (define-vop (flog10)
3385 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3386 (:temporary (:sc long-reg :offset fr0-offset
3387 :from :argument :to :result) fr0)
3388 (:temporary (:sc long-reg :offset fr1-offset
3389 :from :argument :to :result) fr1)
3390 (:results (y :scs (long-reg)))
3391 (:arg-types long-float)
3392 (:result-types long-float)
3393 (:policy :fast-safe)
3394 (:note "inline log10 function")
3396 (:save-p :compute-only)
3398 (note-this-location vop :internal-error)
3413 ;; x is in a FP reg, not fr0 or fr1
3417 (inst fldd (make-random-tn :kind :normal
3418 :sc (sc-or-lose 'double-reg)
3419 :offset (1- (tn-offset x))))))
3421 ((long-stack descriptor-reg)
3425 (if (sc-is x long-stack)
3426 (inst fldl (ea-for-lf-stack x))
3427 (inst fldl (ea-for-lf-desc x)))
3432 (t (inst fstd y)))))
3436 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3437 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3438 (:temporary (:sc long-reg :offset fr0-offset
3439 :from (:argument 0) :to :result) fr0)
3440 (:temporary (:sc long-reg :offset fr1-offset
3441 :from (:argument 1) :to :result) fr1)
3442 (:temporary (:sc long-reg :offset fr2-offset
3443 :from :load :to :result) fr2)
3444 (:results (r :scs (long-reg)))
3445 (:arg-types long-float long-float)
3446 (:result-types long-float)
3447 (:policy :fast-safe)
3448 (:note "inline pow function")
3450 (:save-p :compute-only)
3452 (note-this-location vop :internal-error)
3453 ;; Setup x in fr0 and y in fr1
3455 ;; x in fr0; y in fr1
3456 ((and (sc-is x long-reg) (zerop (tn-offset x))
3457 (sc-is y long-reg) (= 1 (tn-offset y))))
3458 ;; y in fr1; x not in fr0
3459 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3463 (copy-fp-reg-to-fr0 x))
3466 (inst fldl (ea-for-lf-stack x)))
3469 (inst fldl (ea-for-lf-desc x)))))
3470 ;; x in fr0; y not in fr1
3471 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3473 ;; Now load y to fr0
3476 (copy-fp-reg-to-fr0 y))
3479 (inst fldl (ea-for-lf-stack y)))
3482 (inst fldl (ea-for-lf-desc y))))
3484 ;; x in fr1; y not in fr1
3485 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3489 (copy-fp-reg-to-fr0 y))
3492 (inst fldl (ea-for-lf-stack y)))
3495 (inst fldl (ea-for-lf-desc y))))
3498 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3500 ;; Now load x to fr0
3503 (copy-fp-reg-to-fr0 x))
3506 (inst fldl (ea-for-lf-stack x)))
3509 (inst fldl (ea-for-lf-desc x)))))
3510 ;; Neither x or y are in either fr0 or fr1
3517 (inst fldd (make-random-tn :kind :normal
3518 :sc (sc-or-lose 'double-reg)
3519 :offset (- (tn-offset y) 2))))
3521 (inst fldl (ea-for-lf-stack y)))
3523 (inst fldl (ea-for-lf-desc y))))
3527 (inst fldd (make-random-tn :kind :normal
3528 :sc (sc-or-lose 'double-reg)
3529 :offset (1- (tn-offset x)))))
3531 (inst fldl (ea-for-lf-stack x)))
3533 (inst fldl (ea-for-lf-desc x))))))
3535 ;; Now have x at fr0; and y at fr1
3537 ;; Now fr0=y log2(x)
3541 (inst fsubp-sti fr1)
3544 (inst faddp-sti fr1)
3549 (t (inst fstd r)))))
3551 (define-vop (fscalen)
3552 (:translate %scalbn)
3553 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3554 (y :scs (signed-stack signed-reg) :target temp))
3555 (:temporary (:sc long-reg :offset fr0-offset
3556 :from (:argument 0) :to :result) fr0)
3557 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3558 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3559 (:results (r :scs (long-reg)))
3560 (:arg-types long-float signed-num)
3561 (:result-types long-float)
3562 (:policy :fast-safe)
3563 (:note "inline scalbn function")
3565 ;; Setup x in fr0 and y in fr1
3596 (inst fld (make-random-tn :kind :normal
3597 :sc (sc-or-lose 'double-reg)
3598 :offset (1- (tn-offset x)))))))
3599 ((long-stack descriptor-reg)
3608 (if (sc-is x long-stack)
3609 (inst fldl (ea-for-lf-stack x))
3610 (inst fldl (ea-for-lf-desc x)))))
3612 (unless (zerop (tn-offset r))
3615 (define-vop (fscale)
3617 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3618 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3619 (:temporary (:sc long-reg :offset fr0-offset
3620 :from (:argument 0) :to :result) fr0)
3621 (:temporary (:sc long-reg :offset fr1-offset
3622 :from (:argument 1) :to :result) fr1)
3623 (:results (r :scs (long-reg)))
3624 (:arg-types long-float long-float)
3625 (:result-types long-float)
3626 (:policy :fast-safe)
3627 (:note "inline scalb function")
3629 (:save-p :compute-only)
3631 (note-this-location vop :internal-error)
3632 ;; Setup x in fr0 and y in fr1
3634 ;; x in fr0; y in fr1
3635 ((and (sc-is x long-reg) (zerop (tn-offset x))
3636 (sc-is y long-reg) (= 1 (tn-offset y))))
3637 ;; y in fr1; x not in fr0
3638 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3642 (copy-fp-reg-to-fr0 x))
3645 (inst fldl (ea-for-lf-stack x)))
3648 (inst fldl (ea-for-lf-desc x)))))
3649 ;; x in fr0; y not in fr1
3650 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3652 ;; Now load y to fr0
3655 (copy-fp-reg-to-fr0 y))
3658 (inst fldl (ea-for-lf-stack y)))
3661 (inst fldl (ea-for-lf-desc y))))
3663 ;; x in fr1; y not in fr1
3664 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3668 (copy-fp-reg-to-fr0 y))
3671 (inst fldl (ea-for-lf-stack y)))
3674 (inst fldl (ea-for-lf-desc y))))
3677 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3679 ;; Now load x to fr0
3682 (copy-fp-reg-to-fr0 x))
3685 (inst fldl (ea-for-lf-stack x)))
3688 (inst fldl (ea-for-lf-desc x)))))
3689 ;; Neither x or y are in either fr0 or fr1
3696 (inst fldd (make-random-tn :kind :normal
3697 :sc (sc-or-lose 'double-reg)
3698 :offset (- (tn-offset y) 2))))
3700 (inst fldl (ea-for-lf-stack y)))
3702 (inst fldl (ea-for-lf-desc y))))
3706 (inst fldd (make-random-tn :kind :normal
3707 :sc (sc-or-lose 'double-reg)
3708 :offset (1- (tn-offset x)))))
3710 (inst fldl (ea-for-lf-stack x)))
3712 (inst fldl (ea-for-lf-desc x))))))
3714 ;; Now have x at fr0; and y at fr1
3716 (unless (zerop (tn-offset r))
3719 (define-vop (flog1p)
3721 (:args (x :scs (long-reg) :to :result))
3722 (:temporary (:sc long-reg :offset fr0-offset
3723 :from :argument :to :result) fr0)
3724 (:temporary (:sc long-reg :offset fr1-offset
3725 :from :argument :to :result) fr1)
3726 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3727 (:results (y :scs (long-reg)))
3728 (:arg-types long-float)
3729 (:result-types long-float)
3730 (:policy :fast-safe)
3731 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3732 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3733 ;; an enormous PROGN above. Still, it would be probably be good to
3734 ;; add some code to warn about redefining VOPs.
3735 (:note "inline log1p function")
3738 ;; x is in a FP reg, not fr0, fr1.
3741 (inst fldd (make-random-tn :kind :normal
3742 :sc (sc-or-lose 'double-reg)
3743 :offset (- (tn-offset x) 2)))
3745 (inst push #x3e947ae1) ; Constant 0.29
3747 (inst fld (make-ea :dword :base esp-tn))
3750 (inst fnstsw) ; status word to ax
3751 (inst and ah-tn #x45)
3752 (inst jmp :z WITHIN-RANGE)
3753 ;; Out of range for fyl2xp1.
3755 (inst faddd (make-random-tn :kind :normal
3756 :sc (sc-or-lose 'double-reg)
3757 :offset (- (tn-offset x) 1)))
3765 (inst fldd (make-random-tn :kind :normal
3766 :sc (sc-or-lose 'double-reg)
3767 :offset (- (tn-offset x) 1)))
3773 (t (inst fstd y)))))
3775 ;;; The Pentium has a less restricted implementation of the fyl2xp1
3776 ;;; instruction and a range check can be avoided.
3777 (define-vop (flog1p-pentium)
3779 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3780 (:temporary (:sc long-reg :offset fr0-offset
3781 :from :argument :to :result) fr0)
3782 (:temporary (:sc long-reg :offset fr1-offset
3783 :from :argument :to :result) fr1)
3784 (:results (y :scs (long-reg)))
3785 (:arg-types long-float)
3786 (:result-types long-float)
3787 (:policy :fast-safe)
3788 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
3789 (:note "inline log1p function")
3805 ;; x is in a FP reg, not fr0 or fr1
3809 (inst fldd (make-random-tn :kind :normal
3810 :sc (sc-or-lose 'double-reg)
3811 :offset (1- (tn-offset x)))))))
3812 ((long-stack descriptor-reg)
3816 (if (sc-is x long-stack)
3817 (inst fldl (ea-for-lf-stack x))
3818 (inst fldl (ea-for-lf-desc x)))))
3823 (t (inst fstd y)))))
3827 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3828 (:temporary (:sc long-reg :offset fr0-offset
3829 :from :argument :to :result) fr0)
3830 (:temporary (:sc long-reg :offset fr1-offset
3831 :from :argument :to :result) fr1)
3832 (:results (y :scs (long-reg)))
3833 (:arg-types long-float)
3834 (:result-types long-float)
3835 (:policy :fast-safe)
3836 (:note "inline logb function")
3838 (:save-p :compute-only)
3840 (note-this-location vop :internal-error)
3851 ;; x is in a FP reg, not fr0 or fr1
3854 (inst fldd (make-random-tn :kind :normal
3855 :sc (sc-or-lose 'double-reg)
3856 :offset (- (tn-offset x) 2))))))
3857 ((long-stack descriptor-reg)
3860 (if (sc-is x long-stack)
3861 (inst fldl (ea-for-lf-stack x))
3862 (inst fldl (ea-for-lf-desc x)))))
3873 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3874 (:temporary (:sc long-reg :offset fr0-offset
3875 :from (:argument 0) :to :result) fr0)
3876 (:temporary (:sc long-reg :offset fr1-offset
3877 :from (:argument 0) :to :result) fr1)
3878 (:results (r :scs (long-reg)))
3879 (:arg-types long-float)
3880 (:result-types long-float)
3881 (:policy :fast-safe)
3882 (:note "inline atan function")
3884 (:save-p :compute-only)
3886 (note-this-location vop :internal-error)
3887 ;; Setup x in fr1 and 1.0 in fr0
3890 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3893 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3895 ;; x not in fr0 or fr1
3902 (inst fldd (make-random-tn :kind :normal
3903 :sc (sc-or-lose 'double-reg)
3904 :offset (- (tn-offset x) 2))))
3906 (inst fldl (ea-for-lf-stack x)))
3908 (inst fldl (ea-for-lf-desc x))))))
3910 ;; Now have x at fr1; and 1.0 at fr0
3915 (t (inst fstd r)))))
3917 (define-vop (fatan2)
3919 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
3920 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
3921 (:temporary (:sc long-reg :offset fr0-offset
3922 :from (:argument 1) :to :result) fr0)
3923 (:temporary (:sc long-reg :offset fr1-offset
3924 :from (:argument 0) :to :result) fr1)
3925 (:results (r :scs (long-reg)))
3926 (:arg-types long-float long-float)
3927 (:result-types long-float)
3928 (:policy :fast-safe)
3929 (:note "inline atan2 function")
3931 (:save-p :compute-only)
3933 (note-this-location vop :internal-error)
3934 ;; Setup x in fr1 and y in fr0
3936 ;; y in fr0; x in fr1
3937 ((and (sc-is y long-reg) (zerop (tn-offset y))
3938 (sc-is x long-reg) (= 1 (tn-offset x))))
3939 ;; x in fr1; y not in fr0
3940 ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3944 (copy-fp-reg-to-fr0 y))
3947 (inst fldl (ea-for-lf-stack y)))
3950 (inst fldl (ea-for-lf-desc y)))))
3951 ;; y in fr0; x not in fr1
3952 ((and (sc-is y long-reg) (zerop (tn-offset y)))
3954 ;; Now load x to fr0
3957 (copy-fp-reg-to-fr0 x))
3960 (inst fldl (ea-for-lf-stack x)))
3963 (inst fldl (ea-for-lf-desc x))))
3965 ;; y in fr1; x not in fr1
3966 ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3970 (copy-fp-reg-to-fr0 x))
3973 (inst fldl (ea-for-lf-stack x)))
3976 (inst fldl (ea-for-lf-desc x))))
3979 ((and (sc-is x long-reg) (zerop (tn-offset x)))
3981 ;; Now load y to fr0
3984 (copy-fp-reg-to-fr0 y))
3987 (inst fldl (ea-for-lf-stack y)))
3990 (inst fldl (ea-for-lf-desc y)))))
3991 ;; Neither y or x are in either fr0 or fr1
3998 (inst fldd (make-random-tn :kind :normal
3999 :sc (sc-or-lose 'double-reg)
4000 :offset (- (tn-offset x) 2))))
4002 (inst fldl (ea-for-lf-stack x)))
4004 (inst fldl (ea-for-lf-desc x))))
4008 (inst fldd (make-random-tn :kind :normal
4009 :sc (sc-or-lose 'double-reg)
4010 :offset (1- (tn-offset y)))))
4012 (inst fldl (ea-for-lf-stack y)))
4014 (inst fldl (ea-for-lf-desc y))))))
4016 ;; Now have y at fr0; and x at fr1
4021 (t (inst fstd r)))))
4023 ) ; PROGN #!+LONG-FLOAT
4025 ;;;; complex float VOPs
4027 (define-vop (make-complex-single-float)
4028 (:translate complex)
4029 (:args (real :scs (single-reg) :to :result :target r
4030 :load-if (not (location= real r)))
4031 (imag :scs (single-reg) :to :save))
4032 (:arg-types single-float single-float)
4033 (:results (r :scs (complex-single-reg) :from (:argument 0)
4034 :load-if (not (sc-is r complex-single-stack))))
4035 (:result-types complex-single-float)
4036 (:note "inline complex single-float creation")
4037 (:policy :fast-safe)
4041 (let ((r-real (complex-double-reg-real-tn r)))
4042 (unless (location= real r-real)
4043 (cond ((zerop (tn-offset r-real))
4044 (copy-fp-reg-to-fr0 real))
4045 ((zerop (tn-offset real))
4050 (inst fxch real)))))
4051 (let ((r-imag (complex-double-reg-imag-tn r)))
4052 (unless (location= imag r-imag)
4053 (cond ((zerop (tn-offset imag))
4058 (inst fxch imag))))))
4059 (complex-single-stack
4060 (unless (location= real r)
4061 (cond ((zerop (tn-offset real))
4062 (inst fst (ea-for-csf-real-stack r)))
4065 (inst fst (ea-for-csf-real-stack r))
4068 (inst fst (ea-for-csf-imag-stack r))
4069 (inst fxch imag)))))
4071 (define-vop (make-complex-double-float)
4072 (:translate complex)
4073 (:args (real :scs (double-reg) :target r
4074 :load-if (not (location= real r)))
4075 (imag :scs (double-reg) :to :save))
4076 (:arg-types double-float double-float)
4077 (:results (r :scs (complex-double-reg) :from (:argument 0)
4078 :load-if (not (sc-is r complex-double-stack))))
4079 (:result-types complex-double-float)
4080 (:note "inline complex double-float creation")
4081 (:policy :fast-safe)
4085 (let ((r-real (complex-double-reg-real-tn r)))
4086 (unless (location= real r-real)
4087 (cond ((zerop (tn-offset r-real))
4088 (copy-fp-reg-to-fr0 real))
4089 ((zerop (tn-offset real))
4094 (inst fxch real)))))
4095 (let ((r-imag (complex-double-reg-imag-tn r)))
4096 (unless (location= imag r-imag)
4097 (cond ((zerop (tn-offset imag))
4102 (inst fxch imag))))))
4103 (complex-double-stack
4104 (unless (location= real r)
4105 (cond ((zerop (tn-offset real))
4106 (inst fstd (ea-for-cdf-real-stack r)))
4109 (inst fstd (ea-for-cdf-real-stack r))
4112 (inst fstd (ea-for-cdf-imag-stack r))
4113 (inst fxch imag)))))
4116 (define-vop (make-complex-long-float)
4117 (:translate complex)
4118 (:args (real :scs (long-reg) :target r
4119 :load-if (not (location= real r)))
4120 (imag :scs (long-reg) :to :save))
4121 (:arg-types long-float long-float)
4122 (:results (r :scs (complex-long-reg) :from (:argument 0)
4123 :load-if (not (sc-is r complex-long-stack))))
4124 (:result-types complex-long-float)
4125 (:note "inline complex long-float creation")
4126 (:policy :fast-safe)
4130 (let ((r-real (complex-double-reg-real-tn r)))
4131 (unless (location= real r-real)
4132 (cond ((zerop (tn-offset r-real))
4133 (copy-fp-reg-to-fr0 real))
4134 ((zerop (tn-offset real))
4139 (inst fxch real)))))
4140 (let ((r-imag (complex-double-reg-imag-tn r)))
4141 (unless (location= imag r-imag)
4142 (cond ((zerop (tn-offset imag))
4147 (inst fxch imag))))))
4149 (unless (location= real r)
4150 (cond ((zerop (tn-offset real))
4151 (store-long-float (ea-for-clf-real-stack r)))
4154 (store-long-float (ea-for-clf-real-stack r))
4157 (store-long-float (ea-for-clf-imag-stack r))
4158 (inst fxch imag)))))
4161 (define-vop (complex-float-value)
4162 (:args (x :target r))
4164 (:variant-vars offset)
4165 (:policy :fast-safe)
4167 (cond ((sc-is x complex-single-reg complex-double-reg
4168 #!+long-float complex-long-reg)
4170 (make-random-tn :kind :normal
4171 :sc (sc-or-lose 'double-reg)
4172 :offset (+ offset (tn-offset x)))))
4173 (unless (location= value-tn r)
4174 (cond ((zerop (tn-offset r))
4175 (copy-fp-reg-to-fr0 value-tn))
4176 ((zerop (tn-offset value-tn))
4179 (inst fxch value-tn)
4181 (inst fxch value-tn))))))
4182 ((sc-is r single-reg)
4183 (let ((ea (sc-case x
4184 (complex-single-stack
4186 (0 (ea-for-csf-real-stack x))
4187 (1 (ea-for-csf-imag-stack x))))
4190 (0 (ea-for-csf-real-desc x))
4191 (1 (ea-for-csf-imag-desc x)))))))
4192 (with-empty-tn@fp-top(r)
4194 ((sc-is r double-reg)
4195 (let ((ea (sc-case x
4196 (complex-double-stack
4198 (0 (ea-for-cdf-real-stack x))
4199 (1 (ea-for-cdf-imag-stack x))))
4202 (0 (ea-for-cdf-real-desc x))
4203 (1 (ea-for-cdf-imag-desc x)))))))
4204 (with-empty-tn@fp-top(r)
4208 (let ((ea (sc-case x
4211 (0 (ea-for-clf-real-stack x))
4212 (1 (ea-for-clf-imag-stack x))))
4215 (0 (ea-for-clf-real-desc x))
4216 (1 (ea-for-clf-imag-desc x)))))))
4217 (with-empty-tn@fp-top(r)
4219 (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4221 (define-vop (realpart/complex-single-float complex-float-value)
4222 (:translate realpart)
4223 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4225 (:arg-types complex-single-float)
4226 (:results (r :scs (single-reg)))
4227 (:result-types single-float)
4228 (:note "complex float realpart")
4231 (define-vop (realpart/complex-double-float complex-float-value)
4232 (:translate realpart)
4233 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4235 (:arg-types complex-double-float)
4236 (:results (r :scs (double-reg)))
4237 (:result-types double-float)
4238 (:note "complex float realpart")
4242 (define-vop (realpart/complex-long-float complex-float-value)
4243 (:translate realpart)
4244 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4246 (:arg-types complex-long-float)
4247 (:results (r :scs (long-reg)))
4248 (:result-types long-float)
4249 (:note "complex float realpart")
4252 (define-vop (imagpart/complex-single-float complex-float-value)
4253 (:translate imagpart)
4254 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4256 (:arg-types complex-single-float)
4257 (:results (r :scs (single-reg)))
4258 (:result-types single-float)
4259 (:note "complex float imagpart")
4262 (define-vop (imagpart/complex-double-float complex-float-value)
4263 (:translate imagpart)
4264 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4266 (:arg-types complex-double-float)
4267 (:results (r :scs (double-reg)))
4268 (:result-types double-float)
4269 (:note "complex float imagpart")
4273 (define-vop (imagpart/complex-long-float complex-float-value)
4274 (:translate imagpart)
4275 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4277 (:arg-types complex-long-float)
4278 (:results (r :scs (long-reg)))
4279 (:result-types long-float)
4280 (:note "complex float imagpart")
4283 ;;; hack dummy VOPs to bias the representation selection of their
4284 ;;; arguments towards a FP register, which can help avoid consing at
4285 ;;; inappropriate locations
4286 (defknown double-float-reg-bias (double-float) (values))
4287 (define-vop (double-float-reg-bias)
4288 (:translate double-float-reg-bias)
4289 (:args (x :scs (double-reg double-stack) :load-if nil))
4290 (:arg-types double-float)
4291 (:policy :fast-safe)
4292 (:note "inline dummy FP register bias")
4295 (defknown single-float-reg-bias (single-float) (values))
4296 (define-vop (single-float-reg-bias)
4297 (:translate single-float-reg-bias)
4298 (:args (x :scs (single-reg single-stack) :load-if nil))
4299 (:arg-types single-float)
4300 (:policy :fast-safe)
4301 (:note "inline dummy FP register bias")