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) n-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) n-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) n-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) n-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 n-word-bytes) other-pointer-lowtag) y)
71 (inst sts x (- (* data n-word-bytes) other-pointer-lowtag) 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-widetag single-float-value-slot)
82 (frob move-from-double double-reg
83 t double-float-size double-float-widetag 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 n-word-bytes)
96 `((inst lds y (- (* ,value n-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) n-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) n-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 n-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) n-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 n-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) n-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 n-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) n-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 n-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 complex-single-float-widetag
233 complex-single-float-size)
234 (let ((real-tn (complex-single-reg-real-tn x)))
235 (inst sts real-tn (- (* complex-single-float-real-slot
237 other-pointer-lowtag)
239 (let ((imag-tn (complex-single-reg-imag-tn x)))
240 (inst sts imag-tn (- (* complex-single-float-imag-slot
242 other-pointer-lowtag)
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 complex-double-float-widetag
255 complex-double-float-size)
256 (let ((real-tn (complex-double-reg-real-tn x)))
257 (inst stt real-tn (- (* complex-double-float-real-slot
259 other-pointer-lowtag)
261 (let ((imag-tn (complex-double-reg-imag-tn x)))
262 (inst stt imag-tn (- (* complex-double-float-imag-slot
264 other-pointer-lowtag)
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
281 other-pointer-lowtag)
283 (let ((imag-tn (complex-single-reg-imag-tn y)))
284 (inst lds imag-tn (- (* complex-single-float-imag-slot
286 other-pointer-lowtag)
288 (define-move-vop move-to-complex-single :move
289 (descriptor-reg) (complex-single-reg))
291 (define-vop (move-to-complex-double)
292 (:args (x :scs (descriptor-reg)))
293 (:results (y :scs (complex-double-reg)))
294 (:note "pointer to complex float coercion")
296 (let ((real-tn (complex-double-reg-real-tn y)))
297 (inst ldt real-tn (- (* complex-double-float-real-slot
299 other-pointer-lowtag)
301 (let ((imag-tn (complex-double-reg-imag-tn y)))
302 (inst ldt imag-tn (- (* complex-double-float-imag-slot
304 other-pointer-lowtag)
306 (define-move-vop move-to-complex-double :move
307 (descriptor-reg) (complex-double-reg))
310 ;;; complex float move-argument vop
312 (define-vop (move-complex-single-float-argument)
313 (:args (x :scs (complex-single-reg) :target y)
314 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
316 (:note "complex single float argument move")
320 (unless (location= x y)
321 (let ((x-real (complex-single-reg-real-tn x))
322 (y-real (complex-single-reg-real-tn y)))
323 (inst fmove x-real y-real))
324 (let ((x-imag (complex-single-reg-imag-tn x))
325 (y-imag (complex-single-reg-imag-tn y)))
326 (inst fmove x-imag y-imag))))
327 (complex-single-stack
328 (let ((offset (* (tn-offset y) n-word-bytes)))
329 (let ((real-tn (complex-single-reg-real-tn x)))
330 (inst sts real-tn offset nfp))
331 (let ((imag-tn (complex-single-reg-imag-tn x)))
332 (inst sts imag-tn (+ offset n-word-bytes) nfp)))))))
333 (define-move-vop move-complex-single-float-argument :move-argument
334 (complex-single-reg descriptor-reg) (complex-single-reg))
336 (define-vop (move-complex-double-float-argument)
337 (:args (x :scs (complex-double-reg) :target y)
338 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
340 (:note "complex double float argument move")
344 (unless (location= x y)
345 (let ((x-real (complex-double-reg-real-tn x))
346 (y-real (complex-double-reg-real-tn y)))
347 (inst fmove x-real y-real))
348 (let ((x-imag (complex-double-reg-imag-tn x))
349 (y-imag (complex-double-reg-imag-tn y)))
350 (inst fmove x-imag y-imag))))
351 (complex-double-stack
352 (let ((offset (* (tn-offset y) n-word-bytes)))
353 (let ((real-tn (complex-double-reg-real-tn x)))
354 (inst stt real-tn offset nfp))
355 (let ((imag-tn (complex-double-reg-imag-tn x)))
356 (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
357 (define-move-vop move-complex-double-float-argument :move-argument
358 (complex-double-reg descriptor-reg) (complex-double-reg))
361 (define-move-vop move-argument :move-argument
362 (single-reg double-reg complex-single-reg complex-double-reg)
366 ;;;; float arithmetic VOPs
368 (define-vop (float-op)
372 (:note "inline float arithmetic")
374 (:save-p :compute-only))
376 ;;; We need to insure that ops that can cause traps do not clobber an
377 ;;; argument register with invalid results. This so the software trap
378 ;;; handler can re-execute the instruction and produce correct IEEE
379 ;;; result. The :from :load hopefully does that.
380 (macrolet ((frob (name sc ptype)
381 `(define-vop (,name float-op)
382 (:args (x :scs (,sc))
384 (:results (r :scs (,sc) :from :load))
385 (:arg-types ,ptype ,ptype)
386 (:result-types ,ptype))))
387 (frob single-float-op single-reg single-float)
388 (frob double-float-op double-reg double-float))
390 ;; This is resumption-safe with underflow traps enabled,
391 ;; with software handling and (notyet) dynamic rounding mode.
392 (macrolet ((frob (op sinst sname scost dinst dname dcost)
394 (define-vop (,sname single-float-op)
396 (:variant-cost ,scost)
399 (note-this-location vop :internal-error)
401 (define-vop (,dname double-float-op)
403 (:variant-cost ,dcost)
406 (note-this-location vop :internal-error)
408 ;; Not sure these cost number are right. +*- about same / is 4x
409 (frob + adds_su +/single-float 1 addt_su +/double-float 1)
410 (frob - subs_su -/single-float 1 subt_su -/double-float 1)
411 (frob * muls_su */single-float 1 mult_su */double-float 1)
412 (frob / divs_su //single-float 4 divt_su //double-float 4))
414 (macrolet ((frob (name inst translate sc type)
416 (:args (x :scs (,sc) :target y))
417 (:results (y :scs (,sc)))
418 (:translate ,translate)
421 (:result-types ,type)
422 (:note "inline float arithmetic")
424 (:save-p :compute-only)
426 (note-this-location vop :internal-error)
428 (frob abs/single-float fabs abs single-reg single-float)
429 (frob abs/double-float fabs abs double-reg double-float)
430 (frob %negate/single-float fneg %negate single-reg single-float)
431 (frob %negate/double-float fneg %negate double-reg double-float))
434 ;;;; float comparison
436 (define-vop (float-compare)
440 (:variant-vars eq complement)
441 (:temporary (:scs (single-reg)) temp)
443 (:note "inline float comparison")
445 (:save-p :compute-only)
447 (note-this-location vop :internal-error)
449 (inst cmpteq x y temp)
451 (inst cmptle x y temp)
452 (inst cmptlt x y temp)))
454 (if (if complement (not not-p) not-p)
455 (inst fbeq temp target)
456 (inst fbne temp target))))
458 (macrolet ((frob (name sc ptype)
459 `(define-vop (,name float-compare)
460 (:args (x :scs (,sc))
462 (:arg-types ,ptype ,ptype))))
463 (frob single-float-compare single-reg single-float)
464 (frob double-float-compare double-reg double-float))
466 (macrolet ((frob (translate complement sname dname eq)
468 (define-vop (,sname single-float-compare)
469 (:translate ,translate)
470 (:variant ,eq ,complement))
471 (define-vop (,dname double-float-compare)
472 (:translate ,translate)
473 (:variant ,eq ,complement)))))
474 (frob < nil </single-float </double-float nil)
475 (frob > t >/single-float >/double-float nil)
476 (frob = nil =/single-float =/double-float t))
479 ;;;; float conversion
482 ((frob (name translate inst ld-inst to-sc to-type &optional single)
483 (declare (ignorable single))
485 (:args (x :scs (signed-reg) :target temp
486 :load-if (not (sc-is x signed-stack))))
487 (:temporary (:scs (single-stack)) temp)
488 (:results (y :scs (,to-sc)))
489 (:arg-types signed-num)
490 (:result-types ,to-type)
492 (:note "inline float coercion")
493 (:translate ,translate)
495 (:save-p :compute-only)
503 (current-nfp-tn vop))
508 (* (tn-offset stack-tn) n-word-bytes)
509 (current-nfp-tn vop))
510 (note-this-location vop :internal-error)
513 (inst ,inst y y))))))
514 (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
515 (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
517 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
519 (:args (x :scs (,from-sc)))
520 (:results (y :scs (,to-sc)))
521 (:arg-types ,from-type)
522 (:result-types ,to-type)
524 (:note "inline float coercion")
525 (:translate ,translate)
527 (:save-p :compute-only)
529 (note-this-location vop :internal-error)
531 (frob %single-float/double-float %single-float cvtts
532 double-reg double-float single-reg single-float)
533 (frob %double-float/single-float %double-float fmove
534 single-reg single-float double-reg double-float))
537 ((frob (trans from-sc from-type inst &optional single)
538 (declare (ignorable single))
539 `(define-vop (,(symbolicate trans "/" from-type))
540 (:args (x :scs (,from-sc) :target temp))
541 (:temporary (:from (:argument 0) :sc single-reg) temp)
542 (:temporary (:scs (signed-stack)) stack-temp)
543 (:results (y :scs (signed-reg)
544 :load-if (not (sc-is y signed-stack))))
545 (:arg-types ,from-type)
546 (:result-types signed-num)
549 (:note "inline float truncate")
551 (:save-p :compute-only)
553 (note-this-location vop :internal-error)
558 (* (tn-offset y) n-word-bytes)
559 (current-nfp-tn vop)))
562 (* (tn-offset stack-temp)
564 (current-nfp-tn vop))
566 (* (tn-offset stack-temp) n-word-bytes)
567 (current-nfp-tn vop))))))))
568 (frob %unary-truncate single-reg single-float cvttq/c t)
569 (frob %unary-truncate double-reg double-float cvttq/c)
570 (frob %unary-round single-reg single-float cvttq t)
571 (frob %unary-round double-reg double-float cvttq))
573 (define-vop (make-single-float)
574 (:args (bits :scs (signed-reg) :target res
575 :load-if (not (sc-is bits signed-stack))))
576 (:results (res :scs (single-reg)
577 :load-if (not (sc-is res single-stack))))
578 (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
579 (:temporary (:scs (signed-stack)) stack-temp)
580 (:arg-types signed-num)
581 (:result-types single-float)
582 (:translate make-single-float)
591 (* (tn-offset stack-temp) n-word-bytes)
592 (current-nfp-tn vop))
594 (* (tn-offset stack-temp) n-word-bytes)
595 (current-nfp-tn vop)))
598 (* (tn-offset res) n-word-bytes)
599 (current-nfp-tn vop)))))
604 (* (tn-offset bits) n-word-bytes)
605 (current-nfp-tn vop)))
607 (unless (location= bits res)
609 (* (tn-offset bits) n-word-bytes)
610 (current-nfp-tn vop))
612 (* (tn-offset res) n-word-bytes)
613 (current-nfp-tn vop)))))))))
615 (define-vop (make-double-float)
616 (:args (hi-bits :scs (signed-reg))
617 (lo-bits :scs (unsigned-reg)))
618 (:results (res :scs (double-reg)
619 :load-if (not (sc-is res double-stack))))
620 (:temporary (:scs (double-stack)) temp)
621 (:arg-types signed-num unsigned-num)
622 (:result-types double-float)
623 (:translate make-double-float)
627 (let ((stack-tn (sc-case res
631 (* (1+ (tn-offset stack-tn)) n-word-bytes)
632 (current-nfp-tn vop))
634 (* (tn-offset stack-tn) n-word-bytes)
635 (current-nfp-tn vop)))
636 (when (sc-is res double-reg)
638 (* (tn-offset temp) n-word-bytes)
639 (current-nfp-tn vop)))))
641 (define-vop (single-float-bits)
642 (:args (float :scs (single-reg descriptor-reg)
643 :load-if (not (sc-is float single-stack))))
644 (:results (bits :scs (signed-reg)
645 :load-if (or (sc-is float descriptor-reg single-stack)
646 (not (sc-is bits signed-stack)))))
647 (:temporary (:scs (signed-stack)) stack-temp)
648 (:arg-types single-float)
649 (:result-types signed-num)
650 (:translate single-float-bits)
659 (* (tn-offset stack-temp) n-word-bytes)
660 (current-nfp-tn vop))
662 (* (tn-offset stack-temp) n-word-bytes)
663 (current-nfp-tn vop)))
666 (* (tn-offset float) n-word-bytes)
667 (current-nfp-tn vop)))
669 (loadw bits float single-float-value-slot
670 other-pointer-lowtag))))
675 (* (tn-offset bits) n-word-bytes)
676 (current-nfp-tn vop))))))))
678 (define-vop (double-float-high-bits)
679 (:args (float :scs (double-reg descriptor-reg)
680 :load-if (not (sc-is float double-stack))))
681 (:results (hi-bits :scs (signed-reg)))
682 (:temporary (:scs (double-stack)) stack-temp)
683 (:arg-types double-float)
684 (:result-types signed-num)
685 (:translate double-float-high-bits)
692 (* (tn-offset stack-temp) n-word-bytes)
693 (current-nfp-tn vop))
695 (* (1+ (tn-offset stack-temp)) n-word-bytes)
696 (current-nfp-tn vop)))
699 (* (1+ (tn-offset float)) n-word-bytes)
700 (current-nfp-tn vop)))
702 (loadw hi-bits float (1+ double-float-value-slot)
703 other-pointer-lowtag)))))
705 (define-vop (double-float-low-bits)
706 (:args (float :scs (double-reg descriptor-reg)
707 :load-if (not (sc-is float double-stack))))
708 (:results (lo-bits :scs (unsigned-reg)))
709 (:temporary (:scs (double-stack)) stack-temp)
710 (:arg-types double-float)
711 (:result-types unsigned-num)
712 (:translate double-float-low-bits)
719 (* (tn-offset stack-temp) n-word-bytes)
720 (current-nfp-tn vop))
722 (* (tn-offset stack-temp) n-word-bytes)
723 (current-nfp-tn vop)))
726 (* (tn-offset float) n-word-bytes)
727 (current-nfp-tn vop)))
729 (loadw lo-bits float double-float-value-slot
730 other-pointer-lowtag)))
731 (inst mskll lo-bits 4 lo-bits)))
734 ;;;; float mode hackery
736 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
737 (defknown floating-point-modes () float-modes (flushable))
738 (defknown ((setf floating-point-modes)) (float-modes)
741 ;;; Modes bits are (byte 12 52) of fpcr. Grab and return in low bits.
742 (define-vop (floating-point-modes)
743 (:results (res :scs (unsigned-reg)))
744 (:result-types unsigned-num)
745 (:translate floating-point-modes)
748 (:temporary (:sc double-stack) temp)
749 (:temporary (:sc double-reg) temp1)
751 (let ((nfp (current-nfp-tn vop)))
753 (inst mf_fpcr temp1 temp1 temp1)
755 (inst stt temp1 (* n-word-bytes (tn-offset temp)) nfp)
756 (inst ldl res (* (1+ (tn-offset temp)) n-word-bytes) nfp)
757 (inst srl res 49 res))))
759 (define-vop (set-floating-point-modes)
760 (:args (new :scs (unsigned-reg) :target res))
761 (:results (res :scs (unsigned-reg)))
762 (:arg-types unsigned-num)
763 (:result-types unsigned-num)
764 (:translate (setf floating-point-modes))
766 (:temporary (:sc double-stack) temp)
767 (:temporary (:sc double-reg) temp1)
770 (let ((nfp (current-nfp-tn vop)))
771 (inst sll new 49 res)
772 (inst stl zero-tn (* (tn-offset temp) n-word-bytes) nfp)
773 (inst stl res (* (1+ (tn-offset temp)) n-word-bytes) nfp)
774 (inst ldt temp1 (* (tn-offset temp) n-word-bytes) nfp)
776 (inst mt_fpcr temp1 temp1 temp1)
781 ;;;; complex float VOPs
783 (define-vop (make-complex-single-float)
785 (:args (real :scs (single-reg) :target r)
786 (imag :scs (single-reg) :to :save))
787 (:arg-types single-float single-float)
788 (:results (r :scs (complex-single-reg) :from (:argument 0)
789 :load-if (not (sc-is r complex-single-stack))))
790 (:result-types complex-single-float)
791 (:note "inline complex single-float creation")
797 (let ((r-real (complex-single-reg-real-tn r)))
798 (unless (location= real r-real)
799 (inst fmove real r-real)))
800 (let ((r-imag (complex-single-reg-imag-tn r)))
801 (unless (location= imag r-imag)
802 (inst fmove imag r-imag))))
803 (complex-single-stack
804 (let ((nfp (current-nfp-tn vop))
805 (offset (* (tn-offset r) n-word-bytes)))
806 (inst sts real offset nfp)
807 (inst sts imag (+ offset n-word-bytes) nfp))))))
809 (define-vop (make-complex-double-float)
811 (:args (real :scs (double-reg) :target r)
812 (imag :scs (double-reg) :to :save))
813 (:arg-types double-float double-float)
814 (:results (r :scs (complex-double-reg) :from (:argument 0)
815 :load-if (not (sc-is r complex-double-stack))))
816 (:result-types complex-double-float)
817 (:note "inline complex double-float creation")
823 (let ((r-real (complex-double-reg-real-tn r)))
824 (unless (location= real r-real)
825 (inst fmove real r-real)))
826 (let ((r-imag (complex-double-reg-imag-tn r)))
827 (unless (location= imag r-imag)
828 (inst fmove imag r-imag))))
829 (complex-double-stack
830 (let ((nfp (current-nfp-tn vop))
831 (offset (* (tn-offset r) n-word-bytes)))
832 (inst stt real offset nfp)
833 (inst stt imag (+ offset (* 2 n-word-bytes)) nfp))))))
835 (define-vop (complex-single-float-value)
836 (:args (x :scs (complex-single-reg) :target r
837 :load-if (not (sc-is x complex-single-stack))))
838 (:arg-types complex-single-float)
839 (:results (r :scs (single-reg)))
840 (:result-types single-float)
847 (let ((value-tn (ecase slot
848 (:real (complex-single-reg-real-tn x))
849 (:imag (complex-single-reg-imag-tn x)))))
850 (unless (location= value-tn r)
851 (inst fmove value-tn r))))
852 (complex-single-stack
853 (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
855 (current-nfp-tn vop))))))
857 (define-vop (realpart/complex-single-float complex-single-float-value)
858 (:translate realpart)
859 (:note "complex single float realpart")
862 (define-vop (imagpart/complex-single-float complex-single-float-value)
863 (:translate imagpart)
864 (:note "complex single float imagpart")
867 (define-vop (complex-double-float-value)
868 (:args (x :scs (complex-double-reg) :target r
869 :load-if (not (sc-is x complex-double-stack))))
870 (:arg-types complex-double-float)
871 (:results (r :scs (double-reg)))
872 (:result-types double-float)
879 (let ((value-tn (ecase slot
880 (:real (complex-double-reg-real-tn x))
881 (:imag (complex-double-reg-imag-tn x)))))
882 (unless (location= value-tn r)
883 (inst fmove value-tn r))))
884 (complex-double-stack
885 (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
887 (current-nfp-tn vop))))))
889 (define-vop (realpart/complex-double-float complex-double-float-value)
890 (:translate realpart)
891 (:note "complex double float realpart")
894 (define-vop (imagpart/complex-double-float complex-double-float-value)
895 (:translate imagpart)
896 (:note "complex double float imagpart")