7 (define-move-fun (load-single 1) (vop x y)
8 ((single-stack) (single-reg))
9 (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes))
12 (define-move-fun (store-single 1) (vop x y)
13 ((single-reg) (single-stack))
14 (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
17 (defun ld-double (r base offset)
18 (ecase *backend-byte-order*
20 (inst lwc1 r base (+ offset n-word-bytes))
21 (inst lwc1-odd r base offset))
23 (inst lwc1 r base offset)
24 (inst lwc1-odd r base (+ offset n-word-bytes)))))
26 (define-move-fun (load-double 2) (vop x y)
27 ((double-stack) (double-reg))
28 (let ((nfp (current-nfp-tn vop))
29 (offset (* (tn-offset x) n-word-bytes)))
30 (ld-double y nfp offset))
33 (defun str-double (x base offset)
34 (ecase *backend-byte-order*
36 (inst swc1 x base (+ offset n-word-bytes))
37 (inst swc1-odd x base offset))
39 (inst swc1 x base offset)
40 (inst swc1-odd x base (+ offset n-word-bytes)))))
42 (define-move-fun (store-double 2) (vop x y)
43 ((double-reg) (double-stack))
44 (let ((nfp (current-nfp-tn vop))
45 (offset (* (tn-offset y) n-word-bytes)))
46 (str-double x nfp offset)))
52 (macrolet ((frob (vop sc format)
57 :load-if (not (location= x y))))
58 (:results (y :scs (,sc)
59 :load-if (not (location= x y))))
62 (unless (location= y x)
63 (inst fmove ,format y x))))
64 (define-move-vop ,vop :move (,sc) (,sc)))))
65 (frob single-move single-reg :single)
66 (frob double-move double-reg :double))
69 (define-vop (move-from-float)
72 (:temporary (:scs (non-descriptor-reg)) ndescr)
73 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
74 (:variant-vars double-p size type data)
75 (:note "float to pointer coercion")
77 (with-fixed-allocation (y pa-flag ndescr type size)
79 (str-double x y (- (* data n-word-bytes) other-pointer-lowtag))
80 (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag))))))
82 (macrolet ((frob (name sc &rest args)
84 (define-vop (,name move-from-float)
85 (:args (x :scs (,sc) :to :save))
86 (:results (y :scs (descriptor-reg)))
88 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
89 (frob move-from-single single-reg
90 nil single-float-size single-float-widetag single-float-value-slot)
91 (frob move-from-double double-reg
92 t double-float-size double-float-widetag double-float-value-slot))
95 (macrolet ((frob (name sc double-p value)
98 (:args (x :scs (descriptor-reg)))
99 (:results (y :scs (,sc)))
100 (:note "pointer to float coercion")
102 ,@(ecase *backend-byte-order*
106 `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes)
107 other-pointer-lowtag))
108 (inst lwc1-odd y x (- (* ,value n-word-bytes)
109 other-pointer-lowtag))))
111 `((inst lwc1 y x (- (* ,value n-word-bytes)
112 other-pointer-lowtag))))))
114 `((inst lwc1 y x (- (* ,value n-word-bytes)
115 other-pointer-lowtag))
118 (- (* (1+ ,value) n-word-bytes)
119 other-pointer-lowtag)))))))
121 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
122 (frob move-to-single single-reg nil single-float-value-slot)
123 (frob move-to-double double-reg t double-float-value-slot))
126 (macrolet ((frob (name sc stack-sc format double-p)
129 (:args (x :scs (,sc) :target y)
131 :load-if (not (sc-is y ,sc))))
133 (:note "float argument move")
134 (:generator ,(if double-p 2 1)
137 (unless (location= x y)
138 (inst fmove ,format y x)))
140 (let ((offset (* (tn-offset y) n-word-bytes)))
141 ,@(ecase *backend-byte-order*
145 '((inst swc1 x nfp (+ offset n-word-bytes))
146 (inst swc1-odd x nfp offset)))
148 '((inst swc1 x nfp offset)))))
150 `((inst swc1 x nfp offset)
152 '((inst swc1-odd x nfp
153 (+ offset n-word-bytes))))))))))))
154 (define-move-vop ,name :move-arg
155 (,sc descriptor-reg) (,sc)))))
156 (frob move-single-float-arg single-reg single-stack :single nil)
157 (frob move-double-float-arg double-reg double-stack :double t))
160 ;;;; Complex float move functions
162 (defun complex-single-reg-real-tn (x)
163 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
164 :offset (tn-offset x)))
165 (defun complex-single-reg-imag-tn (x)
166 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
167 :offset (+ (tn-offset x) 2)))
169 (defun complex-double-reg-real-tn (x)
170 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
171 :offset (tn-offset x)))
172 (defun complex-double-reg-imag-tn (x)
173 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
174 :offset (+ (tn-offset x) 2)))
177 (define-move-fun (load-complex-single 2) (vop x y)
178 ((complex-single-stack) (complex-single-reg))
179 (let ((nfp (current-nfp-tn vop))
180 (offset (* (tn-offset x) n-word-bytes)))
181 (let ((real-tn (complex-single-reg-real-tn y)))
182 (inst lwc1 real-tn nfp offset))
183 (let ((imag-tn (complex-single-reg-imag-tn y)))
184 (inst lwc1 imag-tn nfp (+ offset n-word-bytes))))
187 (define-move-fun (store-complex-single 2) (vop x y)
188 ((complex-single-reg) (complex-single-stack))
189 (let ((nfp (current-nfp-tn vop))
190 (offset (* (tn-offset y) n-word-bytes)))
191 (let ((real-tn (complex-single-reg-real-tn x)))
192 (inst swc1 real-tn nfp offset))
193 (let ((imag-tn (complex-single-reg-imag-tn x)))
194 (inst swc1 imag-tn nfp (+ offset n-word-bytes)))))
197 (define-move-fun (load-complex-double 4) (vop x y)
198 ((complex-double-stack) (complex-double-reg))
199 (let ((nfp (current-nfp-tn vop))
200 (offset (* (tn-offset x) n-word-bytes)))
201 (let ((real-tn (complex-double-reg-real-tn y)))
202 (ld-double real-tn nfp offset))
203 (let ((imag-tn (complex-double-reg-imag-tn y)))
204 (ld-double imag-tn nfp (+ offset (* 2 n-word-bytes))))
207 (define-move-fun (store-complex-double 4) (vop x y)
208 ((complex-double-reg) (complex-double-stack))
209 (let ((nfp (current-nfp-tn vop))
210 (offset (* (tn-offset y) n-word-bytes)))
211 (let ((real-tn (complex-double-reg-real-tn x)))
212 (str-double real-tn nfp offset))
213 (let ((imag-tn (complex-double-reg-imag-tn x)))
214 (str-double imag-tn nfp (+ offset (* 2 n-word-bytes))))))
217 ;;; Complex float register to register moves.
219 (define-vop (complex-single-move)
220 (:args (x :scs (complex-single-reg) :target y
221 :load-if (not (location= x y))))
222 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
223 (:note "complex single float move")
225 (unless (location= x y)
226 ;; Note the complex-float-regs are aligned to every second
227 ;; float register so there is not need to worry about overlap.
228 (let ((x-real (complex-single-reg-real-tn x))
229 (y-real (complex-single-reg-real-tn y)))
230 (inst fmove :single y-real x-real))
231 (let ((x-imag (complex-single-reg-imag-tn x))
232 (y-imag (complex-single-reg-imag-tn y)))
233 (inst fmove :single y-imag x-imag)))))
235 (define-move-vop complex-single-move :move
236 (complex-single-reg) (complex-single-reg))
238 (define-vop (complex-double-move)
239 (:args (x :scs (complex-double-reg)
240 :target y :load-if (not (location= x y))))
241 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
242 (:note "complex double float move")
244 (unless (location= x y)
245 ;; Note the complex-float-regs are aligned to every second
246 ;; float register so there is not need to worry about overlap.
247 (let ((x-real (complex-double-reg-real-tn x))
248 (y-real (complex-double-reg-real-tn y)))
249 (inst fmove :double y-real x-real))
250 (let ((x-imag (complex-double-reg-imag-tn x))
251 (y-imag (complex-double-reg-imag-tn y)))
252 (inst fmove :double y-imag x-imag)))))
254 (define-move-vop complex-double-move :move
255 (complex-double-reg) (complex-double-reg))
258 ;;; Move from a complex float to a descriptor register allocating a
259 ;;; new complex float object in the process.
261 (define-vop (move-from-complex-single)
262 (:args (x :scs (complex-single-reg) :to :save))
263 (:results (y :scs (descriptor-reg)))
264 (:temporary (:scs (non-descriptor-reg)) ndescr)
265 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
266 (:note "complex single float to pointer coercion")
268 (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
269 complex-single-float-size)
270 (let ((real-tn (complex-single-reg-real-tn x)))
271 (inst swc1 real-tn y (- (* complex-single-float-real-slot
273 other-pointer-lowtag)))
274 (let ((imag-tn (complex-single-reg-imag-tn x)))
275 (inst swc1 imag-tn y (- (* complex-single-float-imag-slot
277 other-pointer-lowtag))))))
279 (define-move-vop move-from-complex-single :move
280 (complex-single-reg) (descriptor-reg))
282 (define-vop (move-from-complex-double)
283 (:args (x :scs (complex-double-reg) :to :save))
284 (:results (y :scs (descriptor-reg)))
285 (:temporary (:scs (non-descriptor-reg)) ndescr)
286 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
287 (:note "complex double float to pointer coercion")
289 (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
290 complex-double-float-size)
291 (let ((real-tn (complex-double-reg-real-tn x)))
292 (str-double real-tn y (- (* complex-double-float-real-slot
294 other-pointer-lowtag)))
295 (let ((imag-tn (complex-double-reg-imag-tn x)))
296 (str-double imag-tn y (- (* complex-double-float-imag-slot
298 other-pointer-lowtag))))))
300 (define-move-vop move-from-complex-double :move
301 (complex-double-reg) (descriptor-reg))
304 ;;; Move from a descriptor to a complex float register
306 (define-vop (move-to-complex-single)
307 (:args (x :scs (descriptor-reg)))
308 (:results (y :scs (complex-single-reg)))
309 (:note "pointer to complex float coercion")
311 (let ((real-tn (complex-single-reg-real-tn y)))
312 (inst lwc1 real-tn x (- (* complex-single-float-real-slot n-word-bytes)
313 other-pointer-lowtag)))
314 (let ((imag-tn (complex-single-reg-imag-tn y)))
315 (inst lwc1 imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
316 other-pointer-lowtag)))
318 (define-move-vop move-to-complex-single :move
319 (descriptor-reg) (complex-single-reg))
321 (define-vop (move-to-complex-double)
322 (:args (x :scs (descriptor-reg)))
323 (:results (y :scs (complex-double-reg)))
324 (:note "pointer to complex float coercion")
326 (let ((real-tn (complex-double-reg-real-tn y)))
327 (ld-double real-tn x (- (* complex-double-float-real-slot n-word-bytes)
328 other-pointer-lowtag)))
329 (let ((imag-tn (complex-double-reg-imag-tn y)))
330 (ld-double imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
331 other-pointer-lowtag)))
333 (define-move-vop move-to-complex-double :move
334 (descriptor-reg) (complex-double-reg))
337 ;;; Complex float move-argument vop
339 (define-vop (move-complex-single-float-arg)
340 (:args (x :scs (complex-single-reg) :target y)
341 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
343 (:note "complex single-float argument move")
347 (unless (location= x y)
348 (let ((x-real (complex-single-reg-real-tn x))
349 (y-real (complex-single-reg-real-tn y)))
350 (inst fmove :single y-real x-real))
351 (let ((x-imag (complex-single-reg-imag-tn x))
352 (y-imag (complex-single-reg-imag-tn y)))
353 (inst fmove :single y-imag x-imag))))
354 (complex-single-stack
355 (let ((offset (* (tn-offset y) n-word-bytes)))
356 (let ((real-tn (complex-single-reg-real-tn x)))
357 (inst swc1 real-tn nfp offset))
358 (let ((imag-tn (complex-single-reg-imag-tn x)))
359 (inst swc1 imag-tn nfp (+ offset n-word-bytes))))))))
360 (define-move-vop move-complex-single-float-arg :move-arg
361 (complex-single-reg descriptor-reg) (complex-single-reg))
363 (define-vop (move-complex-double-float-arg)
364 (:args (x :scs (complex-double-reg) :target y)
365 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
367 (:note "complex double-float argument move")
371 (unless (location= x y)
372 (let ((x-real (complex-double-reg-real-tn x))
373 (y-real (complex-double-reg-real-tn y)))
374 (inst fmove :double y-real x-real))
375 (let ((x-imag (complex-double-reg-imag-tn x))
376 (y-imag (complex-double-reg-imag-tn y)))
377 (inst fmove :double y-imag x-imag))))
378 (complex-double-stack
379 (let ((offset (* (tn-offset y) n-word-bytes)))
380 (let ((real-tn (complex-double-reg-real-tn x)))
381 (str-double real-tn nfp offset))
382 (let ((imag-tn (complex-double-reg-imag-tn x)))
383 (str-double imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
384 (define-move-vop move-complex-double-float-arg :move-arg
385 (complex-double-reg descriptor-reg) (complex-double-reg))
388 (define-move-vop move-arg :move-arg
389 (single-reg double-reg complex-single-reg complex-double-reg)
393 ;;;; stuff for c-call float-in-int-register arguments
395 (define-vop (move-to-single-int-reg)
396 (:args (x :scs (single-reg descriptor-reg)))
397 (:results (y :scs (single-int-carg-reg) :load-if nil))
398 (:note "pointer to float-in-int coercion")
404 (inst lw y x (- (* single-float-value-slot n-word-bytes)
405 other-pointer-lowtag))))
406 (inst nop))) ;nop needed here?
407 (define-move-vop move-to-single-int-reg
408 :move (single-reg descriptor-reg) (single-int-carg-reg))
410 (define-vop (move-single-int-reg)
411 (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
412 (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
413 (:results (y :scs (single-int-carg-reg) :load-if nil))
415 (unless (location= x y)
416 (error "Huh? why did it do that?"))))
417 (define-move-vop move-single-int-reg :move-arg
418 (single-int-carg-reg) (single-int-carg-reg))
420 (define-vop (move-to-double-int-reg)
421 (:args (x :scs (double-reg descriptor-reg)))
422 (:results (y :scs (double-int-carg-reg) :load-if nil))
423 (:note "pointer to float-in-int coercion")
427 (ecase *backend-byte-order*
433 (inst mfc1-odd3 y x))))
435 (inst lw y x (- (* double-float-value-slot n-word-bytes)
436 other-pointer-lowtag))
437 (inst lw-odd y x (- (* (1+ double-float-value-slot) n-word-bytes)
438 other-pointer-lowtag))))
439 (inst nop))) ;nop needed here?
440 (define-move-vop move-to-double-int-reg
441 :move (double-reg descriptor-reg) (double-int-carg-reg))
443 (define-vop (move-double-int-reg)
444 (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
445 (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
446 (:results (y :scs (double-int-carg-reg) :load-if nil))
448 (unless (location= x y)
449 (error "Huh? why did it do that?"))))
450 (define-move-vop move-double-int-reg :move-arg
451 (double-int-carg-reg) (double-int-carg-reg))
454 ;;;; Arithmetic VOPs:
456 (define-vop (float-op)
459 (:variant-vars format operation)
461 (:note "inline float arithmetic")
463 (:save-p :compute-only)
465 (note-this-location vop :internal-error)
466 (inst float-op operation format r x y)))
468 (macrolet ((frob (name sc ptype)
469 `(define-vop (,name float-op)
470 (:args (x :scs (,sc))
472 (:results (r :scs (,sc)))
473 (:arg-types ,ptype ,ptype)
474 (:result-types ,ptype))))
475 (frob single-float-op single-reg single-float)
476 (frob double-float-op double-reg double-float))
478 (macrolet ((frob (op sname scost dname dcost)
480 (define-vop (,sname single-float-op)
482 (:variant :single ',op)
483 (:variant-cost ,scost))
484 (define-vop (,dname double-float-op)
486 (:variant :double ',op)
487 (:variant-cost ,dcost)))))
488 (frob + +/single-float 2 +/double-float 2)
489 (frob - -/single-float 2 -/double-float 2)
490 (frob * */single-float 4 */double-float 5)
491 (frob / //single-float 12 //double-float 19))
493 (macrolet ((frob (name inst translate format sc type)
495 (:args (x :scs (,sc)))
496 (:results (y :scs (,sc)))
497 (:translate ,translate)
500 (:result-types ,type)
501 (:note "inline float arithmetic")
503 (:save-p :compute-only)
505 (note-this-location vop :internal-error)
506 (inst ,inst ,format y x)))))
507 (frob abs/single-float fabs abs :single single-reg single-float)
508 (frob abs/double-float fabs abs :double double-reg double-float)
509 (frob %negate/single-float fneg %negate :single single-reg single-float)
510 (frob %negate/double-float fneg %negate :double double-reg double-float))
515 (define-vop (float-compare)
519 (:variant-vars format operation complement)
521 (:note "inline float comparison")
523 (:save-p :compute-only)
525 (note-this-location vop :internal-error)
526 (inst fcmp operation format x y)
528 (if (if complement (not not-p) not-p)
533 (macrolet ((frob (name sc ptype)
534 `(define-vop (,name float-compare)
535 (:args (x :scs (,sc))
537 (:arg-types ,ptype ,ptype))))
538 (frob single-float-compare single-reg single-float)
539 (frob double-float-compare double-reg double-float))
541 (macrolet ((frob (translate op complement sname dname)
543 (define-vop (,sname single-float-compare)
544 (:translate ,translate)
545 (:variant :single ,op ,complement))
546 (define-vop (,dname double-float-compare)
547 (:translate ,translate)
548 (:variant :double ,op ,complement)))))
549 (frob < :lt nil </single-float </double-float)
550 (frob > :ngt t >/single-float >/double-float)
551 (frob = :seq nil =/single-float =/double-float))
556 (macrolet ((frob (name translate
557 from-sc from-type from-format
558 to-sc to-type to-format)
559 (let ((word-p (eq from-format :word)))
561 (:args (x :scs (,from-sc)))
562 (:results (y :scs (,to-sc)))
563 (:arg-types ,from-type)
564 (:result-types ,to-type)
566 (:note "inline float coercion")
567 (:translate ,translate)
569 (:save-p :compute-only)
570 (:generator ,(if word-p 3 2)
574 (note-this-location vop :internal-error)
575 (inst fcvt ,to-format :word y y))
576 `((note-this-location vop :internal-error)
577 (inst fcvt ,to-format ,from-format y x))))))))
578 (frob %single-float/signed %single-float
579 signed-reg signed-num :word
580 single-reg single-float :single)
581 (frob %double-float/signed %double-float
582 signed-reg signed-num :word
583 double-reg double-float :double)
584 (frob %single-float/double-float %single-float
585 double-reg double-float :double
586 single-reg single-float :single)
587 (frob %double-float/single-float %double-float
588 single-reg single-float :single
589 double-reg double-float :double))
592 (macrolet ((frob (name from-sc from-type from-format)
594 (:args (x :scs (,from-sc)))
595 (:results (y :scs (signed-reg)))
596 (:temporary (:from (:argument 0) :sc ,from-sc) temp)
597 (:arg-types ,from-type)
598 (:result-types signed-num)
599 (:translate %unary-round)
601 (:note "inline float round")
603 (:save-p :compute-only)
605 (note-this-location vop :internal-error)
606 (inst fcvt :word ,from-format temp x)
609 (frob %unary-round/single-float single-reg single-float :single)
610 (frob %unary-round/double-float double-reg double-float :double))
613 ;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
614 ;;; the desired round-to-zero behavior.
616 (macrolet ((frob (name from-sc from-type from-format)
618 (:args (x :scs (,from-sc)))
619 (:results (y :scs (signed-reg)))
620 (:temporary (:from (:argument 0) :sc ,from-sc) temp)
621 (:temporary (:sc non-descriptor-reg) status-save new-status)
622 (:temporary (:sc non-descriptor-reg :offset nl4-offset)
624 (:arg-types ,from-type)
625 (:result-types signed-num)
626 (:translate %unary-truncate)
628 (:note "inline float truncate")
630 (:save-p :compute-only)
632 (pseudo-atomic (pa-flag)
633 (inst cfc1 status-save 31)
634 (inst li new-status (lognot 3))
635 (inst and new-status status-save)
636 (inst or new-status float-round-to-zero)
637 (inst ctc1 new-status 31)
639 ;; These instructions seem to be necessary to ensure that
640 ;; the new modes affect the fcvt instruction.
642 (inst cfc1 new-status 31)
644 (note-this-location vop :internal-error)
645 (inst fcvt :word ,from-format temp x)
648 (inst ctc1 status-save 31))))))
649 (frob %unary-truncate/single-float single-reg single-float :single)
650 (frob %unary-truncate/double-float double-reg double-float :double))
653 (define-vop (make-single-float)
654 (:args (bits :scs (signed-reg)))
655 (:results (res :scs (single-reg)))
656 (:arg-types signed-num)
657 (:result-types single-float)
658 (:translate make-single-float)
664 (define-vop (make-double-float)
665 (:args (hi-bits :scs (signed-reg))
666 (lo-bits :scs (unsigned-reg)))
667 (:results (res :scs (double-reg)))
668 (:arg-types signed-num unsigned-num)
669 (:result-types double-float)
670 (:translate make-double-float)
673 (inst mtc1 res lo-bits)
674 (inst mtc1-odd res hi-bits)
677 (define-vop (single-float-bits)
678 (:args (float :scs (single-reg)))
679 (:results (bits :scs (signed-reg)))
680 (:arg-types single-float)
681 (:result-types signed-num)
682 (:translate single-float-bits)
685 (inst mfc1 bits float)
688 (define-vop (double-float-high-bits)
689 (:args (float :scs (double-reg)))
690 (:results (hi-bits :scs (signed-reg)))
691 (:arg-types double-float)
692 (:result-types signed-num)
693 (:translate double-float-high-bits)
696 (inst mfc1-odd hi-bits float)
699 (define-vop (double-float-low-bits)
700 (:args (float :scs (double-reg)))
701 (:results (lo-bits :scs (unsigned-reg)))
702 (:arg-types double-float)
703 (:result-types unsigned-num)
704 (:translate double-float-low-bits)
707 (inst mfc1 lo-bits float)
711 ;;;; Float mode hackery:
713 (sb!xc:deftype float-modes () '(unsigned-byte 24))
714 (defknown floating-point-modes () float-modes (flushable))
715 (defknown ((setf floating-point-modes)) (float-modes)
718 (define-vop (floating-point-modes)
719 (:results (res :scs (unsigned-reg)))
720 (:result-types unsigned-num)
721 (:translate floating-point-modes)
727 (define-vop (set-floating-point-modes)
728 (:args (new :scs (unsigned-reg) :target res))
729 (:results (res :scs (unsigned-reg)))
730 (:arg-types unsigned-num)
731 (:result-types unsigned-num)
732 (:translate (setf floating-point-modes))
739 ;;;; Complex float VOPs
741 (define-vop (make-complex-single-float)
743 (:args (real :scs (single-reg) :target r)
744 (imag :scs (single-reg) :to :save))
745 (:arg-types single-float single-float)
746 (:results (r :scs (complex-single-reg) :from (:argument 0)
747 :load-if (not (sc-is r complex-single-stack))))
748 (:result-types complex-single-float)
749 (:note "inline complex single-float creation")
755 (let ((r-real (complex-single-reg-real-tn r)))
756 (unless (location= real r-real)
757 (inst fmove :single r-real real)))
758 (let ((r-imag (complex-single-reg-imag-tn r)))
759 (unless (location= imag r-imag)
760 (inst fmove :single r-imag imag))))
761 (complex-single-stack
762 (let ((nfp (current-nfp-tn vop))
763 (offset (* (tn-offset r) n-word-bytes)))
764 (inst swc1 real nfp offset)
765 (inst swc1 imag nfp (+ offset n-word-bytes)))))))
767 (define-vop (make-complex-double-float)
769 (:args (real :scs (double-reg) :target r)
770 (imag :scs (double-reg) :to :save))
771 (:arg-types double-float double-float)
772 (:results (r :scs (complex-double-reg) :from (:argument 0)
773 :load-if (not (sc-is r complex-double-stack))))
774 (:result-types complex-double-float)
775 (:note "inline complex double-float creation")
781 (let ((r-real (complex-double-reg-real-tn r)))
782 (unless (location= real r-real)
783 (inst fmove :double r-real real)))
784 (let ((r-imag (complex-double-reg-imag-tn r)))
785 (unless (location= imag r-imag)
786 (inst fmove :double r-imag imag))))
787 (complex-double-stack
788 (let ((nfp (current-nfp-tn vop))
789 (offset (* (tn-offset r) n-word-bytes)))
790 (str-double real nfp offset)
791 (str-double imag nfp (+ offset (* 2 n-word-bytes))))))))
794 (define-vop (complex-single-float-value)
795 (:args (x :scs (complex-single-reg) :target r
796 :load-if (not (sc-is x complex-single-stack))))
797 (:arg-types complex-single-float)
798 (:results (r :scs (single-reg)))
799 (:result-types single-float)
806 (let ((value-tn (ecase slot
807 (:real (complex-single-reg-real-tn x))
808 (:imag (complex-single-reg-imag-tn x)))))
809 (unless (location= value-tn r)
810 (inst fmove :single r value-tn))))
811 (complex-single-stack
812 (inst lwc1 r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
817 (define-vop (realpart/complex-single-float complex-single-float-value)
818 (:translate realpart)
819 (:note "complex single float realpart")
822 (define-vop (imagpart/complex-single-float complex-single-float-value)
823 (:translate imagpart)
824 (:note "complex single float imagpart")
827 (define-vop (complex-double-float-value)
828 (:args (x :scs (complex-double-reg) :target r
829 :load-if (not (sc-is x complex-double-stack))))
830 (:arg-types complex-double-float)
831 (:results (r :scs (double-reg)))
832 (:result-types double-float)
839 (let ((value-tn (ecase slot
840 (:real (complex-double-reg-real-tn x))
841 (:imag (complex-double-reg-imag-tn x)))))
842 (unless (location= value-tn r)
843 (inst fmove :double r value-tn))))
844 (complex-double-stack
845 (ld-double r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
850 (define-vop (realpart/complex-double-float complex-double-float-value)
851 (:translate realpart)
852 (:note "complex double float realpart")
855 (define-vop (imagpart/complex-double-float complex-double-float-value)
856 (:translate imagpart)
857 (:note "complex double float imagpart")