1;;;; floating point support for the x86
2
3;;;; This software is part of the SBCL system. See the README file for
4;;;; more information.
5;;;;
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.
11
12(in-package "SB!VM")
13
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))
20  #!+long-float
21  (defun ea-for-lf-desc (tn)
22    (ea-for-xf-desc tn long-float-value-slot))
23  ;; complex floats
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))
32  #!+long-float
33  (defun ea-for-clf-real-desc (tn)
34    (ea-for-xf-desc tn complex-long-float-real-slot))
35  #!+long-float
36  (defun ea-for-clf-imag-desc (tn)
37    (ea-for-xf-desc tn complex-long-float-imag-slot)))
38
39(macrolet ((ea-for-xf-stack (tn kind)
40             `(make-ea
41               :dword :base ebp-tn
42               :disp (frame-byte-offset
43                      (+ (tn-offset ,tn)
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))
49  #!+long-float
50  (defun ea-for-lf-stack (tn)
51    (ea-for-xf-stack tn :long)))
52
53;;; Telling the FPU to wait is required in order to make signals occur
54;;; at the expected place, but naturally slows things down.
55;;;
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.
59;;;
60;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
61;;; #'NOTE-NEXT-INSTRUCTION.
62;;;
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))
69  #+nil
70  (when (policy node (or (= debug 3) (> safety speed))))
71  (when note-next-instruction
72    (note-next-instruction note-next-instruction :internal-error))
73  (inst wait))
74
75;;; complex float stack EAs
76(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
77             `(make-ea
78               :dword :base ,base
79               :disp (frame-byte-offset
80                      (+ (tn-offset ,tn)
81                       -1
82                       (* (ecase ,kind
83                            (:single 1)
84                            (:double 2)
85                            (:long 3))
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))
95  #!+long-float
96  (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
97    (ea-for-cxf-stack tn :long :real base))
98  #!+long-float
99  (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
100    (ea-for-cxf-stack tn :long :imag base)))
101
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
105;;; here.
106;;;
107;;; Using a Pop then load.
108(defun copy-fp-reg-to-fr0 (reg)
109  (aver (not (zerop (tn-offset reg))))
110  (inst fstp fr0-tn)
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.
115#+nil
116(defun copy-fp-reg-to-fr0 (reg)
117  (aver (not (zerop (tn-offset reg))))
118  (inst fxch reg)
119  (inst fst  reg))
120
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.
124#!+long-float
125(defun store-long-float (ea)
126   (inst fstpl ea)
127   (inst fldl ea))
128
129;;;; move functions
130
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))))
136
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)))
141        (t
142         (inst fxch x)
143         (inst fst (ea-for-sf-stack y))
144         ;; This may not be necessary as ST0 is likely invalid now.
145         (inst fxch x))))
146
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))))
151
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)))
156        (t
157         (inst fxch x)
158         (inst fstd (ea-for-df-stack y))
159         ;; This may not be necessary as ST0 is likely invalid now.
160         (inst fxch x))))
161
162#!+long-float
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))))
167
168#!+long-float
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)))
173        (t
174         (inst fxch x)
175         (store-long-float (ea-for-lf-stack y))
176         ;; This may not be necessary as ST0 is likely invalid now.
177         (inst fxch x))))
178
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 (tn-value x)))
191    (with-empty-tn@fp-top(y)
192      (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0))
193             (inst fldz))
194            ((= value 1e0)
195             (inst fld1))
196            #!+long-float
197            ((= value (coerce pi *read-default-float-format*))
198             (inst fldpi))
199            #!+long-float
200            ((= value (log 10e0 2e0))
201             (inst fldl2t))
202            #!+long-float
203            ((= value (log 2.718281828459045235360287471352662e0 2e0))
204             (inst fldl2e))
205            #!+long-float
206            ((= value (log 2e0 10e0))
207             (inst fldlg2))
208            #!+long-float
209            ((= value (log 2e0 2.718281828459045235360287471352662e0))
210             (inst fldln2))
211            (t (warn "ignoring bogus i387 constant ~A" value))))))
212
213(define-move-fun (load-fp-immediate 2) (vop x y)
214  ((fp-single-immediate) (single-reg)
215   (fp-double-immediate) (double-reg))
216  (let ((value (register-inline-constant (tn-value x))))
217    (with-empty-tn@fp-top(y)
218      (sc-case y
219        (single-reg
220         (inst fld value))
221        (double-reg
222         (inst fldd value))))))
223(eval-when (:compile-toplevel :execute)
224  (setf *read-default-float-format* 'single-float))
225
226;;;; complex float move functions
227
228(defun complex-single-reg-real-tn (x)
229  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
230                  :offset (tn-offset x)))
231(defun complex-single-reg-imag-tn (x)
232  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
233                  :offset (1+ (tn-offset x))))
234
235(defun complex-double-reg-real-tn (x)
236  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
237                  :offset (tn-offset x)))
238(defun complex-double-reg-imag-tn (x)
239  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
240                  :offset (1+ (tn-offset x))))
241
242#!+long-float
243(defun complex-long-reg-real-tn (x)
244  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
245                  :offset (tn-offset x)))
246#!+long-float
247(defun complex-long-reg-imag-tn (x)
248  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
249                  :offset (1+ (tn-offset x))))
250
251;;; X is source, Y is destination.
252(define-move-fun (load-complex-single 2) (vop x y)
253  ((complex-single-stack) (complex-single-reg))
254  (let ((real-tn (complex-single-reg-real-tn y)))
255    (with-empty-tn@fp-top (real-tn)
256      (inst fld (ea-for-csf-real-stack x))))
257  (let ((imag-tn (complex-single-reg-imag-tn y)))
258    (with-empty-tn@fp-top (imag-tn)
259      (inst fld (ea-for-csf-imag-stack x)))))
260
261(define-move-fun (store-complex-single 2) (vop x y)
262  ((complex-single-reg) (complex-single-stack))
263  (let ((real-tn (complex-single-reg-real-tn x)))
264    (cond ((zerop (tn-offset real-tn))
265           (inst fst (ea-for-csf-real-stack y)))
266          (t
267           (inst fxch real-tn)
268           (inst fst (ea-for-csf-real-stack y))
269           (inst fxch real-tn))))
270  (let ((imag-tn (complex-single-reg-imag-tn x)))
271    (inst fxch imag-tn)
272    (inst fst (ea-for-csf-imag-stack y))
273    (inst fxch imag-tn)))
274
275(define-move-fun (load-complex-double 2) (vop x y)
276  ((complex-double-stack) (complex-double-reg))
277  (let ((real-tn (complex-double-reg-real-tn y)))
278    (with-empty-tn@fp-top(real-tn)
279      (inst fldd (ea-for-cdf-real-stack x))))
280  (let ((imag-tn (complex-double-reg-imag-tn y)))
281    (with-empty-tn@fp-top(imag-tn)
282      (inst fldd (ea-for-cdf-imag-stack x)))))
283
284(define-move-fun (store-complex-double 2) (vop x y)
285  ((complex-double-reg) (complex-double-stack))
286  (let ((real-tn (complex-double-reg-real-tn x)))
287    (cond ((zerop (tn-offset real-tn))
288           (inst fstd (ea-for-cdf-real-stack y)))
289          (t
290           (inst fxch real-tn)
291           (inst fstd (ea-for-cdf-real-stack y))
292           (inst fxch real-tn))))
293  (let ((imag-tn (complex-double-reg-imag-tn x)))
294    (inst fxch imag-tn)
295    (inst fstd (ea-for-cdf-imag-stack y))
296    (inst fxch imag-tn)))
297
298#!+long-float
299(define-move-fun (load-complex-long 2) (vop x y)
300  ((complex-long-stack) (complex-long-reg))
301  (let ((real-tn (complex-long-reg-real-tn y)))
302    (with-empty-tn@fp-top(real-tn)
303      (inst fldl (ea-for-clf-real-stack x))))
304  (let ((imag-tn (complex-long-reg-imag-tn y)))
305    (with-empty-tn@fp-top(imag-tn)
306      (inst fldl (ea-for-clf-imag-stack x)))))
307
308#!+long-float
309(define-move-fun (store-complex-long 2) (vop x y)
310  ((complex-long-reg) (complex-long-stack))
311  (let ((real-tn (complex-long-reg-real-tn x)))
312    (cond ((zerop (tn-offset real-tn))
313           (store-long-float (ea-for-clf-real-stack y)))
314          (t
315           (inst fxch real-tn)
316           (store-long-float (ea-for-clf-real-stack y))
317           (inst fxch real-tn))))
318  (let ((imag-tn (complex-long-reg-imag-tn x)))
319    (inst fxch imag-tn)
320    (store-long-float (ea-for-clf-imag-stack y))
321    (inst fxch imag-tn)))
322
323
324;;;; move VOPs
325
326;;; float register to register moves
327(define-vop (float-move)
328  (:args (x))
329  (:results (y))
330  (:note "float move")
331  (:generator 0
332     (unless (location= x y)
333        (cond ((zerop (tn-offset y))
334               (copy-fp-reg-to-fr0 x))
335              ((zerop (tn-offset x))
336               (inst fstd y))
337              (t
338               (inst fxch x)
339               (inst fstd y)
340               (inst fxch x))))))
341
342(define-vop (single-move float-move)
343  (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
344  (:results (y :scs (single-reg) :load-if (not (location= x y)))))
345(define-move-vop single-move :move (single-reg) (single-reg))
346
347(define-vop (double-move float-move)
348  (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
349  (:results (y :scs (double-reg) :load-if (not (location= x y)))))
350(define-move-vop double-move :move (double-reg) (double-reg))
351
352#!+long-float
353(define-vop (long-move float-move)
354  (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
355  (:results (y :scs (long-reg) :load-if (not (location= x y)))))
356#!+long-float
357(define-move-vop long-move :move (long-reg) (long-reg))
358
359;;; complex float register to register moves
360(define-vop (complex-float-move)
361  (:args (x :target y :load-if (not (location= x y))))
362  (:results (y :load-if (not (location= x y))))
363  (:note "complex float move")
364  (:generator 0
365     (unless (location= x y)
366       ;; Note the complex-float-regs are aligned to every second
367       ;; float register so there is not need to worry about overlap.
368       (let ((x-real (complex-double-reg-real-tn x))
369             (y-real (complex-double-reg-real-tn y)))
370         (cond ((zerop (tn-offset y-real))
371                (copy-fp-reg-to-fr0 x-real))
372               ((zerop (tn-offset x-real))
373                (inst fstd y-real))
374               (t
375                (inst fxch x-real)
376                (inst fstd y-real)
377                (inst fxch x-real))))
378       (let ((x-imag (complex-double-reg-imag-tn x))
379             (y-imag (complex-double-reg-imag-tn y)))
380         (inst fxch x-imag)
381         (inst fstd y-imag)
382         (inst fxch x-imag)))))
383
384(define-vop (complex-single-move complex-float-move)
385  (:args (x :scs (complex-single-reg) :target y
386            :load-if (not (location= x y))))
387  (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
388(define-move-vop complex-single-move :move
389  (complex-single-reg) (complex-single-reg))
390
391(define-vop (complex-double-move complex-float-move)
392  (:args (x :scs (complex-double-reg)
393            :target y :load-if (not (location= x y))))
394  (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
395(define-move-vop complex-double-move :move
396  (complex-double-reg) (complex-double-reg))
397
398#!+long-float
399(define-vop (complex-long-move complex-float-move)
400  (:args (x :scs (complex-long-reg)
401            :target y :load-if (not (location= x y))))
402  (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
403#!+long-float
404(define-move-vop complex-long-move :move
405  (complex-long-reg) (complex-long-reg))
406
407;;; Move from float to a descriptor reg. allocating a new float
408;;; object in the process.
409(define-vop (move-from-single)
410  (:args (x :scs (single-reg) :to :save))
411  (:results (y :scs (descriptor-reg)))
412  (:node-var node)
413  (:note "float to pointer coercion")
414  (:generator 13
415     (with-fixed-allocation (y
416                             single-float-widetag
417                             single-float-size node)
418       ;; w-f-a checks for empty body
419       nil)
420     (with-tn@fp-top(x)
421       (inst fst (ea-for-sf-desc y)))))
422(define-move-vop move-from-single :move
423  (single-reg) (descriptor-reg))
424
425(define-vop (move-from-double)
426  (:args (x :scs (double-reg) :to :save))
427  (:results (y :scs (descriptor-reg)))
428  (:node-var node)
429  (:note "float to pointer coercion")
430  (:generator 13
431     (with-fixed-allocation (y
432                             double-float-widetag
433                             double-float-size
434                             node)
435       nil)
436     (with-tn@fp-top(x)
437       (inst fstd (ea-for-df-desc y)))))
438(define-move-vop move-from-double :move
439  (double-reg) (descriptor-reg))
440
441#!+long-float
442(define-vop (move-from-long)
443  (:args (x :scs (long-reg) :to :save))
444  (:results (y :scs (descriptor-reg)))
445  (:node-var node)
446  (:note "float to pointer coercion")
447  (:generator 13
448     (with-fixed-allocation (y
449                             long-float-widetag
450                             long-float-size
451                             node)
452       nil)
453     (with-tn@fp-top(x)
454       (store-long-float (ea-for-lf-desc y)))))
455#!+long-float
456(define-move-vop move-from-long :move
457  (long-reg) (descriptor-reg))
458
459(define-vop (move-from-fp-constant)
460  (:args (x :scs (fp-constant)))
461  (:results (y :scs (descriptor-reg)))
462  (:generator 2
463     (ecase (sb!c::constant-value (sb!c::tn-leaf x))
464       (0f0 (load-symbol-value y *fp-constant-0f0*))
465       (1f0 (load-symbol-value y *fp-constant-1f0*))
466       (0d0 (load-symbol-value y *fp-constant-0d0*))
467       (1d0 (load-symbol-value y *fp-constant-1d0*))
468       #!+long-float
469       (0l0 (load-symbol-value y *fp-constant-0l0*))
470       #!+long-float
471       (1l0 (load-symbol-value y *fp-constant-1l0*))
472       #!+long-float
473       (#.pi (load-symbol-value y *fp-constant-pi*))
474       #!+long-float
475       (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
476       #!+long-float
477       (#.(log 2.718281828459045235360287471352662L0 2l0)
478          (load-symbol-value y *fp-constant-l2e*))
479       #!+long-float
480       (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
481       #!+long-float
482       (#.(log 2l0 2.718281828459045235360287471352662L0)
483          (load-symbol-value y *fp-constant-ln2*)))))
484(define-move-vop move-from-fp-constant :move
485  (fp-constant) (descriptor-reg))
486
487;;; Move from a descriptor to a float register.
488(define-vop (move-to-single)
489  (:args (x :scs (descriptor-reg)))
490  (:results (y :scs (single-reg)))
491  (:note "pointer to float coercion")
492  (:generator 2
493     (with-empty-tn@fp-top(y)
494       (inst fld (ea-for-sf-desc x)))))
495(define-move-vop move-to-single :move (descriptor-reg) (single-reg))
496
497(define-vop (move-to-double)
498  (:args (x :scs (descriptor-reg)))
499  (:results (y :scs (double-reg)))
500  (:note "pointer to float coercion")
501  (:generator 2
502     (with-empty-tn@fp-top(y)
503       (inst fldd (ea-for-df-desc x)))))
504(define-move-vop move-to-double :move (descriptor-reg) (double-reg))
505
506#!+long-float
507(define-vop (move-to-long)
508  (:args (x :scs (descriptor-reg)))
509  (:results (y :scs (long-reg)))
510  (:note "pointer to float coercion")
511  (:generator 2
512     (with-empty-tn@fp-top(y)
513       (inst fldl (ea-for-lf-desc x)))))
514#!+long-float
515(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
516
517;;; Move from complex float to a descriptor reg. allocating a new
518;;; complex float object in the process.
519(define-vop (move-from-complex-single)
520  (:args (x :scs (complex-single-reg) :to :save))
521  (:results (y :scs (descriptor-reg)))
522  (:node-var node)
523  (:note "complex float to pointer coercion")
524  (:generator 13
525    (with-fixed-allocation (y
526                            complex-single-float-widetag
527                            complex-single-float-size
528                            node)
529      (let ((real-tn (complex-single-reg-real-tn x)))
530        (with-tn@fp-top(real-tn)
531          (inst fst (ea-for-csf-real-desc y))))
532      (let ((imag-tn (complex-single-reg-imag-tn x)))
533        (with-tn@fp-top(imag-tn)
534          (inst fst (ea-for-csf-imag-desc y)))))))
535(define-move-vop move-from-complex-single :move
536  (complex-single-reg) (descriptor-reg))
537
538(define-vop (move-from-complex-double)
539  (:args (x :scs (complex-double-reg) :to :save))
540  (:results (y :scs (descriptor-reg)))
541  (:node-var node)
542  (:note "complex float to pointer coercion")
543  (:generator 13
544     (with-fixed-allocation (y
545                             complex-double-float-widetag
546                             complex-double-float-size
547                             node)
548       (let ((real-tn (complex-double-reg-real-tn x)))
549         (with-tn@fp-top(real-tn)
550           (inst fstd (ea-for-cdf-real-desc y))))
551       (let ((imag-tn (complex-double-reg-imag-tn x)))
552         (with-tn@fp-top(imag-tn)
553           (inst fstd (ea-for-cdf-imag-desc y)))))))
554(define-move-vop move-from-complex-double :move
555  (complex-double-reg) (descriptor-reg))
556
557#!+long-float
558(define-vop (move-from-complex-long)
559  (:args (x :scs (complex-long-reg) :to :save))
560  (:results (y :scs (descriptor-reg)))
561  (:node-var node)
562  (:note "complex float to pointer coercion")
563  (:generator 13
564     (with-fixed-allocation (y
565                             complex-long-float-widetag
566                             complex-long-float-size
567                             node)
568       (let ((real-tn (complex-long-reg-real-tn x)))
569         (with-tn@fp-top(real-tn)
570           (store-long-float (ea-for-clf-real-desc y))))
571       (let ((imag-tn (complex-long-reg-imag-tn x)))
572         (with-tn@fp-top(imag-tn)
573           (store-long-float (ea-for-clf-imag-desc y)))))))
574#!+long-float
575(define-move-vop move-from-complex-long :move
576  (complex-long-reg) (descriptor-reg))
577
578;;; Move from a descriptor to a complex float register.
579(macrolet ((frob (name sc format)
580             `(progn
581                (define-vop (,name)
582                  (:args (x :scs (descriptor-reg)))
583                  (:results (y :scs (,sc)))
584                  (:note "pointer to complex float coercion")
585                  (:generator 2
586                    (let ((real-tn (complex-double-reg-real-tn y)))
587                      (with-empty-tn@fp-top(real-tn)
588                        ,@(ecase format
589                           (:single '((inst fld (ea-for-csf-real-desc x))))
590                           (:double '((inst fldd (ea-for-cdf-real-desc x))))
591                           #!+long-float
592                           (:long '((inst fldl (ea-for-clf-real-desc x)))))))
593                    (let ((imag-tn (complex-double-reg-imag-tn y)))
594                      (with-empty-tn@fp-top(imag-tn)
595                        ,@(ecase format
596                           (:single '((inst fld (ea-for-csf-imag-desc x))))
597                           (:double '((inst fldd (ea-for-cdf-imag-desc x))))
598                           #!+long-float
599                           (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
600                (define-move-vop ,name :move (descriptor-reg) (,sc)))))
601          (frob move-to-complex-single complex-single-reg :single)
602          (frob move-to-complex-double complex-double-reg :double)
603          #!+long-float
604          (frob move-to-complex-double complex-long-reg :long))
605
606;;;; the move argument vops
607;;;;
608;;;; Note these are also used to stuff fp numbers onto the c-call
609;;;; stack so the order is different than the lisp-stack.
610
611;;; the general MOVE-ARG VOP
612(macrolet ((frob (name sc stack-sc format)
613             `(progn
614                (define-vop (,name)
615                  (:args (x :scs (,sc) :target y)
616                         (fp :scs (any-reg)
617                             :load-if (not (sc-is y ,sc))))
618                  (:results (y))
619                  (:note "float argument move")
620                  (:generator ,(case format (:single 2) (:double 3) (:long 4))
621                    (sc-case y
622                      (,sc
623                       (unless (location= x y)
624                          (cond ((zerop (tn-offset y))
625                                 (copy-fp-reg-to-fr0 x))
626                                ((zerop (tn-offset x))
627                                 (inst fstd y))
628                                (t
629                                 (inst fxch x)
630                                 (inst fstd y)
631                                 (inst fxch x)))))
632                      (,stack-sc
633                       (if (= (tn-offset fp) esp-offset)
634                           ;; C-call
635                           (let* ((offset (* (tn-offset y) n-word-bytes))
636                                  (ea (make-ea :dword :base fp :disp offset)))
637                             (with-tn@fp-top(x)
638                                ,@(ecase format
639                                         (:single '((inst fst ea)))
640                                         (:double '((inst fstd ea)))
641                                         #!+long-float
642                                         (:long '((store-long-float ea))))))
643                           ;; Lisp stack
644                           (let ((ea (make-ea
645                                      :dword :base fp
646                                      :disp (frame-byte-offset
647                                             (+ (tn-offset y)
648                                                ,(case format
649                                                       (:single 0)
650                                                       (:double 1)
651                                                       (:long 2)))))))
652                             (with-tn@fp-top(x)
653                               ,@(ecase format
654                                    (:single '((inst fst  ea)))
655                                    (:double '((inst fstd ea)))
656                                    #!+long-float
657                                    (:long '((store-long-float ea)))))))))))
658                (define-move-vop ,name :move-arg
659                  (,sc descriptor-reg) (,sc)))))
660  (frob move-single-float-arg single-reg single-stack :single)
661  (frob move-double-float-arg double-reg double-stack :double)
662  #!+long-float
663  (frob move-long-float-arg long-reg long-stack :long))
664
665;;;; complex float MOVE-ARG VOP
666(macrolet ((frob (name sc stack-sc format)
667             `(progn
668                (define-vop (,name)
669                  (:args (x :scs (,sc) :target y)
670                         (fp :scs (any-reg)
671                             :load-if (not (sc-is y ,sc))))
672                  (:results (y))
673                  (:note "complex float argument move")
674                  (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
675                    (sc-case y
676                      (,sc
677                       (unless (location= x y)
678                         (let ((x-real (complex-double-reg-real-tn x))
679                               (y-real (complex-double-reg-real-tn y)))
680                           (cond ((zerop (tn-offset y-real))
681                                  (copy-fp-reg-to-fr0 x-real))
682                                 ((zerop (tn-offset x-real))
683                                  (inst fstd y-real))
684                                 (t
685                                  (inst fxch x-real)
686                                  (inst fstd y-real)
687                                  (inst fxch x-real))))
688                         (let ((x-imag (complex-double-reg-imag-tn x))
689                               (y-imag (complex-double-reg-imag-tn y)))
690                           (inst fxch x-imag)
691                           (inst fstd y-imag)
692                           (inst fxch x-imag))))
693                      (,stack-sc
694                       (let ((real-tn (complex-double-reg-real-tn x)))
695                         (cond ((zerop (tn-offset real-tn))
696                                ,@(ecase format
697                                    (:single
698                                     '((inst fst
699                                        (ea-for-csf-real-stack y fp))))
700                                    (:double
701                                     '((inst fstd
702                                        (ea-for-cdf-real-stack y fp))))
703                                    #!+long-float
704                                    (:long
705                                     '((store-long-float
706                                        (ea-for-clf-real-stack y fp))))))
707                               (t
708                                (inst fxch real-tn)
709                                ,@(ecase format
710                                    (:single
711                                     '((inst fst
712                                        (ea-for-csf-real-stack y fp))))
713                                    (:double
714                                     '((inst fstd
715                                        (ea-for-cdf-real-stack y fp))))
716                                    #!+long-float
717                                    (:long
718                                     '((store-long-float
719                                        (ea-for-clf-real-stack y fp)))))
720                                (inst fxch real-tn))))
721                       (let ((imag-tn (complex-double-reg-imag-tn x)))
722                         (inst fxch imag-tn)
723                         ,@(ecase format
724                             (:single
725                              '((inst fst (ea-for-csf-imag-stack y fp))))
726                             (:double
727                              '((inst fstd (ea-for-cdf-imag-stack y fp))))
728                             #!+long-float
729                             (:long
730                              '((store-long-float
731                                 (ea-for-clf-imag-stack y fp)))))
732                         (inst fxch imag-tn))))))
733                (define-move-vop ,name :move-arg
734                  (,sc descriptor-reg) (,sc)))))
735  (frob move-complex-single-float-arg
736        complex-single-reg complex-single-stack :single)
737  (frob move-complex-double-float-arg
738        complex-double-reg complex-double-stack :double)
739  #!+long-float
740  (frob move-complex-long-float-arg
741        complex-long-reg complex-long-stack :long))
742
743(define-move-vop move-arg :move-arg
744  (single-reg double-reg #!+long-float long-reg
745   complex-single-reg complex-double-reg #!+long-float complex-long-reg)
746  (descriptor-reg))
747
748
749;;;; arithmetic VOPs
750
751;;; dtc: the floating point arithmetic vops
752;;;
753;;; Note: Although these can accept x and y on the stack or pointed to
754;;; from a descriptor register, they will work with register loading
755;;; without these. Same deal with the result - it need only be a
756;;; register. When load-tns are needed they will probably be in ST0
757;;; and the code below should be able to correctly handle all cases.
758;;;
759;;; However it seems to produce better code if all arg. and result
760;;; options are used; on the P86 there is no extra cost in using a
761;;; memory operand to the FP instructions - not so on the PPro.
762;;;
763;;; It may also be useful to handle constant args?
764;;;
765;;; 22-Jul-97: descriptor args lose in some simple cases when
766;;; a function result computed in a loop. Then Python insists
767;;; on consing the intermediate values! For example
768;;;
769;;; (defun test(a n)
770;;;   (declare (type (simple-array double-float (*)) a)
771;;;        (fixnum n))
772;;;   (let ((sum 0d0))
773;;;     (declare (type double-float sum))
774;;;   (dotimes (i n)
775;;;     (incf sum (* (aref a i)(aref a i))))
776;;;     sum))
777;;;
778;;; So, disabling descriptor args until this can be fixed elsewhere.
779(macrolet
780    ((frob (op fop-sti fopr-sti
781               fop fopr sname scost
782               fopd foprd dname dcost
783               lname lcost)
784       #!-long-float (declare (ignore lcost lname))
785       `(progn
786         (define-vop (,sname)
787           (:translate ,op)
788           (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
789                     :to :eval)
790                  (y :scs (single-reg single-stack #+nil descriptor-reg)
791                     :to :eval))
792           (:temporary (:sc single-reg :offset fr0-offset
793                            :from :eval :to :result) fr0)
794           (:results (r :scs (single-reg single-stack)))
795           (:arg-types single-float single-float)
796           (:result-types single-float)
797           (:policy :fast-safe)
798           (:note "inline float arithmetic")
799           (:vop-var vop)
800           (:save-p :compute-only)
801           (:node-var node)
802           (:generator ,scost
803             ;; Handle a few special cases
804             (cond
805              ;; x, y, and r are the same register.
806              ((and (sc-is x single-reg) (location= x r) (location= y r))
807               (cond ((zerop (tn-offset r))
808                      (inst ,fop fr0))
809                     (t
810                      (inst fxch r)
811                      (inst ,fop fr0)
812                      ;; XX the source register will not be valid.
813                      (note-next-instruction vop :internal-error)
814                      (inst fxch r))))
815
816              ;; x and r are the same register.
817              ((and (sc-is x single-reg) (location= x r))
818               (cond ((zerop (tn-offset r))
819                      (sc-case y
820                         (single-reg
821                          ;; ST(0) = ST(0) op ST(y)
822                          (inst ,fop y))
823                         (single-stack
824                          ;; ST(0) = ST(0) op Mem
825                          (inst ,fop (ea-for-sf-stack y)))
826                         (descriptor-reg
827                          (inst ,fop (ea-for-sf-desc y)))))
828                     (t
829                      ;; y to ST0
830                      (sc-case y
831                         (single-reg
832                          (unless (zerop (tn-offset y))
833                                  (copy-fp-reg-to-fr0 y)))
834                         ((single-stack descriptor-reg)
835                          (inst fstp fr0)
836                          (if (sc-is y single-stack)
837                              (inst fld (ea-for-sf-stack y))
838                            (inst fld (ea-for-sf-desc y)))))
839                      ;; ST(i) = ST(i) op ST0
840                      (inst ,fop-sti r)))
841               (maybe-fp-wait node vop))
842              ;; y and r are the same register.
843              ((and (sc-is y single-reg) (location= y r))
844               (cond ((zerop (tn-offset r))
845                      (sc-case x
846                         (single-reg
847                          ;; ST(0) = ST(x) op ST(0)
848                          (inst ,fopr x))
849                         (single-stack
850                          ;; ST(0) = Mem op ST(0)
851                          (inst ,fopr (ea-for-sf-stack x)))
852                         (descriptor-reg
853                          (inst ,fopr (ea-for-sf-desc x)))))
854                     (t
855                      ;; x to ST0
856                      (sc-case x
857                        (single-reg
858                         (unless (zerop (tn-offset x))
859                                 (copy-fp-reg-to-fr0 x)))
860                        ((single-stack descriptor-reg)
861                         (inst fstp fr0)
862                         (if (sc-is x single-stack)
863                             (inst fld (ea-for-sf-stack x))
864                           (inst fld (ea-for-sf-desc x)))))
865                      ;; ST(i) = ST(0) op ST(i)
866                      (inst ,fopr-sti r)))
867               (maybe-fp-wait node vop))
868              ;; the default case
869              (t
870               ;; Get the result to ST0.
871
872               ;; Special handling is needed if x or y are in ST0, and
873               ;; simpler code is generated.
874               (cond
875                ;; x is in ST0
876                ((and (sc-is x single-reg) (zerop (tn-offset x)))
877                 ;; ST0 = ST0 op y
878                 (sc-case y
879                   (single-reg
880                    (inst ,fop y))
881                   (single-stack
882                    (inst ,fop (ea-for-sf-stack y)))
883                   (descriptor-reg
884                    (inst ,fop (ea-for-sf-desc y)))))
885                ;; y is in ST0
886                ((and (sc-is y single-reg) (zerop (tn-offset y)))
887                 ;; ST0 = x op ST0
888                 (sc-case x
889                   (single-reg
890                    (inst ,fopr x))
891                   (single-stack
892                    (inst ,fopr (ea-for-sf-stack x)))
893                   (descriptor-reg
894                    (inst ,fopr (ea-for-sf-desc x)))))
895                (t
896                 ;; x to ST0
897                 (sc-case x
898                   (single-reg
899                    (copy-fp-reg-to-fr0 x))
900                   (single-stack
901                    (inst fstp fr0)
902                    (inst fld (ea-for-sf-stack x)))
903                   (descriptor-reg
904                    (inst fstp fr0)
905                    (inst fld (ea-for-sf-desc x))))
906                 ;; ST0 = ST0 op y
907                 (sc-case y
908                   (single-reg
909                    (inst ,fop y))
910                   (single-stack
911                    (inst ,fop (ea-for-sf-stack y)))
912                   (descriptor-reg
913                    (inst ,fop (ea-for-sf-desc y))))))
914
915               (note-next-instruction vop :internal-error)
916
917               ;; Finally save the result.
918               (sc-case r
919                 (single-reg
920                  (cond ((zerop (tn-offset r))
921                         (maybe-fp-wait node))
922                        (t
923                         (inst fst r))))
924                 (single-stack
925                  (inst fst (ea-for-sf-stack r))))))))
926
927         (define-vop (,dname)
928           (:translate ,op)
929           (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
930                     :to :eval)
931                  (y :scs (double-reg double-stack #+nil descriptor-reg)
932                     :to :eval))
933           (:temporary (:sc double-reg :offset fr0-offset
934                            :from :eval :to :result) fr0)
935           (:results (r :scs (double-reg double-stack)))
936           (:arg-types double-float double-float)
937           (:result-types double-float)
938           (:policy :fast-safe)
939           (:note "inline float arithmetic")
940           (:vop-var vop)
941           (:save-p :compute-only)
942           (:node-var node)
943           (:generator ,dcost
944             ;; Handle a few special cases.
945             (cond
946              ;; x, y, and r are the same register.
947              ((and (sc-is x double-reg) (location= x r) (location= y r))
948               (cond ((zerop (tn-offset r))
949                      (inst ,fop fr0))
950                     (t
951                      (inst fxch x)
952                      (inst ,fopd fr0)
953                      ;; XX the source register will not be valid.
954                      (note-next-instruction vop :internal-error)
955                      (inst fxch r))))
956
957              ;; x and r are the same register.
958              ((and (sc-is x double-reg) (location= x r))
959               (cond ((zerop (tn-offset r))
960                      (sc-case y
961                         (double-reg
962                          ;; ST(0) = ST(0) op ST(y)
963                          (inst ,fopd y))
964                         (double-stack
965                          ;; ST(0) = ST(0) op Mem
966                          (inst ,fopd (ea-for-df-stack y)))
967                         (descriptor-reg
968                          (inst ,fopd (ea-for-df-desc y)))))
969                     (t
970                      ;; y to ST0
971                      (sc-case y
972                         (double-reg
973                          (unless (zerop (tn-offset y))
974                                  (copy-fp-reg-to-fr0 y)))
975                         ((double-stack descriptor-reg)
976                          (inst fstp fr0)
977                          (if (sc-is y double-stack)
978                              (inst fldd (ea-for-df-stack y))
979                            (inst fldd (ea-for-df-desc y)))))
980                      ;; ST(i) = ST(i) op ST0
981                      (inst ,fop-sti r)))
982               (maybe-fp-wait node vop))
983              ;; y and r are the same register.
984              ((and (sc-is y double-reg) (location= y r))
985               (cond ((zerop (tn-offset r))
986                      (sc-case x
987                         (double-reg
988                          ;; ST(0) = ST(x) op ST(0)
989                          (inst ,foprd x))
990                         (double-stack
991                          ;; ST(0) = Mem op ST(0)
992                          (inst ,foprd (ea-for-df-stack x)))
993                         (descriptor-reg
994                          (inst ,foprd (ea-for-df-desc x)))))
995                     (t
996                      ;; x to ST0
997                      (sc-case x
998                         (double-reg
999                          (unless (zerop (tn-offset x))
1000                                  (copy-fp-reg-to-fr0 x)))
1001                         ((double-stack descriptor-reg)
1002                          (inst fstp fr0)
1003                          (if (sc-is x double-stack)
1004                              (inst fldd (ea-for-df-stack x))
1005                            (inst fldd (ea-for-df-desc x)))))
1006                      ;; ST(i) = ST(0) op ST(i)
1007                      (inst ,fopr-sti r)))
1008               (maybe-fp-wait node vop))
1009              ;; the default case
1010              (t
1011               ;; Get the result to ST0.
1012
1013               ;; Special handling is needed if x or y are in ST0, and
1014               ;; simpler code is generated.
1015               (cond
1016                ;; x is in ST0
1017                ((and (sc-is x double-reg) (zerop (tn-offset x)))
1018                 ;; ST0 = ST0 op y
1019                 (sc-case y
1020                   (double-reg
1021                    (inst ,fopd y))
1022                   (double-stack
1023                    (inst ,fopd (ea-for-df-stack y)))
1024                   (descriptor-reg
1025                    (inst ,fopd (ea-for-df-desc y)))))
1026                ;; y is in ST0
1027                ((and (sc-is y double-reg) (zerop (tn-offset y)))
1028                 ;; ST0 = x op ST0
1029                 (sc-case x
1030                   (double-reg
1031                    (inst ,foprd x))
1032                   (double-stack
1033                    (inst ,foprd (ea-for-df-stack x)))
1034                   (descriptor-reg
1035                    (inst ,foprd (ea-for-df-desc x)))))
1036                (t
1037                 ;; x to ST0
1038                 (sc-case x
1039                   (double-reg
1040                    (copy-fp-reg-to-fr0 x))
1041                   (double-stack
1042                    (inst fstp fr0)
1043                    (inst fldd (ea-for-df-stack x)))
1044                   (descriptor-reg
1045                    (inst fstp fr0)
1046                    (inst fldd (ea-for-df-desc x))))
1047                 ;; ST0 = ST0 op y
1048                 (sc-case y
1049                   (double-reg
1050                    (inst ,fopd y))
1051                   (double-stack
1052                    (inst ,fopd (ea-for-df-stack y)))
1053                   (descriptor-reg
1054                    (inst ,fopd (ea-for-df-desc y))))))
1055
1056               (note-next-instruction vop :internal-error)
1057
1058               ;; Finally save the result.
1059               (sc-case r
1060                 (double-reg
1061                  (cond ((zerop (tn-offset r))
1062                         (maybe-fp-wait node))
1063                        (t
1064                         (inst fst r))))
1065                 (double-stack
1066                  (inst fstd (ea-for-df-stack r))))))))
1067
1068         #!+long-float
1069         (define-vop (,lname)
1070           (:translate ,op)
1071           (:args (x :scs (long-reg) :to :eval)
1072                  (y :scs (long-reg) :to :eval))
1073           (:temporary (:sc long-reg :offset fr0-offset
1074                            :from :eval :to :result) fr0)
1075           (:results (r :scs (long-reg)))
1076           (:arg-types long-float long-float)
1077           (:result-types long-float)
1078           (:policy :fast-safe)
1079           (:note "inline float arithmetic")
1080           (:vop-var vop)
1081           (:save-p :compute-only)
1082           (:node-var node)
1083           (:generator ,lcost
1084             ;; Handle a few special cases.
1085             (cond
1086              ;; x, y, and r are the same register.
1087              ((and (location= x r) (location= y r))
1088               (cond ((zerop (tn-offset r))
1089                      (inst ,fop fr0))
1090                     (t
1091                      (inst fxch x)
1092                      (inst ,fopd fr0)
1093                      ;; XX the source register will not be valid.
1094                      (note-next-instruction vop :internal-error)
1095                      (inst fxch r))))
1096
1097              ;; x and r are the same register.
1098              ((location= x r)
1099               (cond ((zerop (tn-offset r))
1100                      ;; ST(0) = ST(0) op ST(y)
1101                      (inst ,fopd y))
1102                     (t
1103                      ;; y to ST0
1104                      (unless (zerop (tn-offset y))
1105                        (copy-fp-reg-to-fr0 y))
1106                      ;; ST(i) = ST(i) op ST0
1107                      (inst ,fop-sti r)))
1108               (maybe-fp-wait node vop))
1109              ;; y and r are the same register.
1110              ((location= y r)
1111               (cond ((zerop (tn-offset r))
1112                      ;; ST(0) = ST(x) op ST(0)
1113                      (inst ,foprd x))
1114                     (t
1115                      ;; x to ST0
1116                      (unless (zerop (tn-offset x))
1117                        (copy-fp-reg-to-fr0 x))
1118                      ;; ST(i) = ST(0) op ST(i)
1119                      (inst ,fopr-sti r)))
1120               (maybe-fp-wait node vop))
1121              ;; the default case
1122              (t
1123               ;; Get the result to ST0.
1124
1125               ;; Special handling is needed if x or y are in ST0, and
1126               ;; simpler code is generated.
1127               (cond
1128                ;; x is in ST0.
1129                ((zerop (tn-offset x))
1130                 ;; ST0 = ST0 op y
1131                 (inst ,fopd y))
1132                ;; y is in ST0
1133                ((zerop (tn-offset y))
1134                 ;; ST0 = x op ST0
1135                 (inst ,foprd x))
1136                (t
1137                 ;; x to ST0
1138                 (copy-fp-reg-to-fr0 x)
1139                 ;; ST0 = ST0 op y
1140                 (inst ,fopd y)))
1141
1142               (note-next-instruction vop :internal-error)
1143
1144               ;; Finally save the result.
1145               (cond ((zerop (tn-offset r))
1146                      (maybe-fp-wait node))
1147                     (t
1148                      (inst fst r))))))))))
1149
1150    (frob + fadd-sti fadd-sti
1151          fadd fadd +/single-float 2
1152          faddd faddd +/double-float 2
1153          +/long-float 2)
1154    (frob - fsub-sti fsubr-sti
1155          fsub fsubr -/single-float 2
1156          fsubd fsubrd -/double-float 2
1157          -/long-float 2)
1158    (frob * fmul-sti fmul-sti
1159          fmul fmul */single-float 3
1160          fmuld fmuld */double-float 3
1161          */long-float 3)
1162    (frob / fdiv-sti fdivr-sti
1163          fdiv fdivr //single-float 12
1164          fdivd fdivrd //double-float 12
1165          //long-float 12))
1166
1167(macrolet ((frob (name inst translate sc type)
1168             `(define-vop (,name)
1169               (:args (x :scs (,sc) :target fr0))
1170               (:results (y :scs (,sc)))
1171               (:translate ,translate)
1172               (:policy :fast-safe)
1173               (:arg-types ,type)
1174               (:result-types ,type)
1175               (:temporary (:sc double-reg :offset fr0-offset
1176                                :from :argument :to :result) fr0)
1177               (:ignore fr0)
1178               (:note "inline float arithmetic")
1179               (:vop-var vop)
1180               (:save-p :compute-only)
1181               (:generator 1
1182                (note-this-location vop :internal-error)
1183                (unless (zerop (tn-offset x))
1184                  (inst fxch x)         ; x to top of stack
1185                  (unless (location= x y)
1186                    (inst fst x)))      ; Maybe save it.
1187                (inst ,inst)            ; Clobber st0.
1188                (unless (zerop (tn-offset y))
1189                  (inst fst y))))))
1190
1191  (frob abs/single-float fabs abs single-reg single-float)
1192  (frob abs/double-float fabs abs double-reg double-float)
1193  #!+long-float
1194  (frob abs/long-float fabs abs long-reg long-float)
1195  (frob %negate/single-float fchs %negate single-reg single-float)
1196  (frob %negate/double-float fchs %negate double-reg double-float)
1197  #!+long-float
1198  (frob %negate/long-float fchs %negate long-reg long-float))
1199
1200;;;; comparison
1201
1202(define-vop (=/float)
1203  (:args (x) (y))
1204  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1205  (:conditional :e)
1206  (:policy :fast-safe)
1207  (:vop-var vop)
1208  (:save-p :compute-only)
1209  (:note "inline float comparison")
1210  (:ignore temp)
1211  (:generator 3
1212     (note-this-location vop :internal-error)
1213     (cond
1214      ;; x is in ST0; y is in any reg.
1215      ((zerop (tn-offset x))
1216       (inst fucom y))
1217      ;; y is in ST0; x is in another reg.
1218      ((zerop (tn-offset y))
1219       (inst fucom x))
1220      ;; x and y are the same register, not ST0
1221      ((location= x y)
1222       (inst fxch x)
1223       (inst fucom fr0-tn)
1224       (inst fxch x))
1225      ;; x and y are different registers, neither ST0.
1226      (t
1227       (inst fxch x)
1228       (inst fucom y)
1229       (inst fxch x)))
1230     (inst fnstsw)                      ; status word to ax
1231     (inst and ah-tn #x45)              ; C3 C2 C0
1232     (inst cmp ah-tn #x40)))
1233
1234(define-vop (=/single-float =/float)
1235  (:translate =)
1236  (:args (x :scs (single-reg))
1237         (y :scs (single-reg)))
1238  (:arg-types single-float single-float))
1239
1240(define-vop (=/double-float =/float)
1241  (:translate =)
1242  (:args (x :scs (double-reg))
1243         (y :scs (double-reg)))
1244  (:arg-types double-float double-float))
1245
1246#!+long-float
1247(define-vop (=/long-float =/float)
1248  (:translate =)
1249  (:args (x :scs (long-reg))
1250         (y :scs (long-reg)))
1251  (:arg-types long-float long-float))
1252
1253(define-vop (<single-float)
1254  (:translate <)
1255  (:args (x :scs (single-reg single-stack descriptor-reg))
1256         (y :scs (single-reg single-stack descriptor-reg)))
1257  (:arg-types single-float single-float)
1258  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1259  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1260  (:conditional :e)
1261  (:policy :fast-safe)
1262  (:note "inline float comparison")
1263  (:ignore temp)
1264  (:generator 3
1265    ;; Handle a few special cases.
1266    (cond
1267     ;; y is ST0.
1268     ((and (sc-is y single-reg) (zerop (tn-offset y)))
1269      (sc-case x
1270        (single-reg
1271         (inst fcom x))
1272        ((single-stack descriptor-reg)
1273         (if (sc-is x single-stack)
1274             (inst fcom (ea-for-sf-stack x))
1275           (inst fcom (ea-for-sf-desc x)))))
1276      (inst fnstsw)                     ; status word to ax
1277      (inst and ah-tn #x45))
1278
1279     ;; general case when y is not in ST0
1280     (t
1281      ;; x to ST0
1282      (sc-case x
1283         (single-reg
1284          (unless (zerop (tn-offset x))
1285                  (copy-fp-reg-to-fr0 x)))
1286         ((single-stack descriptor-reg)
1287          (inst fstp fr0)
1288          (if (sc-is x single-stack)
1289              (inst fld (ea-for-sf-stack x))
1290            (inst fld (ea-for-sf-desc x)))))
1291      (sc-case y
1292        (single-reg
1293         (inst fcom y))
1294        ((single-stack descriptor-reg)
1295         (if (sc-is y single-stack)
1296             (inst fcom (ea-for-sf-stack y))
1297           (inst fcom (ea-for-sf-desc y)))))
1298      (inst fnstsw)                     ; status word to ax
1299      (inst and ah-tn #x45)             ; C3 C2 C0
1300      (inst cmp ah-tn #x01)))))
1301
1302(define-vop (<double-float)
1303  (:translate <)
1304  (:args (x :scs (double-reg double-stack descriptor-reg))
1305         (y :scs (double-reg double-stack descriptor-reg)))
1306  (:arg-types double-float double-float)
1307  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1308  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1309  (:conditional :e)
1310  (:policy :fast-safe)
1311  (:note "inline float comparison")
1312  (:ignore temp)
1313  (:generator 3
1314    ;; Handle a few special cases
1315    (cond
1316     ;; y is ST0.
1317     ((and (sc-is y double-reg) (zerop (tn-offset y)))
1318      (sc-case x
1319        (double-reg
1320         (inst fcomd x))
1321        ((double-stack descriptor-reg)
1322         (if (sc-is x double-stack)
1323             (inst fcomd (ea-for-df-stack x))
1324           (inst fcomd (ea-for-df-desc x)))))
1325      (inst fnstsw)                     ; status word to ax
1326      (inst and ah-tn #x45))
1327
1328     ;; General case when y is not in ST0.
1329     (t
1330      ;; x to ST0
1331      (sc-case x
1332         (double-reg
1333          (unless (zerop (tn-offset x))
1334                  (copy-fp-reg-to-fr0 x)))
1335         ((double-stack descriptor-reg)
1336          (inst fstp fr0)
1337          (if (sc-is x double-stack)
1338              (inst fldd (ea-for-df-stack x))
1339            (inst fldd (ea-for-df-desc x)))))
1340      (sc-case y
1341        (double-reg
1342         (inst fcomd y))
1343        ((double-stack descriptor-reg)
1344         (if (sc-is y double-stack)
1345             (inst fcomd (ea-for-df-stack y))
1346           (inst fcomd (ea-for-df-desc y)))))
1347      (inst fnstsw)                     ; status word to ax
1348      (inst and ah-tn #x45)             ; C3 C2 C0
1349      (inst cmp ah-tn #x01)))))
1350
1351#!+long-float
1352(define-vop (<long-float)
1353  (:translate <)
1354  (:args (x :scs (long-reg))
1355         (y :scs (long-reg)))
1356  (:arg-types long-float long-float)
1357  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1358  (:conditional :e)
1359  (:policy :fast-safe)
1360  (:note "inline float comparison")
1361  (:ignore temp)
1362  (:generator 3
1363    (cond
1364      ;; x is in ST0; y is in any reg.
1365      ((zerop (tn-offset x))
1366       (inst fcomd y)
1367       (inst fnstsw)                    ; status word to ax
1368       (inst and ah-tn #x45)            ; C3 C2 C0
1369       (inst cmp ah-tn #x01))
1370      ;; y is in ST0; x is in another reg.
1371      ((zerop (tn-offset y))
1372       (inst fcomd x)
1373       (inst fnstsw)                    ; status word to ax
1374       (inst and ah-tn #x45))
1375      ;; x and y are the same register, not ST0
1376      ;; x and y are different registers, neither ST0.
1377      (t
1378       (inst fxch y)
1379       (inst fcomd x)
1380       (inst fxch y)
1381       (inst fnstsw)                    ; status word to ax
1382       (inst and ah-tn #x45)))))        ; C3 C2 C0
1383
1384
1385(define-vop (>single-float)
1386  (:translate >)
1387  (:args (x :scs (single-reg single-stack descriptor-reg))
1388         (y :scs (single-reg single-stack descriptor-reg)))
1389  (:arg-types single-float single-float)
1390  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1391  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1392  (:conditional :e)
1393  (:policy :fast-safe)
1394  (:note "inline float comparison")
1395  (:ignore temp)
1396  (:generator 3
1397    ;; Handle a few special cases.
1398    (cond
1399     ;; y is ST0.
1400     ((and (sc-is y single-reg) (zerop (tn-offset y)))
1401      (sc-case x
1402        (single-reg
1403         (inst fcom x))
1404        ((single-stack descriptor-reg)
1405         (if (sc-is x single-stack)
1406             (inst fcom (ea-for-sf-stack x))
1407           (inst fcom (ea-for-sf-desc x)))))
1408      (inst fnstsw)                     ; status word to ax
1409      (inst and ah-tn #x45)
1410      (inst cmp ah-tn #x01))
1411
1412     ;; general case when y is not in ST0
1413     (t
1414      ;; x to ST0
1415      (sc-case x
1416         (single-reg
1417          (unless (zerop (tn-offset x))
1418                  (copy-fp-reg-to-fr0 x)))
1419         ((single-stack descriptor-reg)
1420          (inst fstp fr0)
1421          (if (sc-is x single-stack)
1422              (inst fld (ea-for-sf-stack x))
1423            (inst fld (ea-for-sf-desc x)))))
1424      (sc-case y
1425        (single-reg
1426         (inst fcom y))
1427        ((single-stack descriptor-reg)
1428         (if (sc-is y single-stack)
1429             (inst fcom (ea-for-sf-stack y))
1430           (inst fcom (ea-for-sf-desc y)))))
1431      (inst fnstsw)                     ; status word to ax
1432      (inst and ah-tn #x45)))))
1433
1434(define-vop (>double-float)
1435  (:translate >)
1436  (:args (x :scs (double-reg double-stack descriptor-reg))
1437         (y :scs (double-reg double-stack descriptor-reg)))
1438  (:arg-types double-float double-float)
1439  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1440  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1441  (:conditional :e)
1442  (:policy :fast-safe)
1443  (:note "inline float comparison")
1444  (:ignore temp)
1445  (:generator 3
1446    ;; Handle a few special cases.
1447    (cond
1448     ;; y is ST0.
1449     ((and (sc-is y double-reg) (zerop (tn-offset y)))
1450      (sc-case x
1451        (double-reg
1452         (inst fcomd x))
1453        ((double-stack descriptor-reg)
1454         (if (sc-is x double-stack)
1455             (inst fcomd (ea-for-df-stack x))
1456           (inst fcomd (ea-for-df-desc x)))))
1457      (inst fnstsw)                     ; status word to ax
1458      (inst and ah-tn #x45)
1459      (inst cmp ah-tn #x01))
1460
1461     ;; general case when y is not in ST0
1462     (t
1463      ;; x to ST0
1464      (sc-case x
1465         (double-reg
1466          (unless (zerop (tn-offset x))
1467                  (copy-fp-reg-to-fr0 x)))
1468         ((double-stack descriptor-reg)
1469          (inst fstp fr0)
1470          (if (sc-is x double-stack)
1471              (inst fldd (ea-for-df-stack x))
1472            (inst fldd (ea-for-df-desc x)))))
1473      (sc-case y
1474        (double-reg
1475         (inst fcomd y))
1476        ((double-stack descriptor-reg)
1477         (if (sc-is y double-stack)
1478             (inst fcomd (ea-for-df-stack y))
1479           (inst fcomd (ea-for-df-desc y)))))
1480      (inst fnstsw)                     ; status word to ax
1481      (inst and ah-tn #x45)))))
1482
1483#!+long-float
1484(define-vop (>long-float)
1485  (:translate >)
1486  (:args (x :scs (long-reg))
1487         (y :scs (long-reg)))
1488  (:arg-types long-float long-float)
1489  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1490  (:conditional :e)
1491  (:policy :fast-safe)
1492  (:note "inline float comparison")
1493  (:ignore temp)
1494  (:generator 3
1495    (cond
1496      ;; y is in ST0; x is in any reg.
1497      ((zerop (tn-offset y))
1498       (inst fcomd x)
1499       (inst fnstsw)                    ; status word to ax
1500       (inst and ah-tn #x45)
1501       (inst cmp ah-tn #x01))
1502      ;; x is in ST0; y is in another reg.
1503      ((zerop (tn-offset x))
1504       (inst fcomd y)
1505       (inst fnstsw)                    ; status word to ax
1506       (inst and ah-tn #x45))
1507      ;; y and x are the same register, not ST0
1508      ;; y and x are different registers, neither ST0.
1509      (t
1510       (inst fxch x)
1511       (inst fcomd y)
1512       (inst fxch x)
1513       (inst fnstsw)                    ; status word to ax
1514       (inst and ah-tn #x45)))))
1515
1516;;; Comparisons with 0 can use the FTST instruction.
1517
1518(define-vop (float-test)
1519  (:args (x))
1520  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1521  (:conditional :e)
1522  (:info y)
1523  (:variant-vars code)
1524  (:policy :fast-safe)
1525  (:vop-var vop)
1526  (:save-p :compute-only)
1527  (:note "inline float comparison")
1528  (:ignore temp y)
1529  (:generator 2
1530     (note-this-location vop :internal-error)
1531     (cond
1532      ;; x is in ST0
1533      ((zerop (tn-offset x))
1534       (inst ftst))
1535      ;; x not ST0
1536      (t
1537       (inst fxch x)
1538       (inst ftst)
1539       (inst fxch x)))
1540     (inst fnstsw)                      ; status word to ax
1541     (inst and ah-tn #x45)              ; C3 C2 C0
1542     (unless (zerop code)
1543        (inst cmp ah-tn code))))
1544
1545(define-vop (=0/single-float float-test)
1546  (:translate =)
1547  (:args (x :scs (single-reg)))
1548  (:arg-types single-float (:constant (single-float 0f0 0f0)))
1549  (:variant #x40))
1550(define-vop (=0/double-float float-test)
1551  (:translate =)
1552  (:args (x :scs (double-reg)))
1553  (:arg-types double-float (:constant (double-float 0d0 0d0)))
1554  (:variant #x40))
1555#!+long-float
1556(define-vop (=0/long-float float-test)
1557  (:translate =)
1558  (:args (x :scs (long-reg)))
1559  (:arg-types long-float (:constant (long-float 0l0 0l0)))
1560  (:variant #x40))
1561
1562(define-vop (<0/single-float float-test)
1563  (:translate <)
1564  (:args (x :scs (single-reg)))
1565  (:arg-types single-float (:constant (single-float 0f0 0f0)))
1566  (:variant #x01))
1567(define-vop (<0/double-float float-test)
1568  (:translate <)
1569  (:args (x :scs (double-reg)))
1570  (:arg-types double-float (:constant (double-float 0d0 0d0)))
1571  (:variant #x01))
1572#!+long-float
1573(define-vop (<0/long-float float-test)
1574  (:translate <)
1575  (:args (x :scs (long-reg)))
1576  (:arg-types long-float (:constant (long-float 0l0 0l0)))
1577  (:variant #x01))
1578
1579(define-vop (>0/single-float float-test)
1580  (:translate >)
1581  (:args (x :scs (single-reg)))
1582  (:arg-types single-float (:constant (single-float 0f0 0f0)))
1583  (:variant #x00))
1584(define-vop (>0/double-float float-test)
1585  (:translate >)
1586  (:args (x :scs (double-reg)))
1587  (:arg-types double-float (:constant (double-float 0d0 0d0)))
1588  (:variant #x00))
1589#!+long-float
1590(define-vop (>0/long-float float-test)
1591  (:translate >)
1592  (:args (x :scs (long-reg)))
1593  (:arg-types long-float (:constant (long-float 0l0 0l0)))
1594  (:variant #x00))
1595
1596#!+long-float
1597(deftransform eql ((x y) (long-float long-float))
1598  `(and (= (long-float-low-bits x) (long-float-low-bits y))
1599        (= (long-float-high-bits x) (long-float-high-bits y))
1600        (= (long-float-exp-bits x) (long-float-exp-bits y))))
1601
1602;;;; conversion
1603
1604(macrolet ((frob (name translate to-sc to-type)
1605             `(define-vop (,name)
1606                (:args (x :scs (signed-stack signed-reg) :target temp))
1607                (:temporary (:sc signed-stack) temp)
1608                (:results (y :scs (,to-sc)))
1609                (:arg-types signed-num)
1610                (:result-types ,to-type)
1611                (:policy :fast-safe)
1612                (:note "inline float coercion")
1613                (:translate ,translate)
1614                (:vop-var vop)
1615                (:save-p :compute-only)
1616                (:generator 5
1617                  (sc-case x
1618                    (signed-reg
1619                     (inst mov temp x)
1620                     (with-empty-tn@fp-top(y)
1621                       (note-this-location vop :internal-error)
1622                       (inst fild temp)))
1623                    (signed-stack
1624                     (with-empty-tn@fp-top(y)
1625                       (note-this-location vop :internal-error)
1626                       (inst fild x))))))))
1627  (frob %single-float/signed %single-float single-reg single-float)
1628  (frob %double-float/signed %double-float double-reg double-float)
1629  #!+long-float
1630  (frob %long-float/signed %long-float long-reg long-float))
1631
1632(macrolet ((frob (name translate to-sc to-type)
1633             `(define-vop (,name)
1634                (:args (x :scs (unsigned-reg)))
1635                (:results (y :scs (,to-sc)))
1636                (:arg-types unsigned-num)
1637                (:result-types ,to-type)
1638                (:policy :fast-safe)
1639                (:note "inline float coercion")
1640                (:translate ,translate)
1641                (:vop-var vop)
1642                (:save-p :compute-only)
1643                (:generator 6
1644                 (inst push 0)
1645                 (inst push x)
1646                 (with-empty-tn@fp-top(y)
1647                   (note-this-location vop :internal-error)
1648                   (inst fildl (make-ea :dword :base esp-tn)))
1649                 (inst add esp-tn 8)))))
1650  (frob %single-float/unsigned %single-float single-reg single-float)
1651  (frob %double-float/unsigned %double-float double-reg double-float)
1652  #!+long-float
1653  (frob %long-float/unsigned %long-float long-reg long-float))
1654
1655(macrolet ((frob (name translate from-sc from-type to-sc to-type
1656                  &optional to-stack-sc store-inst load-inst)
1657             `(define-vop (,name)
1658               (:args (x :scs (,from-sc) :target y))
1659                ,@(and to-stack-sc
1660                       `((:temporary (:sc ,to-stack-sc) temp)))
1661               (:results (y :scs (,to-sc)))
1662               (:arg-types ,from-type)
1663               (:result-types ,to-type)
1664               (:policy :fast-safe)
1665               (:note "inline float coercion")
1666               (:translate ,translate)
1667               (:vop-var vop)
1668               (:save-p :compute-only)
1669               (:generator 2
1670                 (note-this-location vop :internal-error)
1671                ,(if to-stack-sc
1672                     `(progn
1673                        (with-tn@fp-top (x)
1674                          (inst ,store-inst temp))
1675                        (with-empty-tn@fp-top (y)
1676                          (inst ,load-inst temp)))
1677                     `(unless (location= x y)
1678                        (cond
1679                          ((zerop (tn-offset x))
1680                           ;; x is in ST0, y is in another reg. not ST0
1681                           (inst fst  y))
1682                          ((zerop (tn-offset y))
1683                           ;; y is in ST0, x is in another reg. not ST0
1684                           (copy-fp-reg-to-fr0 x))
1685                          (t
1686                           ;; Neither x or y are in ST0, and they are not in
1687                           ;; the same reg.
1688                           (inst fxch x)
1689                           (inst fst  y)
1690                           (inst fxch x)))))))))
1691
1692  (frob %single-float/double-float %single-float double-reg double-float
1693        single-reg single-float
1694        single-stack fst fld)
1695  #!+long-float
1696  (frob %single-float/long-float %single-float long-reg
1697        long-float single-reg single-float
1698        single-stack fst fld)
1699  (frob %double-float/single-float %double-float single-reg single-float
1700        double-reg double-float)
1701  #!+long-float
1702  (frob %double-float/long-float %double-float long-reg long-float
1703        double-reg double-float
1704        double-stack fstd fldd)
1705  #!+long-float
1706  (frob %long-float/single-float %long-float single-reg single-float
1707        long-reg long-float)
1708  #!+long-float
1709  (frob %long-float/double-float %long-float double-reg double-float
1710        long-reg long-float))
1711
1712(macrolet ((frob (trans from-sc from-type round-p)
1713             `(define-vop (,(symbolicate trans "/" from-type))
1714               (:args (x :scs (,from-sc)))
1715               (:temporary (:sc signed-stack) stack-temp)
1716               ,@(unless round-p
1717                       '((:temporary (:sc unsigned-stack) scw)
1718                         (:temporary (:sc any-reg) rcw)))
1719               (:results (y :scs (signed-reg)))
1720               (:arg-types ,from-type)
1721               (:result-types signed-num)
1722               (:translate ,trans)
1723               (:policy :fast-safe)
1724               (:note "inline float truncate")
1725               (:vop-var vop)
1726               (:save-p :compute-only)
1727               (:generator 5
1728                ,@(unless round-p
1729                   '((note-this-location vop :internal-error)
1730                     ;; Catch any pending FPE exceptions.
1731                     (inst wait)))
1732                (,(if round-p 'progn 'pseudo-atomic)
1733                 ;; Normal mode (for now) is "round to best".
1734                 (with-tn@fp-top (x)
1735                   ,@(unless round-p
1736                     '((inst fnstcw scw) ; save current control word
1737                       (move rcw scw)   ; into 16-bit register
1738                       (inst or rcw (ash #b11 10)) ; CHOP
1739                       (move stack-temp rcw)
1740                       (inst fldcw stack-temp)))
1741                   (sc-case y
1742                     (signed-stack
1743                      (inst fist y))
1744                     (signed-reg
1745                      (inst fist stack-temp)
1746                      (inst mov y stack-temp)))
1747                   ,@(unless round-p
1748                      '((inst fldcw scw)))))))))
1749  (frob %unary-truncate/single-float single-reg single-float nil)
1750  (frob %unary-truncate/double-float double-reg double-float nil)
1751  #!+long-float
1752  (frob %unary-truncate/long-float long-reg long-float nil)
1753  (frob %unary-round single-reg single-float t)
1754  (frob %unary-round double-reg double-float t)
1755  #!+long-float
1756  (frob %unary-round long-reg long-float t))
1757
1758(macrolet ((frob (trans from-sc from-type round-p)
1759             `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1760               (:args (x :scs (,from-sc) :target fr0))
1761               (:temporary (:sc double-reg :offset fr0-offset
1762                            :from :argument :to :result) fr0)
1763               ,@(unless round-p
1764                  '((:temporary (:sc unsigned-stack) stack-temp)
1765                    (:temporary (:sc unsigned-stack) scw)
1766                    (:temporary (:sc any-reg) rcw)))
1767               (:results (y :scs (unsigned-reg)))
1768               (:arg-types ,from-type)
1769               (:result-types unsigned-num)
1770               (:translate ,trans)
1771               (:policy :fast-safe)
1772               (:note "inline float truncate")
1773               (:vop-var vop)
1774               (:save-p :compute-only)
1775               (:generator 5
1776                ,@(unless round-p
1777                   '((note-this-location vop :internal-error)
1778                     ;; Catch any pending FPE exceptions.
1779                     (inst wait)))
1780                ;; Normal mode (for now) is "round to best".
1781                (unless (zerop (tn-offset x))
1782                  (copy-fp-reg-to-fr0 x))
1783                ,@(unless round-p
1784                   '((inst fnstcw scw)  ; save current control word
1785                     (move rcw scw)     ; into 16-bit register
1786                     (inst or rcw (ash #b11 10)) ; CHOP
1787                     (move stack-temp rcw)
1788                     (inst fldcw stack-temp)))
1789                (inst sub esp-tn 8)
1790                (inst fistpl (make-ea :dword :base esp-tn))
1791                (inst pop y)
1792                (inst fld fr0) ; copy fr0 to at least restore stack.
1793                (inst add esp-tn 4)
1794                ,@(unless round-p
1795                   '((inst fldcw scw)))))))
1796  (frob %unary-truncate/single-float single-reg single-float nil)
1797  (frob %unary-truncate/double-float double-reg double-float nil)
1798  #!+long-float
1799  (frob %unary-truncate/long-float long-reg long-float nil)
1800  (frob %unary-round single-reg single-float t)
1801  (frob %unary-round double-reg double-float t)
1802  #!+long-float
1803  (frob %unary-round long-reg long-float t))
1804
1805(define-vop (make-single-float)
1806  (:args (bits :scs (signed-reg) :target res
1807               :load-if (not (or (and (sc-is bits signed-stack)
1808                                      (sc-is res single-reg))
1809                                 (and (sc-is bits signed-stack)
1810                                      (sc-is res single-stack)
1811                                      (location= bits res))))))
1812  (:results (res :scs (single-reg single-stack)))
1813  (:temporary (:sc signed-stack) stack-temp)
1814  (:arg-types signed-num)
1815  (:result-types single-float)
1816  (:translate make-single-float)
1817  (:policy :fast-safe)
1818  (:vop-var vop)
1819  (:generator 4
1820    (sc-case res
1821       (single-stack
1822        (sc-case bits
1823          (signed-reg
1824           (inst mov res bits))
1825          (signed-stack
1826           (aver (location= bits res)))))
1827       (single-reg
1828        (sc-case bits
1829          (signed-reg
1830           ;; source must be in memory
1831           (inst mov stack-temp bits)
1832           (with-empty-tn@fp-top(res)
1833              (inst fld stack-temp)))
1834          (signed-stack
1835           (with-empty-tn@fp-top(res)
1836              (inst fld bits))))))))
1837
1838(define-vop (make-single-float-c)
1839  (:results (res :scs (single-reg single-stack)))
1840  (:arg-types (:constant (signed-byte 32)))
1841  (:result-types single-float)
1842  (:info bits)
1843  (:translate make-single-float)
1844  (:policy :fast-safe)
1845  (:vop-var vop)
1846  (:generator 2
1847    (sc-case res
1848      (single-stack
1849       (inst mov res bits))
1850      (single-reg
1851       (with-empty-tn@fp-top (res)
1852         (inst fld (register-inline-constant :dword bits)))))))
1853
1854(define-vop (make-double-float)
1855  (:args (hi-bits :scs (signed-reg))
1856         (lo-bits :scs (unsigned-reg)))
1857  (:results (res :scs (double-reg)))
1858  (:temporary (:sc double-stack) temp)
1859  (:arg-types signed-num unsigned-num)
1860  (:result-types double-float)
1861  (:translate make-double-float)
1862  (:policy :fast-safe)
1863  (:vop-var vop)
1864  (:generator 2
1865    (let ((offset (tn-offset temp)))
1866      (storew hi-bits ebp-tn (frame-word-offset offset))
1867      (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
1868      (with-empty-tn@fp-top(res)
1869        (inst fldd (make-ea :dword :base ebp-tn
1870                            :disp (frame-byte-offset (1+ offset))))))))
1871
1872(define-vop (make-double-float-c)
1873  (:results (res :scs (double-reg)))
1874  (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32)))
1875  (:result-types double-float)
1876  (:info hi lo)
1877  (:translate make-double-float)
1878  (:policy :fast-safe)
1879  (:vop-var vop)
1880  (:generator 1
1881    (with-empty-tn@fp-top(res)
1882      (inst fldd (register-inline-constant
1883                  :double-float-bits (logior (ash hi 32) lo))))))
1884
1885#!+long-float
1886(define-vop (make-long-float)
1887  (:args (exp-bits :scs (signed-reg))
1888         (hi-bits :scs (unsigned-reg))
1889         (lo-bits :scs (unsigned-reg)))
1890  (:results (res :scs (long-reg)))
1891  (:temporary (:sc long-stack) temp)
1892  (:arg-types signed-num unsigned-num unsigned-num)
1893  (:result-types long-float)
1894  (:translate make-long-float)
1895  (:policy :fast-safe)
1896  (:vop-var vop)
1897  (:generator 3
1898    (let ((offset (tn-offset temp)))
1899      (storew exp-bits ebp-tn (frame-word-offset offset))
1900      (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
1901      (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
1902      (with-empty-tn@fp-top(res)
1903        (inst fldl (make-ea :dword :base ebp-tn
1904                            :disp (frame-byte-offset (+ offset 2))))))))
1905
1906(define-vop (single-float-bits)
1907  (:args (float :scs (single-reg descriptor-reg)
1908                :load-if (not (sc-is float single-stack))))
1909  (:results (bits :scs (signed-reg)))
1910  (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1911  (:arg-types single-float)
1912  (:result-types signed-num)
1913  (:translate single-float-bits)
1914  (:policy :fast-safe)
1915  (:vop-var vop)
1916  (:generator 4
1917    (sc-case bits
1918      (signed-reg
1919       (sc-case float
1920         (single-reg
1921          (with-tn@fp-top(float)
1922            (inst fst stack-temp)
1923            (inst mov bits stack-temp)))
1924         (single-stack
1925          (inst mov bits float))
1926         (descriptor-reg
1927          (loadw
1928           bits float single-float-value-slot
1929           other-pointer-lowtag))))
1930      (signed-stack
1931       (sc-case float
1932         (single-reg
1933          (with-tn@fp-top(float)
1934            (inst fst bits))))))))
1935
1936(define-vop (double-float-high-bits)
1937  (:args (float :scs (double-reg descriptor-reg)
1938                :load-if (not (sc-is float double-stack))))
1939  (:results (hi-bits :scs (signed-reg)))
1940  (:temporary (:sc double-stack) temp)
1941  (:arg-types double-float)
1942  (:result-types signed-num)
1943  (:translate double-float-high-bits)
1944  (:policy :fast-safe)
1945  (:vop-var vop)
1946  (:generator 5
1947     (sc-case float
1948       (double-reg
1949        (with-tn@fp-top(float)
1950          (let ((where (make-ea :dword :base ebp-tn
1951                                :disp (frame-byte-offset (1+ (tn-offset temp))))))
1952            (inst fstd where)))
1953        (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
1954       (double-stack
1955        (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
1956       (descriptor-reg
1957        (loadw hi-bits float (1+ double-float-value-slot)
1958               other-pointer-lowtag)))))
1959
1960(define-vop (double-float-low-bits)
1961  (:args (float :scs (double-reg descriptor-reg)
1962                :load-if (not (sc-is float double-stack))))
1963  (:results (lo-bits :scs (unsigned-reg)))
1964  (:temporary (:sc double-stack) temp)
1965  (:arg-types double-float)
1966  (:result-types unsigned-num)
1967  (:translate double-float-low-bits)
1968  (:policy :fast-safe)
1969  (:vop-var vop)
1970  (:generator 5
1971     (sc-case float
1972       (double-reg
1973        (with-tn@fp-top(float)
1974          (let ((where (make-ea :dword :base ebp-tn
1975                                :disp (frame-byte-offset (1+ (tn-offset temp))))))
1976            (inst fstd where)))
1977        (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1978       (double-stack
1979        (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
1980       (descriptor-reg
1981        (loadw lo-bits float double-float-value-slot
1982               other-pointer-lowtag)))))
1983
1984#!+long-float
1985(define-vop (long-float-exp-bits)
1986  (:args (float :scs (long-reg descriptor-reg)
1987                :load-if (not (sc-is float long-stack))))
1988  (:results (exp-bits :scs (signed-reg)))
1989  (:temporary (:sc long-stack) temp)
1990  (:arg-types long-float)
1991  (:result-types signed-num)
1992  (:translate long-float-exp-bits)
1993  (:policy :fast-safe)
1994  (:vop-var vop)
1995  (:generator 5
1996     (sc-case float
1997       (long-reg
1998        (with-tn@fp-top(float)
1999          (let ((where (make-ea :dword :base ebp-tn
2000                                :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2001            (store-long-float where)))
2002        (inst movsx exp-bits
2003              (make-ea :word :base ebp-tn
2004                       :disp (frame-byte-offset (tn-offset temp)))))
2005       (long-stack
2006        (inst movsx exp-bits
2007              (make-ea :word :base ebp-tn
2008                       :disp (frame-byte-offset (tn-offset temp)))))
2009       (descriptor-reg
2010        (inst movsx exp-bits
2011              (make-ea-for-object-slot float (+ 2 long-float-value-slot)
2012                                       other-pointer-lowtag :word))))))
2013
2014#!+long-float
2015(define-vop (long-float-high-bits)
2016  (:args (float :scs (long-reg descriptor-reg)
2017                :load-if (not (sc-is float long-stack))))
2018  (:results (hi-bits :scs (unsigned-reg)))
2019  (:temporary (:sc long-stack) temp)
2020  (:arg-types long-float)
2021  (:result-types unsigned-num)
2022  (:translate long-float-high-bits)
2023  (:policy :fast-safe)
2024  (:vop-var vop)
2025  (:generator 5
2026     (sc-case float
2027       (long-reg
2028        (with-tn@fp-top(float)
2029          (let ((where (make-ea :dword :base ebp-tn
2030                                :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2031            (store-long-float where)))
2032        (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
2033       (long-stack
2034        (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
2035       (descriptor-reg
2036        (loadw hi-bits float (1+ long-float-value-slot)
2037               other-pointer-lowtag)))))
2038
2039#!+long-float
2040(define-vop (long-float-low-bits)
2041  (:args (float :scs (long-reg descriptor-reg)
2042                :load-if (not (sc-is float long-stack))))
2043  (:results (lo-bits :scs (unsigned-reg)))
2044  (:temporary (:sc long-stack) temp)
2045  (:arg-types long-float)
2046  (:result-types unsigned-num)
2047  (:translate long-float-low-bits)
2048  (:policy :fast-safe)
2049  (:vop-var vop)
2050  (:generator 5
2051     (sc-case float
2052       (long-reg
2053        (with-tn@fp-top(float)
2054          (let ((where (make-ea :dword :base ebp-tn
2055                                :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2056            (store-long-float where)))
2057        (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
2058       (long-stack
2059        (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
2060       (descriptor-reg
2061        (loadw lo-bits float long-float-value-slot
2062               other-pointer-lowtag)))))
2063
2064;;;; float mode hackery
2065
2066(sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2067(defknown floating-point-modes () float-modes (flushable))
2068(defknown ((setf floating-point-modes)) (float-modes)
2069  float-modes)
2070
2071(defconstant npx-env-size (* 7 n-word-bytes))
2072(defconstant npx-cw-offset 0)
2073(defconstant npx-sw-offset 4)
2074
2075(define-vop (floating-point-modes)
2076  (:results (res :scs (unsigned-reg)))
2077  (:result-types unsigned-num)
2078  (:translate floating-point-modes)
2079  (:policy :fast-safe)
2080  (:temporary (:sc unsigned-reg :offset eax-offset :target res
2081                   :to :result) eax)
2082  (:generator 8
2083   (inst sub esp-tn npx-env-size)       ; Make space on stack.
2084   (inst wait)                          ; Catch any pending FPE exceptions
2085   (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2086   (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2087   ;; Move current status to high word.
2088   (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2089   ;; Move exception mask to low word.
2090   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2091   (inst add esp-tn npx-env-size)       ; Pop stack.
2092   (inst xor eax #x3f)            ; Flip exception mask to trap enable bits.
2093   (move res eax)))
2094
2095(define-vop (set-floating-point-modes)
2096  (:args (new :scs (unsigned-reg) :to :result :target res))
2097  (:results (res :scs (unsigned-reg)))
2098  (:arg-types unsigned-num)
2099  (:result-types unsigned-num)
2100  (:translate (setf floating-point-modes))
2101  (:policy :fast-safe)
2102  (:temporary (:sc unsigned-reg :offset eax-offset
2103                   :from :eval :to :result) eax)
2104  (:generator 3
2105   (inst sub esp-tn npx-env-size)       ; Make space on stack.
2106   (inst wait)                          ; Catch any pending FPE exceptions.
2107   (inst fstenv (make-ea :dword :base esp-tn))
2108   (inst mov eax new)
2109   (inst xor eax #x3f)            ; Turn trap enable bits into exception mask.
2110   (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2111   (inst shr eax 16)                    ; position status word
2112   (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2113   (inst fldenv (make-ea :dword :base esp-tn))
2114   (inst add esp-tn npx-env-size)       ; Pop stack.
2115   (move res new)))
2116
2117#!-long-float
2118(progn
2119
2120;;; Let's use some of the 80387 special functions.
2121;;;
2122;;; These defs will not take effect unless code/irrat.lisp is modified
2123;;; to remove the inlined alien routine def.
2124
2125(macrolet ((frob (func trans op)
2126             `(define-vop (,func)
2127               (:args (x :scs (double-reg) :target fr0))
2128               (:temporary (:sc double-reg :offset fr0-offset
2129                                :from :argument :to :result) fr0)
2130               (:ignore fr0)
2131               (:results (y :scs (double-reg)))
2132               (:arg-types double-float)
2133               (:result-types double-float)
2134               (:translate ,trans)
2135               (:policy :fast-safe)
2136               (:note "inline NPX function")
2137               (:vop-var vop)
2138               (:save-p :compute-only)
2139               (:node-var node)
2140               (:generator 5
2141                (note-this-location vop :internal-error)
2142                (unless (zerop (tn-offset x))
2143                  (inst fxch x)         ; x to top of stack
2144                  (unless (location= x y)
2145                    (inst fst x)))      ; maybe save it
2146                (inst ,op)              ; clobber st0
2147                (cond ((zerop (tn-offset y))
2148                       (maybe-fp-wait node))
2149                      (t
2150                       (inst fst y)))))))
2151
2152  ;; Quick versions of fsin and fcos that require the argument to be
2153  ;; within range 2^63.
2154  (frob fsin-quick %sin-quick fsin)
2155  (frob fcos-quick %cos-quick fcos)
2156  (frob fsqrt %sqrt fsqrt))
2157
2158;;; Quick version of ftan that requires the argument to be within
2159;;; range 2^63.
2160(define-vop (ftan-quick)
2161  (:translate %tan-quick)
2162  (:args (x :scs (double-reg) :target fr0))
2163  (:temporary (:sc double-reg :offset fr0-offset
2164                   :from :argument :to :result) fr0)
2165  (:temporary (:sc double-reg :offset fr1-offset
2166                   :from :argument :to :result) fr1)
2167  (:results (y :scs (double-reg)))
2168  (:arg-types double-float)
2169  (:result-types double-float)
2170  (:policy :fast-safe)
2171  (:note "inline tan function")
2172  (:vop-var vop)
2173  (:save-p :compute-only)
2174  (:generator 5
2175    (note-this-location vop :internal-error)
2176    (case (tn-offset x)
2177       (0
2178        (inst fstp fr1))
2179       (1
2180        (inst fstp fr0))
2181       (t
2182        (inst fstp fr0)
2183        (inst fstp fr0)
2184        (inst fldd (make-random-tn :kind :normal
2185                                   :sc (sc-or-lose 'double-reg)
2186                                   :offset (- (tn-offset x) 2)))))
2187    (inst fptan)
2188    ;; Result is in fr1
2189    (case (tn-offset y)
2190       (0
2191        (inst fxch fr1))
2192       (1)
2193       (t
2194        (inst fxch fr1)
2195        (inst fstd y)))))
2196
2197;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
2198;;; result if the argument is out of range 2^63 and would thus be
2199;;; hopelessly inaccurate.
2200(macrolet ((frob (func trans op)
2201             `(define-vop (,func)
2202                (:translate ,trans)
2203                (:args (x :scs (double-reg) :target fr0))
2204                (:temporary (:sc double-reg :offset fr0-offset
2205                                 :from :argument :to :result) fr0)
2206                ;; FIXME: make that an arbitrary location and
2207                ;; FXCH only when range reduction needed
2208                (:temporary (:sc double-reg :offset fr1-offset
2209                                 :from :argument :to :result) fr1)
2210                (:temporary (:sc unsigned-reg :offset eax-offset
2211                             :from :argument :to :result) eax)
2212                (:results (y :scs (double-reg)))
2213                (:arg-types double-float)
2214                (:result-types double-float)
2215                (:policy :fast-safe)
2216                (:note "inline sin/cos function")
2217                (:vop-var vop)
2218                (:save-p :compute-only)
2219                (:ignore eax)
2220                (:generator 5
2221                  (let ((DONE (gen-label))
2222                        (REDUCE (gen-label))
2223                        (REDUCE-LOOP (gen-label)))
2224                    (note-this-location vop :internal-error)
2225                    (unless (zerop (tn-offset x))
2226                      (inst fxch x)          ; x to top of stack
2227                      (unless (location= x y)
2228                        (inst fst x))) ; maybe save it
2229                    (inst ,op)
2230                    (inst fnstsw)                  ; status word to ax
2231                    (inst and ah-tn #x04)          ; C2
2232                    (inst jmp :nz REDUCE)
2233                    (emit-label DONE)
2234                    (unless (zerop (tn-offset y))
2235                      (inst fstd y))
2236                    (assemble (*elsewhere*)
2237                      (emit-label REDUCE)
2238                      ;; Else x was out of range so reduce it; ST0 is unchanged.
2239                      (with-empty-tn@fp-top (fr1)
2240                        (inst fldpi)
2241                        (inst fadd fr0))
2242                      (emit-label REDUCE-LOOP)
2243                      (inst fprem1)
2244                      (inst fnstsw)
2245                      (inst and ah-tn #x04)
2246                      (inst jmp :nz REDUCE-LOOP)
2247                      (inst ,op)
2248                      (inst jmp DONE)))))))
2249          (frob fsin  %sin fsin)
2250          (frob fcos  %cos fcos))
2251
2252(define-vop (ftan)
2253  (:translate %tan)
2254  (:args (x :scs (double-reg) :target fr0))
2255  (:temporary (:sc double-reg :offset fr0-offset
2256                   :from :argument :to :result) fr0)
2257  (:temporary (:sc double-reg :offset fr1-offset
2258                   :from :argument :to :result) fr1)
2259  (:temporary (:sc unsigned-reg :offset eax-offset
2260                   :from :argument :to :result) eax)
2261  (:results (y :scs (double-reg)))
2262  (:arg-types double-float)
2263  (:result-types double-float)
2264  (:ignore eax)
2265  (:policy :fast-safe)
2266  (:note "inline tan function")
2267  (:vop-var vop)
2268  (:save-p :compute-only)
2269  (:ignore eax)
2270  (:generator 5
2271    (note-this-location vop :internal-error)
2272    (case (tn-offset x)
2273       (0
2274        (inst fstp fr1))
2275       (1
2276        (inst fstp fr0))
2277       (t
2278        (inst fstp fr0)
2279        (inst fstp fr0)
2280        (inst fldd (make-random-tn :kind :normal
2281                                   :sc (sc-or-lose 'double-reg)
2282                                   :offset (- (tn-offset x) 2)))))
2283    (inst fptan)
2284    (let ((REDUCE (gen-label))
2285          (REDUCE-LOOP (gen-label)))
2286      (inst fnstsw)                        ; status word to ax
2287      (inst and ah-tn #x04)                ; C2
2288      (inst jmp :nz REDUCE)
2289      (assemble (*elsewhere*)
2290        (emit-label REDUCE)
2291        ;; Else x was out of range so reduce it; ST0 is unchanged.
2292        (with-empty-tn@fp-top (fr1)
2293          (inst fldpi)
2294          (inst fadd fr0))
2295        (emit-label REDUCE-LOOP)
2296        (inst fprem1)
2297        (inst fnstsw)
2298        (inst and ah-tn #x04)
2299        (inst jmp :nz REDUCE-LOOP)
2300        (inst fptan)
2301        (inst jmp DONE)))
2302    DONE
2303    ;; Result is in fr1
2304    (case (tn-offset y)
2305       (0
2306        (inst fxch fr1))
2307       (1)
2308       (t
2309        (inst fxch fr1)
2310        (inst fstd y)))))
2311
2312;;; %exp that handles the following special cases: exp(+Inf) is +Inf;
2313;;; exp(-Inf) is 0; exp(NaN) is NaN.
2314(define-vop (fexp)
2315  (:translate %exp)
2316  (:args (x :scs (double-reg) :target fr0))
2317  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2318  (:temporary (:sc double-reg :offset fr0-offset
2319                   :from :argument :to :result) fr0)
2320  (:temporary (:sc double-reg :offset fr1-offset
2321                   :from :argument :to :result) fr1)
2322  (:temporary (:sc double-reg :offset fr2-offset
2323                   :from :argument :to :result) fr2)
2324  (:results (y :scs (double-reg)))
2325  (:arg-types double-float)
2326  (:result-types double-float)
2327  (:policy :fast-safe)
2328  (:note "inline exp function")
2329  (:vop-var vop)
2330  (:save-p :compute-only)
2331  (:ignore temp)
2332  (:generator 5
2333     (note-this-location vop :internal-error)
2334     (unless (zerop (tn-offset x))
2335       (inst fxch x)            ; x to top of stack
2336       (unless (location= x y)
2337         (inst fst x))) ; maybe save it
2338     ;; Check for Inf or NaN
2339     (inst fxam)
2340     (inst fnstsw)
2341     (inst sahf)
2342     (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
2343     (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
2344     (inst and ah-tn #x02)            ; Test sign of Inf.
2345     (inst jmp :z DONE)          ; +Inf gives +Inf.
2346     (inst fstp fr0)                ; -Inf gives 0
2347     (inst fldz)
2348     (inst jmp-short DONE)
2349     NOINFNAN
2350     (inst fstp fr1)
2351     (inst fldl2e)
2352     (inst fmul fr1)
2353     ;; Now fr0=x log2(e)
2354     (inst fst fr1)
2355     (inst frndint)
2356     (inst fst fr2)
2357     (inst fsubp-sti fr1)
2358     (inst f2xm1)
2359     (inst fld1)
2360     (inst faddp-sti fr1)
2361     (inst fscale)
2362     (inst fld fr0)
2363     DONE
2364     (unless (zerop (tn-offset y))
2365             (inst fstd y))))
2366
2367;;; Expm1 = exp(x) - 1.
2368;;; Handles the following special cases:
2369;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2370(define-vop (fexpm1)
2371  (:translate %expm1)
2372  (:args (x :scs (double-reg) :target fr0))
2373  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2374  (:temporary (:sc double-reg :offset fr0-offset
2375                   :from :argument :to :result) fr0)
2376  (:temporary (:sc double-reg :offset fr1-offset
2377                   :from :argument :to :result) fr1)
2378  (:temporary (:sc double-reg :offset fr2-offset
2379                   :from :argument :to :result) fr2)
2380  (:results (y :scs (double-reg)))
2381  (:arg-types double-float)
2382  (:result-types double-float)
2383  (:policy :fast-safe)
2384  (:note "inline expm1 function")
2385  (:vop-var vop)
2386  (:save-p :compute-only)
2387  (:ignore temp)
2388  (:generator 5
2389     (note-this-location vop :internal-error)
2390     (unless (zerop (tn-offset x))
2391       (inst fxch x)            ; x to top of stack
2392       (unless (location= x y)
2393         (inst fst x))) ; maybe save it
2394     ;; Check for Inf or NaN
2395     (inst fxam)
2396     (inst fnstsw)
2397     (inst sahf)
2398     (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
2399     (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
2400     (inst and ah-tn #x02)            ; Test sign of Inf.
2401     (inst jmp :z DONE)          ; +Inf gives +Inf.
2402     (inst fstp fr0)                ; -Inf gives -1.0
2403     (inst fld1)
2404     (inst fchs)
2405     (inst jmp-short DONE)
2406     NOINFNAN
2407     ;; Free two stack slots leaving the argument on top.
2408     (inst fstp fr2)
2409     (inst fstp fr0)
2410     (inst fldl2e)
2411     (inst fmul fr1)    ; Now fr0 = x log2(e)
2412     (inst fst fr1)
2413     (inst frndint)
2414     (inst fsub-sti fr1)
2415     (inst fxch fr1)
2416     (inst f2xm1)
2417     (inst fscale)
2418     (inst fxch fr1)
2419     (inst fld1)
2420     (inst fscale)
2421     (inst fstp fr1)
2422     (inst fld1)
2423     (inst fsub fr1)
2424     (inst fsubr fr2)
2425     DONE
2426     (unless (zerop (tn-offset y))
2427       (inst fstd y))))
2428
2429(define-vop (flog)
2430  (:translate %log)
2431  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2432  (:temporary (:sc double-reg :offset fr0-offset
2433                   :from :argument :to :result) fr0)
2434  (:temporary (:sc double-reg :offset fr1-offset
2435                   :from :argument :to :result) fr1)
2436  (:results (y :scs (double-reg)))
2437  (:arg-types double-float)
2438  (:result-types double-float)
2439  (:policy :fast-safe)
2440  (:note "inline log function")
2441  (:vop-var vop)
2442  (:save-p :compute-only)
2443  (:generator 5
2444     (note-this-location vop :internal-error)
2445     (sc-case x
2446        (double-reg
2447         (case (tn-offset x)
2448            (0
2449             ;; x is in fr0
2450             (inst fstp fr1)
2451             (inst fldln2)
2452             (inst fxch fr1))
2453            (1
2454             ;; x is in fr1
2455             (inst fstp fr0)
2456             (inst fldln2)
2457             (inst fxch fr1))
2458            (t
2459             ;; x is in a FP reg, not fr0 or fr1
2460             (inst fstp fr0)
2461             (inst fstp fr0)
2462             (inst fldln2)
2463             (inst fldd (make-random-tn :kind :normal
2464                                        :sc (sc-or-lose 'double-reg)
2465                                        :offset (1- (tn-offset x))))))
2466         (inst fyl2x))
2467        ((double-stack descriptor-reg)
2468         (inst fstp fr0)
2469         (inst fstp fr0)
2470         (inst fldln2)
2471         (if (sc-is x double-stack)
2472             (inst fldd (ea-for-df-stack x))
2473             (inst fldd (ea-for-df-desc x)))
2474         (inst fyl2x)))
2475     (inst fld fr0)
2476     (case (tn-offset y)
2477       ((0 1))
2478       (t (inst fstd y)))))
2479
2480(define-vop (flog10)
2481  (:translate %log10)
2482  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2483  (:temporary (:sc double-reg :offset fr0-offset
2484                   :from :argument :to :result) fr0)
2485  (:temporary (:sc double-reg :offset fr1-offset
2486                   :from :argument :to :result) fr1)
2487  (:results (y :scs (double-reg)))
2488  (:arg-types double-float)
2489  (:result-types double-float)
2490  (:policy :fast-safe)
2491  (:note "inline log10 function")
2492  (:vop-var vop)
2493  (:save-p :compute-only)
2494  (:generator 5
2495     (note-this-location vop :internal-error)
2496     (sc-case x
2497        (double-reg
2498         (case (tn-offset x)
2499            (0
2500             ;; x is in fr0
2501             (inst fstp fr1)
2502             (inst fldlg2)
2503             (inst fxch fr1))
2504            (1
2505             ;; x is in fr1
2506             (inst fstp fr0)
2507             (inst fldlg2)
2508             (inst fxch fr1))
2509            (t
2510             ;; x is in a FP reg, not fr0 or fr1
2511             (inst fstp fr0)
2512             (inst fstp fr0)
2513             (inst fldlg2)
2514             (inst fldd (make-random-tn :kind :normal
2515                                        :sc (sc-or-lose 'double-reg)
2516                                        :offset (1- (tn-offset x))))))
2517         (inst fyl2x))
2518        ((double-stack descriptor-reg)
2519         (inst fstp fr0)
2520         (inst fstp fr0)
2521         (inst fldlg2)
2522         (if (sc-is x double-stack)
2523             (inst fldd (ea-for-df-stack x))
2524             (inst fldd (ea-for-df-desc x)))
2525         (inst fyl2x)))
2526     (inst fld fr0)
2527     (case (tn-offset y)
2528       ((0 1))
2529       (t (inst fstd y)))))
2530
2531(define-vop (fpow)
2532  (:translate %pow)
2533  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2534         (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2535  (:temporary (:sc double-reg :offset fr0-offset
2536                   :from (:argument 0) :to :result) fr0)
2537  (:temporary (:sc double-reg :offset fr1-offset
2538                   :from (:argument 1) :to :result) fr1)
2539  (:temporary (:sc double-reg :offset fr2-offset
2540                   :from :load :to :result) fr2)
2541  (:results (r :scs (double-reg)))
2542  (:arg-types double-float double-float)
2543  (:result-types double-float)
2544  (:policy :fast-safe)
2545  (:note "inline pow function")
2546  (:vop-var vop)
2547  (:save-p :compute-only)
2548  (:generator 5
2549     (note-this-location vop :internal-error)
2550     ;; Setup x in fr0 and y in fr1
2551     (cond
2552      ;; x in fr0; y in fr1
2553      ((and (sc-is x double-reg) (zerop (tn-offset x))
2554            (sc-is y double-reg) (= 1 (tn-offset y))))
2555      ;; y in fr1; x not in fr0
2556      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2557       ;; Load x to fr0
2558       (sc-case x
2559          (double-reg
2560           (copy-fp-reg-to-fr0 x))
2561          (double-stack
2562           (inst fstp fr0)
2563           (inst fldd (ea-for-df-stack x)))
2564          (descriptor-reg
2565           (inst fstp fr0)
2566           (inst fldd (ea-for-df-desc x)))))
2567      ;; x in fr0; y not in fr1
2568      ((and (sc-is x double-reg) (zerop (tn-offset x)))
2569       (inst fxch fr1)
2570       ;; Now load y to fr0
2571       (sc-case y
2572          (double-reg
2573           (copy-fp-reg-to-fr0 y))
2574          (double-stack
2575           (inst fstp fr0)
2576           (inst fldd (ea-for-df-stack y)))
2577          (descriptor-reg
2578           (inst fstp fr0)
2579           (inst fldd (ea-for-df-desc y))))
2580       (inst fxch fr1))
2581      ;; x in fr1; y not in fr1
2582      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2583       ;; Load y to fr0
2584       (sc-case y
2585          (double-reg
2586           (copy-fp-reg-to-fr0 y))
2587          (double-stack
2588           (inst fstp fr0)
2589           (inst fldd (ea-for-df-stack y)))
2590          (descriptor-reg
2591           (inst fstp fr0)
2592           (inst fldd (ea-for-df-desc y))))
2593       (inst fxch fr1))
2594      ;; y in fr0;
2595      ((and (sc-is y double-reg) (zerop (tn-offset y)))
2596       (inst fxch fr1)
2597       ;; Now load x to fr0
2598       (sc-case x
2599          (double-reg
2600           (copy-fp-reg-to-fr0 x))
2601          (double-stack
2602           (inst fstp fr0)
2603           (inst fldd (ea-for-df-stack x)))
2604          (descriptor-reg
2605           (inst fstp fr0)
2606           (inst fldd (ea-for-df-desc x)))))
2607      ;; Neither x or y are in either fr0 or fr1
2608      (t
2609       ;; Load y then x
2610       (inst fstp fr0)
2611       (inst fstp fr0)
2612       (sc-case y
2613          (double-reg
2614           (inst fldd (make-random-tn :kind :normal
2615                                      :sc (sc-or-lose 'double-reg)
2616                                      :offset (- (tn-offset y) 2))))
2617          (double-stack
2618           (inst fldd (ea-for-df-stack y)))
2619          (descriptor-reg
2620           (inst fldd (ea-for-df-desc y))))
2621       ;; Load x to fr0
2622       (sc-case x
2623          (double-reg
2624           (inst fldd (make-random-tn :kind :normal
2625                                      :sc (sc-or-lose 'double-reg)
2626                                      :offset (1- (tn-offset x)))))
2627          (double-stack
2628           (inst fldd (ea-for-df-stack x)))
2629          (descriptor-reg
2630           (inst fldd (ea-for-df-desc x))))))
2631
2632     ;; Now have x at fr0; and y at fr1
2633     (inst fyl2x)
2634     ;; Now fr0=y log2(x)
2635     (inst fld fr0)
2636     (inst frndint)
2637     (inst fst fr2)
2638     (inst fsubp-sti fr1)
2639     (inst f2xm1)
2640     (inst fld1)
2641     (inst faddp-sti fr1)
2642     (inst fscale)
2643     (inst fld fr0)
2644     (case (tn-offset r)
2645       ((0 1))
2646       (t (inst fstd r)))))
2647
2648(define-vop (fscalen)
2649  (:translate %scalbn)
2650  (:args (x :scs (double-reg double-stack descriptor-reg)
2651            :to (:argument 2) :target fr0)
2652         (y :scs (signed-stack signed-reg) :target temp))
2653  (:temporary (:sc double-reg :offset fr0-offset
2654               :from (:argument 2) :to :result) fr0)
2655  (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2656  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2657  (:results (r :scs (double-reg)))
2658  (:arg-types double-float signed-num)
2659  (:result-types double-float)
2660  (:policy :fast-safe)
2661  (:note "inline scalbn function")
2662  (:generator 5
2663     ;; Setup x in fr0 and y in fr1
2664     (sc-case x
2665       (double-reg
2666        (case (tn-offset x)
2667          (0
2668           (inst fstp fr1)
2669           (sc-case y
2670             (signed-reg
2671              (inst mov temp y)
2672              (inst fild temp))
2673             (signed-stack
2674              (inst fild y)))
2675           (inst fxch fr1))
2676          (1
2677           (inst fstp fr0)
2678           (sc-case y
2679             (signed-reg
2680              (inst mov temp y)
2681              (inst fild temp))
2682             (signed-stack
2683              (inst fild y)))
2684           (inst fxch fr1))
2685          (t
2686           (inst fstp fr0)
2687           (inst fstp fr0)
2688           (sc-case y
2689             (signed-reg
2690              (inst mov temp y)
2691              (inst fild temp))
2692             (signed-stack
2693              (inst fild y)))
2694           (inst fld (make-random-tn :kind :normal
2695                                     :sc (sc-or-lose 'double-reg)
2696                                     :offset (1- (tn-offset x)))))))
2697       ((double-stack descriptor-reg)
2698        (inst fstp fr0)
2699        (inst fstp fr0)
2700        (sc-case y
2701          (signed-reg
2702           (inst mov temp y)
2703           (inst fild temp))
2704          (signed-stack
2705           (inst fild y)))
2706        (if (sc-is x double-stack)
2707            (inst fldd (ea-for-df-stack x))
2708            (inst fldd (ea-for-df-desc x)))))
2709     (inst fscale)
2710     (unless (zerop (tn-offset r))
2711       (inst fstd r))))
2712
2713(define-vop (fscale)
2714  (:translate %scalb)
2715  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2716         (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2717  (:temporary (:sc double-reg :offset fr0-offset
2718                   :from (:argument 0) :to :result) fr0)
2719  (:temporary (:sc double-reg :offset fr1-offset
2720                   :from (:argument 1) :to :result) fr1)
2721  (:results (r :scs (double-reg)))
2722  (:arg-types double-float double-float)
2723  (:result-types double-float)
2724  (:policy :fast-safe)
2725  (:note "inline scalb function")
2726  (:vop-var vop)
2727  (:save-p :compute-only)
2728  (:generator 5
2729     (note-this-location vop :internal-error)
2730     ;; Setup x in fr0 and y in fr1
2731     (cond
2732      ;; x in fr0; y in fr1
2733      ((and (sc-is x double-reg) (zerop (tn-offset x))
2734            (sc-is y double-reg) (= 1 (tn-offset y))))
2735      ;; y in fr1; x not in fr0
2736      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2737       ;; Load x to fr0
2738       (sc-case x
2739          (double-reg
2740           (copy-fp-reg-to-fr0 x))
2741          (double-stack
2742           (inst fstp fr0)
2743           (inst fldd (ea-for-df-stack x)))
2744          (descriptor-reg
2745           (inst fstp fr0)
2746           (inst fldd (ea-for-df-desc x)))))
2747      ;; x in fr0; y not in fr1
2748      ((and (sc-is x double-reg) (zerop (tn-offset x)))
2749       (inst fxch fr1)
2750       ;; Now load y to fr0
2751       (sc-case y
2752          (double-reg
2753           (copy-fp-reg-to-fr0 y))
2754          (double-stack
2755           (inst fstp fr0)
2756           (inst fldd (ea-for-df-stack y)))
2757          (descriptor-reg
2758           (inst fstp fr0)
2759           (inst fldd (ea-for-df-desc y))))
2760       (inst fxch fr1))
2761      ;; x in fr1; y not in fr1
2762      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2763       ;; Load y to fr0
2764       (sc-case y
2765          (double-reg
2766           (copy-fp-reg-to-fr0 y))
2767          (double-stack
2768           (inst fstp fr0)
2769           (inst fldd (ea-for-df-stack y)))
2770          (descriptor-reg
2771           (inst fstp fr0)
2772           (inst fldd (ea-for-df-desc y))))
2773       (inst fxch fr1))
2774      ;; y in fr0;
2775      ((and (sc-is y double-reg) (zerop (tn-offset y)))
2776       (inst fxch fr1)
2777       ;; Now load x to fr0
2778       (sc-case x
2779          (double-reg
2780           (copy-fp-reg-to-fr0 x))
2781          (double-stack
2782           (inst fstp fr0)
2783           (inst fldd (ea-for-df-stack x)))
2784          (descriptor-reg
2785           (inst fstp fr0)
2786           (inst fldd (ea-for-df-desc x)))))
2787      ;; Neither x or y are in either fr0 or fr1
2788      (t
2789       ;; Load y then x
2790       (inst fstp fr0)
2791       (inst fstp fr0)
2792       (sc-case y
2793          (double-reg
2794           (inst fldd (make-random-tn :kind :normal
2795                                      :sc (sc-or-lose 'double-reg)
2796                                      :offset (- (tn-offset y) 2))))
2797          (double-stack
2798           (inst fldd (ea-for-df-stack y)))
2799          (descriptor-reg
2800           (inst fldd (ea-for-df-desc y))))
2801       ;; Load x to fr0
2802       (sc-case x
2803          (double-reg
2804           (inst fldd (make-random-tn :kind :normal
2805                                      :sc (sc-or-lose 'double-reg)
2806                                      :offset (1- (tn-offset x)))))
2807          (double-stack
2808           (inst fldd (ea-for-df-stack x)))
2809          (descriptor-reg
2810           (inst fldd (ea-for-df-desc x))))))
2811
2812     ;; Now have x at fr0; and y at fr1
2813     (inst fscale)
2814     (unless (zerop (tn-offset r))
2815             (inst fstd r))))
2816
2817(define-vop (flog1p)
2818  (:translate %log1p)
2819  (:args (x :scs (double-reg) :to :result))
2820  (:temporary (:sc double-reg :offset fr0-offset
2821                   :from :argument :to :result) fr0)
2822  (:temporary (:sc double-reg :offset fr1-offset
2823                   :from :argument :to :result) fr1)
2824  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2825  (:results (y :scs (double-reg)))
2826  (:arg-types double-float)
2827  (:result-types double-float)
2828  (:policy :fast-safe)
2829  (:note "inline log1p function")
2830  (:ignore temp)
2831  (:generator 5
2832     ;; x is in a FP reg, not fr0, fr1.
2833     (inst fstp fr0)
2834     (inst fstp fr0)
2835     (inst fldd (make-random-tn :kind :normal
2836                                :sc (sc-or-lose 'double-reg)
2837                                :offset (- (tn-offset x) 2)))
2838     ;; Check the range
2839     (inst push #x3e947ae1)     ; Constant 0.29
2840     (inst fabs)
2841     (inst fld (make-ea :dword :base esp-tn))
2842     (inst fcompp)
2843     (inst add esp-tn 4)
2844     (inst fnstsw)                      ; status word to ax
2845     (inst and ah-tn #x45)
2846     (inst jmp :z WITHIN-RANGE)
2847     ;; Out of range for fyl2xp1.
2848     (inst fld1)
2849     (inst faddd (make-random-tn :kind :normal
2850                                 :sc (sc-or-lose 'double-reg)
2851                                 :offset (- (tn-offset x) 1)))
2852     (inst fldln2)
2853     (inst fxch fr1)
2854     (inst fyl2x)
2855     (inst jmp DONE)
2856
2857     WITHIN-RANGE
2858     (inst fldln2)
2859     (inst fldd (make-random-tn :kind :normal
2860                                :sc (sc-or-lose 'double-reg)
2861                                :offset (- (tn-offset x) 1)))
2862     (inst fyl2xp1)
2863     DONE
2864     (inst fld fr0)
2865     (case (tn-offset y)
2866       ((0 1))
2867       (t (inst fstd y)))))
2868
2869;;; The Pentium has a less restricted implementation of the fyl2xp1
2870;;; instruction and a range check can be avoided.
2871(define-vop (flog1p-pentium)
2872  (:translate %log1p)
2873  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2874  (:temporary (:sc double-reg :offset fr0-offset
2875                   :from :argument :to :result) fr0)
2876  (:temporary (:sc double-reg :offset fr1-offset
2877                   :from :argument :to :result) fr1)
2878  (:results (y :scs (double-reg)))
2879  (:arg-types double-float)
2880  (:result-types double-float)
2881  (:policy :fast-safe)
2882  (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2883  (:note "inline log1p with limited x range function")
2884  (:vop-var vop)
2885  (:save-p :compute-only)
2886  (:generator 4
2887     (note-this-location vop :internal-error)
2888     (sc-case x
2889        (double-reg
2890         (case (tn-offset x)
2891            (0
2892             ;; x is in fr0
2893             (inst fstp fr1)
2894             (inst fldln2)
2895             (inst fxch fr1))
2896            (1
2897             ;; x is in fr1
2898             (inst fstp fr0)
2899             (inst fldln2)
2900             (inst fxch fr1))
2901            (t
2902             ;; x is in a FP reg, not fr0 or fr1
2903             (inst fstp fr0)
2904             (inst fstp fr0)
2905             (inst fldln2)
2906             (inst fldd (make-random-tn :kind :normal
2907                                        :sc (sc-or-lose 'double-reg)
2908                                        :offset (1- (tn-offset x)))))))
2909        ((double-stack descriptor-reg)
2910         (inst fstp fr0)
2911         (inst fstp fr0)
2912         (inst fldln2)
2913         (if (sc-is x double-stack)
2914             (inst fldd (ea-for-df-stack x))
2915           (inst fldd (ea-for-df-desc x)))))
2916     (inst fyl2xp1)
2917     (inst fld fr0)
2918     (case (tn-offset y)
2919       ((0 1))
2920       (t (inst fstd y)))))
2921
2922(define-vop (flogb)
2923  (:translate %logb)
2924  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2925  (:temporary (:sc double-reg :offset fr0-offset
2926                   :from :argument :to :result) fr0)
2927  (:temporary (:sc double-reg :offset fr1-offset
2928                   :from :argument :to :result) fr1)
2929  (:results (y :scs (double-reg)))
2930  (:arg-types double-float)
2931  (:result-types double-float)
2932  (:policy :fast-safe)
2933  (:note "inline logb function")
2934  (:vop-var vop)
2935  (:save-p :compute-only)
2936  (:generator 5
2937     (note-this-location vop :internal-error)
2938     (sc-case x
2939        (double-reg
2940         (case (tn-offset x)
2941            (0
2942             ;; x is in fr0
2943             (inst fstp fr1))
2944            (1
2945             ;; x is in fr1
2946             (inst fstp fr0))
2947            (t
2948             ;; x is in a FP reg, not fr0 or fr1
2949             (inst fstp fr0)
2950             (inst fstp fr0)
2951             (inst fldd (make-random-tn :kind :normal
2952                                        :sc (sc-or-lose 'double-reg)
2953                                        :offset (- (tn-offset x) 2))))))
2954        ((double-stack descriptor-reg)
2955         (inst fstp fr0)
2956         (inst fstp fr0)
2957         (if (sc-is x double-stack)
2958             (inst fldd (ea-for-df-stack x))
2959           (inst fldd (ea-for-df-desc x)))))
2960     (inst fxtract)
2961     (case (tn-offset y)
2962       (0
2963        (inst fxch fr1))
2964       (1)
2965       (t (inst fxch fr1)
2966          (inst fstd y)))))
2967
2968(define-vop (fatan)
2969  (:translate %atan)
2970  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2971  (:temporary (:sc double-reg :offset fr0-offset
2972                   :from (:argument 0) :to :result) fr0)
2973  (:temporary (:sc double-reg :offset fr1-offset
2974                   :from (:argument 0) :to :result) fr1)
2975  (:results (r :scs (double-reg)))
2976  (:arg-types double-float)
2977  (:result-types double-float)
2978  (:policy :fast-safe)
2979  (:note "inline atan function")
2980  (:vop-var vop)
2981  (:save-p :compute-only)
2982  (:generator 5
2983     (note-this-location vop :internal-error)
2984     ;; Setup x in fr1 and 1.0 in fr0
2985     (cond
2986      ;; x in fr0
2987      ((and (sc-is x double-reg) (zerop (tn-offset x)))
2988       (inst fstp fr1))
2989      ;; x in fr1
2990      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2991       (inst fstp fr0))
2992      ;; x not in fr0 or fr1
2993      (t
2994       ;; Load x then 1.0
2995       (inst fstp fr0)
2996       (inst fstp fr0)
2997       (sc-case x
2998          (double-reg
2999           (inst fldd (make-random-tn :kind :normal
3000                                      :sc (sc-or-lose 'double-reg)
3001                                      :offset (- (tn-offset x) 2))))
3002          (double-stack
3003           (inst fldd (ea-for-df-stack x)))
3004          (descriptor-reg
3005           (inst fldd (ea-for-df-desc x))))))
3006     (inst fld1)
3007     ;; Now have x at fr1; and 1.0 at fr0
3008     (inst fpatan)
3009     (inst fld fr0)
3010     (case (tn-offset r)
3011       ((0 1))
3012       (t (inst fstd r)))))
3013
3014(define-vop (fatan2)
3015  (:translate %atan2)
3016  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3017         (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3018  (:temporary (:sc double-reg :offset fr0-offset
3019                   :from (:argument 1) :to :result) fr0)
3020  (:temporary (:sc double-reg :offset fr1-offset
3021                   :from (:argument 0) :to :result) fr1)
3022  (:results (r :scs (double-reg)))
3023  (:arg-types double-float double-float)
3024  (:result-types double-float)
3025  (:policy :fast-safe)
3026  (:note "inline atan2 function")
3027  (:vop-var vop)
3028  (:save-p :compute-only)
3029  (:generator 5
3030     (note-this-location vop :internal-error)
3031     ;; Setup x in fr1 and y in fr0
3032     (cond
3033      ;; y in fr0; x in fr1
3034      ((and (sc-is y double-reg) (zerop (tn-offset y))
3035            (sc-is x double-reg) (= 1 (tn-offset x))))
3036      ;; x in fr1; y not in fr0
3037      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3038       ;; Load y to fr0
3039       (sc-case y
3040          (double-reg
3041           (copy-fp-reg-to-fr0 y))
3042          (double-stack
3043           (inst fstp fr0)
3044           (inst fldd (ea-for-df-stack y)))
3045          (descriptor-reg
3046           (inst fstp fr0)
3047           (inst fldd (ea-for-df-desc y)))))
3048      ((and (sc-is x double-reg) (zerop (tn-offset x))
3049            (sc-is y double-reg) (zerop (tn-offset x)))
3050       ;; copy x to fr1
3051       (inst fst fr1))
3052      ;; y in fr0; x not in fr1
3053      ((and (sc-is y double-reg) (zerop (tn-offset y)))
3054       (inst fxch fr1)
3055       ;; Now load x to fr0
3056       (sc-case x
3057          (double-reg
3058           (copy-fp-reg-to-fr0 x))
3059          (double-stack
3060           (inst fstp fr0)
3061           (inst fldd (ea-for-df-stack x)))
3062          (descriptor-reg
3063           (inst fstp fr0)
3064           (inst fldd (ea-for-df-desc x))))
3065       (inst fxch fr1))
3066      ;; y in fr1; x not in fr1
3067      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3068       ;; Load x to fr0
3069       (sc-case x
3070          (double-reg
3071           (copy-fp-reg-to-fr0 x))
3072          (double-stack
3073           (inst fstp fr0)
3074           (inst fldd (ea-for-df-stack x)))
3075          (descriptor-reg
3076           (inst fstp fr0)
3077           (inst fldd (ea-for-df-desc x))))
3078       (inst fxch fr1))
3079      ;; x in fr0;
3080      ((and (sc-is x double-reg) (zerop (tn-offset x)))
3081       (inst fxch fr1)
3082       ;; Now load y to fr0
3083       (sc-case y
3084          (double-reg
3085           (copy-fp-reg-to-fr0 y))
3086          (double-stack
3087           (inst fstp fr0)
3088           (inst fldd (ea-for-df-stack y)))
3089          (descriptor-reg
3090           (inst fstp fr0)
3091           (inst fldd (ea-for-df-desc y)))))
3092      ;; Neither y or x are in either fr0 or fr1
3093      (t
3094       ;; Load x then y
3095       (inst fstp fr0)
3096       (inst fstp fr0)
3097       (sc-case x
3098          (double-reg
3099           (inst fldd (make-random-tn :kind :normal
3100                                      :sc (sc-or-lose 'double-reg)
3101                                      :offset (- (tn-offset x) 2))))
3102          (double-stack
3103           (inst fldd (ea-for-df-stack x)))
3104          (descriptor-reg
3105           (inst fldd (ea-for-df-desc x))))
3106       ;; Load y to fr0
3107       (sc-case y
3108          (double-reg
3109           (inst fldd (make-random-tn :kind :normal
3110                                      :sc (sc-or-lose 'double-reg)
3111                                      :offset (1- (tn-offset y)))))
3112          (double-stack
3113           (inst fldd (ea-for-df-stack y)))
3114          (descriptor-reg
3115           (inst fldd (ea-for-df-desc y))))))
3116
3117     ;; Now have y at fr0; and x at fr1
3118     (inst fpatan)
3119     (inst fld fr0)
3120     (case (tn-offset r)
3121       ((0 1))
3122       (t (inst fstd r)))))
3123) ; PROGN #!-LONG-FLOAT
3124
3125#!+long-float
3126(progn
3127
3128;;; Lets use some of the 80387 special functions.
3129;;;
3130;;; These defs will not take effect unless code/irrat.lisp is modified
3131;;; to remove the inlined alien routine def.
3132
3133(macrolet ((frob (func trans op)
3134             `(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               (:ignore fr0)
3139               (:results (y :scs (long-reg)))
3140               (:arg-types long-float)
3141               (:result-types long-float)
3142               (:translate ,trans)
3143               (:policy :fast-safe)
3144               (:note "inline NPX function")
3145               (:vop-var vop)
3146               (:save-p :compute-only)
3147               (:node-var node)
3148               (:generator 5
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
3154                (inst ,op)              ; clobber st0
3155                (cond ((zerop (tn-offset y))
3156                       (maybe-fp-wait node))
3157                      (t
3158                       (inst fst y)))))))
3159
3160  ;; Quick versions of FSIN and FCOS that require the argument to be
3161  ;; within range 2^63.
3162  (frob fsin-quick %sin-quick fsin)
3163  (frob fcos-quick %cos-quick fcos)
3164  (frob fsqrt %sqrt fsqrt))
3165
3166;;; Quick version of ftan that requires the argument to be within
3167;;; range 2^63.
3168(define-vop (ftan-quick)
3169  (:translate %tan-quick)
3170  (:args (x :scs (long-reg) :target fr0))
3171  (:temporary (:sc long-reg :offset fr0-offset
3172                   :from :argument :to :result) fr0)
3173  (:temporary (:sc long-reg :offset fr1-offset
3174                   :from :argument :to :result) fr1)
3175  (:results (y :scs (long-reg)))
3176  (:arg-types long-float)
3177  (:result-types long-float)
3178  (:policy :fast-safe)
3179  (:note "inline tan function")
3180  (:vop-var vop)
3181  (:save-p :compute-only)
3182  (:generator 5
3183    (note-this-location vop :internal-error)
3184    (case (tn-offset x)
3185       (0
3186        (inst fstp fr1))
3187       (1
3188        (inst fstp fr0))
3189       (t
3190        (inst fstp fr0)
3191        (inst fstp fr0)
3192        (inst fldd (make-random-tn :kind :normal
3193                                   :sc (sc-or-lose 'double-reg)
3194                                   :offset (- (tn-offset x) 2)))))
3195    (inst fptan)
3196    ;; Result is in fr1
3197    (case (tn-offset y)
3198       (0
3199        (inst fxch fr1))
3200       (1)
3201       (t
3202        (inst fxch fr1)
3203        (inst fstd y)))))
3204
3205;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3206;;; the argument is out of range 2^63 and would thus be hopelessly
3207;;; inaccurate.
3208(macrolet ((frob (func trans op)
3209             `(define-vop (,func)
3210                (:translate ,trans)
3211                (:args (x :scs (long-reg) :target fr0))
3212                (:temporary (:sc long-reg :offset fr0-offset
3213                                 :from :argument :to :result) fr0)
3214                (:temporary (:sc unsigned-reg :offset eax-offset
3215                             :from :argument :to :result) eax)
3216                (:results (y :scs (long-reg)))
3217                (:arg-types long-float)
3218                (:result-types long-float)
3219                (:policy :fast-safe)
3220                (:note "inline sin/cos function")
3221                (:vop-var vop)
3222                (:save-p :compute-only)
3223                (:ignore eax)
3224                (:generator 5
3225                  (note-this-location vop :internal-error)
3226                  (unless (zerop (tn-offset x))
3227                          (inst fxch x)          ; x to top of stack
3228                          (unless (location= x y)
3229                                  (inst fst x))) ; maybe save it
3230                  (inst ,op)
3231                  (inst fnstsw)                  ; status word to ax
3232                  (inst and ah-tn #x04)          ; C2
3233                  (inst jmp :z DONE)
3234                  ;; Else x was out of range so reduce it; ST0 is unchanged.
3235                  (inst fstp fr0)               ; Load 0.0
3236                  (inst fldz)
3237                  DONE
3238                  (unless (zerop (tn-offset y))
3239                          (inst fstd y))))))
3240          (frob fsin  %sin fsin)
3241          (frob fcos  %cos fcos))
3242
3243(define-vop (ftan)
3244  (:translate %tan)
3245  (:args (x :scs (long-reg) :target fr0))
3246  (:temporary (:sc long-reg :offset fr0-offset
3247                   :from :argument :to :result) fr0)
3248  (:temporary (:sc long-reg :offset fr1-offset
3249                   :from :argument :to :result) fr1)
3250  (:temporary (:sc unsigned-reg :offset eax-offset
3251                   :from :argument :to :result) eax)
3252  (:results (y :scs (long-reg)))
3253  (:arg-types long-float)
3254  (:result-types long-float)
3255  (:ignore eax)
3256  (:policy :fast-safe)
3257  (:note "inline tan function")
3258  (:vop-var vop)
3259  (:save-p :compute-only)
3260  (:ignore eax)
3261  (:generator 5
3262    (note-this-location vop :internal-error)
3263    (case (tn-offset x)
3264       (0
3265        (inst fstp fr1))
3266       (1
3267        (inst fstp fr0))
3268       (t
3269        (inst fstp fr0)
3270        (inst fstp fr0)
3271        (inst fldd (make-random-tn :kind :normal
3272                                   :sc (sc-or-lose 'double-reg)
3273                                   :offset (- (tn-offset x) 2)))))
3274    (inst fptan)
3275    (inst fnstsw)                        ; status word to ax
3276    (inst and ah-tn #x04)                ; C2
3277    (inst jmp :z DONE)
3278    ;; Else x was out of range so reduce it; ST0 is unchanged.
3279    (inst fldz)                  ; Load 0.0
3280    (inst fxch fr1)
3281    DONE
3282    ;; Result is in fr1
3283    (case (tn-offset y)
3284       (0
3285        (inst fxch fr1))
3286       (1)
3287       (t
3288        (inst fxch fr1)
3289        (inst fstd y)))))
3290
3291;;; Modified exp that handles the following special cases:
3292;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3293(define-vop (fexp)
3294  (:translate %exp)
3295  (:args (x :scs (long-reg) :target fr0))
3296  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3297  (:temporary (:sc long-reg :offset fr0-offset
3298                   :from :argument :to :result) fr0)
3299  (:temporary (:sc long-reg :offset fr1-offset
3300                   :from :argument :to :result) fr1)
3301  (:temporary (:sc long-reg :offset fr2-offset
3302                   :from :argument :to :result) fr2)
3303  (:results (y :scs (long-reg)))
3304  (:arg-types long-float)
3305  (:result-types long-float)
3306  (:policy :fast-safe)
3307  (:note "inline exp function")
3308  (:vop-var vop)
3309  (:save-p :compute-only)
3310  (:ignore temp)
3311  (:generator 5
3312     (note-this-location vop :internal-error)
3313     (unless (zerop (tn-offset x))
3314             (inst fxch x)              ; x to top of stack
3315             (unless (location= x y)
3316                     (inst fst x)))     ; maybe save it
3317     ;; Check for Inf or NaN
3318     (inst fxam)
3319     (inst fnstsw)
3320     (inst sahf)
3321     (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3322     (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3323     (inst and ah-tn #x02)            ; Test sign of Inf.
3324     (inst jmp :z DONE)          ; +Inf gives +Inf.
3325     (inst fstp fr0)                ; -Inf gives 0
3326     (inst fldz)
3327     (inst jmp-short DONE)
3328     NOINFNAN
3329     (inst fstp fr1)
3330     (inst fldl2e)
3331     (inst fmul fr1)
3332     ;; Now fr0=x log2(e)
3333     (inst fst fr1)
3334     (inst frndint)
3335     (inst fst fr2)
3336     (inst fsubp-sti fr1)
3337     (inst f2xm1)
3338     (inst fld1)
3339     (inst faddp-sti fr1)
3340     (inst fscale)
3341     (inst fld fr0)
3342     DONE
3343     (unless (zerop (tn-offset y))
3344             (inst fstd y))))
3345
3346;;; Expm1 = exp(x) - 1.
3347;;; Handles the following special cases:
3348;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3349(define-vop (fexpm1)
3350  (:translate %expm1)
3351  (:args (x :scs (long-reg) :target fr0))
3352  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3353  (:temporary (:sc long-reg :offset fr0-offset
3354                   :from :argument :to :result) fr0)
3355  (:temporary (:sc long-reg :offset fr1-offset
3356                   :from :argument :to :result) fr1)
3357  (:temporary (:sc long-reg :offset fr2-offset
3358                   :from :argument :to :result) fr2)
3359  (:results (y :scs (long-reg)))
3360  (:arg-types long-float)
3361  (:result-types long-float)
3362  (:policy :fast-safe)
3363  (:note "inline expm1 function")
3364  (:vop-var vop)
3365  (:save-p :compute-only)
3366  (:ignore temp)
3367  (:generator 5
3368     (note-this-location vop :internal-error)
3369     (unless (zerop (tn-offset x))
3370       (inst fxch x)            ; x to top of stack
3371       (unless (location= x y)
3372         (inst fst x))) ; maybe save it
3373     ;; Check for Inf or NaN
3374     (inst fxam)
3375     (inst fnstsw)
3376     (inst sahf)
3377     (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3378     (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3379     (inst and ah-tn #x02)            ; Test sign of Inf.
3380     (inst jmp :z DONE)          ; +Inf gives +Inf.
3381     (inst fstp fr0)                ; -Inf gives -1.0
3382     (inst fld1)
3383     (inst fchs)
3384     (inst jmp-short DONE)
3385     NOINFNAN
3386     ;; Free two stack slots leaving the argument on top.
3387     (inst fstp fr2)
3388     (inst fstp fr0)
3389     (inst fldl2e)
3390     (inst fmul fr1)    ; Now fr0 = x log2(e)
3391     (inst fst fr1)
3392     (inst frndint)
3393     (inst fsub-sti fr1)
3394     (inst fxch fr1)
3395     (inst f2xm1)
3396     (inst fscale)
3397     (inst fxch fr1)
3398     (inst fld1)
3399     (inst fscale)
3400     (inst fstp fr1)
3401     (inst fld1)
3402     (inst fsub fr1)
3403     (inst fsubr fr2)
3404     DONE
3405     (unless (zerop (tn-offset y))
3406       (inst fstd y))))
3407
3408(define-vop (flog)
3409  (:translate %log)
3410  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3411  (:temporary (:sc long-reg :offset fr0-offset
3412                   :from :argument :to :result) fr0)
3413  (:temporary (:sc long-reg :offset fr1-offset
3414                   :from :argument :to :result) fr1)
3415  (:results (y :scs (long-reg)))
3416  (:arg-types long-float)
3417  (:result-types long-float)
3418  (:policy :fast-safe)
3419  (:note "inline log function")
3420  (:vop-var vop)
3421  (:save-p :compute-only)
3422  (:generator 5
3423     (note-this-location vop :internal-error)
3424     (sc-case x
3425        (long-reg
3426         (case (tn-offset x)
3427            (0
3428             ;; x is in fr0
3429             (inst fstp fr1)
3430             (inst fldln2)
3431             (inst fxch fr1))
3432            (1
3433             ;; x is in fr1
3434             (inst fstp fr0)
3435             (inst fldln2)
3436             (inst fxch fr1))
3437            (t
3438             ;; x is in a FP reg, not fr0 or fr1
3439             (inst fstp fr0)
3440             (inst fstp fr0)
3441             (inst fldln2)
3442             (inst fldd (make-random-tn :kind :normal
3443                                        :sc (sc-or-lose 'double-reg)
3444                                        :offset (1- (tn-offset x))))))
3445         (inst fyl2x))
3446        ((long-stack descriptor-reg)
3447         (inst fstp fr0)
3448         (inst fstp fr0)
3449         (inst fldln2)
3450         (if (sc-is x long-stack)
3451             (inst fldl (ea-for-lf-stack x))
3452             (inst fldl (ea-for-lf-desc x)))
3453         (inst fyl2x)))
3454     (inst fld fr0)
3455     (case (tn-offset y)
3456       ((0 1))
3457       (t (inst fstd y)))))
3458
3459(define-vop (flog10)
3460  (:translate %log10)
3461  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3462  (:temporary (:sc long-reg :offset fr0-offset
3463                   :from :argument :to :result) fr0)
3464  (:temporary (:sc long-reg :offset fr1-offset
3465                   :from :argument :to :result) fr1)
3466  (:results (y :scs (long-reg)))
3467  (:arg-types long-float)
3468  (:result-types long-float)
3469  (:policy :fast-safe)
3470  (:note "inline log10 function")
3471  (:vop-var vop)
3472  (:save-p :compute-only)
3473  (:generator 5
3474     (note-this-location vop :internal-error)
3475     (sc-case x
3476        (long-reg
3477         (case (tn-offset x)
3478            (0
3479             ;; x is in fr0
3480             (inst fstp fr1)
3481             (inst fldlg2)
3482             (inst fxch fr1))
3483            (1
3484             ;; x is in fr1
3485             (inst fstp fr0)
3486             (inst fldlg2)
3487             (inst fxch fr1))
3488            (t
3489             ;; x is in a FP reg, not fr0 or fr1
3490             (inst fstp fr0)
3491             (inst fstp fr0)
3492             (inst fldlg2)
3493             (inst fldd (make-random-tn :kind :normal
3494                                        :sc (sc-or-lose 'double-reg)
3495                                        :offset (1- (tn-offset x))))))
3496         (inst fyl2x))
3497        ((long-stack descriptor-reg)
3498         (inst fstp fr0)
3499         (inst fstp fr0)
3500         (inst fldlg2)
3501         (if (sc-is x long-stack)
3502             (inst fldl (ea-for-lf-stack x))
3503             (inst fldl (ea-for-lf-desc x)))
3504         (inst fyl2x)))
3505     (inst fld fr0)
3506     (case (tn-offset y)
3507       ((0 1))
3508       (t (inst fstd y)))))
3509
3510(define-vop (fpow)
3511  (:translate %pow)
3512  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3513         (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3514  (:temporary (:sc long-reg :offset fr0-offset
3515                   :from (:argument 0) :to :result) fr0)
3516  (:temporary (:sc long-reg :offset fr1-offset
3517                   :from (:argument 1) :to :result) fr1)
3518  (:temporary (:sc long-reg :offset fr2-offset
3519                   :from :load :to :result) fr2)
3520  (:results (r :scs (long-reg)))
3521  (:arg-types long-float long-float)
3522  (:result-types long-float)
3523  (:policy :fast-safe)
3524  (:note "inline pow function")
3525  (:vop-var vop)
3526  (:save-p :compute-only)
3527  (:generator 5
3528     (note-this-location vop :internal-error)
3529     ;; Setup x in fr0 and y in fr1
3530     (cond
3531      ;; x in fr0; y in fr1
3532      ((and (sc-is x long-reg) (zerop (tn-offset x))
3533            (sc-is y long-reg) (= 1 (tn-offset y))))
3534      ;; y in fr1; x not in fr0
3535      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3536       ;; Load x to fr0
3537       (sc-case x
3538          (long-reg
3539           (copy-fp-reg-to-fr0 x))
3540          (long-stack
3541           (inst fstp fr0)
3542           (inst fldl (ea-for-lf-stack x)))
3543          (descriptor-reg
3544           (inst fstp fr0)
3545           (inst fldl (ea-for-lf-desc x)))))
3546      ;; x in fr0; y not in fr1
3547      ((and (sc-is x long-reg) (zerop (tn-offset x)))
3548       (inst fxch fr1)
3549       ;; Now load y to fr0
3550       (sc-case y
3551          (long-reg
3552           (copy-fp-reg-to-fr0 y))
3553          (long-stack
3554           (inst fstp fr0)
3555           (inst fldl (ea-for-lf-stack y)))
3556          (descriptor-reg
3557           (inst fstp fr0)
3558           (inst fldl (ea-for-lf-desc y))))
3559       (inst fxch fr1))
3560      ;; x in fr1; y not in fr1
3561      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3562       ;; Load y to fr0
3563       (sc-case y
3564          (long-reg
3565           (copy-fp-reg-to-fr0 y))
3566          (long-stack
3567           (inst fstp fr0)
3568           (inst fldl (ea-for-lf-stack y)))
3569          (descriptor-reg
3570           (inst fstp fr0)
3571           (inst fldl (ea-for-lf-desc y))))
3572       (inst fxch fr1))
3573      ;; y in fr0;
3574      ((and (sc-is y long-reg) (zerop (tn-offset y)))
3575       (inst fxch fr1)
3576       ;; Now load x to fr0
3577       (sc-case x
3578          (long-reg
3579           (copy-fp-reg-to-fr0 x))
3580          (long-stack
3581           (inst fstp fr0)
3582           (inst fldl (ea-for-lf-stack x)))
3583          (descriptor-reg
3584           (inst fstp fr0)
3585           (inst fldl (ea-for-lf-desc x)))))
3586      ;; Neither x or y are in either fr0 or fr1
3587      (t
3588       ;; Load y then x
3589       (inst fstp fr0)
3590       (inst fstp fr0)
3591       (sc-case y
3592          (long-reg
3593           (inst fldd (make-random-tn :kind :normal
3594                                      :sc (sc-or-lose 'double-reg)
3595                                      :offset (- (tn-offset y) 2))))
3596          (long-stack
3597           (inst fldl (ea-for-lf-stack y)))
3598          (descriptor-reg
3599           (inst fldl (ea-for-lf-desc y))))
3600       ;; Load x to fr0
3601       (sc-case x
3602          (long-reg
3603           (inst fldd (make-random-tn :kind :normal
3604                                      :sc (sc-or-lose 'double-reg)
3605                                      :offset (1- (tn-offset x)))))
3606          (long-stack
3607           (inst fldl (ea-for-lf-stack x)))
3608          (descriptor-reg
3609           (inst fldl (ea-for-lf-desc x))))))
3610
3611     ;; Now have x at fr0; and y at fr1
3612     (inst fyl2x)
3613     ;; Now fr0=y log2(x)
3614     (inst fld fr0)
3615     (inst frndint)
3616     (inst fst fr2)
3617     (inst fsubp-sti fr1)
3618     (inst f2xm1)
3619     (inst fld1)
3620     (inst faddp-sti fr1)
3621     (inst fscale)
3622     (inst fld fr0)
3623     (case (tn-offset r)
3624       ((0 1))
3625       (t (inst fstd r)))))
3626
3627(define-vop (fscalen)
3628  (:translate %scalbn)
3629  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3630         (y :scs (signed-stack signed-reg) :target temp))
3631  (:temporary (:sc long-reg :offset fr0-offset
3632                   :from (:argument 0) :to :result) fr0)
3633  (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3634  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3635  (:results (r :scs (long-reg)))
3636  (:arg-types long-float signed-num)
3637  (:result-types long-float)
3638  (:policy :fast-safe)
3639  (:note "inline scalbn function")
3640  (:generator 5
3641     ;; Setup x in fr0 and y in fr1
3642     (sc-case x
3643       (long-reg
3644        (case (tn-offset x)
3645          (0
3646           (inst fstp fr1)
3647           (sc-case y
3648             (signed-reg
3649              (inst mov temp y)
3650              (inst fild temp))
3651             (signed-stack
3652              (inst fild y)))
3653           (inst fxch fr1))
3654          (1
3655           (inst fstp fr0)
3656           (sc-case y
3657             (signed-reg
3658              (inst mov temp y)
3659              (inst fild temp))
3660             (signed-stack
3661              (inst fild y)))
3662           (inst fxch fr1))
3663          (t
3664           (inst fstp fr0)
3665           (inst fstp fr0)
3666           (sc-case y
3667             (signed-reg
3668              (inst mov temp y)
3669              (inst fild temp))
3670             (signed-stack
3671              (inst fild y)))
3672           (inst fld (make-random-tn :kind :normal
3673                                     :sc (sc-or-lose 'double-reg)
3674                                     :offset (1- (tn-offset x)))))))
3675       ((long-stack descriptor-reg)
3676        (inst fstp fr0)
3677        (inst fstp fr0)
3678        (sc-case y
3679          (signed-reg
3680           (inst mov temp y)
3681           (inst fild temp))
3682          (signed-stack
3683           (inst fild y)))
3684        (if (sc-is x long-stack)
3685            (inst fldl (ea-for-lf-stack x))
3686            (inst fldl (ea-for-lf-desc x)))))
3687     (inst fscale)
3688     (unless (zerop (tn-offset r))
3689       (inst fstd r))))
3690
3691(define-vop (fscale)
3692  (:translate %scalb)
3693  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3694         (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3695  (:temporary (:sc long-reg :offset fr0-offset
3696                   :from (:argument 0) :to :result) fr0)
3697  (:temporary (:sc long-reg :offset fr1-offset
3698                   :from (:argument 1) :to :result) fr1)
3699  (:results (r :scs (long-reg)))
3700  (:arg-types long-float long-float)
3701  (:result-types long-float)
3702  (:policy :fast-safe)
3703  (:note "inline scalb function")
3704  (:vop-var vop)
3705  (:save-p :compute-only)
3706  (:generator 5
3707     (note-this-location vop :internal-error)
3708     ;; Setup x in fr0 and y in fr1
3709     (cond
3710      ;; x in fr0; y in fr1
3711      ((and (sc-is x long-reg) (zerop (tn-offset x))
3712            (sc-is y long-reg) (= 1 (tn-offset y))))
3713      ;; y in fr1; x not in fr0
3714      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3715       ;; Load x to fr0
3716       (sc-case x
3717          (long-reg
3718           (copy-fp-reg-to-fr0 x))
3719          (long-stack
3720           (inst fstp fr0)
3721           (inst fldl (ea-for-lf-stack x)))
3722          (descriptor-reg
3723           (inst fstp fr0)
3724           (inst fldl (ea-for-lf-desc x)))))
3725      ;; x in fr0; y not in fr1
3726      ((and (sc-is x long-reg) (zerop (tn-offset x)))
3727       (inst fxch fr1)
3728       ;; Now load y to fr0
3729       (sc-case y
3730          (long-reg
3731           (copy-fp-reg-to-fr0 y))
3732          (long-stack
3733           (inst fstp fr0)
3734           (inst fldl (ea-for-lf-stack y)))
3735          (descriptor-reg
3736           (inst fstp fr0)
3737           (inst fldl (ea-for-lf-desc y))))
3738       (inst fxch fr1))
3739      ;; x in fr1; y not in fr1
3740      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3741       ;; Load y to fr0
3742       (sc-case y
3743          (long-reg
3744           (copy-fp-reg-to-fr0 y))
3745          (long-stack
3746           (inst fstp fr0)
3747           (inst fldl (ea-for-lf-stack y)))
3748          (descriptor-reg
3749           (inst fstp fr0)
3750           (inst fldl (ea-for-lf-desc y))))
3751       (inst fxch fr1))
3752      ;; y in fr0;
3753      ((and (sc-is y long-reg) (zerop (tn-offset y)))
3754       (inst fxch fr1)
3755       ;; Now load x to fr0
3756       (sc-case x
3757          (long-reg
3758           (copy-fp-reg-to-fr0 x))
3759          (long-stack
3760           (inst fstp fr0)
3761           (inst fldl (ea-for-lf-stack x)))
3762          (descriptor-reg
3763           (inst fstp fr0)
3764           (inst fldl (ea-for-lf-desc x)))))
3765      ;; Neither x or y are in either fr0 or fr1
3766      (t
3767       ;; Load y then x
3768       (inst fstp fr0)
3769       (inst fstp fr0)
3770       (sc-case y
3771          (long-reg
3772           (inst fldd (make-random-tn :kind :normal
3773                                      :sc (sc-or-lose 'double-reg)
3774                                      :offset (- (tn-offset y) 2))))
3775          (long-stack
3776           (inst fldl (ea-for-lf-stack y)))
3777          (descriptor-reg
3778           (inst fldl (ea-for-lf-desc y))))
3779       ;; Load x to fr0
3780       (sc-case x
3781          (long-reg
3782           (inst fldd (make-random-tn :kind :normal
3783                                      :sc (sc-or-lose 'double-reg)
3784                                      :offset (1- (tn-offset x)))))
3785          (long-stack
3786           (inst fldl (ea-for-lf-stack x)))
3787          (descriptor-reg
3788           (inst fldl (ea-for-lf-desc x))))))
3789
3790     ;; Now have x at fr0; and y at fr1
3791     (inst fscale)
3792     (unless (zerop (tn-offset r))
3793             (inst fstd r))))
3794
3795(define-vop (flog1p)
3796  (:translate %log1p)
3797  (:args (x :scs (long-reg) :to :result))
3798  (:temporary (:sc long-reg :offset fr0-offset
3799                   :from :argument :to :result) fr0)
3800  (:temporary (:sc long-reg :offset fr1-offset
3801                   :from :argument :to :result) fr1)
3802  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3803  (:results (y :scs (long-reg)))
3804  (:arg-types long-float)
3805  (:result-types long-float)
3806  (:policy :fast-safe)
3807  ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3808  ;;   Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3809  ;;   an enormous PROGN above. Still, it would be probably be good to
3810  ;;   add some code to warn about redefining VOPs.
3811  (:note "inline log1p function")
3812  (:ignore temp)
3813  (:generator 5
3814     ;; x is in a FP reg, not fr0, fr1.
3815     (inst fstp fr0)
3816     (inst fstp fr0)
3817     (inst fldd (make-random-tn :kind :normal
3818                                :sc (sc-or-lose 'double-reg)
3819                                :offset (- (tn-offset x) 2)))
3820     ;; Check the range
3821     (inst push #x3e947ae1)     ; Constant 0.29
3822     (inst fabs)
3823     (inst fld (make-ea :dword :base esp-tn))
3824     (inst fcompp)
3825     (inst add esp-tn 4)
3826     (inst fnstsw)                      ; status word to ax
3827     (inst and ah-tn #x45)
3828     (inst jmp :z WITHIN-RANGE)
3829     ;; Out of range for fyl2xp1.
3830     (inst fld1)
3831     (inst faddd (make-random-tn :kind :normal
3832                                 :sc (sc-or-lose 'double-reg)
3833                                 :offset (- (tn-offset x) 1)))
3834     (inst fldln2)
3835     (inst fxch fr1)
3836     (inst fyl2x)
3837     (inst jmp DONE)
3838
3839     WITHIN-RANGE
3840     (inst fldln2)
3841     (inst fldd (make-random-tn :kind :normal
3842                                :sc (sc-or-lose 'double-reg)
3843                                :offset (- (tn-offset x) 1)))
3844     (inst fyl2xp1)
3845     DONE
3846     (inst fld fr0)
3847     (case (tn-offset y)
3848       ((0 1))
3849       (t (inst fstd y)))))
3850
3851;;; The Pentium has a less restricted implementation of the fyl2xp1
3852;;; instruction and a range check can be avoided.
3853(define-vop (flog1p-pentium)
3854  (:translate %log1p)
3855  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3856  (:temporary (:sc long-reg :offset fr0-offset
3857                   :from :argument :to :result) fr0)
3858  (:temporary (:sc long-reg :offset fr1-offset
3859                   :from :argument :to :result) fr1)
3860  (:results (y :scs (long-reg)))
3861  (:arg-types long-float)
3862  (:result-types long-float)
3863  (:policy :fast-safe)
3864  (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
3865  (:note "inline log1p function")
3866  (:generator 5
3867     (sc-case x
3868        (long-reg
3869         (case (tn-offset x)
3870            (0
3871             ;; x is in fr0
3872             (inst fstp fr1)
3873             (inst fldln2)
3874             (inst fxch fr1))
3875            (1
3876             ;; x is in fr1
3877             (inst fstp fr0)
3878             (inst fldln2)
3879             (inst fxch fr1))
3880            (t
3881             ;; x is in a FP reg, not fr0 or fr1
3882             (inst fstp fr0)
3883             (inst fstp fr0)
3884             (inst fldln2)
3885             (inst fldd (make-random-tn :kind :normal
3886                                        :sc (sc-or-lose 'double-reg)
3887                                        :offset (1- (tn-offset x)))))))
3888        ((long-stack descriptor-reg)
3889         (inst fstp fr0)
3890         (inst fstp fr0)
3891         (inst fldln2)
3892         (if (sc-is x long-stack)
3893             (inst fldl (ea-for-lf-stack x))
3894           (inst fldl (ea-for-lf-desc x)))))
3895     (inst fyl2xp1)
3896     (inst fld fr0)
3897     (case (tn-offset y)
3898       ((0 1))
3899       (t (inst fstd y)))))
3900
3901(define-vop (flogb)
3902  (:translate %logb)
3903  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3904  (:temporary (:sc long-reg :offset fr0-offset
3905                   :from :argument :to :result) fr0)
3906  (:temporary (:sc long-reg :offset fr1-offset
3907                   :from :argument :to :result) fr1)
3908  (:results (y :scs (long-reg)))
3909  (:arg-types long-float)
3910  (:result-types long-float)
3911  (:policy :fast-safe)
3912  (:note "inline logb function")
3913  (:vop-var vop)
3914  (:save-p :compute-only)
3915  (:generator 5
3916     (note-this-location vop :internal-error)
3917     (sc-case x
3918        (long-reg
3919         (case (tn-offset x)
3920            (0
3921             ;; x is in fr0
3922             (inst fstp fr1))
3923            (1
3924             ;; x is in fr1
3925             (inst fstp fr0))
3926            (t
3927             ;; x is in a FP reg, not fr0 or fr1
3928             (inst fstp fr0)
3929             (inst fstp fr0)
3930             (inst fldd (make-random-tn :kind :normal
3931                                        :sc (sc-or-lose 'double-reg)
3932                                        :offset (- (tn-offset x) 2))))))
3933        ((long-stack descriptor-reg)
3934         (inst fstp fr0)
3935         (inst fstp fr0)
3936         (if (sc-is x long-stack)
3937             (inst fldl (ea-for-lf-stack x))
3938           (inst fldl (ea-for-lf-desc x)))))
3939     (inst fxtract)
3940     (case (tn-offset y)
3941       (0
3942        (inst fxch fr1))
3943       (1)
3944       (t (inst fxch fr1)
3945          (inst fstd y)))))
3946
3947(define-vop (fatan)
3948  (:translate %atan)
3949  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3950  (:temporary (:sc long-reg :offset fr0-offset
3951                   :from (:argument 0) :to :result) fr0)
3952  (:temporary (:sc long-reg :offset fr1-offset
3953                   :from (:argument 0) :to :result) fr1)
3954  (:results (r :scs (long-reg)))
3955  (:arg-types long-float)
3956  (:result-types long-float)
3957  (:policy :fast-safe)
3958  (:note "inline atan function")
3959  (:vop-var vop)
3960  (:save-p :compute-only)
3961  (:generator 5
3962     (note-this-location vop :internal-error)
3963     ;; Setup x in fr1 and 1.0 in fr0
3964     (cond
3965      ;; x in fr0
3966      ((and (sc-is x long-reg) (zerop (tn-offset x)))
3967       (inst fstp fr1))
3968      ;; x in fr1
3969      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3970       (inst fstp fr0))
3971      ;; x not in fr0 or fr1
3972      (t
3973       ;; Load x then 1.0
3974       (inst fstp fr0)
3975       (inst fstp fr0)
3976       (sc-case x
3977          (long-reg
3978           (inst fldd (make-random-tn :kind :normal
3979                                      :sc (sc-or-lose 'double-reg)
3980                                      :offset (- (tn-offset x) 2))))
3981          (long-stack
3982           (inst fldl (ea-for-lf-stack x)))
3983          (descriptor-reg
3984           (inst fldl (ea-for-lf-desc x))))))
3985     (inst fld1)
3986     ;; Now have x at fr1; and 1.0 at fr0
3987     (inst fpatan)
3988     (inst fld fr0)
3989     (case (tn-offset r)
3990       ((0 1))
3991       (t (inst fstd r)))))
3992
3993(define-vop (fatan2)
3994  (:translate %atan2)
3995  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
3996         (y :scs (long-reg long-stack descriptor-reg) :target fr0))
3997  (:temporary (:sc long-reg :offset fr0-offset
3998                   :from (:argument 1) :to :result) fr0)
3999  (:temporary (:sc long-reg :offset fr1-offset
4000                   :from (:argument 0) :to :result) fr1)
4001  (:results (r :scs (long-reg)))
4002  (:arg-types long-float long-float)
4003  (:result-types long-float)
4004  (:policy :fast-safe)
4005  (:note "inline atan2 function")
4006  (:vop-var vop)
4007  (:save-p :compute-only)
4008  (:generator 5
4009     (note-this-location vop :internal-error)
4010     ;; Setup x in fr1 and y in fr0
4011     (cond
4012      ;; y in fr0; x in fr1
4013      ((and (sc-is y long-reg) (zerop (tn-offset y))
4014            (sc-is x long-reg) (= 1 (tn-offset x))))
4015      ;; x in fr1; y not in fr0
4016      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4017       ;; Load y to fr0
4018       (sc-case y
4019          (long-reg
4020           (copy-fp-reg-to-fr0 y))
4021          (long-stack
4022           (inst fstp fr0)
4023           (inst fldl (ea-for-lf-stack y)))
4024          (descriptor-reg
4025           (inst fstp fr0)
4026           (inst fldl (ea-for-lf-desc y)))))
4027      ;; y in fr0; x not in fr1
4028      ((and (sc-is y long-reg) (zerop (tn-offset y)))
4029       (inst fxch fr1)
4030       ;; Now load x to fr0
4031       (sc-case x
4032          (long-reg
4033           (copy-fp-reg-to-fr0 x))
4034          (long-stack
4035           (inst fstp fr0)
4036           (inst fldl (ea-for-lf-stack x)))
4037          (descriptor-reg
4038           (inst fstp fr0)
4039           (inst fldl (ea-for-lf-desc x))))
4040       (inst fxch fr1))
4041      ;; y in fr1; x not in fr1
4042      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4043       ;; Load x to fr0
4044       (sc-case x
4045          (long-reg
4046           (copy-fp-reg-to-fr0 x))
4047          (long-stack
4048           (inst fstp fr0)
4049           (inst fldl (ea-for-lf-stack x)))
4050          (descriptor-reg
4051           (inst fstp fr0)
4052           (inst fldl (ea-for-lf-desc x))))
4053       (inst fxch fr1))
4054      ;; x in fr0;
4055      ((and (sc-is x long-reg) (zerop (tn-offset x)))
4056       (inst fxch fr1)
4057       ;; Now load y to fr0
4058       (sc-case y
4059          (long-reg
4060           (copy-fp-reg-to-fr0 y))
4061          (long-stack
4062           (inst fstp fr0)
4063           (inst fldl (ea-for-lf-stack y)))
4064          (descriptor-reg
4065           (inst fstp fr0)
4066           (inst fldl (ea-for-lf-desc y)))))
4067      ;; Neither y or x are in either fr0 or fr1
4068      (t
4069       ;; Load x then y
4070       (inst fstp fr0)
4071       (inst fstp fr0)
4072       (sc-case x
4073          (long-reg
4074           (inst fldd (make-random-tn :kind :normal
4075                                      :sc (sc-or-lose 'double-reg)
4076                                      :offset (- (tn-offset x) 2))))
4077          (long-stack
4078           (inst fldl (ea-for-lf-stack x)))
4079          (descriptor-reg
4080           (inst fldl (ea-for-lf-desc x))))
4081       ;; Load y to fr0
4082       (sc-case y
4083          (long-reg
4084           (inst fldd (make-random-tn :kind :normal
4085                                      :sc (sc-or-lose 'double-reg)
4086                                      :offset (1- (tn-offset y)))))
4087          (long-stack
4088           (inst fldl (ea-for-lf-stack y)))
4089          (descriptor-reg
4090           (inst fldl (ea-for-lf-desc y))))))
4091
4092     ;; Now have y at fr0; and x at fr1
4093     (inst fpatan)
4094     (inst fld fr0)
4095     (case (tn-offset r)
4096       ((0 1))
4097       (t (inst fstd r)))))
4098
4099) ; PROGN #!+LONG-FLOAT
4100
4101;;;; complex float VOPs
4102
4103(define-vop (make-complex-single-float)
4104  (:translate complex)
4105  (:args (real :scs (single-reg) :to :result :target r
4106               :load-if (not (location= real r)))
4107         (imag :scs (single-reg) :to :save))
4108  (:arg-types single-float single-float)
4109  (:results (r :scs (complex-single-reg) :from (:argument 0)
4110               :load-if (not (sc-is r complex-single-stack))))
4111  (:result-types complex-single-float)
4112  (:note "inline complex single-float creation")
4113  (:policy :fast-safe)
4114  (:generator 5
4115    (sc-case r
4116      (complex-single-reg
4117       (let ((r-real (complex-double-reg-real-tn r)))
4118         (unless (location= real r-real)
4119           (cond ((zerop (tn-offset r-real))
4120                  (copy-fp-reg-to-fr0 real))
4121                 ((zerop (tn-offset real))
4122                  (inst fstd r-real))
4123                 (t
4124                  (inst fxch real)
4125                  (inst fstd r-real)
4126                  (inst fxch real)))))
4127       (let ((r-imag (complex-double-reg-imag-tn r)))
4128         (unless (location= imag r-imag)
4129           (cond ((zerop (tn-offset imag))
4130                  (inst fstd r-imag))
4131                 (t
4132                  (inst fxch imag)
4133                  (inst fstd r-imag)
4134                  (inst fxch imag))))))
4135      (complex-single-stack
4136       (unless (location= real r)
4137         (cond ((zerop (tn-offset real))
4138                (inst fst (ea-for-csf-real-stack r)))
4139               (t
4140                (inst fxch real)
4141                (inst fst (ea-for-csf-real-stack r))
4142                (inst fxch real))))
4143       (inst fxch imag)
4144       (inst fst (ea-for-csf-imag-stack r))
4145       (inst fxch imag)))))
4146
4147(define-vop (make-complex-double-float)
4148  (:translate complex)
4149  (:args (real :scs (double-reg) :target r
4150               :load-if (not (location= real r)))
4151         (imag :scs (double-reg) :to :save))
4152  (:arg-types double-float double-float)
4153  (:results (r :scs (complex-double-reg) :from (:argument 0)
4154               :load-if (not (sc-is r complex-double-stack))))
4155  (:result-types complex-double-float)
4156  (:note "inline complex double-float creation")
4157  (:policy :fast-safe)
4158  (:generator 5
4159    (sc-case r
4160      (complex-double-reg
4161       (let ((r-real (complex-double-reg-real-tn r)))
4162         (unless (location= real r-real)
4163           (cond ((zerop (tn-offset r-real))
4164                  (copy-fp-reg-to-fr0 real))
4165                 ((zerop (tn-offset real))
4166                  (inst fstd r-real))
4167                 (t
4168                  (inst fxch real)
4169                  (inst fstd r-real)
4170                  (inst fxch real)))))
4171       (let ((r-imag (complex-double-reg-imag-tn r)))
4172         (unless (location= imag r-imag)
4173           (cond ((zerop (tn-offset imag))
4174                  (inst fstd r-imag))
4175                 (t
4176                  (inst fxch imag)
4177                  (inst fstd r-imag)
4178                  (inst fxch imag))))))
4179      (complex-double-stack
4180       (unless (location= real r)
4181         (cond ((zerop (tn-offset real))
4182                (inst fstd (ea-for-cdf-real-stack r)))
4183               (t
4184                (inst fxch real)
4185                (inst fstd (ea-for-cdf-real-stack r))
4186                (inst fxch real))))
4187       (inst fxch imag)
4188       (inst fstd (ea-for-cdf-imag-stack r))
4189       (inst fxch imag)))))
4190
4191#!+long-float
4192(define-vop (make-complex-long-float)
4193  (:translate complex)
4194  (:args (real :scs (long-reg) :target r
4195               :load-if (not (location= real r)))
4196         (imag :scs (long-reg) :to :save))
4197  (:arg-types long-float long-float)
4198  (:results (r :scs (complex-long-reg) :from (:argument 0)
4199               :load-if (not (sc-is r complex-long-stack))))
4200  (:result-types complex-long-float)
4201  (:note "inline complex long-float creation")
4202  (:policy :fast-safe)
4203  (:generator 5
4204    (sc-case r
4205      (complex-long-reg
4206       (let ((r-real (complex-double-reg-real-tn r)))
4207         (unless (location= real r-real)
4208           (cond ((zerop (tn-offset r-real))
4209                  (copy-fp-reg-to-fr0 real))
4210                 ((zerop (tn-offset real))
4211                  (inst fstd r-real))
4212                 (t
4213                  (inst fxch real)
4214                  (inst fstd r-real)
4215                  (inst fxch real)))))
4216       (let ((r-imag (complex-double-reg-imag-tn r)))
4217         (unless (location= imag r-imag)
4218           (cond ((zerop (tn-offset imag))
4219                  (inst fstd r-imag))
4220                 (t
4221                  (inst fxch imag)
4222                  (inst fstd r-imag)
4223                  (inst fxch imag))))))
4224      (complex-long-stack
4225       (unless (location= real r)
4226         (cond ((zerop (tn-offset real))
4227                (store-long-float (ea-for-clf-real-stack r)))
4228               (t
4229                (inst fxch real)
4230                (store-long-float (ea-for-clf-real-stack r))
4231                (inst fxch real))))
4232       (inst fxch imag)
4233       (store-long-float (ea-for-clf-imag-stack r))
4234       (inst fxch imag)))))
4235
4236
4237(define-vop (complex-float-value)
4238  (:args (x :target r))
4239  (:results (r))
4240  (:variant-vars offset)
4241  (:policy :fast-safe)
4242  (:generator 3
4243    (cond ((sc-is x complex-single-reg complex-double-reg
4244                  #!+long-float complex-long-reg)
4245           (let ((value-tn
4246                  (make-random-tn :kind :normal
4247                                  :sc (sc-or-lose 'double-reg)
4248                                  :offset (+ offset (tn-offset x)))))
4249             (unless (location= value-tn r)
4250               (cond ((zerop (tn-offset r))
4251                      (copy-fp-reg-to-fr0 value-tn))
4252                     ((zerop (tn-offset value-tn))
4253                      (inst fstd r))
4254                     (t
4255                      (inst fxch value-tn)
4256                      (inst fstd r)
4257                      (inst fxch value-tn))))))
4258          ((sc-is r single-reg)
4259           (let ((ea (sc-case x
4260                       (complex-single-stack
4261                        (ecase offset
4262                          (0 (ea-for-csf-real-stack x))
4263                          (1 (ea-for-csf-imag-stack x))))
4264                       (descriptor-reg
4265                        (ecase offset
4266                          (0 (ea-for-csf-real-desc x))
4267                          (1 (ea-for-csf-imag-desc x)))))))
4268             (with-empty-tn@fp-top(r)
4269               (inst fld ea))))
4270          ((sc-is r double-reg)
4271           (let ((ea (sc-case x
4272                       (complex-double-stack
4273                        (ecase offset
4274                          (0 (ea-for-cdf-real-stack x))
4275                          (1 (ea-for-cdf-imag-stack x))))
4276                       (descriptor-reg
4277                        (ecase offset
4278                          (0 (ea-for-cdf-real-desc x))
4279                          (1 (ea-for-cdf-imag-desc x)))))))
4280             (with-empty-tn@fp-top(r)
4281               (inst fldd ea))))
4282          #!+long-float
4283          ((sc-is r long-reg)
4284           (let ((ea (sc-case x
4285                       (complex-long-stack
4286                        (ecase offset
4287                          (0 (ea-for-clf-real-stack x))
4288                          (1 (ea-for-clf-imag-stack x))))
4289                       (descriptor-reg
4290                        (ecase offset
4291                          (0 (ea-for-clf-real-desc x))
4292                          (1 (ea-for-clf-imag-desc x)))))))
4293             (with-empty-tn@fp-top(r)
4294               (inst fldl ea))))
4295          (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4296
4297(define-vop (realpart/complex-single-float complex-float-value)
4298  (:translate realpart)
4299  (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4300            :target r))
4301  (:arg-types complex-single-float)
4302  (:results (r :scs (single-reg)))
4303  (:result-types single-float)
4304  (:note "complex float realpart")
4305  (:variant 0))
4306
4307(define-vop (realpart/complex-double-float complex-float-value)
4308  (:translate realpart)
4309  (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4310            :target r))
4311  (:arg-types complex-double-float)
4312  (:results (r :scs (double-reg)))
4313  (:result-types double-float)
4314  (:note "complex float realpart")
4315  (:variant 0))
4316
4317#!+long-float
4318(define-vop (realpart/complex-long-float complex-float-value)
4319  (:translate realpart)
4320  (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4321            :target r))
4322  (:arg-types complex-long-float)
4323  (:results (r :scs (long-reg)))
4324  (:result-types long-float)
4325  (:note "complex float realpart")
4326  (:variant 0))
4327
4328(define-vop (imagpart/complex-single-float complex-float-value)
4329  (:translate imagpart)
4330  (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4331            :target r))
4332  (:arg-types complex-single-float)
4333  (:results (r :scs (single-reg)))
4334  (:result-types single-float)
4335  (:note "complex float imagpart")
4336  (:variant 1))
4337
4338(define-vop (imagpart/complex-double-float complex-float-value)
4339  (:translate imagpart)
4340  (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4341            :target r))
4342  (:arg-types complex-double-float)
4343  (:results (r :scs (double-reg)))
4344  (:result-types double-float)
4345  (:note "complex float imagpart")
4346  (:variant 1))
4347
4348#!+long-float
4349(define-vop (imagpart/complex-long-float complex-float-value)
4350  (:translate imagpart)
4351  (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4352            :target r))
4353  (:arg-types complex-long-float)
4354  (:results (r :scs (long-reg)))
4355  (:result-types long-float)
4356  (:note "complex float imagpart")
4357  (:variant 1))
4358
4359;;; hack dummy VOPs to bias the representation selection of their
4360;;; arguments towards a FP register, which can help avoid consing at
4361;;; inappropriate locations
4362(defknown double-float-reg-bias (double-float) (values))
4363(define-vop (double-float-reg-bias)
4364  (:translate double-float-reg-bias)
4365  (:args (x :scs (double-reg double-stack) :load-if nil))
4366  (:arg-types double-float)
4367  (:policy :fast-safe)
4368  (:note "inline dummy FP register bias")
4369  (:ignore x)
4370  (:generator 0))
4371(defknown single-float-reg-bias (single-float) (values))
4372(define-vop (single-float-reg-bias)
4373  (:translate single-float-reg-bias)
4374  (:args (x :scs (single-reg single-stack) :load-if nil))
4375  (:arg-types single-float)
4376  (:policy :fast-safe)
4377  (:note "inline dummy FP register bias")
4378  (:ignore x)
4379  (:generator 0))
4380