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")