21750f9eda06581dbfe7ec9026de43cb8cb431fc
[sbcl.git] / src / compiler / ppc / float.lisp
1 ;;;; floating point support for the PPC
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 ;;;; Move functions:
15
16 (define-move-fun (load-single 1) (vop x y)
17   ((single-stack) (single-reg))
18   (inst lfs y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes)))
19
20 (define-move-fun (store-single 1) (vop x y)
21   ((single-reg) (single-stack))
22   (inst stfs x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
23
24
25 (define-move-fun (load-double 2) (vop x y)
26   ((double-stack) (double-reg))
27   (let ((nfp (current-nfp-tn vop))
28         (offset (* (tn-offset x) n-word-bytes)))
29     (inst lfd y nfp offset)))
30
31 (define-move-fun (store-double 2) (vop x y)
32   ((double-reg) (double-stack))
33   (let ((nfp (current-nfp-tn vop))
34         (offset (* (tn-offset y) n-word-bytes)))
35     (inst stfd x nfp offset)))
36
37
38 \f
39 ;;;; Move VOPs:
40
41 (macrolet ((frob (vop sc)
42              `(progn
43                 (define-vop (,vop)
44                   (:args (x :scs (,sc)
45                             :target y
46                             :load-if (not (location= x y))))
47                   (:results (y :scs (,sc)
48                                :load-if (not (location= x y))))
49                   (:note "float move")
50                   (:generator 0
51                     (unless (location= y x)
52                       (inst fmr y x))))
53                 (define-move-vop ,vop :move (,sc) (,sc)))))
54   (frob single-move single-reg)
55   (frob double-move double-reg))
56
57
58 (define-vop (move-from-float)
59   (:args (x :to :save))
60   (:results (y))
61   (:note "float to pointer coercion")
62   (:temporary (:scs (non-descriptor-reg)) ndescr)
63   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
64   (:variant-vars double-p size type data)
65   (:generator 13
66     (with-fixed-allocation (y pa-flag ndescr type size)
67       (if double-p
68           (inst stfd x y (- (* data n-word-bytes) other-pointer-lowtag))
69           (inst stfs x y (- (* data n-word-bytes) other-pointer-lowtag))))))
70
71 (macrolet ((frob (name sc &rest args)
72              `(progn
73                 (define-vop (,name move-from-float)
74                   (:args (x :scs (,sc) :to :save))
75                   (:results (y :scs (descriptor-reg)))
76                   (:variant ,@args))
77                 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
78   (frob move-from-single single-reg
79     nil single-float-size single-float-widetag single-float-value-slot)
80   (frob move-from-double double-reg
81     t double-float-size double-float-widetag double-float-value-slot))
82
83 (macrolet ((frob (name sc double-p value)
84              `(progn
85                 (define-vop (,name)
86                   (:args (x :scs (descriptor-reg)))
87                   (:results (y :scs (,sc)))
88                   (:note "pointer to float coercion")
89                   (:generator 2
90                     (inst ,(if double-p 'lfd 'lfs) y x
91                           (- (* ,value n-word-bytes) other-pointer-lowtag))))
92                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
93   (frob move-to-single single-reg nil single-float-value-slot)
94   (frob move-to-double double-reg t double-float-value-slot))
95
96
97 (macrolet ((frob (name sc stack-sc double-p)
98              `(progn
99                 (define-vop (,name)
100                   (:args (x :scs (,sc) :target y)
101                          (nfp :scs (any-reg)
102                               :load-if (not (sc-is y ,sc))))
103                   (:results (y))
104                   (:note "float arg move")
105                   (:generator ,(if double-p 2 1)
106                     (sc-case y
107                       (,sc
108                        (unless (location= x y)
109                          (inst fmr y x)))
110                       (,stack-sc
111                        (let ((offset (* (tn-offset y) n-word-bytes)))
112                          (inst ,(if double-p 'stfd 'stfs) x nfp offset))))))
113                 (define-move-vop ,name :move-arg
114                   (,sc descriptor-reg) (,sc)))))
115   (frob move-single-float-arg single-reg single-stack nil)
116   (frob move-double-float-arg double-reg double-stack t))
117
118
119 \f
120 ;;;; Complex float move functions
121
122 (defun complex-single-reg-real-tn (x)
123   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
124                   :offset (tn-offset x)))
125 (defun complex-single-reg-imag-tn (x)
126   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
127                   :offset (1+ (tn-offset x))))
128
129 (defun complex-double-reg-real-tn (x)
130   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
131                   :offset (tn-offset x)))
132 (defun complex-double-reg-imag-tn (x)
133   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
134                   :offset (1+ (tn-offset x))))
135
136
137 (define-move-fun (load-complex-single 2) (vop x y)
138   ((complex-single-stack) (complex-single-reg))
139   (let ((nfp (current-nfp-tn vop))
140         (offset (* (tn-offset x) n-word-bytes)))
141     (let ((real-tn (complex-single-reg-real-tn y)))
142       (inst lfs real-tn nfp offset))
143     (let ((imag-tn (complex-single-reg-imag-tn y)))
144       (inst lfs imag-tn nfp (+ offset n-word-bytes)))))
145
146 (define-move-fun (store-complex-single 2) (vop x y)
147   ((complex-single-reg) (complex-single-stack))
148   (let ((nfp (current-nfp-tn vop))
149         (offset (* (tn-offset y) n-word-bytes)))
150     (let ((real-tn (complex-single-reg-real-tn x)))
151       (inst stfs real-tn nfp offset))
152     (let ((imag-tn (complex-single-reg-imag-tn x)))
153       (inst stfs imag-tn nfp (+ offset n-word-bytes)))))
154
155
156 (define-move-fun (load-complex-double 4) (vop x y)
157   ((complex-double-stack) (complex-double-reg))
158   (let ((nfp (current-nfp-tn vop))
159         (offset (* (tn-offset x) n-word-bytes)))
160     (let ((real-tn (complex-double-reg-real-tn y)))
161       (inst lfd real-tn nfp offset))
162     (let ((imag-tn (complex-double-reg-imag-tn y)))
163       (inst lfd imag-tn nfp (+ offset (* 2 n-word-bytes))))))
164
165 (define-move-fun (store-complex-double 4) (vop x y)
166   ((complex-double-reg) (complex-double-stack))
167   (let ((nfp (current-nfp-tn vop))
168         (offset (* (tn-offset y) n-word-bytes)))
169     (let ((real-tn (complex-double-reg-real-tn x)))
170       (inst stfd real-tn nfp offset))
171     (let ((imag-tn (complex-double-reg-imag-tn x)))
172       (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes))))))
173
174
175 ;;;
176 ;;; Complex float register to register moves.
177 ;;;
178 (define-vop (complex-single-move)
179   (:args (x :scs (complex-single-reg) :target y
180             :load-if (not (location= x y))))
181   (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
182   (:note "complex single float move")
183   (:generator 0
184      (unless (location= x y)
185        ;; Note the complex-float-regs are aligned to every second
186        ;; float register so there is not need to worry about overlap.
187        (let ((x-real (complex-single-reg-real-tn x))
188              (y-real (complex-single-reg-real-tn y)))
189          (inst fmr y-real x-real))
190        (let ((x-imag (complex-single-reg-imag-tn x))
191              (y-imag (complex-single-reg-imag-tn y)))
192          (inst fmr y-imag x-imag)))))
193 ;;;
194 (define-move-vop complex-single-move :move
195   (complex-single-reg) (complex-single-reg))
196
197 (define-vop (complex-double-move)
198   (:args (x :scs (complex-double-reg)
199             :target y :load-if (not (location= x y))))
200   (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
201   (:note "complex double float move")
202   (:generator 0
203      (unless (location= x y)
204        ;; Note the complex-float-regs are aligned to every second
205        ;; float register so there is not need to worry about overlap.
206        (let ((x-real (complex-double-reg-real-tn x))
207              (y-real (complex-double-reg-real-tn y)))
208          (inst fmr y-real x-real))
209        (let ((x-imag (complex-double-reg-imag-tn x))
210              (y-imag (complex-double-reg-imag-tn y)))
211          (inst fmr y-imag x-imag)))))
212 ;;;
213 (define-move-vop complex-double-move :move
214   (complex-double-reg) (complex-double-reg))
215
216
217 ;;;
218 ;;; Move from a complex float to a descriptor register allocating a
219 ;;; new complex float object in the process.
220 ;;;
221 (define-vop (move-from-complex-single)
222   (:args (x :scs (complex-single-reg) :to :save))
223   (:results (y :scs (descriptor-reg)))
224   (:temporary (:scs (non-descriptor-reg)) ndescr)
225   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
226   (:note "complex single float to pointer coercion")
227   (:generator 13
228      (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
229                                complex-single-float-size)
230        (let ((real-tn (complex-single-reg-real-tn x)))
231          (inst stfs real-tn y (- (* complex-single-float-real-slot
232                                     n-word-bytes)
233                                  other-pointer-lowtag)))
234        (let ((imag-tn (complex-single-reg-imag-tn x)))
235          (inst stfs imag-tn y (- (* complex-single-float-imag-slot
236                                     n-word-bytes)
237                                  other-pointer-lowtag))))))
238 ;;;
239 (define-move-vop move-from-complex-single :move
240   (complex-single-reg) (descriptor-reg))
241
242 (define-vop (move-from-complex-double)
243   (:args (x :scs (complex-double-reg) :to :save))
244   (:results (y :scs (descriptor-reg)))
245   (:temporary (:scs (non-descriptor-reg)) ndescr)
246   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
247   (:note "complex double float to pointer coercion")
248   (:generator 13
249      (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
250                                complex-double-float-size)
251        (let ((real-tn (complex-double-reg-real-tn x)))
252          (inst stfd real-tn y (- (* complex-double-float-real-slot
253                                     n-word-bytes)
254                                  other-pointer-lowtag)))
255        (let ((imag-tn (complex-double-reg-imag-tn x)))
256          (inst stfd imag-tn y (- (* complex-double-float-imag-slot
257                                     n-word-bytes)
258                                  other-pointer-lowtag))))))
259 ;;;
260 (define-move-vop move-from-complex-double :move
261   (complex-double-reg) (descriptor-reg))
262
263
264 ;;;
265 ;;; Move from a descriptor to a complex float register
266 ;;;
267 (define-vop (move-to-complex-single)
268   (:args (x :scs (descriptor-reg)))
269   (:results (y :scs (complex-single-reg)))
270   (:note "pointer to complex float coercion")
271   (:generator 2
272     (let ((real-tn (complex-single-reg-real-tn y)))
273       (inst lfs real-tn x (- (* complex-single-float-real-slot n-word-bytes)
274                              other-pointer-lowtag)))
275     (let ((imag-tn (complex-single-reg-imag-tn y)))
276       (inst lfs imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
277                              other-pointer-lowtag)))))
278 (define-move-vop move-to-complex-single :move
279   (descriptor-reg) (complex-single-reg))
280
281 (define-vop (move-to-complex-double)
282   (:args (x :scs (descriptor-reg)))
283   (:results (y :scs (complex-double-reg)))
284   (:note "pointer to complex float coercion")
285   (:generator 2
286     (let ((real-tn (complex-double-reg-real-tn y)))
287       (inst lfd real-tn x (- (* complex-double-float-real-slot n-word-bytes)
288                              other-pointer-lowtag)))
289     (let ((imag-tn (complex-double-reg-imag-tn y)))
290       (inst lfd imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
291                              other-pointer-lowtag)))))
292 (define-move-vop move-to-complex-double :move
293   (descriptor-reg) (complex-double-reg))
294
295
296 ;;;
297 ;;; Complex float move-arg vop
298 ;;;
299 (define-vop (move-complex-single-float-arg)
300   (:args (x :scs (complex-single-reg) :target y)
301          (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
302   (:results (y))
303   (:note "complex single-float arg move")
304   (:generator 1
305     (sc-case y
306       (complex-single-reg
307        (unless (location= x y)
308          (let ((x-real (complex-single-reg-real-tn x))
309                (y-real (complex-single-reg-real-tn y)))
310            (inst fmr y-real x-real))
311          (let ((x-imag (complex-single-reg-imag-tn x))
312                (y-imag (complex-single-reg-imag-tn y)))
313            (inst fmr y-imag x-imag))))
314       (complex-single-stack
315        (let ((offset (* (tn-offset y) n-word-bytes)))
316          (let ((real-tn (complex-single-reg-real-tn x)))
317            (inst stfs real-tn nfp offset))
318          (let ((imag-tn (complex-single-reg-imag-tn x)))
319            (inst stfs imag-tn nfp (+ offset n-word-bytes))))))))
320 (define-move-vop move-complex-single-float-arg :move-arg
321   (complex-single-reg descriptor-reg) (complex-single-reg))
322
323 (define-vop (move-complex-double-float-arg)
324   (:args (x :scs (complex-double-reg) :target y)
325          (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
326   (:results (y))
327   (:note "complex double-float arg move")
328   (:generator 2
329     (sc-case y
330       (complex-double-reg
331        (unless (location= x y)
332          (let ((x-real (complex-double-reg-real-tn x))
333                (y-real (complex-double-reg-real-tn y)))
334            (inst fmr y-real x-real))
335          (let ((x-imag (complex-double-reg-imag-tn x))
336                (y-imag (complex-double-reg-imag-tn y)))
337            (inst fmr y-imag x-imag))))
338       (complex-double-stack
339        (let ((offset (* (tn-offset y) n-word-bytes)))
340          (let ((real-tn (complex-double-reg-real-tn x)))
341            (inst stfd real-tn nfp offset))
342          (let ((imag-tn (complex-double-reg-imag-tn x)))
343            (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
344 (define-move-vop move-complex-double-float-arg :move-arg
345   (complex-double-reg descriptor-reg) (complex-double-reg))
346
347
348 (define-move-vop move-arg :move-arg
349   (single-reg double-reg complex-single-reg complex-double-reg)
350   (descriptor-reg))
351
352 \f
353 ;;;; Arithmetic VOPs:
354
355 (define-vop (float-op)
356   (:args (x) (y))
357   (:results (r))
358   (:policy :fast-safe)
359   (:note "inline float arithmetic")
360   (:vop-var vop)
361   (:save-p :compute-only))
362
363 (macrolet ((frob (name sc ptype)
364              `(define-vop (,name float-op)
365                 (:args (x :scs (,sc))
366                        (y :scs (,sc)))
367                 (:results (r :scs (,sc)))
368                 (:arg-types ,ptype ,ptype)
369                 (:result-types ,ptype))))
370   (frob single-float-op single-reg single-float)
371   (frob double-float-op double-reg double-float))
372
373 (macrolet ((frob (op sinst sname scost dinst dname dcost)
374              `(progn
375                 (define-vop (,sname single-float-op)
376                   (:translate ,op)
377                   (:generator ,scost
378                     (inst ,sinst r x y)))
379                 (define-vop (,dname double-float-op)
380                   (:translate ,op)
381                   (:generator ,dcost
382                     (inst ,dinst r x y))))))
383   (frob + fadds +/single-float 2 fadd +/double-float 2)
384   (frob - fsubs -/single-float 2 fsub -/double-float 2)
385   (frob * fmuls */single-float 4 fmul */double-float 5)
386   (frob / fdivs //single-float 12 fdiv //double-float 19))
387
388 (macrolet ((frob (name inst translate sc type)
389              `(define-vop (,name)
390                 (:args (x :scs (,sc)))
391                 (:results (y :scs (,sc)))
392                 (:translate ,translate)
393                 (:policy :fast-safe)
394                 (:arg-types ,type)
395                 (:result-types ,type)
396                 (:note "inline float arithmetic")
397                 (:vop-var vop)
398                 (:save-p :compute-only)
399                 (:generator 1
400                   (note-this-location vop :internal-error)
401                   (inst ,inst y x)))))
402   (frob abs/single-float fabs abs single-reg single-float)
403   (frob abs/double-float fabs abs double-reg double-float)
404   (frob %negate/single-float fneg %negate single-reg single-float)
405   (frob %negate/double-float fneg %negate double-reg double-float))
406
407 \f
408 ;;;; Comparison:
409
410 (define-vop (float-compare)
411   (:args (x) (y))
412   (:conditional)
413   (:info target not-p)
414   (:variant-vars format yep nope)
415   (:policy :fast-safe)
416   (:note "inline float comparison")
417   (:vop-var vop)
418   (:save-p :compute-only)
419   (:generator 3
420     (note-this-location vop :internal-error)
421     (ecase format
422       ((:single :double)
423        (inst fcmpo :cr1 x y)))
424     (inst b?  :cr1 (if not-p nope yep) target)))
425
426 (macrolet ((frob (name sc ptype)
427              `(define-vop (,name float-compare)
428                 (:args (x :scs (,sc))
429                        (y :scs (,sc)))
430                 (:arg-types ,ptype ,ptype))))
431   (frob single-float-compare single-reg single-float)
432   (frob double-float-compare double-reg double-float))
433
434 (macrolet ((frob (translate yep nope sname dname)
435              `(progn
436                 (define-vop (,sname single-float-compare)
437                   (:translate ,translate)
438                   (:variant :single ,yep ,nope))
439                 (define-vop (,dname double-float-compare)
440                   (:translate ,translate)
441                   (:variant :double ,yep ,nope)))))
442   (frob < :lt :ge </single-float </double-float)
443   (frob > :gt :le >/single-float >/double-float)
444   (frob = :eq :ne eql/single-float eql/double-float))
445
446 \f
447 ;;;; Conversion:
448
449 (macrolet ((frob (name translate inst to-sc to-type)
450              `(define-vop (,name)
451                 (:args (x :scs (signed-reg)))
452                 (:temporary (:scs (double-stack)) temp)
453                 (:temporary (:scs (double-reg)) fmagic)
454                 (:temporary (:scs (signed-reg)) rtemp)
455                 (:results (y :scs (,to-sc)))
456                 (:arg-types signed-num)
457                 (:result-types ,to-type)
458                 (:policy :fast-safe)
459                 (:note "inline float coercion")
460                 (:translate ,translate)
461                 (:vop-var vop)
462                 (:save-p :compute-only)
463                 (:generator 5
464                   (let* ((stack-offset (* (tn-offset temp) n-word-bytes))
465                          (nfp-tn (current-nfp-tn vop))
466                          (temp-offset-high (* stack-offset n-word-bytes))
467                          (temp-offset-low (* (1+ stack-offset) n-word-bytes)))
468                     (inst lis rtemp #x4330)   ; High word of magic constant
469                     (inst stw rtemp nfp-tn temp-offset-high)
470                     (inst lis rtemp #x8000)
471                     (inst stw rtemp nfp-tn temp-offset-low)
472                     (inst lfd fmagic nfp-tn temp-offset-high)
473                     (inst xor rtemp rtemp x)          ; invert sign bit of x : rtemp had #x80000000
474                     (inst stw rtemp nfp-tn temp-offset-low)
475                     (inst lfd y nfp-tn temp-offset-high)                    
476                     (note-this-location vop :internal-error)
477                     (inst ,inst y y fmagic))))))
478   (frob %single-float/signed %single-float fsubs single-reg single-float)
479   (frob %double-float/signed %double-float fsub double-reg double-float))
480
481 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
482              `(define-vop (,name)
483                 (:args (x :scs (,from-sc)))
484                 (:results (y :scs (,to-sc)))
485                 (:arg-types ,from-type)
486                 (:result-types ,to-type)
487                 (:policy :fast-safe)
488                 (:note "inline float coercion")
489                 (:translate ,translate)
490                 (:vop-var vop)
491                 (:save-p :compute-only)
492                 (:generator 2
493                   (note-this-location vop :internal-error)
494                   (inst ,inst y x)))))
495   (frob %single-float/double-float %single-float frsp
496     double-reg double-float single-reg single-float)
497   (frob %double-float/single-float %double-float fmr
498     single-reg single-float double-reg double-float))
499
500 (macrolet ((frob (trans from-sc from-type inst)
501              `(define-vop (,(symbolicate trans "/" from-type))
502                 (:args (x :scs (,from-sc) :target temp))
503                 (:temporary (:from (:argument 0) :sc single-reg) temp)
504                 (:temporary (:scs (double-stack)) stack-temp)
505                 (:results (y :scs (signed-reg)))
506                 (:arg-types ,from-type)
507                 (:result-types signed-num)
508                 (:translate ,trans)
509                 (:policy :fast-safe)
510                 (:note "inline float truncate")
511                 (:vop-var vop)
512                 (:save-p :compute-only)
513                 (:generator 5
514                   (note-this-location vop :internal-error)
515                   (inst ,inst temp x)
516                   (inst stfd temp (current-nfp-tn vop)
517                         (* (tn-offset stack-temp) n-word-bytes))
518                   (inst lwz y (current-nfp-tn vop)
519                         (+ 4 (* (tn-offset stack-temp) n-word-bytes)))))))
520   (frob %unary-truncate single-reg single-float fctiwz)
521   (frob %unary-truncate double-reg double-float fctiwz)
522   (frob %unary-round single-reg single-float fctiw)
523   (frob %unary-round double-reg double-float fctiw))
524
525 (define-vop (make-single-float)
526   (:args (bits :scs (signed-reg) :target res
527                :load-if (not (sc-is bits signed-stack))))
528   (:results (res :scs (single-reg)
529                  :load-if (not (sc-is res single-stack))))
530   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
531   (:temporary (:scs (signed-stack)) stack-temp)
532   (:arg-types signed-num)
533   (:result-types single-float)
534   (:translate make-single-float)
535   (:policy :fast-safe)
536   (:vop-var vop)
537   (:generator 4
538     (sc-case bits
539       (signed-reg
540        (sc-case res
541          (single-reg
542           (inst stw bits (current-nfp-tn vop)
543                 (* (tn-offset stack-temp) n-word-bytes))
544           (inst lfs res (current-nfp-tn vop)
545                 (* (tn-offset stack-temp) n-word-bytes)))
546          (single-stack
547           (inst stw bits (current-nfp-tn vop)
548                 (* (tn-offset res) n-word-bytes)))))
549       (signed-stack
550        (sc-case res
551          (single-reg
552           (inst lfs res (current-nfp-tn vop)
553                 (* (tn-offset bits) n-word-bytes)))
554          (single-stack
555           (unless (location= bits res)
556             (inst lwz temp (current-nfp-tn vop)
557                   (* (tn-offset bits) n-word-bytes))
558             (inst stw temp (current-nfp-tn vop)
559                   (* (tn-offset res) n-word-bytes)))))))))
560
561 (define-vop (make-double-float)
562   (:args (hi-bits :scs (signed-reg))
563          (lo-bits :scs (unsigned-reg)))
564   (:results (res :scs (double-reg)
565                  :load-if (not (sc-is res double-stack))))
566   (:temporary (:scs (double-stack)) temp)
567   (:arg-types signed-num unsigned-num)
568   (:result-types double-float)
569   (:translate make-double-float)
570   (:policy :fast-safe)
571   (:vop-var vop)
572   (:generator 2
573     (let ((stack-tn (sc-case res
574                       (double-stack res)
575                       (double-reg temp))))
576       (inst stw hi-bits (current-nfp-tn vop)
577             (* (tn-offset stack-tn) n-word-bytes))
578       (inst stw lo-bits (current-nfp-tn vop)
579             (* (1+ (tn-offset stack-tn)) n-word-bytes)))
580     (when (sc-is res double-reg)
581       (inst lfd res (current-nfp-tn vop)
582             (* (tn-offset temp) n-word-bytes)))))
583
584 (define-vop (single-float-bits)
585   (:args (float :scs (single-reg descriptor-reg)
586                 :load-if (not (sc-is float single-stack))))
587   (:results (bits :scs (signed-reg)
588                   :load-if (or (sc-is float descriptor-reg single-stack)
589                                (not (sc-is bits signed-stack)))))
590   (:temporary (:scs (signed-stack)) stack-temp)
591   (:arg-types single-float)
592   (:result-types signed-num)
593   (:translate single-float-bits)
594   (:policy :fast-safe)
595   (:vop-var vop)
596   (:generator 4
597     (sc-case bits
598       (signed-reg
599        (sc-case float
600          (single-reg
601           (inst stfs float (current-nfp-tn vop)
602                 (* (tn-offset stack-temp) n-word-bytes))
603           (inst lwz bits (current-nfp-tn vop)
604                 (* (tn-offset stack-temp) n-word-bytes)))
605          (single-stack
606           (inst lwz bits (current-nfp-tn vop)
607                 (* (tn-offset float) n-word-bytes)))
608          (descriptor-reg
609           (loadw bits float single-float-value-slot other-pointer-lowtag))))
610       (signed-stack
611        (sc-case float
612          (single-reg
613           (inst stfs float (current-nfp-tn vop)
614                 (* (tn-offset bits) n-word-bytes))))))))
615
616 (define-vop (double-float-high-bits)
617   (:args (float :scs (double-reg descriptor-reg)
618                 :load-if (not (sc-is float double-stack))))
619   (:results (hi-bits :scs (signed-reg)))
620   (:temporary (:scs (double-stack)) stack-temp)
621   (:arg-types double-float)
622   (:result-types signed-num)
623   (:translate double-float-high-bits)
624   (:policy :fast-safe)
625   (:vop-var vop)
626   (:generator 5
627     (sc-case float
628       (double-reg
629         (inst stfd float (current-nfp-tn vop)
630               (* (tn-offset stack-temp) n-word-bytes))
631         (inst lwz hi-bits (current-nfp-tn vop)
632               (* (tn-offset stack-temp) n-word-bytes)))
633       (double-stack
634         (inst lwz hi-bits (current-nfp-tn vop)
635               (* (tn-offset float) n-word-bytes)))
636       (descriptor-reg
637         (loadw hi-bits float double-float-value-slot
638                other-pointer-lowtag)))))
639
640 (define-vop (double-float-low-bits)
641   (:args (float :scs (double-reg descriptor-reg)
642                 :load-if (not (sc-is float double-stack))))
643   (:results (lo-bits :scs (unsigned-reg)))
644   (:temporary (:scs (double-stack)) stack-temp)
645   (:arg-types double-float)
646   (:result-types unsigned-num)
647   (:translate double-float-low-bits)
648   (:policy :fast-safe)
649   (:vop-var vop)
650   (:generator 5
651     (sc-case float
652       (double-reg
653         (inst stfd float (current-nfp-tn vop)
654               (* (tn-offset stack-temp) n-word-bytes))
655         (inst lwz lo-bits (current-nfp-tn vop)
656               (* (1+ (tn-offset stack-temp)) n-word-bytes)))
657       (double-stack
658         (inst lwz lo-bits (current-nfp-tn vop)
659               (* (1+ (tn-offset float)) n-word-bytes)))
660       (descriptor-reg
661         (loadw lo-bits float (1+ double-float-value-slot)
662                other-pointer-lowtag)))))
663 \f
664 ;;;; Float mode hackery:
665
666 (sb!xc:deftype float-modes () '(unsigned-byte 32))
667 (defknown floating-point-modes () float-modes (flushable))
668 (defknown ((setf floating-point-modes)) (float-modes)
669   float-modes)
670
671 (define-vop (floating-point-modes)
672   (:results (res :scs (unsigned-reg)))
673   (:result-types unsigned-num)
674   (:translate floating-point-modes)
675   (:policy :fast-safe)
676   (:vop-var vop)
677   (:temporary (:sc double-stack) temp)
678   (:temporary (:sc single-reg) fp-temp)
679   (:generator 3
680     (let ((nfp (current-nfp-tn vop)))
681       (inst mffs fp-temp)
682       (inst stfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
683       (loadw res nfp (1+ (tn-offset temp))))))
684
685 (define-vop (set-floating-point-modes)
686   (:args (new :scs (unsigned-reg) :target res))
687   (:results (res :scs (unsigned-reg)))
688   (:arg-types unsigned-num)
689   (:result-types unsigned-num)
690   (:translate (setf floating-point-modes))
691   (:policy :fast-safe)
692   (:temporary (:sc double-stack) temp)
693   (:temporary (:sc single-reg) fp-temp)
694   (:vop-var vop)
695   (:generator 3
696     (let ((nfp (current-nfp-tn vop)))
697       (storew new nfp (1+ (tn-offset temp)))
698       (inst lfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
699       (inst mtfsf 255 fp-temp)
700       (move res new))))
701
702 \f
703 ;;;; Complex float VOPs
704
705 (define-vop (make-complex-single-float)
706   (:translate complex)
707   (:args (real :scs (single-reg) :target r
708                :load-if (not (location= real r)))
709          (imag :scs (single-reg) :to :save))
710   (:arg-types single-float single-float)
711   (:results (r :scs (complex-single-reg) :from (:argument 0)
712                :load-if (not (sc-is r complex-single-stack))))
713   (:result-types complex-single-float)
714   (:note "inline complex single-float creation")
715   (:policy :fast-safe)
716   (:vop-var vop)
717   (:generator 5
718     (sc-case r
719       (complex-single-reg
720        (let ((r-real (complex-single-reg-real-tn r)))
721          (unless (location= real r-real)
722            (inst fmr r-real real)))
723        (let ((r-imag (complex-single-reg-imag-tn r)))
724          (unless (location= imag r-imag)
725            (inst fmr r-imag imag))))
726       (complex-single-stack
727        (let ((nfp (current-nfp-tn vop))
728              (offset (* (tn-offset r) n-word-bytes)))
729          (unless (location= real r)
730            (inst stfs real nfp offset))
731          (inst stfs imag nfp (+ offset n-word-bytes)))))))
732
733 (define-vop (make-complex-double-float)
734   (:translate complex)
735   (:args (real :scs (double-reg) :target r
736                :load-if (not (location= real r)))
737          (imag :scs (double-reg) :to :save))
738   (:arg-types double-float double-float)
739   (:results (r :scs (complex-double-reg) :from (:argument 0)
740                :load-if (not (sc-is r complex-double-stack))))
741   (:result-types complex-double-float)
742   (:note "inline complex double-float creation")
743   (:policy :fast-safe)
744   (:vop-var vop)
745   (:generator 5
746     (sc-case r
747       (complex-double-reg
748        (let ((r-real (complex-double-reg-real-tn r)))
749          (unless (location= real r-real)
750            (inst fmr r-real real)))
751        (let ((r-imag (complex-double-reg-imag-tn r)))
752          (unless (location= imag r-imag)
753            (inst fmr r-imag imag))))
754       (complex-double-stack
755        (let ((nfp (current-nfp-tn vop))
756              (offset (* (tn-offset r) n-word-bytes)))
757          (unless (location= real r)
758            (inst stfd real nfp offset))
759          (inst stfd imag nfp (+ offset (* 2 n-word-bytes))))))))
760
761
762 (define-vop (complex-single-float-value)
763   (:args (x :scs (complex-single-reg) :target r
764             :load-if (not (sc-is x complex-single-stack))))
765   (:arg-types complex-single-float)
766   (:results (r :scs (single-reg)))
767   (:result-types single-float)
768   (:variant-vars slot)
769   (:policy :fast-safe)
770   (:vop-var vop)
771   (:generator 3
772     (sc-case x
773       (complex-single-reg
774        (let ((value-tn (ecase slot
775                          (:real (complex-single-reg-real-tn x))
776                          (:imag (complex-single-reg-imag-tn x)))))
777          (unless (location= value-tn r)
778            (inst fmr r value-tn))))
779       (complex-single-stack
780        (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
781                                               (tn-offset x))
782                                            n-word-bytes))))))
783
784 (define-vop (realpart/complex-single-float complex-single-float-value)
785   (:translate realpart)
786   (:note "complex single float realpart")
787   (:variant :real))
788
789 (define-vop (imagpart/complex-single-float complex-single-float-value)
790   (:translate imagpart)
791   (:note "complex single float imagpart")
792   (:variant :imag))
793
794 (define-vop (complex-double-float-value)
795   (:args (x :scs (complex-double-reg) :target r
796             :load-if (not (sc-is x complex-double-stack))))
797   (:arg-types complex-double-float)
798   (:results (r :scs (double-reg)))
799   (:result-types double-float)
800   (:variant-vars slot)
801   (:policy :fast-safe)
802   (:vop-var vop)
803   (:generator 3
804     (sc-case x
805       (complex-double-reg
806        (let ((value-tn (ecase slot
807                          (:real (complex-double-reg-real-tn x))
808                          (:imag (complex-double-reg-imag-tn x)))))
809          (unless (location= value-tn r)
810            (inst fmr r value-tn))))
811       (complex-double-stack
812        (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
813                                               (tn-offset x))
814                                            n-word-bytes))))))
815
816 (define-vop (realpart/complex-double-float complex-double-float-value)
817   (:translate realpart)
818   (:note "complex double float realpart")
819   (:variant :real))
820
821 (define-vop (imagpart/complex-double-float complex-double-float-value)
822   (:translate imagpart)
823   (:note "complex double float imagpart")
824   (:variant :imag))