8c00995ebc4117c152fa4119c2bb52ae540d44a0
[sbcl.git] / src / compiler / x86-64 / float.lisp
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 \f
14 (macrolet ((ea-for-xf-desc (tn slot)
15              `(make-ea
16                :qword :base ,tn
17                :disp (- (* ,slot n-word-bytes)
18                         other-pointer-lowtag))))
19   (defun ea-for-df-desc (tn)
20     (ea-for-xf-desc tn double-float-value-slot))
21   ;; complex floats
22   (defun ea-for-csf-real-desc (tn)
23     (ea-for-xf-desc tn complex-single-float-real-slot))
24   (defun ea-for-csf-imag-desc (tn)
25     (ea-for-xf-desc tn complex-single-float-imag-slot))
26   (defun ea-for-cdf-real-desc (tn)
27     (ea-for-xf-desc tn complex-double-float-real-slot))
28   (defun ea-for-cdf-imag-desc (tn)
29     (ea-for-xf-desc tn complex-double-float-imag-slot)))
30
31 (macrolet ((ea-for-xf-stack (tn kind)
32              (declare (ignore kind))
33              `(make-ea
34                :qword :base rbp-tn
35                :disp (- (* (+ (tn-offset ,tn) 1)
36                            n-word-bytes)))))
37   (defun ea-for-sf-stack (tn)
38     (ea-for-xf-stack tn :single))
39   (defun ea-for-df-stack (tn)
40     (ea-for-xf-stack tn :double)))
41
42 ;;; complex float stack EAs
43 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
44              (declare (ignore kind))
45              `(make-ea
46                :qword :base ,base
47                :disp (- (* (+ (tn-offset ,tn)
48                               (* 1 (ecase ,slot (:real 1) (:imag 2))))
49                            n-word-bytes)))))
50   (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
51     (ea-for-cxf-stack tn :single :real base))
52   (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
53     (ea-for-cxf-stack tn :single :imag base))
54   (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
55     (ea-for-cxf-stack tn :double :real base))
56   (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
57     (ea-for-cxf-stack tn :double :imag base)))
58
59 \f
60 ;;;; move functions
61
62 ;;; X is source, Y is destination.
63
64 (define-move-fun (load-fp-zero 1) (vop x y)
65   ((fp-single-zero) (single-reg)
66    (fp-double-zero) (double-reg))
67   (identity x) ; KLUDGE: IDENTITY as IGNORABLE...
68   (inst movq y fp-double-zero-tn))
69
70 (define-move-fun (load-single 2) (vop x y)
71   ((single-stack) (single-reg))
72   (inst movss y (ea-for-sf-stack x)))
73
74 (define-move-fun (store-single 2) (vop x y)
75   ((single-reg) (single-stack))
76   (inst movss (ea-for-sf-stack y) x))
77
78 (define-move-fun (load-double 2) (vop x y)
79   ((double-stack) (double-reg))
80   (inst movsd y (ea-for-df-stack x)))
81
82 (define-move-fun (store-double 2) (vop x y)
83   ((double-reg) (double-stack))
84   (inst movsd  (ea-for-df-stack y) x))
85
86 (eval-when (:compile-toplevel :execute)
87   (setf *read-default-float-format* 'single-float))
88 \f
89 ;;;; complex float move functions
90
91 (defun complex-single-reg-real-tn (x)
92   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
93                   :offset (tn-offset x)))
94 (defun complex-single-reg-imag-tn (x)
95   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
96                   :offset (1+ (tn-offset x))))
97
98 (defun complex-double-reg-real-tn (x)
99   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
100                   :offset (tn-offset x)))
101 (defun complex-double-reg-imag-tn (x)
102   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
103                   :offset (1+ (tn-offset x))))
104
105 ;;; X is source, Y is destination.
106 (define-move-fun (load-complex-single 2) (vop x y)
107   ((complex-single-stack) (complex-single-reg))
108   (let ((real-tn (complex-single-reg-real-tn y)))
109     (inst movss real-tn (ea-for-csf-real-stack x)))
110   (let ((imag-tn (complex-single-reg-imag-tn y)))
111     (inst movss imag-tn (ea-for-csf-imag-stack x))))
112
113 (define-move-fun (store-complex-single 2) (vop x y)
114   ((complex-single-reg) (complex-single-stack))
115   (let ((real-tn (complex-single-reg-real-tn x))
116         (imag-tn (complex-single-reg-imag-tn x)))
117     (inst movss (ea-for-csf-real-stack y) real-tn)
118     (inst movss (ea-for-csf-imag-stack y) imag-tn)))
119
120 (define-move-fun (load-complex-double 2) (vop x y)
121   ((complex-double-stack) (complex-double-reg))
122   (let ((real-tn (complex-double-reg-real-tn y)))
123     (inst movsd real-tn (ea-for-cdf-real-stack x)))
124   (let ((imag-tn (complex-double-reg-imag-tn y)))
125     (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
126
127 (define-move-fun (store-complex-double 2) (vop x y)
128   ((complex-double-reg) (complex-double-stack))
129   (let ((real-tn (complex-double-reg-real-tn x))
130         (imag-tn (complex-double-reg-imag-tn x)))
131     (inst movsd (ea-for-cdf-real-stack y) real-tn)
132     (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
133
134 \f
135 ;;;; move VOPs
136
137 ;;; float register to register moves
138 (macrolet ((frob (vop sc)
139              `(progn
140                 (define-vop (,vop)
141                   (:args (x :scs (,sc)
142                             :target y
143                             :load-if (not (location= x y))))
144                   (:results (y :scs (,sc)
145                                :load-if (not (location= x y))))
146                   (:note "float move")
147                   (:generator 0
148                     (unless (location= y x)
149                       (inst movq y x))))
150                 (define-move-vop ,vop :move (,sc) (,sc)))))
151   (frob single-move single-reg)
152   (frob double-move double-reg))
153
154 ;;; complex float register to register moves
155 (define-vop (complex-float-move)
156   (:args (x :target y :load-if (not (location= x y))))
157   (:results (y :load-if (not (location= x y))))
158   (:note "complex float move")
159   (:generator 0
160      (unless (location= x y)
161        ;; Note the complex-float-regs are aligned to every second
162        ;; float register so there is not need to worry about overlap.
163        ;; (It would be better to put the imagpart in the top half of the 
164        ;; register, or something, but let's worry about that later)
165        (let ((x-real (complex-single-reg-real-tn x))
166              (y-real (complex-single-reg-real-tn y)))
167          (inst movq y-real x-real))
168        (let ((x-imag (complex-single-reg-imag-tn x))
169              (y-imag (complex-single-reg-imag-tn y)))
170          (inst movq y-imag x-imag)))))
171
172 (define-vop (complex-single-move complex-float-move)
173   (:args (x :scs (complex-single-reg) :target y
174             :load-if (not (location= x y))))
175   (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
176 (define-move-vop complex-single-move :move
177   (complex-single-reg) (complex-single-reg))
178
179 (define-vop (complex-double-move complex-float-move)
180   (:args (x :scs (complex-double-reg)
181             :target y :load-if (not (location= x y))))
182   (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
183 (define-move-vop complex-double-move :move
184   (complex-double-reg) (complex-double-reg))
185
186 \f
187 ;;; Move from float to a descriptor reg. allocating a new float
188 ;;; object in the process.
189 (define-vop (move-from-single)
190   (:args (x :scs (single-reg) :to :save))
191   (:results (y :scs (descriptor-reg)))
192   (:note "float to pointer coercion")
193   (:generator 4
194     (inst movd y x)
195     (inst shl y 32)
196     (inst or y single-float-widetag)))
197
198 (define-move-vop move-from-single :move
199   (single-reg) (descriptor-reg))
200
201 (define-vop (move-from-double)
202   (:args (x :scs (double-reg) :to :save))
203   (:results (y :scs (descriptor-reg)))
204   (:node-var node)
205   (:note "float to pointer coercion")
206   (:generator 13
207      (with-fixed-allocation (y
208                              double-float-widetag
209                              double-float-size
210                              node)
211        (inst movsd (ea-for-df-desc y) x))))
212 (define-move-vop move-from-double :move
213   (double-reg) (descriptor-reg))
214
215 ;;; Move from a descriptor to a float register.
216 (define-vop (move-to-single)
217   (:args (x :scs (descriptor-reg) :target tmp))
218   (:temporary (:sc unsigned-reg) tmp)
219   (:results (y :scs (single-reg)))
220   (:note "pointer to float coercion")
221   (:generator 2
222     (move tmp x)
223     (inst shr tmp 32)
224     (inst movd y tmp)))
225
226 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
227
228 (define-vop (move-to-double)
229   (:args (x :scs (descriptor-reg)))
230   (:results (y :scs (double-reg)))
231   (:note "pointer to float coercion")
232   (:generator 2
233     (inst movsd y (ea-for-df-desc x))))
234 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
235
236 \f
237 ;;; Move from complex float to a descriptor reg. allocating a new
238 ;;; complex float object in the process.
239 (define-vop (move-from-complex-single)
240   (:args (x :scs (complex-single-reg) :to :save))
241   (:results (y :scs (descriptor-reg)))
242   (:node-var node)
243   (:note "complex float to pointer coercion")
244   (:generator 13
245      (with-fixed-allocation (y
246                              complex-single-float-widetag
247                              complex-single-float-size
248                              node)
249        (let ((real-tn (complex-single-reg-real-tn x)))
250          (inst movss (ea-for-csf-real-desc y) real-tn))
251        (let ((imag-tn (complex-single-reg-imag-tn x)))
252          (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
253 (define-move-vop move-from-complex-single :move
254   (complex-single-reg) (descriptor-reg))
255
256 (define-vop (move-from-complex-double)
257   (:args (x :scs (complex-double-reg) :to :save))
258   (:results (y :scs (descriptor-reg)))
259   (:node-var node)
260   (:note "complex float to pointer coercion")
261   (:generator 13
262      (with-fixed-allocation (y
263                              complex-double-float-widetag
264                              complex-double-float-size
265                              node)
266        (let ((real-tn (complex-double-reg-real-tn x)))
267          (inst movsd (ea-for-cdf-real-desc y) real-tn))
268        (let ((imag-tn (complex-double-reg-imag-tn x)))
269          (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
270 (define-move-vop move-from-complex-double :move
271   (complex-double-reg) (descriptor-reg))
272
273 ;;; Move from a descriptor to a complex float register.
274 (macrolet ((frob (name sc format)
275              `(progn
276                 (define-vop (,name)
277                   (:args (x :scs (descriptor-reg)))
278                   (:results (y :scs (,sc)))
279                   (:note "pointer to complex float coercion")
280                   (:generator 2
281                     (let ((real-tn (complex-double-reg-real-tn y)))
282                       ,@(ecase
283                          format
284                          (:single
285                           '((inst movss real-tn (ea-for-csf-real-desc x))))
286                          (:double
287                           '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
288                     (let ((imag-tn (complex-double-reg-imag-tn y)))
289                       ,@(ecase
290                          format
291                          (:single
292                           '((inst movss imag-tn (ea-for-csf-imag-desc x))))
293                          (:double 
294                           '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
295                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
296   (frob move-to-complex-single complex-single-reg :single)
297   (frob move-to-complex-double complex-double-reg :double))
298 \f
299 ;;;; the move argument vops
300 ;;;;
301 ;;;; Note these are also used to stuff fp numbers onto the c-call
302 ;;;; stack so the order is different than the lisp-stack.
303
304 ;;; the general MOVE-ARG VOP
305 (macrolet ((frob (name sc stack-sc format)
306              `(progn
307                 (define-vop (,name)
308                   (:args (x :scs (,sc) :target y)
309                          (fp :scs (any-reg)
310                              :load-if (not (sc-is y ,sc))))
311                   (:results (y))
312                   (:note "float argument move")
313                   (:generator ,(case format (:single 2) (:double 3) )
314                     (sc-case y
315                       (,sc
316                        (unless (location= x y)
317                          (inst movq y x)))
318                       (,stack-sc
319                        (if (= (tn-offset fp) esp-offset)
320                            (let* ((offset (* (tn-offset y) n-word-bytes))
321                                   (ea (make-ea :dword :base fp :disp offset)))
322                              ,@(ecase format
323                                       (:single '((inst movss ea x)))
324                                       (:double '((inst movsd ea x)))))
325                            (let ((ea (make-ea
326                                       :dword :base fp
327                                       :disp (- (* (+ (tn-offset y)
328                                                      ,(case format
329                                                             (:single 1)
330                                                             (:double 2) ))
331                                                   n-word-bytes)))))
332                              (with-tn@fp-top(x)
333                                ,@(ecase format
334                                     (:single '((inst movss ea x)))
335                                     (:double '((inst movsd ea x)))))))))))
336                 (define-move-vop ,name :move-arg
337                   (,sc descriptor-reg) (,sc)))))
338   (frob move-single-float-arg single-reg single-stack :single)
339   (frob move-double-float-arg double-reg double-stack :double))
340
341 ;;;; complex float MOVE-ARG VOP
342 (macrolet ((frob (name sc stack-sc format)
343              `(progn
344                 (define-vop (,name)
345                   (:args (x :scs (,sc) :target y)
346                          (fp :scs (any-reg)
347                              :load-if (not (sc-is y ,sc))))
348                   (:results (y))
349                   (:note "complex float argument move")
350                   (:generator ,(ecase format (:single 2) (:double 3))
351                     (sc-case y
352                       (,sc
353                        (unless (location= x y)
354                          (let ((x-real (complex-double-reg-real-tn x))
355                                (y-real (complex-double-reg-real-tn y)))
356                            (inst movsd y-real x-real))
357                          (let ((x-imag (complex-double-reg-imag-tn x))
358                                (y-imag (complex-double-reg-imag-tn y)))
359                            (inst movsd y-imag x-imag))))
360                       (,stack-sc
361                        (let ((real-tn (complex-double-reg-real-tn x)))
362                          ,@(ecase format
363                                   (:single
364                                    '((inst movss
365                                       (ea-for-csf-real-stack y fp)
366                                       real-tn)))
367                                   (:double
368                                    '((inst movsd
369                                       (ea-for-cdf-real-stack y fp)
370                                       real-tn)))))
371                        (let ((imag-tn (complex-double-reg-imag-tn x)))
372                          ,@(ecase format
373                                   (:single
374                                    '((inst movss
375                                       (ea-for-csf-imag-stack y fp) imag-tn)))
376                                   (:double
377                                    '((inst movsd
378                                       (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
379                 (define-move-vop ,name :move-arg
380                   (,sc descriptor-reg) (,sc)))))
381   (frob move-complex-single-float-arg
382         complex-single-reg complex-single-stack :single)
383   (frob move-complex-double-float-arg
384         complex-double-reg complex-double-stack :double))
385
386 (define-move-vop move-arg :move-arg
387   (single-reg double-reg
388    complex-single-reg complex-double-reg)
389   (descriptor-reg))
390
391 \f
392 ;;;; arithmetic VOPs
393
394 (define-vop (float-op)
395   (:args (x) (y))
396   (:results (r))
397   (:policy :fast-safe)
398   (:note "inline float arithmetic")
399   (:vop-var vop)
400   (:save-p :compute-only))
401
402 (macrolet ((frob (name sc ptype)
403              `(define-vop (,name float-op)
404                 (:args (x :scs (,sc) :target r)
405                        (y :scs (,sc)))
406                 (:results (r :scs (,sc)))
407                 (:arg-types ,ptype ,ptype)
408                 (:result-types ,ptype))))
409   (frob single-float-op single-reg single-float)
410   (frob double-float-op double-reg double-float))
411
412 (macrolet ((generate (movinst opinst commutative)
413              `(progn
414                 (cond
415                   ((location= x r)
416                    (inst ,opinst x y))
417                   ((and ,commutative (location= y r))
418                    (inst ,opinst y x))
419                   ((not (location= r y))
420                    (inst ,movinst r x)
421                    (inst ,opinst r y))
422                   (t
423                    (inst ,movinst tmp x)
424                    (inst ,opinst tmp y)
425                    (inst ,movinst r tmp)))))
426            (frob (op sinst sname scost dinst dname dcost commutative)
427              `(progn
428                 (define-vop (,sname single-float-op)
429                     (:translate ,op)
430                   (:temporary (:sc single-reg) tmp)
431                   (:generator ,scost
432                     (generate movss ,sinst ,commutative)))
433                 (define-vop (,dname double-float-op)
434                   (:translate ,op)
435                   (:temporary (:sc single-reg) tmp)
436                   (:generator ,dcost
437                     (generate movsd ,dinst ,commutative))))))
438   (frob + addss +/single-float 2 addsd +/double-float 2 t)
439   (frob - subss -/single-float 2 subsd -/double-float 2 nil)
440   (frob * mulss */single-float 4 mulsd */double-float 5 t)
441   (frob / divss //single-float 12 divsd //double-float 19 nil))
442
443
444 \f
445 (macrolet ((frob ((name translate sc type) &body body)
446              `(define-vop (,name)
447                   (:args (x :scs (,sc)))
448                 (:results (y :scs (,sc)))
449                 (:translate ,translate)
450                 (:policy :fast-safe)
451                 (:arg-types ,type)
452                 (:result-types ,type)
453                 (:temporary (:sc any-reg) hex8)
454                 (:temporary
455                  (:sc ,sc) xmm)
456                 (:note "inline float arithmetic")
457                 (:vop-var vop)
458                 (:save-p :compute-only)
459                 (:generator 1
460                             (note-this-location vop :internal-error)
461                             ;; we should be able to do this better.  what we 
462                             ;; really would like to do is use the target as the
463                             ;; temp whenever it's not also the source
464                             (unless (location= x y)
465                               (inst movq y x))
466                             ,@body))))
467   (frob (%negate/double-float %negate double-reg double-float)
468         (inst lea hex8 (make-ea :qword :disp 1))
469         (inst ror hex8 1)               ; #x8000000000000000
470         (inst movd xmm hex8)
471         (inst xorpd y xmm))
472   (frob (%negate/single-float %negate single-reg single-float)
473         (inst lea hex8 (make-ea :qword :disp 1))
474         (inst rol hex8 31)
475         (inst movd xmm hex8)
476         (inst xorps y xmm))
477   (frob (abs/double-float abs  double-reg double-float)
478         (inst mov hex8 -1)
479         (inst shr hex8 1)
480         (inst movd xmm hex8)
481         (inst andpd y xmm))
482   (frob (abs/single-float abs  single-reg single-float)
483         (inst mov hex8 -1)
484         (inst shr hex8 33)
485         (inst movd xmm hex8)
486         (inst andps y xmm)))
487 \f
488 ;;;; comparison
489
490 (define-vop (float-compare)
491   (:conditional)
492   (:info target not-p)
493   (:policy :fast-safe)
494   (:vop-var vop)
495   (:save-p :compute-only)
496   (:note "inline float comparison"))
497
498 ;;; comiss and comisd can cope with one or other arg in memory: we
499 ;;; could (should, indeed) extend these to cope with descriptor args
500 ;;; and stack args
501
502 (define-vop (single-float-compare float-compare)
503   (:args (x :scs (single-reg)) (y :scs (single-reg)))
504   (:conditional)
505   (:arg-types single-float single-float))
506 (define-vop (double-float-compare float-compare)
507   (:args (x :scs (double-reg)) (y :scs (double-reg)))
508   (:conditional)
509   (:arg-types double-float double-float))
510
511 (define-vop (=/single-float single-float-compare)
512     (:translate =)
513   (:info target not-p)
514   (:vop-var vop)
515   (:generator 3
516     (note-this-location vop :internal-error)
517     (inst comiss x y)
518     ;; if PF&CF, there was a NaN involved => not equal
519     ;; otherwise, ZF => equal
520     (cond (not-p
521            (inst jmp :p target)
522            (inst jmp :ne target))
523           (t
524            (let ((not-lab (gen-label)))
525              (inst jmp :p not-lab)
526              (inst jmp :e target)
527              (emit-label not-lab))))))
528
529 (define-vop (=/double-float double-float-compare)
530     (:translate =)
531   (:info target not-p)
532   (:vop-var vop)
533   (:generator 3
534     (note-this-location vop :internal-error)
535     (inst comisd x y)
536     (cond (not-p
537            (inst jmp :p target)
538            (inst jmp :ne target))
539           (t
540            (let ((not-lab (gen-label)))
541              (inst jmp :p not-lab)
542              (inst jmp :e target)
543              (emit-label not-lab))))))
544
545 ;; XXX all of these probably have bad NaN behaviour
546 (define-vop (<double-float double-float-compare)
547   (:translate <)
548   (:info target not-p)
549   (:generator 2
550     (inst comisd x y)
551     (inst jmp (if not-p :nc :c) target)))
552
553 (define-vop (<single-float single-float-compare)
554   (:translate <)
555   (:info target not-p)
556   (:generator 2
557     (inst comiss x y)
558     (inst jmp (if not-p :nc :c) target)))
559
560 (define-vop (>double-float double-float-compare)
561   (:translate >)
562   (:info target not-p)
563   (:generator 2
564     (inst comisd x y)
565     (inst jmp (if not-p :na :a) target)))
566
567 (define-vop (>single-float single-float-compare)
568   (:translate >)
569   (:info target not-p)
570   (:generator 2
571     (inst comiss x y)
572     (inst jmp (if not-p :na :a) target)))
573
574
575 \f
576 ;;;; conversion
577
578 (macrolet ((frob (name translate inst to-sc to-type)
579              `(define-vop (,name)
580                 (:args (x :scs (signed-stack signed-reg) :target temp))
581                 (:temporary (:sc signed-stack) temp)
582                 (:results (y :scs (,to-sc)))
583                 (:arg-types signed-num)
584                 (:result-types ,to-type)
585                 (:policy :fast-safe)
586                 (:note "inline float coercion")
587                 (:translate ,translate)
588                 (:vop-var vop)
589                 (:save-p :compute-only)
590                 (:generator 5
591                   (sc-case x
592                     (signed-reg
593                      (inst mov temp x)
594                      (note-this-location vop :internal-error)
595                      (inst ,inst y temp))
596                     (signed-stack
597                      (note-this-location vop :internal-error)
598                      (inst ,inst y x)))))))
599   (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
600   (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
601
602 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
603              `(define-vop (,name)
604                (:args (x :scs (,from-sc) :target y))
605                (:results (y :scs (,to-sc)))
606                (:arg-types ,from-type)
607                (:result-types ,to-type)
608                (:policy :fast-safe)
609                (:note "inline float coercion")
610                (:translate ,translate)
611                (:vop-var vop)
612                (:save-p :compute-only)
613                (:generator 2
614                 (note-this-location vop :internal-error)
615                 (inst ,inst y x)))))
616   (frob %single-float/double-float %single-float cvtsd2ss double-reg
617         double-float single-reg single-float)
618
619   (frob %double-float/single-float %double-float cvtss2sd 
620         single-reg single-float double-reg double-float))
621
622 (macrolet ((frob (trans inst from-sc from-type round-p)
623              (declare (ignore round-p))
624              `(define-vop (,(symbolicate trans "/" from-type))
625                (:args (x :scs (,from-sc)))
626                (:temporary (:sc any-reg) temp-reg)
627                (:results (y :scs (signed-reg)))
628                (:arg-types ,from-type)
629                (:result-types signed-num)
630                (:translate ,trans)
631                (:policy :fast-safe)
632                (:note "inline float truncate")
633                (:vop-var vop)
634                (:save-p :compute-only)
635                (:generator 5
636                  (sc-case y
637                           (signed-stack
638                            (inst ,inst temp-reg x)
639                            (move y temp-reg))
640                           (signed-reg
641                            (inst ,inst y x)
642                            ))))))
643   (frob %unary-truncate cvttss2si single-reg single-float nil)
644   (frob %unary-truncate cvttsd2si double-reg double-float nil)
645
646   (frob %unary-round cvtss2si single-reg single-float t)
647   (frob %unary-round cvtsd2si double-reg double-float t))
648
649 (define-vop (make-single-float)
650   (:args (bits :scs (signed-reg) :target res
651                :load-if (not (or (and (sc-is bits signed-stack)
652                                       (sc-is res single-reg))
653                                  (and (sc-is bits signed-stack)
654                                       (sc-is res single-stack)
655                                       (location= bits res))))))
656   (:results (res :scs (single-reg single-stack)))
657   (:arg-types signed-num)
658   (:result-types single-float)
659   (:translate make-single-float)
660   (:policy :fast-safe)
661   (:vop-var vop)
662   (:generator 4
663     (sc-case res
664        (single-stack
665         (sc-case bits
666           (signed-reg
667            (inst mov res bits))
668           (signed-stack
669            (aver (location= bits res)))))
670        (single-reg
671         (sc-case bits
672           (signed-reg
673            (inst movd res bits))
674           (signed-stack
675            (inst movd res bits)))))))
676
677 (define-vop (make-double-float)
678   (:args (hi-bits :scs (signed-reg))
679          (lo-bits :scs (unsigned-reg)))
680   (:results (res :scs (double-reg)))
681   (:temporary (:sc unsigned-reg) temp)
682   (:arg-types signed-num unsigned-num)
683   (:result-types double-float)
684   (:translate make-double-float)
685   (:policy :fast-safe)
686   (:vop-var vop)
687   (:generator 2
688     (move temp hi-bits)
689     (inst shl temp 32)
690     (inst or temp lo-bits)
691     (inst movd res temp)))
692
693 (define-vop (single-float-bits)
694   (:args (float :scs (single-reg descriptor-reg)
695                 :load-if (not (sc-is float single-stack))))
696   (:results (bits :scs (signed-reg)))
697   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
698   (:arg-types single-float)
699   (:result-types signed-num)
700   (:translate single-float-bits)
701   (:policy :fast-safe)
702   (:vop-var vop)
703   (:generator 4
704     (sc-case bits
705       (signed-reg
706        (sc-case float
707          (single-reg
708           (inst movss stack-temp float)
709           (move bits stack-temp))
710          (single-stack
711           (move bits float))
712          (descriptor-reg
713           (move bits float)
714           (inst shr bits 32))))
715       (signed-stack
716        (sc-case float
717          (single-reg
718           (inst movss bits float)))))
719     ;; Sign-extend
720     (inst shl bits 32)
721     (inst sar bits 32)))
722
723 (define-vop (double-float-high-bits)
724   (:args (float :scs (double-reg descriptor-reg)
725                 :load-if (not (sc-is float double-stack))))
726   (:results (hi-bits :scs (signed-reg)))
727   (:temporary (:sc signed-stack :from :argument :to :result) temp)
728   (:arg-types double-float)
729   (:result-types signed-num)
730   (:translate double-float-high-bits)
731   (:policy :fast-safe)
732   (:vop-var vop)
733   (:generator 5
734      (sc-case float
735        (double-reg
736         (inst movsd temp float)
737         (move hi-bits temp))
738        (double-stack
739         (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
740        (descriptor-reg
741         (loadw hi-bits float double-float-value-slot
742                other-pointer-lowtag)))
743      (inst sar hi-bits 32)))
744
745 (define-vop (double-float-low-bits)
746   (:args (float :scs (double-reg descriptor-reg)
747                 :load-if (not (sc-is float double-stack))))
748   (:results (lo-bits :scs (unsigned-reg)))
749   (:temporary (:sc signed-stack :from :argument :to :result) temp)
750   (:arg-types double-float)
751   (:result-types unsigned-num)
752   (:translate double-float-low-bits)
753   (:policy :fast-safe)
754   (:vop-var vop)
755   (:generator 5
756      (sc-case float
757        (double-reg
758         (inst movsd temp float)
759         (move lo-bits temp))
760        (double-stack
761         (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
762        (descriptor-reg
763         (loadw lo-bits float double-float-value-slot
764                other-pointer-lowtag)))
765      (inst shl lo-bits 32)
766      (inst shr lo-bits 32)))
767
768 \f
769 ;;;; float mode hackery
770
771 (sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
772 (defknown floating-point-modes () float-modes (flushable))
773 (defknown ((setf floating-point-modes)) (float-modes)
774   float-modes)
775
776 (define-vop (floating-point-modes)
777   (:results (res :scs (unsigned-reg)))
778   (:result-types unsigned-num)
779   (:translate floating-point-modes)
780   (:policy :fast-safe)
781   (:temporary (:sc unsigned-stack :from :argument :to :result) temp)
782   (:generator 8
783    (inst stmxcsr temp)
784    (move res temp)
785    ;; Extract status from bytes 0-5 to bytes 16-21
786    (inst and temp (1- (expt 2 6)))
787    (inst shl temp 16)
788    ;; Extract mask from bytes 7-12 to bytes 0-5
789    (inst shr res 7)
790    (inst and res (1- (expt 2 6)))
791    ;; Flip the bits to convert from "1 means exception masked" to 
792    ;; "1 means exception enabled".
793    (inst xor res (1- (expt 2 6)))
794    (inst or res temp)))
795
796 (define-vop (set-floating-point-modes)
797   (:args (new :scs (unsigned-reg) :to :result :target res))
798   (:results (res :scs (unsigned-reg)))
799   (:arg-types unsigned-num)
800   (:result-types unsigned-num)
801   (:translate (setf floating-point-modes))
802   (:policy :fast-safe)
803   (:temporary (:sc unsigned-reg :from :argument :to :result) temp1)
804   (:temporary (:sc unsigned-stack :from :argument :to :result) temp2)
805   (:generator 3
806    (move res new)             
807    (inst stmxcsr temp2)
808    ;; Clear status + masks
809    (inst and temp2 (lognot (logior (1- (expt 2 6))
810                                    (ash (1- (expt 2 6)) 7))))
811    ;; Replace current status
812    (move temp1 new)
813    (inst shr temp1 16)
814    (inst and temp1 (1- (expt 2 6)))
815    (inst or temp2 temp1)
816    ;; Replace exception masks
817    (move temp1 new)
818    (inst and temp1 (1- (expt 2 6)))
819    (inst xor temp1 (1- (expt 2 6)))
820    (inst shl temp1 7)
821    (inst or temp2 temp1)
822    (inst ldmxcsr temp2)))
823 \f
824
825 ;;;; complex float VOPs
826
827 (define-vop (make-complex-single-float)
828   (:translate complex)
829   (:args (real :scs (single-reg) :to :result :target r
830                :load-if (not (location= real r)))
831          (imag :scs (single-reg) :to :save))
832   (:arg-types single-float single-float)
833   (:results (r :scs (complex-single-reg) :from (:argument 0)
834                :load-if (not (sc-is r complex-single-stack))))
835   (:result-types complex-single-float)
836   (:note "inline complex single-float creation")
837   (:policy :fast-safe)
838   (:generator 5
839     (sc-case r
840       (complex-single-reg
841        (let ((r-real (complex-single-reg-real-tn r)))
842          (unless (location= real r-real)
843            (inst movss r-real real)))
844        (let ((r-imag (complex-single-reg-imag-tn r)))
845          (unless (location= imag r-imag)
846            (inst movss r-imag imag))))
847       (complex-single-stack
848        (inst movss (ea-for-csf-real-stack r) real)
849        (inst movss (ea-for-csf-imag-stack r) imag)))))
850
851 (define-vop (make-complex-double-float)
852   (:translate complex)
853   (:args (real :scs (double-reg) :target r
854                :load-if (not (location= real r)))
855          (imag :scs (double-reg) :to :save))
856   (:arg-types double-float double-float)
857   (:results (r :scs (complex-double-reg) :from (:argument 0)
858                :load-if (not (sc-is r complex-double-stack))))
859   (:result-types complex-double-float)
860   (:note "inline complex double-float creation")
861   (:policy :fast-safe)
862   (:generator 5
863     (sc-case r
864       (complex-double-reg
865        (let ((r-real (complex-double-reg-real-tn r)))
866          (unless (location= real r-real)
867            (inst movsd r-real real)))
868        (let ((r-imag (complex-double-reg-imag-tn r)))
869          (unless (location= imag r-imag)
870            (inst movsd r-imag imag))))
871       (complex-double-stack
872        (inst movsd (ea-for-cdf-real-stack r) real)
873        (inst movsd (ea-for-cdf-imag-stack r) imag)))))
874
875 (define-vop (complex-float-value)
876   (:args (x :target r))
877   (:results (r))
878   (:variant-vars offset)
879   (:policy :fast-safe)
880   (:generator 3
881     (cond ((sc-is x complex-single-reg complex-double-reg)
882            (let ((value-tn
883                   (make-random-tn :kind :normal
884                                   :sc (sc-or-lose 'double-reg)
885                                   :offset (+ offset (tn-offset x)))))
886              (unless (location= value-tn r)
887                (if (sc-is x complex-single-reg)
888                    (inst movss r value-tn)
889                    (inst movsd r value-tn)))))
890           ((sc-is r single-reg)
891            (let ((ea (sc-case x
892                        (complex-single-stack
893                         (ecase offset
894                           (0 (ea-for-csf-real-stack x))
895                           (1 (ea-for-csf-imag-stack x))))
896                        (descriptor-reg
897                         (ecase offset
898                           (0 (ea-for-csf-real-desc x))
899                           (1 (ea-for-csf-imag-desc x)))))))
900              (inst movss r ea)))
901           ((sc-is r double-reg)
902            (let ((ea (sc-case x
903                        (complex-double-stack
904                         (ecase offset
905                           (0 (ea-for-cdf-real-stack x))
906                           (1 (ea-for-cdf-imag-stack x))))
907                        (descriptor-reg
908                         (ecase offset
909                           (0 (ea-for-cdf-real-desc x))
910                           (1 (ea-for-cdf-imag-desc x)))))))
911              (inst movsd r ea)))
912           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
913
914 (define-vop (realpart/complex-single-float complex-float-value)
915   (:translate realpart)
916   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
917             :target r))
918   (:arg-types complex-single-float)
919   (:results (r :scs (single-reg)))
920   (:result-types single-float)
921   (:note "complex float realpart")
922   (:variant 0))
923
924 (define-vop (realpart/complex-double-float complex-float-value)
925   (:translate realpart)
926   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
927             :target r))
928   (:arg-types complex-double-float)
929   (:results (r :scs (double-reg)))
930   (:result-types double-float)
931   (:note "complex float realpart")
932   (:variant 0))
933
934 (define-vop (imagpart/complex-single-float complex-float-value)
935   (:translate imagpart)
936   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
937             :target r))
938   (:arg-types complex-single-float)
939   (:results (r :scs (single-reg)))
940   (:result-types single-float)
941   (:note "complex float imagpart")
942   (:variant 1))
943
944 (define-vop (imagpart/complex-double-float complex-float-value)
945   (:translate imagpart)
946   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
947             :target r))
948   (:arg-types complex-double-float)
949   (:results (r :scs (double-reg)))
950   (:result-types double-float)
951   (:note "complex float imagpart")
952   (:variant 1))
953
954 \f
955 ;;; hack dummy VOPs to bias the representation selection of their
956 ;;; arguments towards a FP register, which can help avoid consing at
957 ;;; inappropriate locations
958 (defknown double-float-reg-bias (double-float) (values))
959 (define-vop (double-float-reg-bias)
960   (:translate double-float-reg-bias)
961   (:args (x :scs (double-reg double-stack) :load-if nil))
962   (:arg-types double-float)
963   (:policy :fast-safe)
964   (:note "inline dummy FP register bias")
965   (:ignore x)
966   (:generator 0))
967 (defknown single-float-reg-bias (single-float) (values))
968 (define-vop (single-float-reg-bias)
969   (:translate single-float-reg-bias)
970   (:args (x :scs (single-reg single-stack) :load-if nil))
971   (:arg-types single-float)
972   (:policy :fast-safe)
973   (:note "inline dummy FP register bias")
974   (:ignore x)
975   (:generator 0))