1 ;;;; floating point support for the Alpha
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.
14 ;;;; float move functions
16 (define-move-function (load-fp-zero 1) (vop x y)
17 ((fp-single-zero) (single-reg)
18 (fp-double-zero) (double-reg))
21 (define-move-function (load-single 1) (vop x y)
22 ((single-stack) (single-reg))
23 (inst lds y (* (tn-offset x) word-bytes) (current-nfp-tn vop)))
25 (define-move-function (store-single 1) (vop x y)
26 ((single-reg) (single-stack))
27 (inst sts x (* (tn-offset y) word-bytes) (current-nfp-tn vop)))
30 (define-move-function (load-double 2) (vop x y)
31 ((double-stack) (double-reg))
32 (let ((nfp (current-nfp-tn vop))
33 (offset (* (tn-offset x) word-bytes)))
34 (inst ldt y offset nfp)))
36 (define-move-function (store-double 2) (vop x y)
37 ((double-reg) (double-stack))
38 (let ((nfp (current-nfp-tn vop))
39 (offset (* (tn-offset y) word-bytes)))
40 (inst stt x offset nfp)))
44 (macrolet ((frob (vop sc)
49 :load-if (not (location= x y))))
50 (:results (y :scs (,sc)
51 :load-if (not (location= x y))))
54 (unless (location= y x)
56 (define-move-vop ,vop :move (,sc) (,sc)))))
57 (frob single-move single-reg)
58 (frob double-move double-reg))
61 (define-vop (move-from-float)
64 (:temporary (:scs (non-descriptor-reg)) ndescr)
65 (:variant-vars double-p size type data)
66 (:note "float to pointer coercion")
68 (with-fixed-allocation (y ndescr type size)
70 (inst stt x (- (* data word-bytes) other-pointer-type) y)
71 (inst sts x (- (* data word-bytes) other-pointer-type) y)))))
73 (macrolet ((frob (name sc &rest args)
75 (define-vop (,name move-from-float)
76 (:args (x :scs (,sc) :to :save))
77 (:results (y :scs (descriptor-reg)))
79 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
80 (frob move-from-single single-reg
81 nil single-float-size single-float-type single-float-value-slot)
82 (frob move-from-double double-reg
83 t double-float-size double-float-type double-float-value-slot))
85 (macrolet ((frob (name sc double-p value)
88 (:args (x :scs (descriptor-reg)))
89 (:results (y :scs (,sc)))
90 (:note "pointer to float coercion")
93 `((inst ldt y (- (* ,value word-bytes)
96 `((inst lds y (- (* ,value word-bytes)
99 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
100 (frob move-to-single single-reg nil single-float-value-slot)
101 (frob move-to-double double-reg t double-float-value-slot))
104 (macrolet ((frob (name sc stack-sc double-p)
107 (:args (x :scs (,sc) :target y)
109 :load-if (not (sc-is y ,sc))))
111 (:note "float argument move")
112 (:generator ,(if double-p 2 1)
115 (unless (location= x y)
118 (let ((offset (* (tn-offset y) word-bytes)))
120 '((inst stt x offset nfp))
121 '((inst sts x offset nfp))))))))
122 (define-move-vop ,name :move-argument
123 (,sc descriptor-reg) (,sc)))))
124 (frob move-single-float-argument single-reg single-stack nil)
125 (frob move-double-float-argument double-reg double-stack t))
127 ;;;; complex float move functions
129 (defun complex-single-reg-real-tn (x)
130 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
131 :offset (tn-offset x)))
132 (defun complex-single-reg-imag-tn (x)
133 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
134 :offset (1+ (tn-offset x))))
136 (defun complex-double-reg-real-tn (x)
137 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg )
138 :offset (tn-offset x)))
139 (defun complex-double-reg-imag-tn (x)
140 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg )
141 :offset (1+ (tn-offset x))))
144 (define-move-function (load-complex-single 2) (vop x y)
145 ((complex-single-stack) (complex-single-reg))
146 (let ((nfp (current-nfp-tn vop))
147 (offset (* (tn-offset x) sb!vm:word-bytes)))
148 (let ((real-tn (complex-single-reg-real-tn y)))
149 (inst lds real-tn offset nfp))
150 (let ((imag-tn (complex-single-reg-imag-tn y)))
151 (inst lds imag-tn (+ offset sb!vm:word-bytes) nfp))))
153 (define-move-function (store-complex-single 2) (vop x y)
154 ((complex-single-reg) (complex-single-stack))
155 (let ((nfp (current-nfp-tn vop))
156 (offset (* (tn-offset y) sb!vm:word-bytes)))
157 (let ((real-tn (complex-single-reg-real-tn x)))
158 (inst sts real-tn offset nfp))
159 (let ((imag-tn (complex-single-reg-imag-tn x)))
160 (inst sts imag-tn (+ offset sb!vm:word-bytes) nfp))))
163 (define-move-function (load-complex-double 4) (vop x y)
164 ((complex-double-stack) (complex-double-reg))
165 (let ((nfp (current-nfp-tn vop))
166 (offset (* (tn-offset x) sb!vm:word-bytes)))
167 (let ((real-tn (complex-double-reg-real-tn y)))
168 (inst ldt real-tn offset nfp))
169 (let ((imag-tn (complex-double-reg-imag-tn y)))
170 (inst ldt imag-tn (+ offset (* 2 sb!vm:word-bytes)) nfp))))
172 (define-move-function (store-complex-double 4) (vop x y)
173 ((complex-double-reg) (complex-double-stack))
174 (let ((nfp (current-nfp-tn vop))
175 (offset (* (tn-offset y) sb!vm:word-bytes)))
176 (let ((real-tn (complex-double-reg-real-tn x)))
177 (inst stt real-tn offset nfp))
178 (let ((imag-tn (complex-double-reg-imag-tn x)))
179 (inst stt imag-tn (+ offset (* 2 sb!vm:word-bytes)) nfp))))
182 ;;; complex float register to register moves.
184 (define-vop (complex-single-move)
185 (:args (x :scs (complex-single-reg) :target y
186 :load-if (not (location= x y))))
187 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
188 (:note "complex single float move")
190 (unless (location= x y)
191 ;; Note the complex-float-regs are aligned to every second
192 ;; float register so there is not need to worry about overlap.
193 (let ((x-real (complex-single-reg-real-tn x))
194 (y-real (complex-single-reg-real-tn y)))
195 (inst fmove x-real y-real))
196 (let ((x-imag (complex-single-reg-imag-tn x))
197 (y-imag (complex-single-reg-imag-tn y)))
198 (inst fmove x-imag y-imag)))))
200 (define-move-vop complex-single-move :move
201 (complex-single-reg) (complex-single-reg))
203 (define-vop (complex-double-move)
204 (:args (x :scs (complex-double-reg)
205 :target y :load-if (not (location= x y))))
206 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
207 (:note "complex double float move")
209 (unless (location= x y)
210 ;; Note the complex-float-regs are aligned to every second
211 ;; float register so there is not need to worry about overlap.
212 (let ((x-real (complex-double-reg-real-tn x))
213 (y-real (complex-double-reg-real-tn y)))
214 (inst fmove x-real y-real))
215 (let ((x-imag (complex-double-reg-imag-tn x))
216 (y-imag (complex-double-reg-imag-tn y)))
217 (inst fmove x-imag y-imag)))))
219 (define-move-vop complex-double-move :move
220 (complex-double-reg) (complex-double-reg))
223 ;;; Move from a complex float to a descriptor register allocating a
224 ;;; new complex float object in the process.
226 (define-vop (move-from-complex-single)
227 (:args (x :scs (complex-single-reg) :to :save))
228 (:results (y :scs (descriptor-reg)))
229 (:temporary (:scs (non-descriptor-reg)) ndescr)
230 (:note "complex single float to pointer coercion")
232 (with-fixed-allocation (y ndescr sb!vm:complex-single-float-type
233 sb!vm:complex-single-float-size)
234 (let ((real-tn (complex-single-reg-real-tn x)))
235 (inst sts real-tn (- (* sb!vm:complex-single-float-real-slot
237 sb!vm:other-pointer-type)
239 (let ((imag-tn (complex-single-reg-imag-tn x)))
240 (inst sts imag-tn (- (* sb!vm:complex-single-float-imag-slot
242 sb!vm:other-pointer-type)
245 (define-move-vop move-from-complex-single :move
246 (complex-single-reg) (descriptor-reg))
248 (define-vop (move-from-complex-double)
249 (:args (x :scs (complex-double-reg) :to :save))
250 (:results (y :scs (descriptor-reg)))
251 (:temporary (:scs (non-descriptor-reg)) ndescr)
252 (:note "complex double float to pointer coercion")
254 (with-fixed-allocation (y ndescr sb!vm:complex-double-float-type
255 sb!vm:complex-double-float-size)
256 (let ((real-tn (complex-double-reg-real-tn x)))
257 (inst stt real-tn (- (* sb!vm:complex-double-float-real-slot
259 sb!vm:other-pointer-type)
261 (let ((imag-tn (complex-double-reg-imag-tn x)))
262 (inst stt imag-tn (- (* sb!vm:complex-double-float-imag-slot
264 sb!vm:other-pointer-type)
267 (define-move-vop move-from-complex-double :move
268 (complex-double-reg) (descriptor-reg))
271 ;;; Move from a descriptor to a complex float register.
273 (define-vop (move-to-complex-single)
274 (:args (x :scs (descriptor-reg)))
275 (:results (y :scs (complex-single-reg)))
276 (:note "pointer to complex float coercion")
278 (let ((real-tn (complex-single-reg-real-tn y)))
279 (inst lds real-tn (- (* complex-single-float-real-slot sb!vm:word-bytes)
280 sb!vm:other-pointer-type)
282 (let ((imag-tn (complex-single-reg-imag-tn y)))
283 (inst lds imag-tn (- (* complex-single-float-imag-slot sb!vm:word-bytes)
284 sb!vm:other-pointer-type)
286 (define-move-vop move-to-complex-single :move
287 (descriptor-reg) (complex-single-reg))
289 (define-vop (move-to-complex-double)
290 (:args (x :scs (descriptor-reg)))
291 (:results (y :scs (complex-double-reg)))
292 (:note "pointer to complex float coercion")
294 (let ((real-tn (complex-double-reg-real-tn y)))
295 (inst ldt real-tn (- (* complex-double-float-real-slot sb!vm:word-bytes)
296 sb!vm:other-pointer-type)
298 (let ((imag-tn (complex-double-reg-imag-tn y)))
299 (inst ldt imag-tn (- (* complex-double-float-imag-slot sb!vm:word-bytes)
300 sb!vm:other-pointer-type)
302 (define-move-vop move-to-complex-double :move
303 (descriptor-reg) (complex-double-reg))
306 ;;; complex float move-argument vop
308 (define-vop (move-complex-single-float-argument)
309 (:args (x :scs (complex-single-reg) :target y)
310 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
312 (:note "complex single float argument move")
316 (unless (location= x y)
317 (let ((x-real (complex-single-reg-real-tn x))
318 (y-real (complex-single-reg-real-tn y)))
319 (inst fmove x-real y-real))
320 (let ((x-imag (complex-single-reg-imag-tn x))
321 (y-imag (complex-single-reg-imag-tn y)))
322 (inst fmove x-imag y-imag))))
323 (complex-single-stack
324 (let ((offset (* (tn-offset y) sb!vm:word-bytes)))
325 (let ((real-tn (complex-single-reg-real-tn x)))
326 (inst sts real-tn offset nfp))
327 (let ((imag-tn (complex-single-reg-imag-tn x)))
328 (inst sts imag-tn (+ offset word-bytes) nfp)))))))
329 (define-move-vop move-complex-single-float-argument :move-argument
330 (complex-single-reg descriptor-reg) (complex-single-reg))
332 (define-vop (move-complex-double-float-argument)
333 (:args (x :scs (complex-double-reg) :target y)
334 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
336 (:note "complex double float argument move")
340 (unless (location= x y)
341 (let ((x-real (complex-double-reg-real-tn x))
342 (y-real (complex-double-reg-real-tn y)))
343 (inst fmove x-real y-real))
344 (let ((x-imag (complex-double-reg-imag-tn x))
345 (y-imag (complex-double-reg-imag-tn y)))
346 (inst fmove x-imag y-imag))))
347 (complex-double-stack
348 (let ((offset (* (tn-offset y) sb!vm:word-bytes)))
349 (let ((real-tn (complex-double-reg-real-tn x)))
350 (inst stt real-tn offset nfp))
351 (let ((imag-tn (complex-double-reg-imag-tn x)))
352 (inst stt imag-tn (+ offset (* 2 word-bytes)) nfp)))))))
353 (define-move-vop move-complex-double-float-argument :move-argument
354 (complex-double-reg descriptor-reg) (complex-double-reg))
357 (define-move-vop move-argument :move-argument
358 (single-reg double-reg complex-single-reg complex-double-reg)
362 ;;;; float arithmetic VOPs
364 (define-vop (float-op)
368 (:note "inline float arithmetic")
370 (:save-p :compute-only))
372 ;;; We need to insure that ops that can cause traps do not clobber an
373 ;;; argument register with invalid results. This so the software trap
374 ;;; handler can re-execute the instruction and produce correct IEEE
375 ;;; result. The :from :load hopefully does that.
376 (macrolet ((frob (name sc ptype)
377 `(define-vop (,name float-op)
378 (:args (x :scs (,sc))
380 (:results (r :scs (,sc) :from :load))
381 (:arg-types ,ptype ,ptype)
382 (:result-types ,ptype))))
383 (frob single-float-op single-reg single-float)
384 (frob double-float-op double-reg double-float))
386 ;; This is resumption-safe with underflow traps enabled,
387 ;; with software handling and (notyet) dynamic rounding mode.
388 (macrolet ((frob (op sinst sname scost dinst dname dcost)
390 (define-vop (,sname single-float-op)
392 (:variant-cost ,scost)
395 (note-this-location vop :internal-error)
397 (define-vop (,dname double-float-op)
399 (:variant-cost ,dcost)
402 (note-this-location vop :internal-error)
404 ;; Not sure these cost number are right. +*- about same / is 4x
405 (frob + adds_su +/single-float 1 addt_su +/double-float 1)
406 (frob - subs_su -/single-float 1 subt_su -/double-float 1)
407 (frob * muls_su */single-float 1 mult_su */double-float 1)
408 (frob / divs_su //single-float 4 divt_su //double-float 4))
410 (macrolet ((frob (name inst translate sc type)
412 (:args (x :scs (,sc) :target y))
413 (:results (y :scs (,sc)))
414 (:translate ,translate)
417 (:result-types ,type)
418 (:note "inline float arithmetic")
420 (:save-p :compute-only)
422 (note-this-location vop :internal-error)
424 (frob abs/single-float fabs abs single-reg single-float)
425 (frob abs/double-float fabs abs double-reg double-float)
426 (frob %negate/single-float fneg %negate single-reg single-float)
427 (frob %negate/double-float fneg %negate double-reg double-float))
430 ;;;; float comparison
432 (define-vop (float-compare)
436 (:variant-vars eq complement)
437 (:temporary (:scs (single-reg)) temp)
439 (:note "inline float comparison")
441 (:save-p :compute-only)
443 (note-this-location vop :internal-error)
445 (inst cmpteq x y temp)
447 (inst cmptle x y temp)
448 (inst cmptlt x y temp)))
450 (if (if complement (not not-p) not-p)
451 (inst fbeq temp target)
452 (inst fbne temp target))))
454 (macrolet ((frob (name sc ptype)
455 `(define-vop (,name float-compare)
456 (:args (x :scs (,sc))
458 (:arg-types ,ptype ,ptype))))
459 (frob single-float-compare single-reg single-float)
460 (frob double-float-compare double-reg double-float))
462 (macrolet ((frob (translate complement sname dname eq)
464 (define-vop (,sname single-float-compare)
465 (:translate ,translate)
466 (:variant ,eq ,complement))
467 (define-vop (,dname double-float-compare)
468 (:translate ,translate)
469 (:variant ,eq ,complement)))))
470 (frob < nil </single-float </double-float nil)
471 (frob > t >/single-float >/double-float nil)
472 (frob = nil =/single-float =/double-float t))
475 ;;;; float conversion
478 ((frob (name translate inst ld-inst to-sc to-type &optional single)
479 (declare (ignorable single))
481 (:args (x :scs (signed-reg) :target temp
482 :load-if (not (sc-is x signed-stack))))
483 (:temporary (:scs (single-stack)) temp)
484 (:results (y :scs (,to-sc)))
485 (:arg-types signed-num)
486 (:result-types ,to-type)
488 (:note "inline float coercion")
489 (:translate ,translate)
491 (:save-p :compute-only)
497 (* (tn-offset temp) sb!vm:word-bytes)
498 (current-nfp-tn vop))
503 (* (tn-offset stack-tn) sb!vm:word-bytes)
504 (current-nfp-tn vop))
505 (note-this-location vop :internal-error)
508 (inst ,inst y y))))))
509 (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
510 (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
512 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
514 (:args (x :scs (,from-sc)))
515 (:results (y :scs (,to-sc)))
516 (:arg-types ,from-type)
517 (:result-types ,to-type)
519 (:note "inline float coercion")
520 (:translate ,translate)
522 (:save-p :compute-only)
524 (note-this-location vop :internal-error)
526 (frob %single-float/double-float %single-float cvtts
527 double-reg double-float single-reg single-float)
528 (frob %double-float/single-float %double-float fmove
529 single-reg single-float double-reg double-float))
532 ((frob (trans from-sc from-type inst &optional single)
533 (declare (ignorable single))
534 `(define-vop (,(symbolicate trans "/" from-type))
535 (:args (x :scs (,from-sc) :target temp))
536 (:temporary (:from (:argument 0) :sc single-reg) temp)
537 (:temporary (:scs (signed-stack)) stack-temp)
538 (:results (y :scs (signed-reg)
539 :load-if (not (sc-is y signed-stack))))
540 (:arg-types ,from-type)
541 (:result-types signed-num)
544 (:note "inline float truncate")
546 (:save-p :compute-only)
548 (note-this-location vop :internal-error)
553 (* (tn-offset y) sb!vm:word-bytes)
554 (current-nfp-tn vop)))
557 (* (tn-offset stack-temp)
559 (current-nfp-tn vop))
561 (* (tn-offset stack-temp) sb!vm:word-bytes)
562 (current-nfp-tn vop))))))))
563 (frob %unary-truncate single-reg single-float cvttq/c t)
564 (frob %unary-truncate double-reg double-float cvttq/c)
565 (frob %unary-round single-reg single-float cvttq t)
566 (frob %unary-round double-reg double-float cvttq))
568 (define-vop (make-single-float)
569 (:args (bits :scs (signed-reg) :target res
570 :load-if (not (sc-is bits signed-stack))))
571 (:results (res :scs (single-reg)
572 :load-if (not (sc-is res single-stack))))
573 (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
574 (:temporary (:scs (signed-stack)) stack-temp)
575 (:arg-types signed-num)
576 (:result-types single-float)
577 (:translate make-single-float)
586 (* (tn-offset stack-temp) sb!vm:word-bytes)
587 (current-nfp-tn vop))
589 (* (tn-offset stack-temp) sb!vm:word-bytes)
590 (current-nfp-tn vop)))
593 (* (tn-offset res) sb!vm:word-bytes)
594 (current-nfp-tn vop)))))
599 (* (tn-offset bits) sb!vm:word-bytes)
600 (current-nfp-tn vop)))
602 (unless (location= bits res)
604 (* (tn-offset bits) sb!vm:word-bytes)
605 (current-nfp-tn vop))
607 (* (tn-offset res) sb!vm:word-bytes)
608 (current-nfp-tn vop)))))))))
610 (define-vop (make-double-float)
611 (:args (hi-bits :scs (signed-reg))
612 (lo-bits :scs (unsigned-reg)))
613 (:results (res :scs (double-reg)
614 :load-if (not (sc-is res double-stack))))
615 (:temporary (:scs (double-stack)) temp)
616 (:arg-types signed-num unsigned-num)
617 (:result-types double-float)
618 (:translate make-double-float)
622 (let ((stack-tn (sc-case res
626 (* (1+ (tn-offset stack-tn)) sb!vm:word-bytes)
627 (current-nfp-tn vop))
629 (* (tn-offset stack-tn) sb!vm:word-bytes)
630 (current-nfp-tn vop)))
631 (when (sc-is res double-reg)
633 (* (tn-offset temp) sb!vm:word-bytes)
634 (current-nfp-tn vop)))))
636 (define-vop (single-float-bits)
637 (:args (float :scs (single-reg descriptor-reg)
638 :load-if (not (sc-is float single-stack))))
639 (:results (bits :scs (signed-reg)
640 :load-if (or (sc-is float descriptor-reg single-stack)
641 (not (sc-is bits signed-stack)))))
642 (:temporary (:scs (signed-stack)) stack-temp)
643 (:arg-types single-float)
644 (:result-types signed-num)
645 (:translate single-float-bits)
654 (* (tn-offset stack-temp) sb!vm:word-bytes)
655 (current-nfp-tn vop))
657 (* (tn-offset stack-temp) sb!vm:word-bytes)
658 (current-nfp-tn vop)))
661 (* (tn-offset float) sb!vm:word-bytes)
662 (current-nfp-tn vop)))
664 (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-type))))
669 (* (tn-offset bits) sb!vm:word-bytes)
670 (current-nfp-tn vop))))))))
672 (define-vop (double-float-high-bits)
673 (:args (float :scs (double-reg descriptor-reg)
674 :load-if (not (sc-is float double-stack))))
675 (:results (hi-bits :scs (signed-reg)))
676 (:temporary (:scs (double-stack)) stack-temp)
677 (:arg-types double-float)
678 (:result-types signed-num)
679 (:translate double-float-high-bits)
686 (* (tn-offset stack-temp) sb!vm:word-bytes)
687 (current-nfp-tn vop))
689 (* (1+ (tn-offset stack-temp)) sb!vm:word-bytes)
690 (current-nfp-tn vop)))
693 (* (1+ (tn-offset float)) sb!vm:word-bytes)
694 (current-nfp-tn vop)))
696 (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
697 sb!vm:other-pointer-type)))))
699 (define-vop (double-float-low-bits)
700 (:args (float :scs (double-reg descriptor-reg)
701 :load-if (not (sc-is float double-stack))))
702 (:results (lo-bits :scs (unsigned-reg)))
703 (:temporary (:scs (double-stack)) stack-temp)
704 (:arg-types double-float)
705 (:result-types unsigned-num)
706 (:translate double-float-low-bits)
713 (* (tn-offset stack-temp) sb!vm:word-bytes)
714 (current-nfp-tn vop))
716 (* (tn-offset stack-temp) sb!vm:word-bytes)
717 (current-nfp-tn vop)))
720 (* (tn-offset float) sb!vm:word-bytes)
721 (current-nfp-tn vop)))
723 (loadw lo-bits float sb!vm:double-float-value-slot
724 sb!vm:other-pointer-type)))
725 (inst mskll lo-bits 4 lo-bits)))
728 ;;;; float mode hackery
730 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
731 (defknown floating-point-modes () float-modes (flushable))
732 (defknown ((setf floating-point-modes)) (float-modes)
735 ;;; Modes bits are (byte 12 52) of fpcr. Grab and return in low bits.
736 (define-vop (floating-point-modes)
737 (:results (res :scs (unsigned-reg)))
738 (:result-types unsigned-num)
739 (:translate floating-point-modes)
742 (:temporary (:sc double-stack) temp)
743 (:temporary (:sc double-reg) temp1)
745 (let ((nfp (current-nfp-tn vop)))
747 (inst mf_fpcr temp1 temp1 temp1)
749 (inst stt temp1 (* word-bytes (tn-offset temp)) nfp)
750 (inst ldl res (* (1+ (tn-offset temp)) sb!vm:word-bytes) nfp)
751 (inst srl res 49 res))))
753 (define-vop (set-floating-point-modes)
754 (:args (new :scs (unsigned-reg) :target res))
755 (:results (res :scs (unsigned-reg)))
756 (:arg-types unsigned-num)
757 (:result-types unsigned-num)
758 (:translate (setf floating-point-modes))
760 (:temporary (:sc double-stack) temp)
761 (:temporary (:sc double-reg) temp1)
764 (let ((nfp (current-nfp-tn vop)))
765 (inst sll new 49 res)
766 (inst stl zero-tn (* (tn-offset temp) sb!vm:word-bytes) nfp)
767 (inst stl res (* (1+ (tn-offset temp)) sb!vm:word-bytes) nfp)
768 (inst ldt temp1 (* (tn-offset temp) sb!vm:word-bytes) nfp)
770 (inst mt_fpcr temp1 temp1 temp1)
775 ;;;; complex float VOPs
777 (define-vop (make-complex-single-float)
779 (:args (real :scs (single-reg) :target r)
780 (imag :scs (single-reg) :to :save))
781 (:arg-types single-float single-float)
782 (:results (r :scs (complex-single-reg) :from (:argument 0)
783 :load-if (not (sc-is r complex-single-stack))))
784 (:result-types complex-single-float)
785 (:note "inline complex single-float creation")
791 (let ((r-real (complex-single-reg-real-tn r)))
792 (unless (location= real r-real)
793 (inst fmove real r-real)))
794 (let ((r-imag (complex-single-reg-imag-tn r)))
795 (unless (location= imag r-imag)
796 (inst fmove imag r-imag))))
797 (complex-single-stack
798 (let ((nfp (current-nfp-tn vop))
799 (offset (* (tn-offset r) sb!vm:word-bytes)))
800 (inst sts real offset nfp)
801 (inst sts imag (+ offset sb!vm:word-bytes) nfp))))))
803 (define-vop (make-complex-double-float)
805 (:args (real :scs (double-reg) :target r)
806 (imag :scs (double-reg) :to :save))
807 (:arg-types double-float double-float)
808 (:results (r :scs (complex-double-reg) :from (:argument 0)
809 :load-if (not (sc-is r complex-double-stack))))
810 (:result-types complex-double-float)
811 (:note "inline complex double-float creation")
817 (let ((r-real (complex-double-reg-real-tn r)))
818 (unless (location= real r-real)
819 (inst fmove real r-real)))
820 (let ((r-imag (complex-double-reg-imag-tn r)))
821 (unless (location= imag r-imag)
822 (inst fmove imag r-imag))))
823 (complex-double-stack
824 (let ((nfp (current-nfp-tn vop))
825 (offset (* (tn-offset r) sb!vm:word-bytes)))
826 (inst stt real offset nfp)
827 (inst stt imag (+ offset (* 2 sb!vm:word-bytes)) nfp))))))
829 (define-vop (complex-single-float-value)
830 (:args (x :scs (complex-single-reg) :target r
831 :load-if (not (sc-is x complex-single-stack))))
832 (:arg-types complex-single-float)
833 (:results (r :scs (single-reg)))
834 (:result-types single-float)
841 (let ((value-tn (ecase slot
842 (:real (complex-single-reg-real-tn x))
843 (:imag (complex-single-reg-imag-tn x)))))
844 (unless (location= value-tn r)
845 (inst fmove value-tn r))))
846 (complex-single-stack
847 (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
849 (current-nfp-tn vop))))))
851 (define-vop (realpart/complex-single-float complex-single-float-value)
852 (:translate realpart)
853 (:note "complex single float realpart")
856 (define-vop (imagpart/complex-single-float complex-single-float-value)
857 (:translate imagpart)
858 (:note "complex single float imagpart")
861 (define-vop (complex-double-float-value)
862 (:args (x :scs (complex-double-reg) :target r
863 :load-if (not (sc-is x complex-double-stack))))
864 (:arg-types complex-double-float)
865 (:results (r :scs (double-reg)))
866 (:result-types double-float)
873 (let ((value-tn (ecase slot
874 (:real (complex-double-reg-real-tn x))
875 (:imag (complex-double-reg-imag-tn x)))))
876 (unless (location= value-tn r)
877 (inst fmove value-tn r))))
878 (complex-double-stack
879 (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
881 (current-nfp-tn vop))))))
883 (define-vop (realpart/complex-double-float complex-double-float-value)
884 (:translate realpart)
885 (:note "complex double float realpart")
888 (define-vop (imagpart/complex-double-float complex-double-float-value)
889 (:translate imagpart)
890 (:note "complex double float imagpart")