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-fun (load-fp-zero 1) (vop x y)
17 ((fp-single-zero) (single-reg)
18 (fp-double-zero) (double-reg))
21 (define-move-fun (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-fun (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)))
29 (define-move-fun (load-double 2) (vop x y)
30 ((double-stack) (double-reg))
31 (let ((nfp (current-nfp-tn vop))
32 (offset (* (tn-offset x) n-word-bytes)))
33 (inst ldt y offset nfp)))
35 (define-move-fun (store-double 2) (vop x y)
36 ((double-reg) (double-stack))
37 (let ((nfp (current-nfp-tn vop))
38 (offset (* (tn-offset y) n-word-bytes)))
39 (inst stt x offset nfp)))
43 (macrolet ((frob (vop sc)
48 :load-if (not (location= x y))))
49 (:results (y :scs (,sc)
50 :load-if (not (location= x y))))
53 (unless (location= y x)
55 (define-move-vop ,vop :move (,sc) (,sc)))))
56 (frob single-move single-reg)
57 (frob double-move double-reg))
60 (define-vop (move-from-float)
63 (:temporary (:scs (non-descriptor-reg)) ndescr)
64 (:variant-vars double-p size type data)
65 (:note "float to pointer coercion")
67 (with-fixed-allocation (y ndescr type size)
69 (inst stt x (- (* data n-word-bytes) other-pointer-lowtag) y)
70 (inst sts x (- (* data n-word-bytes) other-pointer-lowtag) y)))))
72 (macrolet ((frob (name sc &rest args)
74 (define-vop (,name move-from-float)
75 (:args (x :scs (,sc) :to :save))
76 (:results (y :scs (descriptor-reg)))
78 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
79 (frob move-from-single single-reg
80 nil single-float-size single-float-widetag single-float-value-slot)
81 (frob move-from-double double-reg
82 t double-float-size double-float-widetag double-float-value-slot))
84 (macrolet ((frob (name sc double-p value)
87 (:args (x :scs (descriptor-reg)))
88 (:results (y :scs (,sc)))
89 (:note "pointer to float coercion")
92 `((inst ldt y (- (* ,value n-word-bytes)
95 `((inst lds y (- (* ,value n-word-bytes)
98 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
99 (frob move-to-single single-reg nil single-float-value-slot)
100 (frob move-to-double double-reg t double-float-value-slot))
103 (macrolet ((frob (name sc stack-sc double-p)
106 (:args (x :scs (,sc) :target y)
108 :load-if (not (sc-is y ,sc))))
110 (:note "float argument move")
111 (:generator ,(if double-p 2 1)
114 (unless (location= x y)
117 (let ((offset (* (tn-offset y) n-word-bytes)))
119 '((inst stt x offset nfp))
120 '((inst sts x offset nfp))))))))
121 (define-move-vop ,name :move-argument
122 (,sc descriptor-reg) (,sc)))))
123 (frob move-single-float-argument single-reg single-stack nil)
124 (frob move-double-float-argument double-reg double-stack t))
126 ;;;; complex float move functions
128 (defun complex-single-reg-real-tn (x)
129 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
130 :offset (tn-offset x)))
131 (defun complex-single-reg-imag-tn (x)
132 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
133 :offset (1+ (tn-offset x))))
135 (defun complex-double-reg-real-tn (x)
136 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg )
137 :offset (tn-offset x)))
138 (defun complex-double-reg-imag-tn (x)
139 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg )
140 :offset (1+ (tn-offset x))))
143 (define-move-fun (load-complex-single 2) (vop x y)
144 ((complex-single-stack) (complex-single-reg))
145 (let ((nfp (current-nfp-tn vop))
146 (offset (* (tn-offset x) n-word-bytes)))
147 (let ((real-tn (complex-single-reg-real-tn y)))
148 (inst lds real-tn offset nfp))
149 (let ((imag-tn (complex-single-reg-imag-tn y)))
150 (inst lds imag-tn (+ offset n-word-bytes) nfp))))
152 (define-move-fun (store-complex-single 2) (vop x y)
153 ((complex-single-reg) (complex-single-stack))
154 (let ((nfp (current-nfp-tn vop))
155 (offset (* (tn-offset y) n-word-bytes)))
156 (let ((real-tn (complex-single-reg-real-tn x)))
157 (inst sts real-tn offset nfp))
158 (let ((imag-tn (complex-single-reg-imag-tn x)))
159 (inst sts imag-tn (+ offset n-word-bytes) nfp))))
162 (define-move-fun (load-complex-double 4) (vop x y)
163 ((complex-double-stack) (complex-double-reg))
164 (let ((nfp (current-nfp-tn vop))
165 (offset (* (tn-offset x) n-word-bytes)))
166 (let ((real-tn (complex-double-reg-real-tn y)))
167 (inst ldt real-tn offset nfp))
168 (let ((imag-tn (complex-double-reg-imag-tn y)))
169 (inst ldt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
171 (define-move-fun (store-complex-double 4) (vop x y)
172 ((complex-double-reg) (complex-double-stack))
173 (let ((nfp (current-nfp-tn vop))
174 (offset (* (tn-offset y) n-word-bytes)))
175 (let ((real-tn (complex-double-reg-real-tn x)))
176 (inst stt real-tn offset nfp))
177 (let ((imag-tn (complex-double-reg-imag-tn x)))
178 (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
181 ;;; complex float register to register moves.
183 (define-vop (complex-single-move)
184 (:args (x :scs (complex-single-reg) :target y
185 :load-if (not (location= x y))))
186 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
187 (:note "complex single float move")
189 (unless (location= x y)
190 ;; Note the complex-float-regs are aligned to every second
191 ;; float register so there is not need to worry about overlap.
192 (let ((x-real (complex-single-reg-real-tn x))
193 (y-real (complex-single-reg-real-tn y)))
194 (inst fmove x-real y-real))
195 (let ((x-imag (complex-single-reg-imag-tn x))
196 (y-imag (complex-single-reg-imag-tn y)))
197 (inst fmove x-imag y-imag)))))
199 (define-move-vop complex-single-move :move
200 (complex-single-reg) (complex-single-reg))
202 (define-vop (complex-double-move)
203 (:args (x :scs (complex-double-reg)
204 :target y :load-if (not (location= x y))))
205 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
206 (:note "complex double float move")
208 (unless (location= x y)
209 ;; Note the complex-float-regs are aligned to every second
210 ;; float register so there is not need to worry about overlap.
211 (let ((x-real (complex-double-reg-real-tn x))
212 (y-real (complex-double-reg-real-tn y)))
213 (inst fmove x-real y-real))
214 (let ((x-imag (complex-double-reg-imag-tn x))
215 (y-imag (complex-double-reg-imag-tn y)))
216 (inst fmove x-imag y-imag)))))
218 (define-move-vop complex-double-move :move
219 (complex-double-reg) (complex-double-reg))
222 ;;; Move from a complex float to a descriptor register allocating a
223 ;;; new complex float object in the process.
225 (define-vop (move-from-complex-single)
226 (:args (x :scs (complex-single-reg) :to :save))
227 (:results (y :scs (descriptor-reg)))
228 (:temporary (:scs (non-descriptor-reg)) ndescr)
229 (:note "complex single float to pointer coercion")
231 (with-fixed-allocation (y ndescr complex-single-float-widetag
232 complex-single-float-size)
233 (let ((real-tn (complex-single-reg-real-tn x)))
234 (inst sts real-tn (- (* complex-single-float-real-slot
236 other-pointer-lowtag)
238 (let ((imag-tn (complex-single-reg-imag-tn x)))
239 (inst sts imag-tn (- (* complex-single-float-imag-slot
241 other-pointer-lowtag)
244 (define-move-vop move-from-complex-single :move
245 (complex-single-reg) (descriptor-reg))
247 (define-vop (move-from-complex-double)
248 (:args (x :scs (complex-double-reg) :to :save))
249 (:results (y :scs (descriptor-reg)))
250 (:temporary (:scs (non-descriptor-reg)) ndescr)
251 (:note "complex double float to pointer coercion")
253 (with-fixed-allocation (y ndescr complex-double-float-widetag
254 complex-double-float-size)
255 (let ((real-tn (complex-double-reg-real-tn x)))
256 (inst stt real-tn (- (* complex-double-float-real-slot
258 other-pointer-lowtag)
260 (let ((imag-tn (complex-double-reg-imag-tn x)))
261 (inst stt imag-tn (- (* complex-double-float-imag-slot
263 other-pointer-lowtag)
266 (define-move-vop move-from-complex-double :move
267 (complex-double-reg) (descriptor-reg))
270 ;;; Move from a descriptor to a complex float register.
272 (define-vop (move-to-complex-single)
273 (:args (x :scs (descriptor-reg)))
274 (:results (y :scs (complex-single-reg)))
275 (:note "pointer to complex float coercion")
277 (let ((real-tn (complex-single-reg-real-tn y)))
278 (inst lds real-tn (- (* complex-single-float-real-slot
280 other-pointer-lowtag)
282 (let ((imag-tn (complex-single-reg-imag-tn y)))
283 (inst lds imag-tn (- (* complex-single-float-imag-slot
285 other-pointer-lowtag)
287 (define-move-vop move-to-complex-single :move
288 (descriptor-reg) (complex-single-reg))
290 (define-vop (move-to-complex-double)
291 (:args (x :scs (descriptor-reg)))
292 (:results (y :scs (complex-double-reg)))
293 (:note "pointer to complex float coercion")
295 (let ((real-tn (complex-double-reg-real-tn y)))
296 (inst ldt real-tn (- (* complex-double-float-real-slot
298 other-pointer-lowtag)
300 (let ((imag-tn (complex-double-reg-imag-tn y)))
301 (inst ldt imag-tn (- (* complex-double-float-imag-slot
303 other-pointer-lowtag)
305 (define-move-vop move-to-complex-double :move
306 (descriptor-reg) (complex-double-reg))
309 ;;; complex float move-argument vop
311 (define-vop (move-complex-single-float-argument)
312 (:args (x :scs (complex-single-reg) :target y)
313 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
315 (:note "complex single float argument move")
319 (unless (location= x y)
320 (let ((x-real (complex-single-reg-real-tn x))
321 (y-real (complex-single-reg-real-tn y)))
322 (inst fmove x-real y-real))
323 (let ((x-imag (complex-single-reg-imag-tn x))
324 (y-imag (complex-single-reg-imag-tn y)))
325 (inst fmove x-imag y-imag))))
326 (complex-single-stack
327 (let ((offset (* (tn-offset y) n-word-bytes)))
328 (let ((real-tn (complex-single-reg-real-tn x)))
329 (inst sts real-tn offset nfp))
330 (let ((imag-tn (complex-single-reg-imag-tn x)))
331 (inst sts imag-tn (+ offset n-word-bytes) nfp)))))))
332 (define-move-vop move-complex-single-float-argument :move-argument
333 (complex-single-reg descriptor-reg) (complex-single-reg))
335 (define-vop (move-complex-double-float-argument)
336 (:args (x :scs (complex-double-reg) :target y)
337 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
339 (:note "complex double float argument move")
343 (unless (location= x y)
344 (let ((x-real (complex-double-reg-real-tn x))
345 (y-real (complex-double-reg-real-tn y)))
346 (inst fmove x-real y-real))
347 (let ((x-imag (complex-double-reg-imag-tn x))
348 (y-imag (complex-double-reg-imag-tn y)))
349 (inst fmove x-imag y-imag))))
350 (complex-double-stack
351 (let ((offset (* (tn-offset y) n-word-bytes)))
352 (let ((real-tn (complex-double-reg-real-tn x)))
353 (inst stt real-tn offset nfp))
354 (let ((imag-tn (complex-double-reg-imag-tn x)))
355 (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
356 (define-move-vop move-complex-double-float-argument :move-argument
357 (complex-double-reg descriptor-reg) (complex-double-reg))
360 (define-move-vop move-argument :move-argument
361 (single-reg double-reg complex-single-reg complex-double-reg)
365 ;;;; float arithmetic VOPs
367 (define-vop (float-op)
371 (:note "inline float arithmetic")
373 (:save-p :compute-only))
375 ;;; We need to insure that ops that can cause traps do not clobber an
376 ;;; argument register with invalid results. This so the software trap
377 ;;; handler can re-execute the instruction and produce correct IEEE
378 ;;; result. The :from :load hopefully does that.
379 (macrolet ((frob (name sc ptype)
380 `(define-vop (,name float-op)
381 (:args (x :scs (,sc))
383 (:results (r :scs (,sc) :from :load))
384 (:arg-types ,ptype ,ptype)
385 (:result-types ,ptype))))
386 (frob single-float-op single-reg single-float)
387 (frob double-float-op double-reg double-float))
389 ;; This is resumption-safe with underflow traps enabled,
390 ;; with software handling and (notyet) dynamic rounding mode.
391 (macrolet ((frob (op sinst sname scost dinst dname dcost)
393 (define-vop (,sname single-float-op)
395 (:variant-cost ,scost)
398 (note-this-location vop :internal-error)
400 (define-vop (,dname double-float-op)
402 (:variant-cost ,dcost)
405 (note-this-location vop :internal-error)
407 ;; Not sure these cost number are right. +*- about same / is 4x
408 (frob + adds_su +/single-float 1 addt_su +/double-float 1)
409 (frob - subs_su -/single-float 1 subt_su -/double-float 1)
410 (frob * muls_su */single-float 1 mult_su */double-float 1)
411 (frob / divs_su //single-float 4 divt_su //double-float 4))
413 (macrolet ((frob (name inst translate sc type)
415 (:args (x :scs (,sc) :target y))
416 (:results (y :scs (,sc)))
417 (:translate ,translate)
420 (:result-types ,type)
421 (:note "inline float arithmetic")
423 (:save-p :compute-only)
425 (note-this-location vop :internal-error)
427 (frob abs/single-float fabs abs single-reg single-float)
428 (frob abs/double-float fabs abs double-reg double-float)
429 (frob %negate/single-float fneg %negate single-reg single-float)
430 (frob %negate/double-float fneg %negate double-reg double-float))
433 ;;;; float comparison
435 (define-vop (float-compare)
439 (:variant-vars eq complement)
440 (:temporary (:scs (single-reg)) temp)
442 (:note "inline float comparison")
444 (:save-p :compute-only)
446 (note-this-location vop :internal-error)
448 (inst cmpteq x y temp)
450 (inst cmptle x y temp)
451 (inst cmptlt x y temp)))
453 (if (if complement (not not-p) not-p)
454 (inst fbeq temp target)
455 (inst fbne temp target))))
457 (macrolet ((frob (name sc ptype)
458 `(define-vop (,name float-compare)
459 (:args (x :scs (,sc))
461 (:arg-types ,ptype ,ptype))))
462 (frob single-float-compare single-reg single-float)
463 (frob double-float-compare double-reg double-float))
465 (macrolet ((frob (translate complement sname dname eq)
467 (define-vop (,sname single-float-compare)
468 (:translate ,translate)
469 (:variant ,eq ,complement))
470 (define-vop (,dname double-float-compare)
471 (:translate ,translate)
472 (:variant ,eq ,complement)))))
473 (frob < nil </single-float </double-float nil)
474 (frob > t >/single-float >/double-float nil)
475 (frob = nil =/single-float =/double-float t))
478 ;;;; float conversion
481 ((frob (name translate inst ld-inst to-sc to-type &optional single)
482 (declare (ignorable single))
484 (:args (x :scs (signed-reg) :target temp
485 :load-if (not (sc-is x signed-stack))))
486 (:temporary (:scs (single-stack)) temp)
487 (:results (y :scs (,to-sc)))
488 (:arg-types signed-num)
489 (:result-types ,to-type)
491 (:note "inline float coercion")
492 (:translate ,translate)
494 (:save-p :compute-only)
502 (current-nfp-tn vop))
507 (* (tn-offset stack-tn) n-word-bytes)
508 (current-nfp-tn vop))
509 (note-this-location vop :internal-error)
512 (inst ,inst y y))))))
513 (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
514 (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
516 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
518 (:args (x :scs (,from-sc)))
519 (:results (y :scs (,to-sc)))
520 (:arg-types ,from-type)
521 (:result-types ,to-type)
523 (:note "inline float coercion")
524 (:translate ,translate)
526 (:save-p :compute-only)
528 (note-this-location vop :internal-error)
530 (frob %single-float/double-float %single-float cvtts
531 double-reg double-float single-reg single-float)
532 (frob %double-float/single-float %double-float fmove
533 single-reg single-float double-reg double-float))
536 ((frob (trans from-sc from-type inst &optional single)
537 (declare (ignorable single))
538 `(define-vop (,(symbolicate trans "/" from-type))
539 (:args (x :scs (,from-sc) :target temp))
540 (:temporary (:from (:argument 0) :sc single-reg) temp)
541 (:temporary (:scs (signed-stack)) stack-temp)
542 (:results (y :scs (signed-reg)
543 :load-if (not (sc-is y signed-stack))))
544 (:arg-types ,from-type)
545 (:result-types signed-num)
548 (:note "inline float truncate")
550 (:save-p :compute-only)
552 (note-this-location vop :internal-error)
557 (* (tn-offset y) n-word-bytes)
558 (current-nfp-tn vop)))
561 (* (tn-offset stack-temp)
563 (current-nfp-tn vop))
565 (* (tn-offset stack-temp) n-word-bytes)
566 (current-nfp-tn vop))))))))
567 (frob %unary-truncate single-reg single-float cvttq/c t)
568 (frob %unary-truncate double-reg double-float cvttq/c)
569 (frob %unary-round single-reg single-float cvttq t)
570 (frob %unary-round double-reg double-float cvttq))
572 (define-vop (make-single-float)
573 (:args (bits :scs (signed-reg) :target res
574 :load-if (not (sc-is bits signed-stack))))
575 (:results (res :scs (single-reg)
576 :load-if (not (sc-is res single-stack))))
577 (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
578 (:temporary (:scs (signed-stack)) stack-temp)
579 (:arg-types signed-num)
580 (:result-types single-float)
581 (:translate make-single-float)
590 (* (tn-offset stack-temp) n-word-bytes)
591 (current-nfp-tn vop))
593 (* (tn-offset stack-temp) n-word-bytes)
594 (current-nfp-tn vop)))
597 (* (tn-offset res) n-word-bytes)
598 (current-nfp-tn vop)))))
603 (* (tn-offset bits) n-word-bytes)
604 (current-nfp-tn vop)))
606 (unless (location= bits res)
608 (* (tn-offset bits) n-word-bytes)
609 (current-nfp-tn vop))
611 (* (tn-offset res) n-word-bytes)
612 (current-nfp-tn vop)))))))))
614 (define-vop (make-double-float)
615 (:args (hi-bits :scs (signed-reg))
616 (lo-bits :scs (unsigned-reg)))
617 (:results (res :scs (double-reg)
618 :load-if (not (sc-is res double-stack))))
619 (:temporary (:scs (double-stack)) temp)
620 (:arg-types signed-num unsigned-num)
621 (:result-types double-float)
622 (:translate make-double-float)
626 (let ((stack-tn (sc-case res
630 (* (1+ (tn-offset stack-tn)) n-word-bytes)
631 (current-nfp-tn vop))
633 (* (tn-offset stack-tn) n-word-bytes)
634 (current-nfp-tn vop)))
635 (when (sc-is res double-reg)
637 (* (tn-offset temp) n-word-bytes)
638 (current-nfp-tn vop)))))
640 (define-vop (single-float-bits)
641 (:args (float :scs (single-reg descriptor-reg)
642 :load-if (not (sc-is float single-stack))))
643 (:results (bits :scs (signed-reg)
644 :load-if (or (sc-is float descriptor-reg single-stack)
645 (not (sc-is bits signed-stack)))))
646 (:temporary (:scs (signed-stack)) stack-temp)
647 (:arg-types single-float)
648 (:result-types signed-num)
649 (:translate single-float-bits)
658 (* (tn-offset stack-temp) n-word-bytes)
659 (current-nfp-tn vop))
661 (* (tn-offset stack-temp) n-word-bytes)
662 (current-nfp-tn vop)))
665 (* (tn-offset float) n-word-bytes)
666 (current-nfp-tn vop)))
668 (loadw bits float single-float-value-slot
669 other-pointer-lowtag))))
674 (* (tn-offset bits) n-word-bytes)
675 (current-nfp-tn vop))))))))
677 (define-vop (double-float-high-bits)
678 (:args (float :scs (double-reg descriptor-reg)
679 :load-if (not (sc-is float double-stack))))
680 (:results (hi-bits :scs (signed-reg)))
681 (:temporary (:scs (double-stack)) stack-temp)
682 (:arg-types double-float)
683 (:result-types signed-num)
684 (:translate double-float-high-bits)
691 (* (tn-offset stack-temp) n-word-bytes)
692 (current-nfp-tn vop))
694 (* (1+ (tn-offset stack-temp)) n-word-bytes)
695 (current-nfp-tn vop)))
698 (* (1+ (tn-offset float)) n-word-bytes)
699 (current-nfp-tn vop)))
701 (loadw hi-bits float (1+ double-float-value-slot)
702 other-pointer-lowtag)))))
704 (define-vop (double-float-low-bits)
705 (:args (float :scs (double-reg descriptor-reg)
706 :load-if (not (sc-is float double-stack))))
707 (:results (lo-bits :scs (unsigned-reg)))
708 (:temporary (:scs (double-stack)) stack-temp)
709 (:arg-types double-float)
710 (:result-types unsigned-num)
711 (:translate double-float-low-bits)
718 (* (tn-offset stack-temp) n-word-bytes)
719 (current-nfp-tn vop))
721 (* (tn-offset stack-temp) n-word-bytes)
722 (current-nfp-tn vop)))
725 (* (tn-offset float) n-word-bytes)
726 (current-nfp-tn vop)))
728 (loadw lo-bits float double-float-value-slot
729 other-pointer-lowtag)))
730 (inst mskll lo-bits 4 lo-bits)))
733 ;;;; float mode hackery
735 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
736 (defknown floating-point-modes () float-modes (flushable))
737 (defknown ((setf floating-point-modes)) (float-modes)
740 ;;; Modes bits are (byte 12 52) of fpcr. Grab and return in low bits.
741 (define-vop (floating-point-modes)
742 (:results (res :scs (unsigned-reg)))
743 (:result-types unsigned-num)
744 (:translate floating-point-modes)
747 (:temporary (:sc double-stack) temp)
748 (:temporary (:sc double-reg) temp1)
750 (let ((nfp (current-nfp-tn vop)))
752 (inst mf_fpcr temp1 temp1 temp1)
754 (inst stt temp1 (* n-word-bytes (tn-offset temp)) nfp)
755 (inst ldl res (* (1+ (tn-offset temp)) n-word-bytes) nfp)
756 (inst srl res 49 res))))
758 (define-vop (set-floating-point-modes)
759 (:args (new :scs (unsigned-reg) :target res))
760 (:results (res :scs (unsigned-reg)))
761 (:arg-types unsigned-num)
762 (:result-types unsigned-num)
763 (:translate (setf floating-point-modes))
765 (:temporary (:sc double-stack) temp)
766 (:temporary (:sc double-reg) temp1)
769 (let ((nfp (current-nfp-tn vop)))
770 (inst sll new 49 res)
771 (inst stl zero-tn (* (tn-offset temp) n-word-bytes) nfp)
772 (inst stl res (* (1+ (tn-offset temp)) n-word-bytes) nfp)
773 (inst ldt temp1 (* (tn-offset temp) n-word-bytes) nfp)
775 (inst mt_fpcr temp1 temp1 temp1)
780 ;;;; complex float VOPs
782 (define-vop (make-complex-single-float)
784 (:args (real :scs (single-reg) :target r)
785 (imag :scs (single-reg) :to :save))
786 (:arg-types single-float single-float)
787 (:results (r :scs (complex-single-reg) :from (:argument 0)
788 :load-if (not (sc-is r complex-single-stack))))
789 (:result-types complex-single-float)
790 (:note "inline complex single-float creation")
796 (let ((r-real (complex-single-reg-real-tn r)))
797 (unless (location= real r-real)
798 (inst fmove real r-real)))
799 (let ((r-imag (complex-single-reg-imag-tn r)))
800 (unless (location= imag r-imag)
801 (inst fmove imag r-imag))))
802 (complex-single-stack
803 (let ((nfp (current-nfp-tn vop))
804 (offset (* (tn-offset r) n-word-bytes)))
805 (inst sts real offset nfp)
806 (inst sts imag (+ offset n-word-bytes) nfp))))))
808 (define-vop (make-complex-double-float)
810 (:args (real :scs (double-reg) :target r)
811 (imag :scs (double-reg) :to :save))
812 (:arg-types double-float double-float)
813 (:results (r :scs (complex-double-reg) :from (:argument 0)
814 :load-if (not (sc-is r complex-double-stack))))
815 (:result-types complex-double-float)
816 (:note "inline complex double-float creation")
822 (let ((r-real (complex-double-reg-real-tn r)))
823 (unless (location= real r-real)
824 (inst fmove real r-real)))
825 (let ((r-imag (complex-double-reg-imag-tn r)))
826 (unless (location= imag r-imag)
827 (inst fmove imag r-imag))))
828 (complex-double-stack
829 (let ((nfp (current-nfp-tn vop))
830 (offset (* (tn-offset r) n-word-bytes)))
831 (inst stt real offset nfp)
832 (inst stt imag (+ offset (* 2 n-word-bytes)) nfp))))))
834 (define-vop (complex-single-float-value)
835 (:args (x :scs (complex-single-reg) :target r
836 :load-if (not (sc-is x complex-single-stack))))
837 (:arg-types complex-single-float)
838 (:results (r :scs (single-reg)))
839 (:result-types single-float)
846 (let ((value-tn (ecase slot
847 (:real (complex-single-reg-real-tn x))
848 (:imag (complex-single-reg-imag-tn x)))))
849 (unless (location= value-tn r)
850 (inst fmove value-tn r))))
851 (complex-single-stack
852 (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
854 (current-nfp-tn vop))))))
856 (define-vop (realpart/complex-single-float complex-single-float-value)
857 (:translate realpart)
858 (:note "complex single float realpart")
861 (define-vop (imagpart/complex-single-float complex-single-float-value)
862 (:translate imagpart)
863 (:note "complex single float imagpart")
866 (define-vop (complex-double-float-value)
867 (:args (x :scs (complex-double-reg) :target r
868 :load-if (not (sc-is x complex-double-stack))))
869 (:arg-types complex-double-float)
870 (:results (r :scs (double-reg)))
871 (:result-types double-float)
878 (let ((value-tn (ecase slot
879 (:real (complex-double-reg-real-tn x))
880 (:imag (complex-double-reg-imag-tn x)))))
881 (unless (location= value-tn r)
882 (inst fmove value-tn r))))
883 (complex-double-stack
884 (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
886 (current-nfp-tn vop))))))
888 (define-vop (realpart/complex-double-float complex-double-float-value)
889 (:translate realpart)
890 (:note "complex double float realpart")
893 (define-vop (imagpart/complex-double-float complex-double-float-value)
894 (:translate imagpart)
895 (:note "complex double float imagpart")