1 ;;;; floating point support for the PPC
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
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
)))
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
)))
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
)))
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
)))
41 (macrolet ((frob (vop sc
)
46 :load-if
(not (location= x y
))))
47 (:results
(y :scs
(,sc
)
48 :load-if
(not (location= x y
))))
51 (unless (location= y x
)
53 (define-move-vop ,vop
:move
(,sc
) (,sc
)))))
54 (frob single-move single-reg
)
55 (frob double-move double-reg
))
58 (define-vop (move-from-float)
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
)
66 (with-fixed-allocation (y pa-flag ndescr type size
)
68 (inst stfd x y
(- (* data n-word-bytes
) other-pointer-lowtag
))
69 (inst stfs x y
(- (* data n-word-bytes
) other-pointer-lowtag
))))))
71 (macrolet ((frob (name sc
&rest args
)
73 (define-vop (,name move-from-float
)
74 (:args
(x :scs
(,sc
) :to
:save
))
75 (:results
(y :scs
(descriptor-reg)))
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
))
83 (macrolet ((frob (name sc double-p value
)
86 (:args
(x :scs
(descriptor-reg)))
87 (:results
(y :scs
(,sc
)))
88 (:note
"pointer to float coercion")
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
))
97 (macrolet ((frob (name sc stack-sc double-p
)
100 (:args
(x :scs
(,sc
) :target y
)
102 :load-if
(not (sc-is y
,sc
))))
104 (:note
"float arg move")
105 (:generator
,(if double-p
2 1)
108 (unless (location= x y
)
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
))
120 ;;;; Complex float move functions
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
))))
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
))))
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
)))))
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
)))))
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
))))))
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
))))))
176 ;;; Complex float register to register moves.
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")
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
)))))
194 (define-move-vop complex-single-move
:move
195 (complex-single-reg) (complex-single-reg))
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")
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
)))))
213 (define-move-vop complex-double-move
:move
214 (complex-double-reg) (complex-double-reg))
218 ;;; Move from a complex float to a descriptor register allocating a
219 ;;; new complex float object in the process.
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")
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
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
237 other-pointer-lowtag
))))))
239 (define-move-vop move-from-complex-single
:move
240 (complex-single-reg) (descriptor-reg))
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")
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
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
258 other-pointer-lowtag
))))))
260 (define-move-vop move-from-complex-double
:move
261 (complex-double-reg) (descriptor-reg))
265 ;;; Move from a descriptor to a complex float register
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")
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))
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")
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))
297 ;;; Complex float move-arg vop
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
))))
303 (:note
"complex single-float arg move")
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))
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
))))
327 (:note
"complex double-float arg move")
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))
348 (define-move-vop move-arg
:move-arg
349 (single-reg double-reg complex-single-reg complex-double-reg
)
353 ;;;; Arithmetic VOPs:
355 (define-vop (float-op)
359 (:note
"inline float arithmetic")
361 (:save-p
:compute-only
))
363 (macrolet ((frob (name sc ptype
)
364 `(define-vop (,name float-op
)
365 (:args
(x :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
))
373 (macrolet ((frob (op sinst sname scost dinst dname dcost
)
375 (define-vop (,sname single-float-op
)
378 (inst ,sinst r x y
)))
379 (define-vop (,dname double-float-op
)
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))
388 (macrolet ((frob (name inst translate sc type
)
390 (:args
(x :scs
(,sc
)))
391 (:results
(y :scs
(,sc
)))
392 (:translate
,translate
)
395 (:result-types
,type
)
396 (:note
"inline float arithmetic")
398 (:save-p
:compute-only
)
400 (note-this-location vop
:internal-error
)
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
))
410 (define-vop (float-compare)
414 (:variant-vars format yep nope
)
416 (:note
"inline float comparison")
418 (:save-p
:compute-only
)
420 (note-this-location vop
:internal-error
)
423 (inst fcmpo
:cr1 x y
)))
424 (inst b?
:cr1
(if not-p nope yep
) target
)))
426 (macrolet ((frob (name sc ptype
)
427 `(define-vop (,name float-compare
)
428 (:args
(x :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
))
434 (macrolet ((frob (translate yep nope sname dname
)
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
))
449 (macrolet ((frob (name translate inst to-sc to-type
)
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
)
459 (:note
"inline float coercion")
460 (:translate
,translate
)
462 (:save-p
:compute-only
)
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
))
481 (macrolet ((frob (name translate inst to-sc to-type
)
483 (:args
(x :scs
(unsigned-reg)))
484 (:temporary
(:scs
(double-stack)) temp
)
485 (:temporary
(:scs
(double-reg)) fmagic
)
486 (:temporary
(:scs
(signed-reg)) rtemp
)
487 (:results
(y :scs
(,to-sc
)))
488 (:arg-types unsigned-num
)
489 (:result-types
,to-type
)
491 (:note
"inline float coercion")
492 (:translate
,translate
)
494 (:save-p
:compute-only
)
496 (let* ((stack-offset (* (tn-offset temp
) n-word-bytes
))
497 (nfp-tn (current-nfp-tn vop
))
498 (temp-offset-high (* stack-offset n-word-bytes
))
499 (temp-offset-low (* (1+ stack-offset
) n-word-bytes
)))
500 (inst lis rtemp
#x4330
) ; High word of magic constant
501 (inst stw rtemp nfp-tn temp-offset-high
)
502 (inst stw zero-tn nfp-tn temp-offset-low
)
503 (inst lfd fmagic nfp-tn temp-offset-high
)
504 (inst stw x nfp-tn temp-offset-low
)
505 (inst lfd y nfp-tn temp-offset-high
)
506 (note-this-location vop
:internal-error
)
507 (inst ,inst y y fmagic
))))))
508 (frob %single-float
/unsigned %single-float fsubs single-reg single-float
)
509 (frob %double-float
/unsigned %double-float fsub double-reg double-float
))
511 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type
)
513 (:args
(x :scs
(,from-sc
)))
514 (:results
(y :scs
(,to-sc
)))
515 (:arg-types
,from-type
)
516 (:result-types
,to-type
)
518 (:note
"inline float coercion")
519 (:translate
,translate
)
521 (:save-p
:compute-only
)
523 (note-this-location vop
:internal-error
)
525 (frob %single-float
/double-float %single-float frsp
526 double-reg double-float single-reg single-float
)
527 (frob %double-float
/single-float %double-float fmr
528 single-reg single-float double-reg double-float
))
530 (macrolet ((frob (trans from-sc from-type inst
)
531 `(define-vop (,(symbolicate trans
"/" from-type
))
532 (:args
(x :scs
(,from-sc
) :target temp
))
533 (:temporary
(:from
(:argument
0) :sc single-reg
) temp
)
534 (:temporary
(:scs
(double-stack)) stack-temp
)
535 (:results
(y :scs
(signed-reg)))
536 (:arg-types
,from-type
)
537 (:result-types signed-num
)
540 (:note
"inline float truncate")
542 (:save-p
:compute-only
)
544 (note-this-location vop
:internal-error
)
546 (inst stfd temp
(current-nfp-tn vop
)
547 (* (tn-offset stack-temp
) n-word-bytes
))
548 (inst lwz y
(current-nfp-tn vop
)
549 (+ 4 (* (tn-offset stack-temp
) n-word-bytes
)))))))
550 (frob %unary-truncate single-reg single-float fctiwz
)
551 (frob %unary-truncate double-reg double-float fctiwz
)
552 (frob %unary-round single-reg single-float fctiw
)
553 (frob %unary-round double-reg double-float fctiw
))
555 (define-vop (make-single-float)
556 (:args
(bits :scs
(signed-reg) :target res
557 :load-if
(not (sc-is bits signed-stack
))))
558 (:results
(res :scs
(single-reg)
559 :load-if
(not (sc-is res single-stack
))))
560 (:temporary
(:scs
(signed-reg) :from
(:argument
0) :to
(:result
0)) temp
)
561 (:temporary
(:scs
(signed-stack)) stack-temp
)
562 (:arg-types signed-num
)
563 (:result-types single-float
)
564 (:translate make-single-float
)
572 (inst stw bits
(current-nfp-tn vop
)
573 (* (tn-offset stack-temp
) n-word-bytes
))
574 (inst lfs res
(current-nfp-tn vop
)
575 (* (tn-offset stack-temp
) n-word-bytes
)))
577 (inst stw bits
(current-nfp-tn vop
)
578 (* (tn-offset res
) n-word-bytes
)))))
582 (inst lfs res
(current-nfp-tn vop
)
583 (* (tn-offset bits
) n-word-bytes
)))
585 (unless (location= bits res
)
586 (inst lwz temp
(current-nfp-tn vop
)
587 (* (tn-offset bits
) n-word-bytes
))
588 (inst stw temp
(current-nfp-tn vop
)
589 (* (tn-offset res
) n-word-bytes
)))))))))
591 (define-vop (make-double-float)
592 (:args
(hi-bits :scs
(signed-reg))
593 (lo-bits :scs
(unsigned-reg)))
594 (:results
(res :scs
(double-reg)
595 :load-if
(not (sc-is res double-stack
))))
596 (:temporary
(:scs
(double-stack)) temp
)
597 (:arg-types signed-num unsigned-num
)
598 (:result-types double-float
)
599 (:translate make-double-float
)
603 (let ((stack-tn (sc-case res
606 (inst stw hi-bits
(current-nfp-tn vop
)
607 (* (tn-offset stack-tn
) n-word-bytes
))
608 (inst stw lo-bits
(current-nfp-tn vop
)
609 (* (1+ (tn-offset stack-tn
)) n-word-bytes
)))
610 (when (sc-is res double-reg
)
611 (inst lfd res
(current-nfp-tn vop
)
612 (* (tn-offset temp
) n-word-bytes
)))))
614 (define-vop (single-float-bits)
615 (:args
(float :scs
(single-reg descriptor-reg
)
616 :load-if
(not (sc-is float single-stack
))))
617 (:results
(bits :scs
(signed-reg)
618 :load-if
(or (sc-is float descriptor-reg single-stack
)
619 (not (sc-is bits signed-stack
)))))
620 (:temporary
(:scs
(signed-stack)) stack-temp
)
621 (:arg-types single-float
)
622 (:result-types signed-num
)
623 (:translate single-float-bits
)
631 (inst stfs float
(current-nfp-tn vop
)
632 (* (tn-offset stack-temp
) n-word-bytes
))
633 (inst lwz bits
(current-nfp-tn vop
)
634 (* (tn-offset stack-temp
) n-word-bytes
)))
636 (inst lwz bits
(current-nfp-tn vop
)
637 (* (tn-offset float
) n-word-bytes
)))
639 (loadw bits float single-float-value-slot other-pointer-lowtag
))))
643 (inst stfs float
(current-nfp-tn vop
)
644 (* (tn-offset bits
) n-word-bytes
))))))))
646 (define-vop (double-float-high-bits)
647 (:args
(float :scs
(double-reg descriptor-reg
)
648 :load-if
(not (sc-is float double-stack
))))
649 (:results
(hi-bits :scs
(signed-reg)))
650 (:temporary
(:scs
(double-stack)) stack-temp
)
651 (:arg-types double-float
)
652 (:result-types signed-num
)
653 (:translate double-float-high-bits
)
659 (inst stfd float
(current-nfp-tn vop
)
660 (* (tn-offset stack-temp
) n-word-bytes
))
661 (inst lwz hi-bits
(current-nfp-tn vop
)
662 (* (tn-offset stack-temp
) n-word-bytes
)))
664 (inst lwz hi-bits
(current-nfp-tn vop
)
665 (* (tn-offset float
) n-word-bytes
)))
667 (loadw hi-bits float double-float-value-slot
668 other-pointer-lowtag
)))))
670 (define-vop (double-float-low-bits)
671 (:args
(float :scs
(double-reg descriptor-reg
)
672 :load-if
(not (sc-is float double-stack
))))
673 (:results
(lo-bits :scs
(unsigned-reg)))
674 (:temporary
(:scs
(double-stack)) stack-temp
)
675 (:arg-types double-float
)
676 (:result-types unsigned-num
)
677 (:translate double-float-low-bits
)
683 (inst stfd float
(current-nfp-tn vop
)
684 (* (tn-offset stack-temp
) n-word-bytes
))
685 (inst lwz lo-bits
(current-nfp-tn vop
)
686 (* (1+ (tn-offset stack-temp
)) n-word-bytes
)))
688 (inst lwz lo-bits
(current-nfp-tn vop
)
689 (* (1+ (tn-offset float
)) n-word-bytes
)))
691 (loadw lo-bits float
(1+ double-float-value-slot
)
692 other-pointer-lowtag
)))))
694 ;;;; Float mode hackery:
696 (sb!xc
:deftype float-modes
() '(unsigned-byte 32))
697 (defknown floating-point-modes
() float-modes
(flushable))
698 (defknown ((setf floating-point-modes
)) (float-modes)
701 (define-vop (floating-point-modes)
702 (:results
(res :scs
(unsigned-reg)))
703 (:result-types unsigned-num
)
704 (:translate floating-point-modes
)
707 (:temporary
(:sc double-stack
) temp
)
708 (:temporary
(:sc single-reg
) fp-temp
)
710 (let ((nfp (current-nfp-tn vop
)))
712 (inst stfd fp-temp nfp
(* n-word-bytes
(tn-offset temp
)))
713 (loadw res nfp
(1+ (tn-offset temp
))))))
715 (define-vop (set-floating-point-modes)
716 (:args
(new :scs
(unsigned-reg) :target res
))
717 (:results
(res :scs
(unsigned-reg)))
718 (:arg-types unsigned-num
)
719 (:result-types unsigned-num
)
720 (:translate
(setf floating-point-modes
))
722 (:temporary
(:sc double-stack
) temp
)
723 (:temporary
(:sc single-reg
) fp-temp
)
726 (let ((nfp (current-nfp-tn vop
)))
727 (storew new nfp
(1+ (tn-offset temp
)))
728 (inst lfd fp-temp nfp
(* n-word-bytes
(tn-offset temp
)))
729 (inst mtfsf
255 fp-temp
)
733 ;;;; Complex float VOPs
735 (define-vop (make-complex-single-float)
737 (:args
(real :scs
(single-reg) :target r
738 :load-if
(not (location= real r
)))
739 (imag :scs
(single-reg) :to
:save
))
740 (:arg-types single-float single-float
)
741 (:results
(r :scs
(complex-single-reg) :from
(:argument
0)
742 :load-if
(not (sc-is r complex-single-stack
))))
743 (:result-types complex-single-float
)
744 (:note
"inline complex single-float creation")
750 (let ((r-real (complex-single-reg-real-tn r
)))
751 (unless (location= real r-real
)
752 (inst fmr r-real real
)))
753 (let ((r-imag (complex-single-reg-imag-tn r
)))
754 (unless (location= imag r-imag
)
755 (inst fmr r-imag imag
))))
756 (complex-single-stack
757 (let ((nfp (current-nfp-tn vop
))
758 (offset (* (tn-offset r
) n-word-bytes
)))
759 (unless (location= real r
)
760 (inst stfs real nfp offset
))
761 (inst stfs imag nfp
(+ offset n-word-bytes
)))))))
763 (define-vop (make-complex-double-float)
765 (:args
(real :scs
(double-reg) :target r
766 :load-if
(not (location= real r
)))
767 (imag :scs
(double-reg) :to
:save
))
768 (:arg-types double-float double-float
)
769 (:results
(r :scs
(complex-double-reg) :from
(:argument
0)
770 :load-if
(not (sc-is r complex-double-stack
))))
771 (:result-types complex-double-float
)
772 (:note
"inline complex double-float creation")
778 (let ((r-real (complex-double-reg-real-tn r
)))
779 (unless (location= real r-real
)
780 (inst fmr r-real real
)))
781 (let ((r-imag (complex-double-reg-imag-tn r
)))
782 (unless (location= imag r-imag
)
783 (inst fmr r-imag imag
))))
784 (complex-double-stack
785 (let ((nfp (current-nfp-tn vop
))
786 (offset (* (tn-offset r
) n-word-bytes
)))
787 (unless (location= real r
)
788 (inst stfd real nfp offset
))
789 (inst stfd imag nfp
(+ offset
(* 2 n-word-bytes
))))))))
792 (define-vop (complex-single-float-value)
793 (:args
(x :scs
(complex-single-reg) :target r
794 :load-if
(not (sc-is x complex-single-stack
))))
795 (:arg-types complex-single-float
)
796 (:results
(r :scs
(single-reg)))
797 (:result-types single-float
)
804 (let ((value-tn (ecase slot
805 (:real
(complex-single-reg-real-tn x
))
806 (:imag
(complex-single-reg-imag-tn x
)))))
807 (unless (location= value-tn r
)
808 (inst fmr r value-tn
))))
809 (complex-single-stack
810 (inst lfs r
(current-nfp-tn vop
) (* (+ (ecase slot
(:real
0) (:imag
1))
814 (define-vop (realpart/complex-single-float complex-single-float-value
)
815 (:translate realpart
)
816 (:note
"complex single float realpart")
819 (define-vop (imagpart/complex-single-float complex-single-float-value
)
820 (:translate imagpart
)
821 (:note
"complex single float imagpart")
824 (define-vop (complex-double-float-value)
825 (:args
(x :scs
(complex-double-reg) :target r
826 :load-if
(not (sc-is x complex-double-stack
))))
827 (:arg-types complex-double-float
)
828 (:results
(r :scs
(double-reg)))
829 (:result-types double-float
)
836 (let ((value-tn (ecase slot
837 (:real
(complex-double-reg-real-tn x
))
838 (:imag
(complex-double-reg-imag-tn x
)))))
839 (unless (location= value-tn r
)
840 (inst fmr r value-tn
))))
841 (complex-double-stack
842 (inst lfd r
(current-nfp-tn vop
) (* (+ (ecase slot
(:real
0) (:imag
2))
846 (define-vop (realpart/complex-double-float complex-double-float-value
)
847 (:translate realpart
)
848 (:note
"complex double float realpart")
851 (define-vop (imagpart/complex-double-float complex-double-float-value
)
852 (:translate imagpart
)
853 (:note
"complex double float imagpart")