2 ;;; Written by Rob MacLachlan
3 ;;; Sparc conversion by William Lott.
10 (define-move-fun (load-single 1) (vop x y)
11 ((single-stack) (single-reg))
12 (inst lfs y (current-nfp-tn vop) (* (tn-offset x) sb!vm:n-word-bytes)))
14 (define-move-fun (store-single 1) (vop x y)
15 ((single-reg) (single-stack))
16 (inst stfs x (current-nfp-tn vop) (* (tn-offset y) sb!vm:n-word-bytes)))
19 (define-move-fun (load-double 2) (vop x y)
20 ((double-stack) (double-reg))
21 (let ((nfp (current-nfp-tn vop))
22 (offset (* (tn-offset x) sb!vm:n-word-bytes)))
23 (inst lfd y nfp offset)))
25 (define-move-fun (store-double 2) (vop x y)
26 ((double-reg) (double-stack))
27 (let ((nfp (current-nfp-tn vop))
28 (offset (* (tn-offset y) sb!vm:n-word-bytes)))
29 (inst stfd x nfp offset)))
35 (macrolet ((frob (vop sc)
40 :load-if (not (location= x y))))
41 (:results (y :scs (,sc)
42 :load-if (not (location= x y))))
45 (unless (location= y x)
47 (define-move-vop ,vop :move (,sc) (,sc)))))
48 (frob single-move single-reg)
49 (frob double-move double-reg))
52 (define-vop (move-from-float)
55 (:note "float to pointer coercion")
56 (:temporary (:scs (non-descriptor-reg)) ndescr)
57 (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
58 (:variant-vars double-p size type data)
60 (with-fixed-allocation (y pa-flag ndescr type size))
62 (inst stfd x y (- (* data sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag))
63 (inst stfs x y (- (* data sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
65 (macrolet ((frob (name sc &rest args)
67 (define-vop (,name move-from-float)
68 (:args (x :scs (,sc) :to :save))
69 (:results (y :scs (descriptor-reg)))
71 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
72 (frob move-from-single single-reg
73 nil sb!vm:single-float-size sb!vm:single-float-widetag sb!vm:single-float-value-slot)
74 (frob move-from-double double-reg
75 t sb!vm:double-float-size sb!vm:double-float-widetag sb!vm:double-float-value-slot))
77 (macrolet ((frob (name sc double-p value)
80 (:args (x :scs (descriptor-reg)))
81 (:results (y :scs (,sc)))
82 (:note "pointer to float coercion")
84 (inst ,(if double-p 'lfd 'lfs) y x
85 (- (* ,value sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag))))
86 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
87 (frob move-to-single single-reg nil sb!vm:single-float-value-slot)
88 (frob move-to-double double-reg t sb!vm:double-float-value-slot))
91 (macrolet ((frob (name sc stack-sc double-p)
94 (:args (x :scs (,sc) :target y)
96 :load-if (not (sc-is y ,sc))))
98 (:note "float arg move")
99 (:generator ,(if double-p 2 1)
102 (unless (location= x y)
105 (let ((offset (* (tn-offset y) sb!vm:n-word-bytes)))
106 (inst ,(if double-p 'stfd 'stfs) x nfp offset))))))
107 (define-move-vop ,name :move-arg
108 (,sc descriptor-reg) (,sc)))))
109 (frob move-single-float-arg single-reg single-stack nil)
110 (frob move-double-float-arg double-reg double-stack t))
114 ;;;; Complex float move functions
116 (defun complex-single-reg-real-tn (x)
117 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
118 :offset (tn-offset x)))
119 (defun complex-single-reg-imag-tn (x)
120 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
121 :offset (1+ (tn-offset x))))
123 (defun complex-double-reg-real-tn (x)
124 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
125 :offset (tn-offset x)))
126 (defun complex-double-reg-imag-tn (x)
127 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
128 :offset (+ (tn-offset x) 2)))
131 (define-move-fun (load-complex-single 2) (vop x y)
132 ((complex-single-stack) (complex-single-reg))
133 (let ((nfp (current-nfp-tn vop))
134 (offset (* (tn-offset x) sb!vm:n-word-bytes)))
135 (let ((real-tn (complex-single-reg-real-tn y)))
136 (inst lfs real-tn nfp offset))
137 (let ((imag-tn (complex-single-reg-imag-tn y)))
138 (inst lfs imag-tn nfp (+ offset sb!vm:n-word-bytes)))))
140 (define-move-fun (store-complex-single 2) (vop x y)
141 ((complex-single-reg) (complex-single-stack))
142 (let ((nfp (current-nfp-tn vop))
143 (offset (* (tn-offset y) sb!vm:n-word-bytes)))
144 (let ((real-tn (complex-single-reg-real-tn x)))
145 (inst stfs real-tn nfp offset))
146 (let ((imag-tn (complex-single-reg-imag-tn x)))
147 (inst stfs imag-tn nfp (+ offset sb!vm:n-word-bytes)))))
150 (define-move-fun (load-complex-double 4) (vop x y)
151 ((complex-double-stack) (complex-double-reg))
152 (let ((nfp (current-nfp-tn vop))
153 (offset (* (tn-offset x) sb!vm:n-word-bytes)))
154 (let ((real-tn (complex-double-reg-real-tn y)))
155 (inst lfd real-tn nfp offset))
156 (let ((imag-tn (complex-double-reg-imag-tn y)))
157 (inst lfd imag-tn nfp (+ offset (* 2 sb!vm:n-word-bytes))))))
159 (define-move-fun (store-complex-double 4) (vop x y)
160 ((complex-double-reg) (complex-double-stack))
161 (let ((nfp (current-nfp-tn vop))
162 (offset (* (tn-offset y) sb!vm:n-word-bytes)))
163 (let ((real-tn (complex-double-reg-real-tn x)))
164 (inst stfd real-tn nfp offset))
165 (let ((imag-tn (complex-double-reg-imag-tn x)))
166 (inst stfd imag-tn nfp (+ offset (* 2 sb!vm:n-word-bytes))))))
170 ;;; Complex float register to register moves.
172 (define-vop (complex-single-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 (:note "complex single float move")
178 (unless (location= x y)
179 ;; Note the complex-float-regs are aligned to every second
180 ;; float register so there is not need to worry about overlap.
181 (let ((x-real (complex-single-reg-real-tn x))
182 (y-real (complex-single-reg-real-tn y)))
183 (inst fmr y-real x-real))
184 (let ((x-imag (complex-single-reg-imag-tn x))
185 (y-imag (complex-single-reg-imag-tn y)))
186 (inst fmr y-imag x-imag)))))
188 (define-move-vop complex-single-move :move
189 (complex-single-reg) (complex-single-reg))
191 (define-vop (complex-double-move)
192 (:args (x :scs (complex-double-reg)
193 :target y :load-if (not (location= x y))))
194 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
195 (:note "complex double float move")
197 (unless (location= x y)
198 ;; Note the complex-float-regs are aligned to every second
199 ;; float register so there is not need to worry about overlap.
200 (let ((x-real (complex-double-reg-real-tn x))
201 (y-real (complex-double-reg-real-tn y)))
202 (inst fmr y-real x-real))
203 (let ((x-imag (complex-double-reg-imag-tn x))
204 (y-imag (complex-double-reg-imag-tn y)))
205 (inst fmr y-imag x-imag)))))
207 (define-move-vop complex-double-move :move
208 (complex-double-reg) (complex-double-reg))
212 ;;; Move from a complex float to a descriptor register allocating a
213 ;;; new complex float object in the process.
215 (define-vop (move-from-complex-single)
216 (:args (x :scs (complex-single-reg) :to :save))
217 (:results (y :scs (descriptor-reg)))
218 (:temporary (:scs (non-descriptor-reg)) ndescr)
219 (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
220 (:note "complex single float to pointer coercion")
222 (with-fixed-allocation (y pa-flag ndescr sb!vm:complex-single-float-widetag
223 sb!vm:complex-single-float-size))
224 (let ((real-tn (complex-single-reg-real-tn x)))
225 (inst stfs real-tn y (- (* sb!vm:complex-single-float-real-slot
227 sb!vm:other-pointer-lowtag)))
228 (let ((imag-tn (complex-single-reg-imag-tn x)))
229 (inst stfs imag-tn y (- (* sb!vm:complex-single-float-imag-slot
231 sb!vm:other-pointer-lowtag)))))
233 (define-move-vop move-from-complex-single :move
234 (complex-single-reg) (descriptor-reg))
236 (define-vop (move-from-complex-double)
237 (:args (x :scs (complex-double-reg) :to :save))
238 (:results (y :scs (descriptor-reg)))
239 (:temporary (:scs (non-descriptor-reg)) ndescr)
240 (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
241 (:note "complex double float to pointer coercion")
243 (with-fixed-allocation (y pa-flag ndescr sb!vm:complex-double-float-widetag
244 sb!vm:complex-double-float-size))
245 (let ((real-tn (complex-double-reg-real-tn x)))
246 (inst stfd real-tn y (- (* sb!vm:complex-double-float-real-slot
248 sb!vm:other-pointer-lowtag)))
249 (let ((imag-tn (complex-double-reg-imag-tn x)))
250 (inst stfd imag-tn y (- (* sb!vm:complex-double-float-imag-slot
252 sb!vm:other-pointer-lowtag)))))
254 (define-move-vop move-from-complex-double :move
255 (complex-double-reg) (descriptor-reg))
259 ;;; Move from a descriptor to a complex float register
261 (define-vop (move-to-complex-single)
262 (:args (x :scs (descriptor-reg)))
263 (:results (y :scs (complex-single-reg)))
264 (:note "pointer to complex float coercion")
266 (let ((real-tn (complex-single-reg-real-tn y)))
267 (inst lfs real-tn x (- (* complex-single-float-real-slot n-word-bytes)
268 other-pointer-lowtag)))
269 (let ((imag-tn (complex-single-reg-imag-tn y)))
270 (inst lfs imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
271 other-pointer-lowtag)))))
272 (define-move-vop move-to-complex-single :move
273 (descriptor-reg) (complex-single-reg))
275 (define-vop (move-to-complex-double)
276 (:args (x :scs (descriptor-reg)))
277 (:results (y :scs (complex-double-reg)))
278 (:note "pointer to complex float coercion")
280 (let ((real-tn (complex-double-reg-real-tn y)))
281 (inst lfd real-tn x (- (* complex-double-float-real-slot n-word-bytes)
282 other-pointer-lowtag)))
283 (let ((imag-tn (complex-double-reg-imag-tn y)))
284 (inst lfd imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
285 other-pointer-lowtag)))))
286 (define-move-vop move-to-complex-double :move
287 (descriptor-reg) (complex-double-reg))
291 ;;; Complex float move-arg vop
293 (define-vop (move-complex-single-float-arg)
294 (:args (x :scs (complex-single-reg) :target y)
295 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
297 (:note "complex single-float arg move")
301 (unless (location= x y)
302 (let ((x-real (complex-single-reg-real-tn x))
303 (y-real (complex-single-reg-real-tn y)))
304 (inst fmr y-real x-real))
305 (let ((x-imag (complex-single-reg-imag-tn x))
306 (y-imag (complex-single-reg-imag-tn y)))
307 (inst fmr y-imag x-imag))))
308 (complex-single-stack
309 (let ((offset (* (tn-offset y) n-word-bytes)))
310 (let ((real-tn (complex-single-reg-real-tn x)))
311 (inst stfs real-tn nfp offset))
312 (let ((imag-tn (complex-single-reg-imag-tn x)))
313 (inst stfs imag-tn nfp (+ offset n-word-bytes))))))))
314 (define-move-vop move-complex-single-float-arg :move-arg
315 (complex-single-reg descriptor-reg) (complex-single-reg))
317 (define-vop (move-complex-double-float-arg)
318 (:args (x :scs (complex-double-reg) :target y)
319 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
321 (:note "complex double-float arg move")
325 (unless (location= x y)
326 (let ((x-real (complex-double-reg-real-tn x))
327 (y-real (complex-double-reg-real-tn y)))
328 (inst fmr y-real x-real))
329 (let ((x-imag (complex-double-reg-imag-tn x))
330 (y-imag (complex-double-reg-imag-tn y)))
331 (inst fmr y-imag x-imag))))
332 (complex-double-stack
333 (let ((offset (* (tn-offset y) n-word-bytes)))
334 (let ((real-tn (complex-double-reg-real-tn x)))
335 (inst stfd real-tn nfp offset))
336 (let ((imag-tn (complex-double-reg-imag-tn x)))
337 (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
338 (define-move-vop move-complex-double-float-arg :move-arg
339 (complex-double-reg descriptor-reg) (complex-double-reg))
342 (define-move-vop move-arg :move-arg
343 (single-reg double-reg complex-single-reg complex-double-reg)
347 ;;;; Arithmetic VOPs:
349 (define-vop (float-op)
353 (:note "inline float arithmetic")
355 (:save-p :compute-only))
357 (macrolet ((frob (name sc ptype)
358 `(define-vop (,name float-op)
359 (:args (x :scs (,sc))
361 (:results (r :scs (,sc)))
362 (:arg-types ,ptype ,ptype)
363 (:result-types ,ptype))))
364 (frob single-float-op single-reg single-float)
365 (frob double-float-op double-reg double-float))
367 (macrolet ((frob (op sinst sname scost dinst dname dcost)
369 (define-vop (,sname single-float-op)
372 (inst ,sinst r x y)))
373 (define-vop (,dname double-float-op)
376 (inst ,dinst r x y))))))
377 (frob + fadds +/single-float 2 fadd +/double-float 2)
378 (frob - fsubs -/single-float 2 fsub -/double-float 2)
379 (frob * fmuls */single-float 4 fmul */double-float 5)
380 (frob / fdivs //single-float 12 fdiv //double-float 19))
382 (macrolet ((frob (name inst translate sc type)
384 (:args (x :scs (,sc)))
385 (:results (y :scs (,sc)))
386 (:translate ,translate)
389 (:result-types ,type)
390 (:note "inline float arithmetic")
392 (:save-p :compute-only)
394 (note-this-location vop :internal-error)
396 (frob abs/single-float fabs abs single-reg single-float)
397 (frob abs/double-float fabs abs double-reg double-float)
398 (frob %negate/single-float fneg %negate single-reg single-float)
399 (frob %negate/double-float fneg %negate double-reg double-float))
404 (define-vop (float-compare)
408 (:variant-vars format yep nope)
410 (:note "inline float comparison")
412 (:save-p :compute-only)
414 (note-this-location vop :internal-error)
417 (inst fcmpo :cr1 x y)))
418 (inst b? :cr1 (if not-p nope yep) target)))
420 (macrolet ((frob (name sc ptype)
421 `(define-vop (,name float-compare)
422 (:args (x :scs (,sc))
424 (:arg-types ,ptype ,ptype))))
425 (frob single-float-compare single-reg single-float)
426 (frob double-float-compare double-reg double-float))
428 (macrolet ((frob (translate yep nope sname dname)
430 (define-vop (,sname single-float-compare)
431 (:translate ,translate)
432 (:variant :single ,yep ,nope))
433 (define-vop (,dname double-float-compare)
434 (:translate ,translate)
435 (:variant :double ,yep ,nope)))))
436 (frob < :lt :ge </single-float </double-float)
437 (frob > :gt :le >/single-float >/double-float)
438 (frob = :eq :ne eql/single-float eql/double-float))
443 (macrolet ((frob (name translate inst to-sc to-type)
445 (:args (x :scs (signed-reg)))
446 (:temporary (:scs (double-stack)) temp)
447 (:temporary (:scs (double-reg)) fmagic)
448 (:temporary (:scs (signed-reg)) rtemp)
449 (:results (y :scs (,to-sc)))
450 (:arg-types signed-num)
451 (:result-types ,to-type)
453 (:note "inline float coercion")
454 (:translate ,translate)
456 (:save-p :compute-only)
458 (let* ((stack-offset (* (tn-offset temp) sb!vm:n-word-bytes))
459 (nfp-tn (current-nfp-tn vop))
460 (temp-offset-high (* stack-offset sb!vm:n-word-bytes))
461 (temp-offset-low (* (1+ stack-offset) sb!vm:n-word-bytes)))
462 (inst lis rtemp #x4330) ; High word of magic constant
463 (inst stw rtemp nfp-tn temp-offset-high)
464 (inst lis rtemp #x8000)
465 (inst stw rtemp nfp-tn temp-offset-low)
466 (inst lfd fmagic nfp-tn temp-offset-high)
467 (inst xor rtemp rtemp x) ; invert sign bit of x : rtemp had #x80000000
468 (inst stw rtemp nfp-tn temp-offset-low)
469 (inst lfd y nfp-tn temp-offset-high)
470 (note-this-location vop :internal-error)
471 (inst ,inst y y fmagic))))))
472 (frob %single-float/signed %single-float fsubs single-reg single-float)
473 (frob %double-float/signed %double-float fsub double-reg double-float))
475 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
477 (:args (x :scs (,from-sc)))
478 (:results (y :scs (,to-sc)))
479 (:arg-types ,from-type)
480 (:result-types ,to-type)
482 (:note "inline float coercion")
483 (:translate ,translate)
485 (:save-p :compute-only)
487 (note-this-location vop :internal-error)
489 (frob %single-float/double-float %single-float frsp
490 double-reg double-float single-reg single-float)
491 (frob %double-float/single-float %double-float fmr
492 single-reg single-float double-reg double-float))
494 (macrolet ((frob (trans from-sc from-type inst)
495 `(define-vop (,(symbolicate trans "/" from-type))
496 (:args (x :scs (,from-sc) :target temp))
497 (:temporary (:from (:argument 0) :sc single-reg) temp)
498 (:temporary (:scs (double-stack)) stack-temp)
499 (:results (y :scs (signed-reg)
500 :load-if (not (sc-is y signed-stack))))
501 (:arg-types ,from-type)
502 (:result-types signed-num)
505 (:note "inline float truncate")
507 (:save-p :compute-only)
509 (note-this-location vop :internal-error)
513 (inst stfd temp (current-nfp-tn vop)
514 (* (tn-offset y) sb!vm:n-word-bytes)))
516 (inst stfd temp (current-nfp-tn vop)
517 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
518 (inst lwz y (current-nfp-tn vop)
519 (+ 4 (* (tn-offset stack-temp) sb!vm: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))
527 (define-vop (make-single-float)
528 (:args (bits :scs (signed-reg) :target res
529 :load-if (not (sc-is bits signed-stack))))
530 (:results (res :scs (single-reg)
531 :load-if (not (sc-is res single-stack))))
532 (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
533 (:temporary (:scs (signed-stack)) stack-temp)
534 (:arg-types signed-num)
535 (:result-types single-float)
536 (:translate make-single-float)
544 (inst stw bits (current-nfp-tn vop)
545 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
546 (inst lfs res (current-nfp-tn vop)
547 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
549 (inst stw bits (current-nfp-tn vop)
550 (* (tn-offset res) sb!vm:n-word-bytes)))))
554 (inst lfs res (current-nfp-tn vop)
555 (* (tn-offset bits) sb!vm:n-word-bytes)))
557 (unless (location= bits res)
558 (inst lwz temp (current-nfp-tn vop)
559 (* (tn-offset bits) sb!vm:n-word-bytes))
560 (inst stw temp (current-nfp-tn vop)
561 (* (tn-offset res) sb!vm:n-word-bytes)))))))))
563 (define-vop (make-double-float)
564 (:args (hi-bits :scs (signed-reg))
565 (lo-bits :scs (unsigned-reg)))
566 (:results (res :scs (double-reg)
567 :load-if (not (sc-is res double-stack))))
568 (:temporary (:scs (double-stack)) temp)
569 (:arg-types signed-num unsigned-num)
570 (:result-types double-float)
571 (:translate make-double-float)
575 (let ((stack-tn (sc-case res
578 (inst stw hi-bits (current-nfp-tn vop)
579 (* (tn-offset stack-tn) sb!vm:n-word-bytes))
580 (inst stw lo-bits (current-nfp-tn vop)
581 (* (1+ (tn-offset stack-tn)) sb!vm:n-word-bytes)))
582 (when (sc-is res double-reg)
583 (inst lfd res (current-nfp-tn vop)
584 (* (tn-offset temp) sb!vm:n-word-bytes)))))
586 (define-vop (single-float-bits)
587 (:args (float :scs (single-reg descriptor-reg)
588 :load-if (not (sc-is float single-stack))))
589 (:results (bits :scs (signed-reg)
590 :load-if (or (sc-is float descriptor-reg single-stack)
591 (not (sc-is bits signed-stack)))))
592 (:temporary (:scs (signed-stack)) stack-temp)
593 (:arg-types single-float)
594 (:result-types signed-num)
595 (:translate single-float-bits)
603 (inst stfs float (current-nfp-tn vop)
604 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
605 (inst lwz bits (current-nfp-tn vop)
606 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
608 (inst lwz bits (current-nfp-tn vop)
609 (* (tn-offset float) sb!vm:n-word-bytes)))
611 (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-lowtag))))
615 (inst stfs float (current-nfp-tn vop)
616 (* (tn-offset bits) sb!vm:n-word-bytes))))))))
618 (define-vop (double-float-high-bits)
619 (:args (float :scs (double-reg descriptor-reg)
620 :load-if (not (sc-is float double-stack))))
621 (:results (hi-bits :scs (signed-reg)
622 :load-if (or (sc-is float descriptor-reg double-stack)
623 (not (sc-is hi-bits signed-stack)))))
624 (:temporary (:scs (signed-stack)) stack-temp)
625 (:arg-types double-float)
626 (:result-types signed-num)
627 (:translate double-float-high-bits)
635 (inst stfd float (current-nfp-tn vop)
636 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
637 (inst lwz hi-bits (current-nfp-tn vop)
638 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
640 (inst lwz hi-bits (current-nfp-tn vop)
641 (* (tn-offset float) sb!vm:n-word-bytes)))
643 (loadw hi-bits float sb!vm:double-float-value-slot
644 sb!vm:other-pointer-lowtag))))
648 (inst stfd float (current-nfp-tn vop)
649 (* (tn-offset hi-bits) sb!vm:n-word-bytes))))))))
651 (define-vop (double-float-low-bits)
652 (:args (float :scs (double-reg descriptor-reg)
653 :load-if (not (sc-is float double-stack))))
654 (:results (lo-bits :scs (unsigned-reg)
655 :load-if (or (sc-is float descriptor-reg double-stack)
656 (not (sc-is lo-bits unsigned-stack)))))
657 (:temporary (:scs (unsigned-stack)) stack-temp)
658 (:arg-types double-float)
659 (:result-types unsigned-num)
660 (:translate double-float-low-bits)
668 (inst stfd float (current-nfp-tn vop)
669 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
670 (inst lwz lo-bits (current-nfp-tn vop)
671 (* (1+ (tn-offset stack-temp)) sb!vm:n-word-bytes)))
673 (inst lwz lo-bits (current-nfp-tn vop)
674 (* (1+ (tn-offset float)) sb!vm:n-word-bytes)))
676 (loadw lo-bits float (1+ sb!vm:double-float-value-slot)
677 sb!vm:other-pointer-lowtag))))
681 (inst stfd float (current-nfp-tn vop)
682 (* (tn-offset lo-bits) sb!vm:n-word-bytes))))))))
685 ;;;; Float mode hackery:
687 (sb!xc:deftype float-modes () '(unsigned-byte 32))
688 (defknown floating-point-modes () float-modes (flushable))
689 (defknown ((setf floating-point-modes)) (float-modes)
692 (define-vop (floating-point-modes)
693 (:results (res :scs (unsigned-reg)))
694 (:result-types unsigned-num)
695 (:translate floating-point-modes)
698 (:temporary (:sc double-stack) temp)
699 (:temporary (:sc single-reg) fp-temp)
701 (let ((nfp (current-nfp-tn vop)))
703 (inst stfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
704 (loadw res nfp (1+ (tn-offset temp))))))
706 (define-vop (set-floating-point-modes)
707 (:args (new :scs (unsigned-reg) :target res))
708 (:results (res :scs (unsigned-reg)))
709 (:arg-types unsigned-num)
710 (:result-types unsigned-num)
711 (:translate (setf floating-point-modes))
713 (:temporary (:sc double-stack) temp)
714 (:temporary (:sc single-reg) fp-temp)
717 (let ((nfp (current-nfp-tn vop)))
718 (storew new nfp (1+ (tn-offset temp)))
719 (inst lfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
720 (inst mtfsf 255 fp-temp)
724 ;;;; Complex float VOPs
726 (define-vop (make-complex-single-float)
728 (:args (real :scs (single-reg) :target r
729 :load-if (not (location= real r)))
730 (imag :scs (single-reg) :to :save))
731 (:arg-types single-float single-float)
732 (:results (r :scs (complex-single-reg) :from (:argument 0)
733 :load-if (not (sc-is r complex-single-stack))))
734 (:result-types complex-single-float)
735 (:note "inline complex single-float creation")
741 (let ((r-real (complex-single-reg-real-tn r)))
742 (unless (location= real r-real)
743 (inst fmr r-real real)))
744 (let ((r-imag (complex-single-reg-imag-tn r)))
745 (unless (location= imag r-imag)
746 (inst fmr r-imag imag))))
747 (complex-single-stack
748 (let ((nfp (current-nfp-tn vop))
749 (offset (* (tn-offset r) sb!vm:n-word-bytes)))
750 (unless (location= real r)
751 (inst stfs real nfp offset))
752 (inst stfs imag nfp (+ offset sb!vm:n-word-bytes)))))))
754 (define-vop (make-complex-double-float)
756 (:args (real :scs (double-reg) :target r
757 :load-if (not (location= real r)))
758 (imag :scs (double-reg) :to :save))
759 (:arg-types double-float double-float)
760 (:results (r :scs (complex-double-reg) :from (:argument 0)
761 :load-if (not (sc-is r complex-double-stack))))
762 (:result-types complex-double-float)
763 (:note "inline complex double-float creation")
769 (let ((r-real (complex-double-reg-real-tn r)))
770 (unless (location= real r-real)
771 (inst fmr r-real real)))
772 (let ((r-imag (complex-double-reg-imag-tn r)))
773 (unless (location= imag r-imag)
774 (inst fmr r-imag imag))))
775 (complex-double-stack
776 (let ((nfp (current-nfp-tn vop))
777 (offset (* (tn-offset r) sb!vm:n-word-bytes)))
778 (unless (location= real r)
779 (inst stfd real nfp offset))
780 (inst stfd imag nfp (+ offset (* 2 sb!vm:n-word-bytes))))))))
783 (define-vop (complex-single-float-value)
784 (:args (x :scs (complex-single-reg) :target r
785 :load-if (not (sc-is x complex-single-stack))))
786 (:arg-types complex-single-float)
787 (:results (r :scs (single-reg)))
788 (:result-types single-float)
795 (let ((value-tn (ecase slot
796 (:real (complex-single-reg-real-tn x))
797 (:imag (complex-single-reg-imag-tn x)))))
798 (unless (location= value-tn r)
799 (inst fmr r value-tn))))
800 (complex-single-stack
801 (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
803 sb!vm:n-word-bytes))))))
805 (define-vop (realpart/complex-single-float complex-single-float-value)
806 (:translate realpart)
807 (:note "complex single float realpart")
810 (define-vop (imagpart/complex-single-float complex-single-float-value)
811 (:translate imagpart)
812 (:note "complex single float imagpart")
815 (define-vop (complex-double-float-value)
816 (:args (x :scs (complex-double-reg) :target r
817 :load-if (not (sc-is x complex-double-stack))))
818 (:arg-types complex-double-float)
819 (:results (r :scs (double-reg)))
820 (:result-types double-float)
827 (let ((value-tn (ecase slot
828 (:real (complex-double-reg-real-tn x))
829 (:imag (complex-double-reg-imag-tn x)))))
830 (unless (location= value-tn r)
831 (inst fmr r value-tn))))
832 (complex-double-stack
833 (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
835 sb!vm:n-word-bytes))))))
837 (define-vop (realpart/complex-double-float complex-double-float-value)
838 (:translate realpart)
839 (:note "complex double float realpart")
842 (define-vop (imagpart/complex-double-float complex-double-float-value)
843 (:translate imagpart)
844 (:note "complex double float imagpart")