c885e1305cd6006428286b543d13e9235f61f547
[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                              ,@(ecase format
333                                  (:single '((inst movss ea x)))
334                                  (:double '((inst movsd ea x))))))))))
335                 (define-move-vop ,name :move-arg
336                   (,sc descriptor-reg) (,sc)))))
337   (frob move-single-float-arg single-reg single-stack :single)
338   (frob move-double-float-arg double-reg double-stack :double))
339
340 ;;;; complex float MOVE-ARG VOP
341 (macrolet ((frob (name sc stack-sc format)
342              `(progn
343                 (define-vop (,name)
344                   (:args (x :scs (,sc) :target y)
345                          (fp :scs (any-reg)
346                              :load-if (not (sc-is y ,sc))))
347                   (:results (y))
348                   (:note "complex float argument move")
349                   (:generator ,(ecase format (:single 2) (:double 3))
350                     (sc-case y
351                       (,sc
352                        (unless (location= x y)
353                          (let ((x-real (complex-double-reg-real-tn x))
354                                (y-real (complex-double-reg-real-tn y)))
355                            (inst movsd y-real x-real))
356                          (let ((x-imag (complex-double-reg-imag-tn x))
357                                (y-imag (complex-double-reg-imag-tn y)))
358                            (inst movsd y-imag x-imag))))
359                       (,stack-sc
360                        (let ((real-tn (complex-double-reg-real-tn x)))
361                          ,@(ecase format
362                                   (:single
363                                    '((inst movss
364                                       (ea-for-csf-real-stack y fp)
365                                       real-tn)))
366                                   (:double
367                                    '((inst movsd
368                                       (ea-for-cdf-real-stack y fp)
369                                       real-tn)))))
370                        (let ((imag-tn (complex-double-reg-imag-tn x)))
371                          ,@(ecase format
372                                   (:single
373                                    '((inst movss
374                                       (ea-for-csf-imag-stack y fp) imag-tn)))
375                                   (:double
376                                    '((inst movsd
377                                       (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
378                 (define-move-vop ,name :move-arg
379                   (,sc descriptor-reg) (,sc)))))
380   (frob move-complex-single-float-arg
381         complex-single-reg complex-single-stack :single)
382   (frob move-complex-double-float-arg
383         complex-double-reg complex-double-stack :double))
384
385 (define-move-vop move-arg :move-arg
386   (single-reg double-reg
387    complex-single-reg complex-double-reg)
388   (descriptor-reg))
389
390 \f
391 ;;;; arithmetic VOPs
392
393 (define-vop (float-op)
394   (:args (x) (y))
395   (:results (r))
396   (:policy :fast-safe)
397   (:note "inline float arithmetic")
398   (:vop-var vop)
399   (:save-p :compute-only))
400
401 (macrolet ((frob (name sc ptype)
402              `(define-vop (,name float-op)
403                 (:args (x :scs (,sc) :target r)
404                        (y :scs (,sc)))
405                 (:results (r :scs (,sc)))
406                 (:arg-types ,ptype ,ptype)
407                 (:result-types ,ptype))))
408   (frob single-float-op single-reg single-float)
409   (frob double-float-op double-reg double-float))
410
411 (macrolet ((generate (movinst opinst commutative)
412              `(progn
413                 (cond
414                   ((location= x r)
415                    (inst ,opinst x y))
416                   ((and ,commutative (location= y r))
417                    (inst ,opinst y x))
418                   ((not (location= r y))
419                    (inst ,movinst r x)
420                    (inst ,opinst r y))
421                   (t
422                    (inst ,movinst tmp x)
423                    (inst ,opinst tmp y)
424                    (inst ,movinst r tmp)))))
425            (frob (op sinst sname scost dinst dname dcost commutative)
426              `(progn
427                 (define-vop (,sname single-float-op)
428                     (:translate ,op)
429                   (:temporary (:sc single-reg) tmp)
430                   (:generator ,scost
431                     (generate movss ,sinst ,commutative)))
432                 (define-vop (,dname double-float-op)
433                   (:translate ,op)
434                   (:temporary (:sc single-reg) tmp)
435                   (:generator ,dcost
436                     (generate movsd ,dinst ,commutative))))))
437   (frob + addss +/single-float 2 addsd +/double-float 2 t)
438   (frob - subss -/single-float 2 subsd -/double-float 2 nil)
439   (frob * mulss */single-float 4 mulsd */double-float 5 t)
440   (frob / divss //single-float 12 divsd //double-float 19 nil))
441
442
443 \f
444 (macrolet ((frob ((name translate sc type) &body body)
445              `(define-vop (,name)
446                   (:args (x :scs (,sc)))
447                 (:results (y :scs (,sc)))
448                 (:translate ,translate)
449                 (:policy :fast-safe)
450                 (:arg-types ,type)
451                 (:result-types ,type)
452                 (:temporary (:sc any-reg) hex8)
453                 (:temporary
454                  (:sc ,sc) xmm)
455                 (:note "inline float arithmetic")
456                 (:vop-var vop)
457                 (:save-p :compute-only)
458                 (:generator 1
459                             (note-this-location vop :internal-error)
460                             ;; we should be able to do this better.  what we 
461                             ;; really would like to do is use the target as the
462                             ;; temp whenever it's not also the source
463                             (unless (location= x y)
464                               (inst movq y x))
465                             ,@body))))
466   (frob (%negate/double-float %negate double-reg double-float)
467         (inst lea hex8 (make-ea :qword :disp 1))
468         (inst ror hex8 1)               ; #x8000000000000000
469         (inst movd xmm hex8)
470         (inst xorpd y xmm))
471   (frob (%negate/single-float %negate single-reg single-float)
472         (inst lea hex8 (make-ea :qword :disp 1))
473         (inst rol hex8 31)
474         (inst movd xmm hex8)
475         (inst xorps y xmm))
476   (frob (abs/double-float abs  double-reg double-float)
477         (inst mov hex8 -1)
478         (inst shr hex8 1)
479         (inst movd xmm hex8)
480         (inst andpd y xmm))
481   (frob (abs/single-float abs  single-reg single-float)
482         (inst mov hex8 -1)
483         (inst shr hex8 33)
484         (inst movd xmm hex8)
485         (inst andps y xmm)))
486 \f
487 ;;;; comparison
488
489 (define-vop (float-compare)
490   (:conditional)
491   (:info target not-p)
492   (:policy :fast-safe)
493   (:vop-var vop)
494   (:save-p :compute-only)
495   (:note "inline float comparison"))
496
497 ;;; comiss and comisd can cope with one or other arg in memory: we
498 ;;; could (should, indeed) extend these to cope with descriptor args
499 ;;; and stack args
500
501 (define-vop (single-float-compare float-compare)
502   (:args (x :scs (single-reg)) (y :scs (single-reg)))
503   (:conditional)
504   (:arg-types single-float single-float))
505 (define-vop (double-float-compare float-compare)
506   (:args (x :scs (double-reg)) (y :scs (double-reg)))
507   (:conditional)
508   (:arg-types double-float double-float))
509
510 (define-vop (=/single-float single-float-compare)
511     (:translate =)
512   (:info target not-p)
513   (:vop-var vop)
514   (:generator 3
515     (note-this-location vop :internal-error)
516     (inst comiss x y)
517     ;; if PF&CF, there was a NaN involved => not equal
518     ;; otherwise, ZF => equal
519     (cond (not-p
520            (inst jmp :p target)
521            (inst jmp :ne target))
522           (t
523            (let ((not-lab (gen-label)))
524              (inst jmp :p not-lab)
525              (inst jmp :e target)
526              (emit-label not-lab))))))
527
528 (define-vop (=/double-float double-float-compare)
529     (:translate =)
530   (:info target not-p)
531   (:vop-var vop)
532   (:generator 3
533     (note-this-location vop :internal-error)
534     (inst comisd x y)
535     (cond (not-p
536            (inst jmp :p target)
537            (inst jmp :ne target))
538           (t
539            (let ((not-lab (gen-label)))
540              (inst jmp :p not-lab)
541              (inst jmp :e target)
542              (emit-label not-lab))))))
543
544 ;; XXX all of these probably have bad NaN behaviour
545 (define-vop (<double-float double-float-compare)
546   (:translate <)
547   (:info target not-p)
548   (:generator 2
549     (inst comisd x y)
550     (inst jmp (if not-p :nc :c) target)))
551
552 (define-vop (<single-float single-float-compare)
553   (:translate <)
554   (:info target not-p)
555   (:generator 2
556     (inst comiss x y)
557     (inst jmp (if not-p :nc :c) target)))
558
559 (define-vop (>double-float double-float-compare)
560   (:translate >)
561   (:info target not-p)
562   (:generator 2
563     (inst comisd x y)
564     (inst jmp (if not-p :na :a) target)))
565
566 (define-vop (>single-float single-float-compare)
567   (:translate >)
568   (:info target not-p)
569   (:generator 2
570     (inst comiss x y)
571     (inst jmp (if not-p :na :a) target)))
572
573
574 \f
575 ;;;; conversion
576
577 (macrolet ((frob (name translate inst to-sc to-type)
578              `(define-vop (,name)
579                 (:args (x :scs (signed-stack signed-reg) :target temp))
580                 (:temporary (:sc signed-stack) temp)
581                 (:results (y :scs (,to-sc)))
582                 (:arg-types signed-num)
583                 (:result-types ,to-type)
584                 (:policy :fast-safe)
585                 (:note "inline float coercion")
586                 (:translate ,translate)
587                 (:vop-var vop)
588                 (:save-p :compute-only)
589                 (:generator 5
590                   (sc-case x
591                     (signed-reg
592                      (inst mov temp x)
593                      (note-this-location vop :internal-error)
594                      (inst ,inst y temp))
595                     (signed-stack
596                      (note-this-location vop :internal-error)
597                      (inst ,inst y x)))))))
598   (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
599   (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
600
601 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
602              `(define-vop (,name)
603                (:args (x :scs (,from-sc) :target y))
604                (:results (y :scs (,to-sc)))
605                (:arg-types ,from-type)
606                (:result-types ,to-type)
607                (:policy :fast-safe)
608                (:note "inline float coercion")
609                (:translate ,translate)
610                (:vop-var vop)
611                (:save-p :compute-only)
612                (:generator 2
613                 (note-this-location vop :internal-error)
614                 (inst ,inst y x)))))
615   (frob %single-float/double-float %single-float cvtsd2ss double-reg
616         double-float single-reg single-float)
617
618   (frob %double-float/single-float %double-float cvtss2sd 
619         single-reg single-float double-reg double-float))
620
621 (macrolet ((frob (trans inst from-sc from-type round-p)
622              (declare (ignore round-p))
623              `(define-vop (,(symbolicate trans "/" from-type))
624                (:args (x :scs (,from-sc)))
625                (:temporary (:sc any-reg) temp-reg)
626                (:results (y :scs (signed-reg)))
627                (:arg-types ,from-type)
628                (:result-types signed-num)
629                (:translate ,trans)
630                (:policy :fast-safe)
631                (:note "inline float truncate")
632                (:vop-var vop)
633                (:save-p :compute-only)
634                (:generator 5
635                  (sc-case y
636                           (signed-stack
637                            (inst ,inst temp-reg x)
638                            (move y temp-reg))
639                           (signed-reg
640                            (inst ,inst y x)
641                            ))))))
642   (frob %unary-truncate cvttss2si single-reg single-float nil)
643   (frob %unary-truncate cvttsd2si double-reg double-float nil)
644
645   (frob %unary-round cvtss2si single-reg single-float t)
646   (frob %unary-round cvtsd2si double-reg double-float t))
647
648 (define-vop (make-single-float)
649   (:args (bits :scs (signed-reg) :target res
650                :load-if (not (or (and (sc-is bits signed-stack)
651                                       (sc-is res single-reg))
652                                  (and (sc-is bits signed-stack)
653                                       (sc-is res single-stack)
654                                       (location= bits res))))))
655   (:results (res :scs (single-reg single-stack)))
656   (:arg-types signed-num)
657   (:result-types single-float)
658   (:translate make-single-float)
659   (:policy :fast-safe)
660   (:vop-var vop)
661   (:generator 4
662     (sc-case res
663        (single-stack
664         (sc-case bits
665           (signed-reg
666            (inst mov res bits))
667           (signed-stack
668            (aver (location= bits res)))))
669        (single-reg
670         (sc-case bits
671           (signed-reg
672            (inst movd res bits))
673           (signed-stack
674            (inst movd res bits)))))))
675
676 (define-vop (make-double-float)
677   (:args (hi-bits :scs (signed-reg))
678          (lo-bits :scs (unsigned-reg)))
679   (:results (res :scs (double-reg)))
680   (:temporary (:sc unsigned-reg) temp)
681   (:arg-types signed-num unsigned-num)
682   (:result-types double-float)
683   (:translate make-double-float)
684   (:policy :fast-safe)
685   (:vop-var vop)
686   (:generator 2
687     (move temp hi-bits)
688     (inst shl temp 32)
689     (inst or temp lo-bits)
690     (inst movd res temp)))
691
692 (define-vop (single-float-bits)
693   (:args (float :scs (single-reg descriptor-reg)
694                 :load-if (not (sc-is float single-stack))))
695   (:results (bits :scs (signed-reg)))
696   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
697   (:arg-types single-float)
698   (:result-types signed-num)
699   (:translate single-float-bits)
700   (:policy :fast-safe)
701   (:vop-var vop)
702   (:generator 4
703     (sc-case bits
704       (signed-reg
705        (sc-case float
706          (single-reg
707           (inst movss stack-temp float)
708           (move bits stack-temp))
709          (single-stack
710           (move bits float))
711          (descriptor-reg
712           (move bits float)
713           (inst shr bits 32))))
714       (signed-stack
715        (sc-case float
716          (single-reg
717           (inst movss bits float)))))
718     ;; Sign-extend
719     (inst shl bits 32)
720     (inst sar bits 32)))
721
722 (define-vop (double-float-high-bits)
723   (:args (float :scs (double-reg descriptor-reg)
724                 :load-if (not (sc-is float double-stack))))
725   (:results (hi-bits :scs (signed-reg)))
726   (:temporary (:sc signed-stack :from :argument :to :result) temp)
727   (:arg-types double-float)
728   (:result-types signed-num)
729   (:translate double-float-high-bits)
730   (:policy :fast-safe)
731   (:vop-var vop)
732   (:generator 5
733      (sc-case float
734        (double-reg
735         (inst movsd temp float)
736         (move hi-bits temp))
737        (double-stack
738         (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
739        (descriptor-reg
740         (loadw hi-bits float double-float-value-slot
741                other-pointer-lowtag)))
742      (inst sar hi-bits 32)))
743
744 (define-vop (double-float-low-bits)
745   (:args (float :scs (double-reg descriptor-reg)
746                 :load-if (not (sc-is float double-stack))))
747   (:results (lo-bits :scs (unsigned-reg)))
748   (:temporary (:sc signed-stack :from :argument :to :result) temp)
749   (:arg-types double-float)
750   (:result-types unsigned-num)
751   (:translate double-float-low-bits)
752   (:policy :fast-safe)
753   (:vop-var vop)
754   (:generator 5
755      (sc-case float
756        (double-reg
757         (inst movsd temp float)
758         (move lo-bits temp))
759        (double-stack
760         (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
761        (descriptor-reg
762         (loadw lo-bits float double-float-value-slot
763                other-pointer-lowtag)))
764      (inst shl lo-bits 32)
765      (inst shr lo-bits 32)))
766
767 \f
768
769 ;;;; complex float VOPs
770
771 (define-vop (make-complex-single-float)
772   (:translate complex)
773   (:args (real :scs (single-reg) :to :result :target r
774                :load-if (not (location= real r)))
775          (imag :scs (single-reg) :to :save))
776   (:arg-types single-float single-float)
777   (:results (r :scs (complex-single-reg) :from (:argument 0)
778                :load-if (not (sc-is r complex-single-stack))))
779   (:result-types complex-single-float)
780   (:note "inline complex single-float creation")
781   (:policy :fast-safe)
782   (:generator 5
783     (sc-case r
784       (complex-single-reg
785        (let ((r-real (complex-single-reg-real-tn r)))
786          (unless (location= real r-real)
787            (inst movss r-real real)))
788        (let ((r-imag (complex-single-reg-imag-tn r)))
789          (unless (location= imag r-imag)
790            (inst movss r-imag imag))))
791       (complex-single-stack
792        (inst movss (ea-for-csf-real-stack r) real)
793        (inst movss (ea-for-csf-imag-stack r) imag)))))
794
795 (define-vop (make-complex-double-float)
796   (:translate complex)
797   (:args (real :scs (double-reg) :target r
798                :load-if (not (location= real r)))
799          (imag :scs (double-reg) :to :save))
800   (:arg-types double-float double-float)
801   (:results (r :scs (complex-double-reg) :from (:argument 0)
802                :load-if (not (sc-is r complex-double-stack))))
803   (:result-types complex-double-float)
804   (:note "inline complex double-float creation")
805   (:policy :fast-safe)
806   (:generator 5
807     (sc-case r
808       (complex-double-reg
809        (let ((r-real (complex-double-reg-real-tn r)))
810          (unless (location= real r-real)
811            (inst movsd r-real real)))
812        (let ((r-imag (complex-double-reg-imag-tn r)))
813          (unless (location= imag r-imag)
814            (inst movsd r-imag imag))))
815       (complex-double-stack
816        (inst movsd (ea-for-cdf-real-stack r) real)
817        (inst movsd (ea-for-cdf-imag-stack r) imag)))))
818
819 (define-vop (complex-float-value)
820   (:args (x :target r))
821   (:results (r))
822   (:variant-vars offset)
823   (:policy :fast-safe)
824   (:generator 3
825     (cond ((sc-is x complex-single-reg complex-double-reg)
826            (let ((value-tn
827                   (make-random-tn :kind :normal
828                                   :sc (sc-or-lose 'double-reg)
829                                   :offset (+ offset (tn-offset x)))))
830              (unless (location= value-tn r)
831                (if (sc-is x complex-single-reg)
832                    (inst movss r value-tn)
833                    (inst movsd r value-tn)))))
834           ((sc-is r single-reg)
835            (let ((ea (sc-case x
836                        (complex-single-stack
837                         (ecase offset
838                           (0 (ea-for-csf-real-stack x))
839                           (1 (ea-for-csf-imag-stack x))))
840                        (descriptor-reg
841                         (ecase offset
842                           (0 (ea-for-csf-real-desc x))
843                           (1 (ea-for-csf-imag-desc x)))))))
844              (inst movss r ea)))
845           ((sc-is r double-reg)
846            (let ((ea (sc-case x
847                        (complex-double-stack
848                         (ecase offset
849                           (0 (ea-for-cdf-real-stack x))
850                           (1 (ea-for-cdf-imag-stack x))))
851                        (descriptor-reg
852                         (ecase offset
853                           (0 (ea-for-cdf-real-desc x))
854                           (1 (ea-for-cdf-imag-desc x)))))))
855              (inst movsd r ea)))
856           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
857
858 (define-vop (realpart/complex-single-float complex-float-value)
859   (:translate realpart)
860   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
861             :target r))
862   (:arg-types complex-single-float)
863   (:results (r :scs (single-reg)))
864   (:result-types single-float)
865   (:note "complex float realpart")
866   (:variant 0))
867
868 (define-vop (realpart/complex-double-float complex-float-value)
869   (:translate realpart)
870   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
871             :target r))
872   (:arg-types complex-double-float)
873   (:results (r :scs (double-reg)))
874   (:result-types double-float)
875   (:note "complex float realpart")
876   (:variant 0))
877
878 (define-vop (imagpart/complex-single-float complex-float-value)
879   (:translate imagpart)
880   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
881             :target r))
882   (:arg-types complex-single-float)
883   (:results (r :scs (single-reg)))
884   (:result-types single-float)
885   (:note "complex float imagpart")
886   (:variant 1))
887
888 (define-vop (imagpart/complex-double-float complex-float-value)
889   (:translate imagpart)
890   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
891             :target r))
892   (:arg-types complex-double-float)
893   (:results (r :scs (double-reg)))
894   (:result-types double-float)
895   (:note "complex float imagpart")
896   (:variant 1))
897
898 \f
899 ;;; hack dummy VOPs to bias the representation selection of their
900 ;;; arguments towards a FP register, which can help avoid consing at
901 ;;; inappropriate locations
902 (defknown double-float-reg-bias (double-float) (values))
903 (define-vop (double-float-reg-bias)
904   (:translate double-float-reg-bias)
905   (:args (x :scs (double-reg double-stack) :load-if nil))
906   (:arg-types double-float)
907   (:policy :fast-safe)
908   (:note "inline dummy FP register bias")
909   (:ignore x)
910   (:generator 0))
911 (defknown single-float-reg-bias (single-float) (values))
912 (define-vop (single-float-reg-bias)
913   (:translate single-float-reg-bias)
914   (:args (x :scs (single-reg single-stack) :load-if nil))
915   (:arg-types single-float)
916   (:policy :fast-safe)
917   (:note "inline dummy FP register bias")
918   (:ignore x)
919   (:generator 0))