1 ;;;; floating point support for the Sparc
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-single 1) (vop x y)
17 ((single-stack) (single-reg))
18 (inst ldf y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes)))
20 (define-move-fun (store-single 1) (vop x y)
21 ((single-reg) (single-stack))
22 (inst stf x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
25 (define-move-fun (load-double 2) (vop x y)
26 ((double-stack) (double-reg))
27 (let ((nfp (current-nfp-tn vop))
28 (offset (* (tn-offset x) n-word-bytes)))
29 (inst lddf y nfp offset)))
31 (define-move-fun (store-double 2) (vop x y)
32 ((double-reg) (double-stack))
33 (let ((nfp (current-nfp-tn vop))
34 (offset (* (tn-offset y) n-word-bytes)))
35 (inst stdf x nfp offset)))
37 ;;; The offset may be an integer or a TN in which case it will be
38 ;;; temporarily modified but is restored if restore-offset is true.
39 (defun load-long-reg (reg base offset &optional (restore-offset t))
41 (inst ldqf reg base offset)
43 (let ((reg0 (make-random-tn :kind :normal
44 :sc (sc-or-lose 'double-reg)
45 :offset (tn-offset reg)))
46 (reg2 (make-random-tn :kind :normal
47 :sc (sc-or-lose 'double-reg)
48 :offset (+ 2 (tn-offset reg)))))
49 (cond ((integerp offset)
50 (inst lddf reg0 base offset)
51 (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
53 (inst lddf reg0 base offset)
54 (inst add offset (* 2 n-word-bytes))
55 (inst lddf reg2 base offset)
57 (inst sub offset (* 2 n-word-bytes)))))))
60 (define-move-fun (load-long 2) (vop x y)
61 ((long-stack) (long-reg))
62 (let ((nfp (current-nfp-tn vop))
63 (offset (* (tn-offset x) n-word-bytes)))
64 (load-long-reg y nfp offset)))
66 ;;; The offset may be an integer or a TN in which case it will be
67 ;;; temporarily modified but is restored if restore-offset is true.
68 (defun store-long-reg (reg base offset &optional (restore-offset t))
70 (inst stqf reg base offset)
72 (let ((reg0 (make-random-tn :kind :normal
73 :sc (sc-or-lose 'double-reg)
74 :offset (tn-offset reg)))
75 (reg2 (make-random-tn :kind :normal
76 :sc (sc-or-lose 'double-reg)
77 :offset (+ 2 (tn-offset reg)))))
78 (cond ((integerp offset)
79 (inst stdf reg0 base offset)
80 (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
82 (inst stdf reg0 base offset)
83 (inst add offset (* 2 n-word-bytes))
84 (inst stdf reg2 base offset)
86 (inst sub offset (* 2 n-word-bytes)))))))
89 (define-move-fun (store-long 2) (vop x y)
90 ((long-reg) (long-stack))
91 (let ((nfp (current-nfp-tn vop))
92 (offset (* (tn-offset y) n-word-bytes)))
93 (store-long-reg x nfp offset)))
98 ;;; Exploit the V9 double-float move instruction. This is conditional
99 ;;; on the :sparc-v9 feature.
100 (defun move-double-reg (dst src)
105 (let ((dst (make-random-tn :kind :normal
106 :sc (sc-or-lose 'single-reg)
107 :offset (+ i (tn-offset dst))))
108 (src (make-random-tn :kind :normal
109 :sc (sc-or-lose 'single-reg)
110 :offset (+ i (tn-offset src)))))
111 (inst fmovs dst src))))
113 ;;; Exploit the V9 long-float move instruction. This is conditional
114 ;;; on the :sparc-v9 feature.
115 (defun move-long-reg (dst src)
120 (let ((dst (make-random-tn :kind :normal
121 :sc (sc-or-lose 'single-reg)
122 :offset (+ i (tn-offset dst))))
123 (src (make-random-tn :kind :normal
124 :sc (sc-or-lose 'single-reg)
125 :offset (+ i (tn-offset src)))))
126 (inst fmovs dst src))))
128 (macrolet ((frob (vop sc format)
133 :load-if (not (location= x y))))
134 (:results (y :scs (,sc)
135 :load-if (not (location= x y))))
138 (unless (location= y x)
140 (:single `((inst fmovs y x)))
141 (:double `((move-double-reg y x)))
142 (:long `((move-long-reg y x)))))))
143 (define-move-vop ,vop :move (,sc) (,sc)))))
144 (frob single-move single-reg :single)
145 (frob double-move double-reg :double)
147 (frob long-move long-reg :long))
150 (define-vop (move-from-float)
151 (:args (x :to :save))
153 (:note "float to pointer coercion")
154 (:temporary (:scs (non-descriptor-reg)) ndescr)
155 (:variant-vars format size type data)
157 (with-fixed-allocation (y ndescr type size))
160 (inst stf x y (- (* data n-word-bytes) other-pointer-lowtag)))
162 (inst stdf x y (- (* data n-word-bytes) other-pointer-lowtag)))
164 (store-long-reg x y (- (* data n-word-bytes)
165 other-pointer-lowtag))))))
167 (macrolet ((frob (name sc &rest args)
169 (define-vop (,name move-from-float)
170 (:args (x :scs (,sc) :to :save))
171 (:results (y :scs (descriptor-reg)))
173 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
174 (frob move-from-single single-reg :single
175 single-float-size single-float-widetag single-float-value-slot)
176 (frob move-from-double double-reg :double
177 double-float-size double-float-widetag double-float-value-slot)
179 (frob move-from-long long-reg :long
180 long-float-size long-float-widetag long-float-value-slot))
182 (macrolet ((frob (name sc format value)
185 (:args (x :scs (descriptor-reg)))
186 (:results (y :scs (,sc)))
187 (:note "pointer to float coercion")
193 (- (* ,value n-word-bytes) other-pointer-lowtag))))
194 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
195 (frob move-to-single single-reg :single single-float-value-slot)
196 (frob move-to-double double-reg :double double-float-value-slot))
199 (define-vop (move-to-long)
200 (:args (x :scs (descriptor-reg)))
201 (:results (y :scs (long-reg)))
202 (:note "pointer to float coercion")
204 (load-long-reg y x (- (* long-float-value-slot n-word-bytes)
205 other-pointer-lowtag))))
207 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
209 (macrolet ((frob (name sc stack-sc format)
212 (:args (x :scs (,sc) :target y)
214 :load-if (not (sc-is y ,sc))))
216 (:note "float argument move")
217 (:generator ,(ecase format (:single 1) (:double 2))
220 (unless (location= x y)
222 (:single '((inst fmovs y x)))
223 (:double '((move-double-reg y x))))))
225 (let ((offset (* (tn-offset y) n-word-bytes)))
230 (define-move-vop ,name :move-arg
231 (,sc descriptor-reg) (,sc)))))
232 (frob move-single-float-arg single-reg single-stack :single)
233 (frob move-double-float-arg double-reg double-stack :double))
236 (define-vop (move-long-float-arg)
237 (:args (x :scs (long-reg) :target y)
238 (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
240 (:note "float argument move")
244 (unless (location= x y)
245 (move-long-reg y x)))
247 (let ((offset (* (tn-offset y) n-word-bytes)))
248 (store-long-reg x nfp offset))))))
251 (define-move-vop move-long-float-arg :move-arg
252 (long-reg descriptor-reg) (long-reg))
255 ;;;; Complex float move functions
257 (defun complex-single-reg-real-tn (x)
258 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
259 :offset (tn-offset x)))
260 (defun complex-single-reg-imag-tn (x)
261 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
262 :offset (1+ (tn-offset x))))
264 (defun complex-double-reg-real-tn (x)
265 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
266 :offset (tn-offset x)))
267 (defun complex-double-reg-imag-tn (x)
268 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
269 :offset (+ (tn-offset x) 2)))
272 (defun complex-long-reg-real-tn (x)
273 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
274 :offset (tn-offset x)))
276 (defun complex-long-reg-imag-tn (x)
277 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
278 :offset (+ (tn-offset x) 4)))
281 (define-move-fun (load-complex-single 2) (vop x y)
282 ((complex-single-stack) (complex-single-reg))
283 (let ((nfp (current-nfp-tn vop))
284 (offset (* (tn-offset x) n-word-bytes)))
285 (let ((real-tn (complex-single-reg-real-tn y)))
286 (inst ldf real-tn nfp offset))
287 (let ((imag-tn (complex-single-reg-imag-tn y)))
288 (inst ldf imag-tn nfp (+ offset n-word-bytes)))))
290 (define-move-fun (store-complex-single 2) (vop x y)
291 ((complex-single-reg) (complex-single-stack))
292 (let ((nfp (current-nfp-tn vop))
293 (offset (* (tn-offset y) n-word-bytes)))
294 (let ((real-tn (complex-single-reg-real-tn x)))
295 (inst stf real-tn nfp offset))
296 (let ((imag-tn (complex-single-reg-imag-tn x)))
297 (inst stf imag-tn nfp (+ offset n-word-bytes)))))
300 (define-move-fun (load-complex-double 4) (vop x y)
301 ((complex-double-stack) (complex-double-reg))
302 (let ((nfp (current-nfp-tn vop))
303 (offset (* (tn-offset x) n-word-bytes)))
304 (let ((real-tn (complex-double-reg-real-tn y)))
305 (inst lddf real-tn nfp offset))
306 (let ((imag-tn (complex-double-reg-imag-tn y)))
307 (inst lddf imag-tn nfp (+ offset (* 2 n-word-bytes))))))
309 (define-move-fun (store-complex-double 4) (vop x y)
310 ((complex-double-reg) (complex-double-stack))
311 (let ((nfp (current-nfp-tn vop))
312 (offset (* (tn-offset y) n-word-bytes)))
313 (let ((real-tn (complex-double-reg-real-tn x)))
314 (inst stdf real-tn nfp offset))
315 (let ((imag-tn (complex-double-reg-imag-tn x)))
316 (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes))))))
320 (define-move-fun (load-complex-long 5) (vop x y)
321 ((complex-long-stack) (complex-long-reg))
322 (let ((nfp (current-nfp-tn vop))
323 (offset (* (tn-offset x) n-word-bytes)))
324 (let ((real-tn (complex-long-reg-real-tn y)))
325 (load-long-reg real-tn nfp offset))
326 (let ((imag-tn (complex-long-reg-imag-tn y)))
327 (load-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))
330 (define-move-fun (store-complex-long 5) (vop x y)
331 ((complex-long-reg) (complex-long-stack))
332 (let ((nfp (current-nfp-tn vop))
333 (offset (* (tn-offset y) n-word-bytes)))
334 (let ((real-tn (complex-long-reg-real-tn x)))
335 (store-long-reg real-tn nfp offset))
336 (let ((imag-tn (complex-long-reg-imag-tn x)))
337 (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))
340 ;;; Complex float register to register moves.
342 (define-vop (complex-single-move)
343 (:args (x :scs (complex-single-reg) :target y
344 :load-if (not (location= x y))))
345 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
346 (:note "complex single float move")
348 (unless (location= x y)
349 ;; Note the complex-float-regs are aligned to every second
350 ;; float register so there is not need to worry about overlap.
351 (let ((x-real (complex-single-reg-real-tn x))
352 (y-real (complex-single-reg-real-tn y)))
353 (inst fmovs y-real x-real))
354 (let ((x-imag (complex-single-reg-imag-tn x))
355 (y-imag (complex-single-reg-imag-tn y)))
356 (inst fmovs y-imag x-imag)))))
358 (define-move-vop complex-single-move :move
359 (complex-single-reg) (complex-single-reg))
361 (define-vop (complex-double-move)
362 (:args (x :scs (complex-double-reg)
363 :target y :load-if (not (location= x y))))
364 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
365 (:note "complex double float move")
367 (unless (location= x y)
368 ;; Note the complex-float-regs are aligned to every second
369 ;; float register so there is not need to worry about overlap.
370 (let ((x-real (complex-double-reg-real-tn x))
371 (y-real (complex-double-reg-real-tn y)))
372 (move-double-reg y-real x-real))
373 (let ((x-imag (complex-double-reg-imag-tn x))
374 (y-imag (complex-double-reg-imag-tn y)))
375 (move-double-reg y-imag x-imag)))))
377 (define-move-vop complex-double-move :move
378 (complex-double-reg) (complex-double-reg))
381 (define-vop (complex-long-move)
382 (:args (x :scs (complex-long-reg)
383 :target y :load-if (not (location= x y))))
384 (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))
385 (:note "complex long float move")
387 (unless (location= x y)
388 ;; Note the complex-float-regs are aligned to every second
389 ;; float register so there is not need to worry about overlap.
390 (let ((x-real (complex-long-reg-real-tn x))
391 (y-real (complex-long-reg-real-tn y)))
392 (move-long-reg y-real x-real))
393 (let ((x-imag (complex-long-reg-imag-tn x))
394 (y-imag (complex-long-reg-imag-tn y)))
395 (move-long-reg y-imag x-imag)))))
398 (define-move-vop complex-long-move :move
399 (complex-long-reg) (complex-long-reg))
402 ;;; Move from a complex float to a descriptor register allocating a
403 ;;; new complex float object in the process.
405 (define-vop (move-from-complex-single)
406 (:args (x :scs (complex-single-reg) :to :save))
407 (:results (y :scs (descriptor-reg)))
408 (:temporary (:scs (non-descriptor-reg)) ndescr)
409 (:note "complex single float to pointer coercion")
411 (with-fixed-allocation (y ndescr complex-single-float-widetag
412 complex-single-float-size))
413 (let ((real-tn (complex-single-reg-real-tn x)))
414 (inst stf real-tn y (- (* complex-single-float-real-slot
416 other-pointer-lowtag)))
417 (let ((imag-tn (complex-single-reg-imag-tn x)))
418 (inst stf imag-tn y (- (* complex-single-float-imag-slot
420 other-pointer-lowtag)))))
422 (define-move-vop move-from-complex-single :move
423 (complex-single-reg) (descriptor-reg))
425 (define-vop (move-from-complex-double)
426 (:args (x :scs (complex-double-reg) :to :save))
427 (:results (y :scs (descriptor-reg)))
428 (:temporary (:scs (non-descriptor-reg)) ndescr)
429 (:note "complex double float to pointer coercion")
431 (with-fixed-allocation (y ndescr complex-double-float-widetag
432 complex-double-float-size))
433 (let ((real-tn (complex-double-reg-real-tn x)))
434 (inst stdf real-tn y (- (* complex-double-float-real-slot
436 other-pointer-lowtag)))
437 (let ((imag-tn (complex-double-reg-imag-tn x)))
438 (inst stdf imag-tn y (- (* complex-double-float-imag-slot
440 other-pointer-lowtag)))))
442 (define-move-vop move-from-complex-double :move
443 (complex-double-reg) (descriptor-reg))
446 (define-vop (move-from-complex-long)
447 (:args (x :scs (complex-long-reg) :to :save))
448 (:results (y :scs (descriptor-reg)))
449 (:temporary (:scs (non-descriptor-reg)) ndescr)
450 (:note "complex long float to pointer coercion")
452 (with-fixed-allocation (y ndescr complex-long-float-widetag
453 complex-long-float-size))
454 (let ((real-tn (complex-long-reg-real-tn x)))
455 (store-long-reg real-tn y (- (* complex-long-float-real-slot
457 other-pointer-lowtag)))
458 (let ((imag-tn (complex-long-reg-imag-tn x)))
459 (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
461 other-pointer-lowtag)))))
464 (define-move-vop move-from-complex-long :move
465 (complex-long-reg) (descriptor-reg))
468 ;;; Move from a descriptor to a complex float register
470 (define-vop (move-to-complex-single)
471 (:args (x :scs (descriptor-reg)))
472 (:results (y :scs (complex-single-reg)))
473 (:note "pointer to complex float coercion")
475 (let ((real-tn (complex-single-reg-real-tn y)))
476 (inst ldf real-tn x (- (* complex-single-float-real-slot n-word-bytes)
477 other-pointer-lowtag)))
478 (let ((imag-tn (complex-single-reg-imag-tn y)))
479 (inst ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
480 other-pointer-lowtag)))))
481 (define-move-vop move-to-complex-single :move
482 (descriptor-reg) (complex-single-reg))
484 (define-vop (move-to-complex-double)
485 (:args (x :scs (descriptor-reg)))
486 (:results (y :scs (complex-double-reg)))
487 (:note "pointer to complex float coercion")
489 (let ((real-tn (complex-double-reg-real-tn y)))
490 (inst lddf real-tn x (- (* complex-double-float-real-slot n-word-bytes)
491 other-pointer-lowtag)))
492 (let ((imag-tn (complex-double-reg-imag-tn y)))
493 (inst lddf imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
494 other-pointer-lowtag)))))
495 (define-move-vop move-to-complex-double :move
496 (descriptor-reg) (complex-double-reg))
499 (define-vop (move-to-complex-long)
500 (:args (x :scs (descriptor-reg)))
501 (:results (y :scs (complex-long-reg)))
502 (:note "pointer to complex float coercion")
504 (let ((real-tn (complex-long-reg-real-tn y)))
505 (load-long-reg real-tn x (- (* complex-long-float-real-slot n-word-bytes)
506 other-pointer-lowtag)))
507 (let ((imag-tn (complex-long-reg-imag-tn y)))
508 (load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
509 other-pointer-lowtag)))))
511 (define-move-vop move-to-complex-long :move
512 (descriptor-reg) (complex-long-reg))
515 ;;; Complex float move-arg vop
517 (define-vop (move-complex-single-float-arg)
518 (:args (x :scs (complex-single-reg) :target y)
519 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
521 (:note "complex single-float argument move")
525 (unless (location= x y)
526 (let ((x-real (complex-single-reg-real-tn x))
527 (y-real (complex-single-reg-real-tn y)))
528 (inst fmovs y-real x-real))
529 (let ((x-imag (complex-single-reg-imag-tn x))
530 (y-imag (complex-single-reg-imag-tn y)))
531 (inst fmovs y-imag x-imag))))
532 (complex-single-stack
533 (let ((offset (* (tn-offset y) n-word-bytes)))
534 (let ((real-tn (complex-single-reg-real-tn x)))
535 (inst stf real-tn nfp offset))
536 (let ((imag-tn (complex-single-reg-imag-tn x)))
537 (inst stf imag-tn nfp (+ offset n-word-bytes))))))))
538 (define-move-vop move-complex-single-float-arg :move-arg
539 (complex-single-reg descriptor-reg) (complex-single-reg))
541 (define-vop (move-complex-double-float-arg)
542 (:args (x :scs (complex-double-reg) :target y)
543 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
545 (:note "complex double-float argument move")
549 (unless (location= x y)
550 (let ((x-real (complex-double-reg-real-tn x))
551 (y-real (complex-double-reg-real-tn y)))
552 (move-double-reg y-real x-real))
553 (let ((x-imag (complex-double-reg-imag-tn x))
554 (y-imag (complex-double-reg-imag-tn y)))
555 (move-double-reg y-imag x-imag))))
556 (complex-double-stack
557 (let ((offset (* (tn-offset y) n-word-bytes)))
558 (let ((real-tn (complex-double-reg-real-tn x)))
559 (inst stdf real-tn nfp offset))
560 (let ((imag-tn (complex-double-reg-imag-tn x)))
561 (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
562 (define-move-vop move-complex-double-float-arg :move-arg
563 (complex-double-reg descriptor-reg) (complex-double-reg))
566 (define-vop (move-complex-long-float-arg)
567 (:args (x :scs (complex-long-reg) :target y)
568 (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
570 (:note "complex long-float argument move")
574 (unless (location= x y)
575 (let ((x-real (complex-long-reg-real-tn x))
576 (y-real (complex-long-reg-real-tn y)))
577 (move-long-reg y-real x-real))
578 (let ((x-imag (complex-long-reg-imag-tn x))
579 (y-imag (complex-long-reg-imag-tn y)))
580 (move-long-reg y-imag x-imag))))
582 (let ((offset (* (tn-offset y) n-word-bytes)))
583 (let ((real-tn (complex-long-reg-real-tn x)))
584 (store-long-reg real-tn nfp offset))
585 (let ((imag-tn (complex-long-reg-imag-tn x)))
586 (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes)))))))))
588 (define-move-vop move-complex-long-float-arg :move-arg
589 (complex-long-reg descriptor-reg) (complex-long-reg))
592 (define-move-vop move-arg :move-arg
593 (single-reg double-reg #!+long-float long-reg
594 complex-single-reg complex-double-reg #!+long-float complex-long-reg)
598 ;;;; Arithmetic VOPs:
600 (define-vop (float-op)
604 (:note "inline float arithmetic")
606 (:save-p :compute-only))
608 (macrolet ((frob (name sc ptype)
609 `(define-vop (,name float-op)
610 (:args (x :scs (,sc))
612 (:results (r :scs (,sc)))
613 (:arg-types ,ptype ,ptype)
614 (:result-types ,ptype))))
615 (frob single-float-op single-reg single-float)
616 (frob double-float-op double-reg double-float)
618 (frob long-float-op long-reg long-float))
620 (macrolet ((frob (op sinst sname scost dinst dname dcost)
622 (define-vop (,sname single-float-op)
625 (inst ,sinst r x y)))
626 (define-vop (,dname double-float-op)
629 (inst ,dinst r x y))))))
630 (frob + fadds +/single-float 2 faddd +/double-float 2)
631 (frob - fsubs -/single-float 2 fsubd -/double-float 2)
632 (frob * fmuls */single-float 4 fmuld */double-float 5)
633 (frob / fdivs //single-float 12 fdivd //double-float 19))
636 (macrolet ((frob (op linst lname lcost)
637 `(define-vop (,lname long-float-op)
640 (inst ,linst r x y)))))
641 (frob + faddq +/long-float 2)
642 (frob - fsubq -/long-float 2)
643 (frob * fmulq */long-float 6)
644 (frob / fdivq //long-float 20))
647 (macrolet ((frob (name inst translate sc type)
649 (:args (x :scs (,sc)))
650 (:results (y :scs (,sc)))
651 (:translate ,translate)
654 (:result-types ,type)
655 (:note "inline float arithmetic")
657 (:save-p :compute-only)
659 (note-this-location vop :internal-error)
661 (frob abs/single-float fabss abs single-reg single-float)
662 (frob %negate/single-float fnegs %negate single-reg single-float))
664 (defun negate-double-reg (dst src)
668 ;; Negate the MS part of the numbers, then copy over the rest
671 (let ((dst-odd (make-random-tn :kind :normal
672 :sc (sc-or-lose 'single-reg)
673 :offset (+ 1 (tn-offset dst))))
674 (src-odd (make-random-tn :kind :normal
675 :sc (sc-or-lose 'single-reg)
676 :offset (+ 1 (tn-offset src)))))
677 (inst fmovs dst-odd src-odd)))
679 (defun abs-double-reg (dst src)
683 ;; Abs the MS part of the numbers, then copy over the rest
686 (let ((dst-2 (make-random-tn :kind :normal
687 :sc (sc-or-lose 'single-reg)
688 :offset (+ 1 (tn-offset dst))))
689 (src-2 (make-random-tn :kind :normal
690 :sc (sc-or-lose 'single-reg)
691 :offset (+ 1 (tn-offset src)))))
692 (inst fmovs dst-2 src-2)))
694 (define-vop (abs/double-float)
695 (:args (x :scs (double-reg)))
696 (:results (y :scs (double-reg)))
699 (:arg-types double-float)
700 (:result-types double-float)
701 (:note "inline float arithmetic")
703 (:save-p :compute-only)
705 (note-this-location vop :internal-error)
706 (abs-double-reg y x)))
708 (define-vop (%negate/double-float)
709 (:args (x :scs (double-reg)))
710 (:results (y :scs (double-reg)))
713 (:arg-types double-float)
714 (:result-types double-float)
715 (:note "inline float arithmetic")
717 (:save-p :compute-only)
719 (note-this-location vop :internal-error)
720 (negate-double-reg y x)))
723 (define-vop (abs/long-float)
724 (:args (x :scs (long-reg)))
725 (:results (y :scs (long-reg)))
728 (:arg-types long-float)
729 (:result-types long-float)
730 (:note "inline float arithmetic")
732 (:save-p :compute-only)
734 (note-this-location vop :internal-error)
740 (let ((y-odd (make-random-tn
742 :sc (sc-or-lose 'single-reg)
743 :offset (+ i 1 (tn-offset y))))
744 (x-odd (make-random-tn
746 :sc (sc-or-lose 'single-reg)
747 :offset (+ i 1 (tn-offset x)))))
748 (inst fmovs y-odd x-odd)))))
751 (define-vop (%negate/long-float)
752 (:args (x :scs (long-reg)))
753 (:results (y :scs (long-reg)))
756 (:arg-types long-float)
757 (:result-types long-float)
758 (:note "inline float arithmetic")
760 (:save-p :compute-only)
762 (note-this-location vop :internal-error)
768 (let ((y-odd (make-random-tn
770 :sc (sc-or-lose 'single-reg)
771 :offset (+ i 1 (tn-offset y))))
772 (x-odd (make-random-tn
774 :sc (sc-or-lose 'single-reg)
775 :offset (+ i 1 (tn-offset x)))))
776 (inst fmovs y-odd x-odd)))))
781 (define-vop (float-compare)
785 (:variant-vars format yep nope)
787 (:note "inline float comparison")
789 (:save-p :compute-only)
791 (note-this-location vop :internal-error)
793 (:single (inst fcmps x y))
794 (:double (inst fcmpd x y))
795 (:long (inst fcmpq x y)))
796 ;; The SPARC V9 doesn't need an instruction between a
797 ;; floating-point compare and a floating-point branch.
798 #!-:sparc-v9 (inst nop)
799 (inst fb (if not-p nope yep) target)
802 (macrolet ((frob (name sc ptype)
803 `(define-vop (,name float-compare)
804 (:args (x :scs (,sc))
806 (:arg-types ,ptype ,ptype))))
807 (frob single-float-compare single-reg single-float)
808 (frob double-float-compare double-reg double-float)
810 (frob long-float-compare long-reg long-float))
812 (macrolet ((frob (translate yep nope sname dname #!+long-float lname)
814 (define-vop (,sname single-float-compare)
815 (:translate ,translate)
816 (:variant :single ,yep ,nope))
817 (define-vop (,dname double-float-compare)
818 (:translate ,translate)
819 (:variant :double ,yep ,nope))
821 (define-vop (,lname long-float-compare)
822 (:translate ,translate)
823 (:variant :long ,yep ,nope)))))
824 (frob < :l :ge </single-float </double-float #!+long-float </long-float)
825 (frob > :g :le >/single-float >/double-float #!+long-float >/long-float)
826 (frob = :eq :ne eql/single-float eql/double-float #!+long-float eql/long-float))
829 (deftransform eql ((x y) (long-float long-float))
830 '(and (= (long-float-low-bits x) (long-float-low-bits y))
831 (= (long-float-mid-bits x) (long-float-mid-bits y))
832 (= (long-float-high-bits x) (long-float-high-bits y))
833 (= (long-float-exp-bits x) (long-float-exp-bits y))))
838 (macrolet ((frob (name translate inst to-sc to-type)
840 (:args (x :scs (signed-reg) :target stack-temp
841 :load-if (not (sc-is x signed-stack))))
842 (:temporary (:scs (single-stack) :from :argument) stack-temp)
843 (:temporary (:scs (single-reg) :to :result :target y) temp)
844 (:results (y :scs (,to-sc)))
845 (:arg-types signed-num)
846 (:result-types ,to-type)
848 (:note "inline float coercion")
849 (:translate ,translate)
851 (:save-p :compute-only)
858 (* (tn-offset temp) n-word-bytes))
864 (* (tn-offset stack-tn) n-word-bytes))
865 (note-this-location vop :internal-error)
866 (inst ,inst y temp))))))
867 (frob %single-float/signed %single-float fitos single-reg single-float)
868 (frob %double-float/signed %double-float fitod double-reg double-float)
870 (frob %long-float/signed %long-float fitoq long-reg long-float))
872 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
874 (:args (x :scs (,from-sc)))
875 (:results (y :scs (,to-sc)))
876 (:arg-types ,from-type)
877 (:result-types ,to-type)
879 (:note "inline float coercion")
880 (:translate ,translate)
882 (:save-p :compute-only)
884 (note-this-location vop :internal-error)
886 (frob %single-float/double-float %single-float fdtos
887 double-reg double-float single-reg single-float)
889 (frob %single-float/long-float %single-float fqtos
890 long-reg long-float single-reg single-float)
891 (frob %double-float/single-float %double-float fstod
892 single-reg single-float double-reg double-float)
894 (frob %double-float/long-float %double-float fqtod
895 long-reg long-float double-reg double-float)
897 (frob %long-float/single-float %long-float fstoq
898 single-reg single-float long-reg long-float)
900 (frob %long-float/double-float %long-float fdtoq
901 double-reg double-float long-reg long-float))
903 (macrolet ((frob (trans from-sc from-type inst)
904 `(define-vop (,(symbolicate trans "/" from-type))
905 (:args (x :scs (,from-sc) :target temp))
906 (:temporary (:from (:argument 0) :sc single-reg) temp)
907 (:temporary (:scs (signed-stack)) stack-temp)
908 (:results (y :scs (signed-reg)
909 :load-if (not (sc-is y signed-stack))))
910 (:arg-types ,from-type)
911 (:result-types signed-num)
914 (:note "inline float truncate")
916 (:save-p :compute-only)
918 (note-this-location vop :internal-error)
922 (inst stf temp (current-nfp-tn vop)
923 (* (tn-offset y) n-word-bytes)))
925 (inst stf temp (current-nfp-tn vop)
926 (* (tn-offset stack-temp) n-word-bytes))
927 (inst ld y (current-nfp-tn vop)
928 (* (tn-offset stack-temp) n-word-bytes))))))))
929 (frob %unary-truncate single-reg single-float fstoi)
930 (frob %unary-truncate double-reg double-float fdtoi)
932 (frob %unary-truncate long-reg long-float fqtoi)
933 ;; KLUDGE -- these two forms were protected by #-sun4.
934 ;; (frob %unary-round single-reg single-float fstoir)
935 ;; (frob %unary-round double-reg double-float fdtoir)
938 (deftransform %unary-round ((x) (float) (signed-byte 32))
939 '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
942 (one-half (float 1/2 x)))
946 (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
949 (define-vop (make-single-float)
950 (:args (bits :scs (signed-reg) :target res
951 :load-if (not (sc-is bits signed-stack))))
952 (:results (res :scs (single-reg)
953 :load-if (not (sc-is res single-stack))))
954 (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
955 (:temporary (:scs (signed-stack)) stack-temp)
956 (:arg-types signed-num)
957 (:result-types single-float)
958 (:translate make-single-float)
966 (inst st bits (current-nfp-tn vop)
967 (* (tn-offset stack-temp) n-word-bytes))
968 (inst ldf res (current-nfp-tn vop)
969 (* (tn-offset stack-temp) n-word-bytes)))
971 (inst st bits (current-nfp-tn vop)
972 (* (tn-offset res) n-word-bytes)))))
976 (inst ldf res (current-nfp-tn vop)
977 (* (tn-offset bits) n-word-bytes)))
979 (unless (location= bits res)
980 (inst ld temp (current-nfp-tn vop)
981 (* (tn-offset bits) n-word-bytes))
982 (inst st temp (current-nfp-tn vop)
983 (* (tn-offset res) n-word-bytes)))))))))
985 (define-vop (make-double-float)
986 (:args (hi-bits :scs (signed-reg))
987 (lo-bits :scs (unsigned-reg)))
988 (:results (res :scs (double-reg)
989 :load-if (not (sc-is res double-stack))))
990 (:temporary (:scs (double-stack)) temp)
991 (:arg-types signed-num unsigned-num)
992 (:result-types double-float)
993 (:translate make-double-float)
997 (let ((stack-tn (sc-case res
1000 (inst st hi-bits (current-nfp-tn vop)
1001 (* (tn-offset stack-tn) n-word-bytes))
1002 (inst st lo-bits (current-nfp-tn vop)
1003 (* (1+ (tn-offset stack-tn)) n-word-bytes)))
1004 (when (sc-is res double-reg)
1005 (inst lddf res (current-nfp-tn vop)
1006 (* (tn-offset temp) n-word-bytes)))))
1009 (define-vop (make-long-float)
1010 (:args (hi-bits :scs (signed-reg))
1011 (lo1-bits :scs (unsigned-reg))
1012 (lo2-bits :scs (unsigned-reg))
1013 (lo3-bits :scs (unsigned-reg)))
1014 (:results (res :scs (long-reg)
1015 :load-if (not (sc-is res long-stack))))
1016 (:temporary (:scs (long-stack)) temp)
1017 (:arg-types signed-num unsigned-num unsigned-num unsigned-num)
1018 (:result-types long-float)
1019 (:translate make-long-float)
1020 (:policy :fast-safe)
1023 (let ((stack-tn (sc-case res
1026 (inst st hi-bits (current-nfp-tn vop)
1027 (* (tn-offset stack-tn) n-word-bytes))
1028 (inst st lo1-bits (current-nfp-tn vop)
1029 (* (1+ (tn-offset stack-tn)) n-word-bytes))
1030 (inst st lo2-bits (current-nfp-tn vop)
1031 (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
1032 (inst st lo3-bits (current-nfp-tn vop)
1033 (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
1034 (when (sc-is res long-reg)
1035 (load-long-reg res (current-nfp-tn vop)
1036 (* (tn-offset temp) n-word-bytes)))))
1038 (define-vop (single-float-bits)
1039 (:args (float :scs (single-reg descriptor-reg)
1040 :load-if (not (sc-is float single-stack))))
1041 (:results (bits :scs (signed-reg)
1042 :load-if (or (sc-is float descriptor-reg single-stack)
1043 (not (sc-is bits signed-stack)))))
1044 (:temporary (:scs (signed-stack)) stack-temp)
1045 (:arg-types single-float)
1046 (:result-types signed-num)
1047 (:translate single-float-bits)
1048 (:policy :fast-safe)
1055 (inst stf float (current-nfp-tn vop)
1056 (* (tn-offset stack-temp) n-word-bytes))
1057 (inst ld bits (current-nfp-tn vop)
1058 (* (tn-offset stack-temp) n-word-bytes)))
1060 (inst ld bits (current-nfp-tn vop)
1061 (* (tn-offset float) n-word-bytes)))
1063 (loadw bits float single-float-value-slot
1064 other-pointer-lowtag))))
1068 (inst stf float (current-nfp-tn vop)
1069 (* (tn-offset bits) n-word-bytes))))))))
1071 (define-vop (double-float-high-bits)
1072 (:args (float :scs (double-reg descriptor-reg)
1073 :load-if (not (sc-is float double-stack))))
1074 (:results (hi-bits :scs (signed-reg)))
1075 (:temporary (:scs (double-stack)) stack-temp)
1076 (:arg-types double-float)
1077 (:result-types signed-num)
1078 (:translate double-float-high-bits)
1079 (:policy :fast-safe)
1084 (inst stdf float (current-nfp-tn vop)
1085 (* (tn-offset stack-temp) n-word-bytes))
1086 (inst ld hi-bits (current-nfp-tn vop)
1087 (* (tn-offset stack-temp) n-word-bytes)))
1089 (inst ld hi-bits (current-nfp-tn vop)
1090 (* (tn-offset float) n-word-bytes)))
1092 (loadw hi-bits float double-float-value-slot
1093 other-pointer-lowtag)))))
1095 (define-vop (double-float-low-bits)
1096 (:args (float :scs (double-reg descriptor-reg)
1097 :load-if (not (sc-is float double-stack))))
1098 (:results (lo-bits :scs (unsigned-reg)))
1099 (:temporary (:scs (double-stack)) stack-temp)
1100 (:arg-types double-float)
1101 (:result-types unsigned-num)
1102 (:translate double-float-low-bits)
1103 (:policy :fast-safe)
1108 (inst stdf float (current-nfp-tn vop)
1109 (* (tn-offset stack-temp) n-word-bytes))
1110 (inst ld lo-bits (current-nfp-tn vop)
1111 (* (1+ (tn-offset stack-temp)) n-word-bytes)))
1113 (inst ld lo-bits (current-nfp-tn vop)
1114 (* (1+ (tn-offset float)) n-word-bytes)))
1116 (loadw lo-bits float (1+ double-float-value-slot)
1117 other-pointer-lowtag)))))
1120 (define-vop (long-float-exp-bits)
1121 (:args (float :scs (long-reg descriptor-reg)
1122 :load-if (not (sc-is float long-stack))))
1123 (:results (exp-bits :scs (signed-reg)))
1124 (:temporary (:scs (double-stack)) stack-temp)
1125 (:arg-types long-float)
1126 (:result-types signed-num)
1127 (:translate long-float-exp-bits)
1128 (:policy :fast-safe)
1133 (let ((float (make-random-tn :kind :normal
1134 :sc (sc-or-lose 'double-reg)
1135 :offset (tn-offset float))))
1136 (inst stdf float (current-nfp-tn vop)
1137 (* (tn-offset stack-temp) n-word-bytes)))
1138 (inst ld exp-bits (current-nfp-tn vop)
1139 (* (tn-offset stack-temp) n-word-bytes)))
1141 (inst ld exp-bits (current-nfp-tn vop)
1142 (* (tn-offset float) n-word-bytes)))
1144 (loadw exp-bits float long-float-value-slot
1145 other-pointer-lowtag)))))
1148 (define-vop (long-float-high-bits)
1149 (:args (float :scs (long-reg descriptor-reg)
1150 :load-if (not (sc-is float long-stack))))
1151 (:results (high-bits :scs (unsigned-reg)))
1152 (:temporary (:scs (double-stack)) stack-temp)
1153 (:arg-types long-float)
1154 (:result-types unsigned-num)
1155 (:translate long-float-high-bits)
1156 (:policy :fast-safe)
1161 (let ((float (make-random-tn :kind :normal
1162 :sc (sc-or-lose 'double-reg)
1163 :offset (tn-offset float))))
1164 (inst stdf float (current-nfp-tn vop)
1165 (* (tn-offset stack-temp) n-word-bytes)))
1166 (inst ld high-bits (current-nfp-tn vop)
1167 (* (1+ (tn-offset stack-temp)) n-word-bytes)))
1169 (inst ld high-bits (current-nfp-tn vop)
1170 (* (1+ (tn-offset float)) n-word-bytes)))
1172 (loadw high-bits float (1+ long-float-value-slot)
1173 other-pointer-lowtag)))))
1176 (define-vop (long-float-mid-bits)
1177 (:args (float :scs (long-reg descriptor-reg)
1178 :load-if (not (sc-is float long-stack))))
1179 (:results (mid-bits :scs (unsigned-reg)))
1180 (:temporary (:scs (double-stack)) stack-temp)
1181 (:arg-types long-float)
1182 (:result-types unsigned-num)
1183 (:translate long-float-mid-bits)
1184 (:policy :fast-safe)
1189 (let ((float (make-random-tn :kind :normal
1190 :sc (sc-or-lose 'double-reg)
1191 :offset (+ 2 (tn-offset float)))))
1192 (inst stdf float (current-nfp-tn vop)
1193 (* (tn-offset stack-temp) n-word-bytes)))
1194 (inst ld mid-bits (current-nfp-tn vop)
1195 (* (tn-offset stack-temp) n-word-bytes)))
1197 (inst ld mid-bits (current-nfp-tn vop)
1198 (* (+ 2 (tn-offset float)) n-word-bytes)))
1200 (loadw mid-bits float (+ 2 long-float-value-slot)
1201 other-pointer-lowtag)))))
1204 (define-vop (long-float-low-bits)
1205 (:args (float :scs (long-reg descriptor-reg)
1206 :load-if (not (sc-is float long-stack))))
1207 (:results (lo-bits :scs (unsigned-reg)))
1208 (:temporary (:scs (double-stack)) stack-temp)
1209 (:arg-types long-float)
1210 (:result-types unsigned-num)
1211 (:translate long-float-low-bits)
1212 (:policy :fast-safe)
1217 (let ((float (make-random-tn :kind :normal
1218 :sc (sc-or-lose 'double-reg)
1219 :offset (+ 2 (tn-offset float)))))
1220 (inst stdf float (current-nfp-tn vop)
1221 (* (tn-offset stack-temp) n-word-bytes)))
1222 (inst ld lo-bits (current-nfp-tn vop)
1223 (* (1+ (tn-offset stack-temp)) n-word-bytes)))
1225 (inst ld lo-bits (current-nfp-tn vop)
1226 (* (+ 3 (tn-offset float)) n-word-bytes)))
1228 (loadw lo-bits float (+ 3 long-float-value-slot)
1229 other-pointer-lowtag)))))
1232 ;;;; Float mode hackery:
1234 (sb!xc:deftype float-modes () '(unsigned-byte 32))
1235 (defknown floating-point-modes () float-modes (flushable))
1236 (defknown ((setf floating-point-modes)) (float-modes)
1239 (define-vop (floating-point-modes)
1240 (:results (res :scs (unsigned-reg)))
1241 (:result-types unsigned-num)
1242 (:translate floating-point-modes)
1243 (:policy :fast-safe)
1245 (:temporary (:sc unsigned-stack) temp)
1247 (let ((nfp (current-nfp-tn vop)))
1248 (inst stfsr nfp (* n-word-bytes (tn-offset temp)))
1249 (loadw res nfp (tn-offset temp))
1253 (define-vop (floating-point-modes)
1254 (:results (res :scs (unsigned-reg)))
1255 (:result-types unsigned-num)
1256 (:translate floating-point-modes)
1257 (:policy :fast-safe)
1259 (:temporary (:sc double-stack) temp)
1261 (let* ((nfp (current-nfp-tn vop))
1262 (offset (* 4 (tn-offset temp))))
1263 (inst stxfsr nfp offset)
1264 ;; The desired FP mode data is in the least significant 32
1265 ;; bits, which is stored at the next higher word in memory.
1266 (loadw res nfp (+ offset 4))
1267 ;; Is this nop needed? (toy@rtp.ericsson.se)
1270 (define-vop (set-floating-point-modes)
1271 (:args (new :scs (unsigned-reg) :target res))
1272 (:results (res :scs (unsigned-reg)))
1273 (:arg-types unsigned-num)
1274 (:result-types unsigned-num)
1275 (:translate (setf floating-point-modes))
1276 (:policy :fast-safe)
1277 (:temporary (:sc unsigned-stack) temp)
1280 (let ((nfp (current-nfp-tn vop)))
1281 (storew new nfp (tn-offset temp))
1282 (inst ldfsr nfp (* n-word-bytes (tn-offset temp)))
1286 (define-vop (set-floating-point-modes)
1287 (:args (new :scs (unsigned-reg) :target res))
1288 (:results (res :scs (unsigned-reg)))
1289 (:arg-types unsigned-num)
1290 (:result-types unsigned-num)
1291 (:translate (setf floating-point-modes))
1292 (:policy :fast-safe)
1293 (:temporary (:sc double-stack) temp)
1294 (:temporary (:sc unsigned-reg) my-fsr)
1297 (let ((nfp (current-nfp-tn vop))
1298 (offset (* n-word-bytes (tn-offset temp))))
1300 ;; Get the current FSR, so we can get the new %fcc's
1301 (inst stxfsr nfp offset)
1302 (inst ldx my-fsr nfp offset)
1303 ;; Carefully merge in the new mode bits with the rest of the
1304 ;; FSR. This is only needed if we care about preserving the
1305 ;; high 32 bits of the FSR, which contain the additional
1306 ;; %fcc's on the sparc V9. If not, we don't need this, but we
1307 ;; do need to make sure that the unused bits are written as
1308 ;; zeroes, according the the V9 architecture manual.
1310 (inst srlx my-fsr 32)
1311 (inst sllx my-fsr 32)
1312 (inst or my-fsr new)
1313 ;; Save it back and load it into the fsr register
1314 (inst stx my-fsr nfp offset)
1315 (inst ldxfsr nfp offset)
1319 (define-vop (set-floating-point-modes)
1320 (:args (new :scs (unsigned-reg) :target res))
1321 (:results (res :scs (unsigned-reg)))
1322 (:arg-types unsigned-num)
1323 (:result-types unsigned-num)
1324 (:translate (setf floating-point-modes))
1325 (:policy :fast-safe)
1326 (:temporary (:sc double-stack) temp)
1327 (:temporary (:sc unsigned-reg) my-fsr)
1330 (let ((nfp (current-nfp-tn vop))
1331 (offset (* n-word-bytes (tn-offset temp))))
1332 (inst stx new nfp offset)
1333 (inst ldxfsr nfp offset)
1337 ;;;; Special functions.
1341 (:args (x :scs (double-reg)))
1342 (:results (y :scs (double-reg)))
1344 (:policy :fast-safe)
1345 (:guard #!+(or :sparc-v7 :sparc-v8 :sparc-v9) t
1346 #!-(or :sparc-v7 :sparc-v8 :sparc-v9) nil)
1347 (:arg-types double-float)
1348 (:result-types double-float)
1349 (:note "inline float arithmetic")
1351 (:save-p :compute-only)
1353 (note-this-location vop :internal-error)
1357 (define-vop (fsqrt-long)
1358 (:args (x :scs (long-reg)))
1359 (:results (y :scs (long-reg)))
1361 (:policy :fast-safe)
1362 (:arg-types long-float)
1363 (:result-types long-float)
1364 (:note "inline float arithmetic")
1366 (:save-p :compute-only)
1368 (note-this-location vop :internal-error)
1372 ;;;; Complex float VOPs
1374 (define-vop (make-complex-single-float)
1375 (:translate complex)
1376 (:args (real :scs (single-reg) :target r
1377 :load-if (not (location= real r)))
1378 (imag :scs (single-reg) :to :save))
1379 (:arg-types single-float single-float)
1380 (:results (r :scs (complex-single-reg) :from (:argument 0)
1381 :load-if (not (sc-is r complex-single-stack))))
1382 (:result-types complex-single-float)
1383 (:note "inline complex single-float creation")
1384 (:policy :fast-safe)
1389 (let ((r-real (complex-single-reg-real-tn r)))
1390 (unless (location= real r-real)
1391 (inst fmovs r-real real)))
1392 (let ((r-imag (complex-single-reg-imag-tn r)))
1393 (unless (location= imag r-imag)
1394 (inst fmovs r-imag imag))))
1395 (complex-single-stack
1396 (let ((nfp (current-nfp-tn vop))
1397 (offset (* (tn-offset r) n-word-bytes)))
1398 (unless (location= real r)
1399 (inst stf real nfp offset))
1400 (inst stf imag nfp (+ offset n-word-bytes)))))))
1402 (define-vop (make-complex-double-float)
1403 (:translate complex)
1404 (:args (real :scs (double-reg) :target r
1405 :load-if (not (location= real r)))
1406 (imag :scs (double-reg) :to :save))
1407 (:arg-types double-float double-float)
1408 (:results (r :scs (complex-double-reg) :from (:argument 0)
1409 :load-if (not (sc-is r complex-double-stack))))
1410 (:result-types complex-double-float)
1411 (:note "inline complex double-float creation")
1412 (:policy :fast-safe)
1417 (let ((r-real (complex-double-reg-real-tn r)))
1418 (unless (location= real r-real)
1419 (move-double-reg r-real real)))
1420 (let ((r-imag (complex-double-reg-imag-tn r)))
1421 (unless (location= imag r-imag)
1422 (move-double-reg r-imag imag))))
1423 (complex-double-stack
1424 (let ((nfp (current-nfp-tn vop))
1425 (offset (* (tn-offset r) n-word-bytes)))
1426 (unless (location= real r)
1427 (inst stdf real nfp offset))
1428 (inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))
1431 (define-vop (make-complex-long-float)
1432 (:translate complex)
1433 (:args (real :scs (long-reg) :target r
1434 :load-if (not (location= real r)))
1435 (imag :scs (long-reg) :to :save))
1436 (:arg-types long-float long-float)
1437 (:results (r :scs (complex-long-reg) :from (:argument 0)
1438 :load-if (not (sc-is r complex-long-stack))))
1439 (:result-types complex-long-float)
1440 (:note "inline complex long-float creation")
1441 (:policy :fast-safe)
1446 (let ((r-real (complex-long-reg-real-tn r)))
1447 (unless (location= real r-real)
1448 (move-long-reg r-real real)))
1449 (let ((r-imag (complex-long-reg-imag-tn r)))
1450 (unless (location= imag r-imag)
1451 (move-long-reg r-imag imag))))
1453 (let ((nfp (current-nfp-tn vop))
1454 (offset (* (tn-offset r) n-word-bytes)))
1455 (unless (location= real r)
1456 (store-long-reg real nfp offset))
1457 (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))
1459 (define-vop (complex-single-float-value)
1460 (:args (x :scs (complex-single-reg) :target r
1461 :load-if (not (sc-is x complex-single-stack))))
1462 (:arg-types complex-single-float)
1463 (:results (r :scs (single-reg)))
1464 (:result-types single-float)
1465 (:variant-vars slot)
1466 (:policy :fast-safe)
1471 (let ((value-tn (ecase slot
1472 (:real (complex-single-reg-real-tn x))
1473 (:imag (complex-single-reg-imag-tn x)))))
1474 (unless (location= value-tn r)
1475 (inst fmovs r value-tn))))
1476 (complex-single-stack
1477 (inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
1481 (define-vop (realpart/complex-single-float complex-single-float-value)
1482 (:translate realpart)
1483 (:note "complex single float realpart")
1486 (define-vop (imagpart/complex-single-float complex-single-float-value)
1487 (:translate imagpart)
1488 (:note "complex single float imagpart")
1491 (define-vop (complex-double-float-value)
1492 (:args (x :scs (complex-double-reg) :target r
1493 :load-if (not (sc-is x complex-double-stack))))
1494 (:arg-types complex-double-float)
1495 (:results (r :scs (double-reg)))
1496 (:result-types double-float)
1497 (:variant-vars slot)
1498 (:policy :fast-safe)
1503 (let ((value-tn (ecase slot
1504 (:real (complex-double-reg-real-tn x))
1505 (:imag (complex-double-reg-imag-tn x)))))
1506 (unless (location= value-tn r)
1507 (move-double-reg r value-tn))))
1508 (complex-double-stack
1509 (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
1513 (define-vop (realpart/complex-double-float complex-double-float-value)
1514 (:translate realpart)
1515 (:note "complex double float realpart")
1518 (define-vop (imagpart/complex-double-float complex-double-float-value)
1519 (:translate imagpart)
1520 (:note "complex double float imagpart")
1524 (define-vop (complex-long-float-value)
1525 (:args (x :scs (complex-long-reg) :target r
1526 :load-if (not (sc-is x complex-long-stack))))
1527 (:arg-types complex-long-float)
1528 (:results (r :scs (long-reg)))
1529 (:result-types long-float)
1530 (:variant-vars slot)
1531 (:policy :fast-safe)
1536 (let ((value-tn (ecase slot
1537 (:real (complex-long-reg-real-tn x))
1538 (:imag (complex-long-reg-imag-tn x)))))
1539 (unless (location= value-tn r)
1540 (move-long-reg r value-tn))))
1542 (load-long-reg r (current-nfp-tn vop)
1543 (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
1547 (define-vop (realpart/complex-long-float complex-long-float-value)
1548 (:translate realpart)
1549 (:note "complex long float realpart")
1553 (define-vop (imagpart/complex-long-float complex-long-float-value)
1554 (:translate imagpart)
1555 (:note "complex long float imagpart")
1560 ;;;; Complex float arithmetic
1567 ((frob (float-type fneg cost)
1568 (let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type))
1569 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1570 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1571 (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1572 (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1573 `(define-vop (,vop-name)
1574 (:args (x :scs (,complex-reg)))
1575 (:arg-types ,c-type)
1576 (:results (r :scs (,complex-reg)))
1577 (:result-types ,c-type)
1578 (:policy :fast-safe)
1579 (:note "inline complex float arithmetic")
1580 (:translate %negate)
1582 (let ((xr (,real-tn x))
1587 (,@fneg ri xi)))))))
1588 (frob single (inst fnegs) 4)
1589 (frob double (negate-double-reg) 4))
1591 ;; Add and subtract for two complex arguments
1593 ((frob (op inst float-type cost)
1594 (let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT"))
1595 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1596 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1597 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1598 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1599 `(define-vop (,vop-name)
1600 (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
1601 (:results (r :scs (,complex-reg)))
1602 (:arg-types ,c-type ,c-type)
1603 (:result-types ,c-type)
1604 (:policy :fast-safe)
1605 (:note "inline complex float arithmetic")
1608 (let ((xr (,real-part x))
1613 (ri (,imag-part r)))
1614 (inst ,inst rr xr yr)
1615 (inst ,inst ri xi yi)))))))
1616 (frob + fadds single 4)
1617 (frob + faddd double 4)
1618 (frob - fsubs single 4)
1619 (frob - fsubd double 4))
1621 ;; Add and subtract a complex and a float
1624 ((frob (size op fop fmov cost)
1625 (let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-"
1628 (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1629 (real-reg (symbolicate size "-REG"))
1630 (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1631 (r-type (symbolicate size "-FLOAT"))
1632 (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1633 (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1634 `(define-vop (,vop-name)
1635 (:args (x :scs (,complex-reg))
1636 (y :scs (,real-reg)))
1637 (:results (r :scs (,complex-reg)))
1638 (:arg-types ,c-type ,r-type)
1639 (:result-types ,c-type)
1640 (:policy :fast-safe)
1641 (:note "inline complex float/float arithmetic")
1644 (let ((xr (,real-part x))
1647 (ri (,imag-part r)))
1649 (unless (location= ri xi)
1650 (,@fmov ri xi))))))))
1652 (frob single + fadds (inst fmovs) 2)
1653 (frob single - fsubs (inst fmovs) 2)
1654 (frob double + faddd (move-double-reg) 4)
1655 (frob double - fsubd (move-double-reg) 4))
1657 ;; Add a float and a complex
1659 ((frob (size fop fmov cost)
1661 (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
1662 (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1663 (real-reg (symbolicate size "-REG"))
1664 (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1665 (r-type (symbolicate size "-FLOAT"))
1666 (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1667 (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1668 `(define-vop (,vop-name)
1669 (:args (y :scs (,real-reg))
1670 (x :scs (,complex-reg)))
1671 (:results (r :scs (,complex-reg)))
1672 (:arg-types ,r-type ,c-type)
1673 (:result-types ,c-type)
1674 (:policy :fast-safe)
1675 (:note "inline complex float/float arithmetic")
1678 (let ((xr (,real-part x))
1681 (ri (,imag-part r)))
1683 (unless (location= ri xi)
1684 (,@fmov ri xi))))))))
1685 (frob single fadds (inst fmovs) 1)
1686 (frob double faddd (move-double-reg) 2))
1688 ;; Subtract a complex from a float
1691 ((frob (size fop fneg cost)
1692 (let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT"))
1693 (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1694 (real-reg (symbolicate size "-REG"))
1695 (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1696 (r-type (symbolicate size "-FLOAT"))
1697 (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1698 (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1699 `(define-vop (single-float---complex-single-float)
1700 (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
1701 (:results (r :scs (,complex-reg)))
1702 (:arg-types ,r-type ,c-type)
1703 (:result-types ,c-type)
1704 (:policy :fast-safe)
1705 (:note "inline complex float/float arithmetic")
1708 (let ((yr (,real-part y))
1711 (ri (,imag-part r)))
1716 (frob single fsubs (inst fnegs) 2)
1717 (frob double fsubd (negate-double-reg) 2)))
1719 ;; Multiply two complex numbers
1723 ((frob (size fmul fadd fsub cost)
1724 (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
1725 (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1726 (real-reg (symbolicate size "-REG"))
1727 (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1728 (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1729 (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1730 `(define-vop (,vop-name)
1731 (:args (x :scs (,complex-reg))
1732 (y :scs (,complex-reg)))
1733 (:results (r :scs (,complex-reg)))
1734 (:arg-types ,c-type ,c-type)
1735 (:result-types ,c-type)
1736 (:policy :fast-safe)
1737 (:note "inline complex float multiplication")
1739 (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
1741 (let ((xr (,real-part x))
1746 (ri (,imag-part r)))
1747 ;; All of the temps are needed in case the result TN happens to
1748 ;; be the same as one of the arg TN's
1749 (inst ,fmul prod-1 xr yr)
1750 (inst ,fmul prod-2 xi yi)
1751 (inst ,fmul prod-3 xr yi)
1752 (inst ,fmul prod-4 xi yr)
1753 (inst ,fsub rr prod-1 prod-2)
1754 (inst ,fadd ri prod-3 prod-4)))))))
1756 (frob single fmuls fadds fsubs 6)
1757 (frob double fmuld faddd fsubd 6))
1760 ((frob (size fmul fadd fsub cost)
1761 (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
1762 (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1763 (real-reg (symbolicate size "-REG"))
1764 (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1765 (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1766 (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1767 `(define-vop (,vop-name)
1768 (:args (x :scs (,complex-reg))
1769 (y :scs (,complex-reg)))
1770 (:results (r :scs (,complex-reg)))
1771 (:arg-types ,c-type ,c-type)
1772 (:result-types ,c-type)
1773 (:policy :fast-safe)
1774 (:note "inline complex float multiplication")
1776 (:temporary (:scs (,real-reg)) p1 p2)
1778 (let ((xr (,real-part x))
1783 (ri (,imag-part r)))
1784 (cond ((location= r x)
1785 (inst ,fmul p1 xr yr)
1786 (inst ,fmul p2 xr yi)
1787 (inst ,fmul rr xi yi)
1788 (inst ,fsub rr p1 xr)
1789 (inst ,fmul p1 xi yr)
1790 (inst ,fadd ri p2 p1))
1792 (inst ,fmul p1 yr xr)
1793 (inst ,fmul p2 yr xi)
1794 (inst ,fmul rr yi xi)
1795 (inst ,fsub rr p1 rr)
1796 (inst ,fmul p1 yi xr)
1797 (inst ,fadd ri p2 p1))
1799 (inst ,fmul rr yr xr)
1800 (inst ,fmul ri xi yi)
1801 (inst ,fsub rr rr ri)
1802 (inst ,fmul p1 xr yi)
1803 (inst ,fmul ri xi yr)
1804 (inst ,fadd ri ri p1)))))))))
1806 (frob single fmuls fadds fsubs 6)
1807 (frob double fmuld faddd fsubd 6))
1809 ;; Multiply a complex by a float. The case of float * complex is
1810 ;; handled by a deftransform to convert it to the complex*float case.
1812 ((frob (float-type fmul mov cost)
1813 (let* ((vop-name (symbolicate "COMPLEX-"
1818 (vop-name-r (symbolicate float-type
1822 (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
1823 (real-sc-type (symbolicate float-type "-REG"))
1824 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1825 (r-type (symbolicate float-type "-FLOAT"))
1826 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1827 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1830 (define-vop (,vop-name)
1831 (:args (x :scs (,complex-sc-type))
1832 (y :scs (,real-sc-type)))
1833 (:results (r :scs (,complex-sc-type)))
1834 (:arg-types ,c-type ,r-type)
1835 (:result-types ,c-type)
1836 (:policy :fast-safe)
1837 (:note "inline complex float arithmetic")
1839 (:temporary (:scs (,real-sc-type)) temp)
1841 (let ((xr (,real-part x))
1844 (ri (,imag-part r)))
1845 (cond ((location= y rr)
1846 (inst ,fmul temp xr y) ; xr * y
1847 (inst ,fmul ri xi y) ; xi * yi
1850 (inst ,fmul rr xr y)
1851 (inst ,fmul ri xi y))))))
1853 (define-vop (,vop-name-r)
1854 (:args (y :scs (,real-sc-type))
1855 (x :scs (,complex-sc-type)))
1856 (:results (r :scs (,complex-sc-type)))
1857 (:arg-types ,r-type ,c-type)
1858 (:result-types ,c-type)
1859 (:policy :fast-safe)
1860 (:note "inline complex float arithmetic")
1862 (:temporary (:scs (,real-sc-type)) temp)
1864 (let ((xr (,real-part x))
1867 (ri (,imag-part r)))
1868 (cond ((location= y rr)
1869 (inst ,fmul temp xr y) ; xr * y
1870 (inst ,fmul ri xi y) ; xi * yi
1873 (inst ,fmul rr xr y)
1874 (inst ,fmul ri xi y))))))))))
1875 (frob single fmuls (inst fmovs) 4)
1876 (frob double fmuld (move-double-reg) 4))
1879 ;; Divide a complex by a complex
1881 ;; Here's how we do a complex division
1883 ;; Compute (xr + i*xi)/(yr + i*yi)
1885 ;; Assume |yi| < |yr|. Then
1887 ;; (xr + i*xi) (xr + i*xi)
1888 ;; ----------- = -----------------
1889 ;; (yr + i*yi) yr*(1 + i*(yi/yr))
1891 ;; (xr + i*xi)*(1 - i*(yi/yr))
1892 ;; = ---------------------------
1893 ;; yr*(1 + (yi/yr)^2)
1895 ;; (xr + (yi/yr)*xi) + i*(xi - (yi/yr)*xr)
1896 ;; = --------------------------------------
1900 ;; We do the similar thing when |yi| > |yr|. The result is
1903 ;; (xr + i*xi) (xr + i*xi)
1904 ;; ----------- = -----------------
1905 ;; (yr + i*yi) yi*((yr/yi) + i)
1907 ;; (xr + i*xi)*((yr/yi) - i)
1908 ;; = -------------------------
1909 ;; yi*((yr/yi)^2 + 1)
1911 ;; (xr*(yr/yi) + xi) + i*(xi*(yr/yi) - xr)
1912 ;; = ---------------------------------------
1918 ((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov cost)
1919 (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
1920 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1921 (real-reg (symbolicate float-type "-REG"))
1922 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1923 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1924 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1925 `(define-vop (,vop-name)
1926 (:args (x :scs (,complex-reg))
1927 (y :scs (,complex-reg)))
1928 (:results (r :scs (,complex-reg)))
1929 (:arg-types ,c-type ,c-type)
1930 (:result-types ,c-type)
1931 (:policy :fast-safe)
1932 (:note "inline complex float division")
1934 (:temporary (:sc ,real-reg) ratio)
1935 (:temporary (:sc ,real-reg) den)
1936 (:temporary (:sc ,real-reg) temp-r)
1937 (:temporary (:sc ,real-reg) temp-i)
1939 (let ((xr (,real-part x))
1945 (bigger (gen-label))
1949 (inst ,fcmp ratio den)
1950 #!-:sparc-v9 (inst nop)
1951 (inst fb :ge bigger)
1953 ;; The case of |yi| <= |yr|
1954 (inst ,fdiv ratio yi yr) ; ratio = yi/yr
1955 (inst ,fmul den ratio yi)
1956 (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
1958 (inst ,fmul temp-r ratio xi)
1959 (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
1960 (inst ,fdiv temp-r temp-r den)
1962 (inst ,fmul temp-i ratio xr)
1963 (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
1965 (inst ,fdiv temp-i temp-i den)
1968 ;; The case of |yi| > |yr|
1969 (inst ,fdiv ratio yr yi) ; ratio = yr/yi
1970 (inst ,fmul den ratio yr)
1971 (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
1973 (inst ,fmul temp-r ratio xr)
1974 (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
1975 (inst ,fdiv temp-r temp-r den)
1977 (inst ,fmul temp-i ratio xi)
1978 (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
1979 (inst ,fdiv temp-i temp-i den)
1982 (unless (location= temp-r rr)
1984 (unless (location= temp-i ri)
1988 (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) (inst fmovs) 15)
1989 (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) (move-double-reg) 15))
1992 ((frob (float-type fcmp fadd fsub fmul fdiv fabs cost)
1993 (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
1994 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1995 (real-reg (symbolicate float-type "-REG"))
1996 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1997 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1998 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1999 `(define-vop (,vop-name)
2000 (:args (x :scs (,complex-reg))
2001 (y :scs (,complex-reg)))
2002 (:results (r :scs (,complex-reg)))
2003 (:arg-types ,c-type ,c-type)
2004 (:result-types ,c-type)
2005 (:policy :fast-safe)
2006 (:note "inline complex float division")
2008 (:temporary (:sc ,real-reg) ratio)
2009 (:temporary (:sc ,real-reg) den)
2010 (:temporary (:sc ,real-reg) temp-r)
2011 (:temporary (:sc ,real-reg) temp-i)
2013 (let ((xr (,real-part x))
2019 (bigger (gen-label))
2023 (inst ,fcmp ratio den)
2024 #!-:sparc-v9 (inst nop)
2025 (inst fb :ge bigger)
2027 ;; The case of |yi| <= |yr|
2028 (inst ,fdiv ratio yi yr) ; ratio = yi/yr
2029 (inst ,fmul den ratio yi)
2030 (inst ,fmul temp-r ratio xi)
2031 (inst ,fmul temp-i ratio xr)
2033 (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
2034 (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
2036 (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
2040 ;; The case of |yi| > |yr|
2041 (inst ,fdiv ratio yr yi) ; ratio = yr/yi
2042 (inst ,fmul den ratio yr)
2043 (inst ,fmul temp-r ratio xr)
2044 (inst ,fmul temp-i ratio xi)
2046 (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
2047 (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
2049 (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
2053 (inst ,fdiv rr temp-r den)
2054 (inst ,fdiv ri temp-i den)
2057 (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15)
2058 (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15))
2061 ;; Divide a complex by a real
2063 ((frob (float-type fdiv cost)
2064 (let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" float-type "-FLOAT"))
2065 (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
2066 (real-sc-type (symbolicate float-type "-REG"))
2067 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2068 (r-type (symbolicate float-type "-FLOAT"))
2069 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2070 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2071 `(define-vop (,vop-name)
2072 (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
2073 (:results (r :scs (,complex-sc-type)))
2074 (:arg-types ,c-type ,r-type)
2075 (:result-types ,c-type)
2076 (:policy :fast-safe)
2077 (:note "inline complex float arithmetic")
2080 (let ((xr (,real-part x))
2083 (ri (,imag-part r)))
2084 (inst ,fdiv rr xr y) ; xr * y
2085 (inst ,fdiv ri xi y) ; xi * yi
2087 (frob single fdivs 2)
2088 (frob double fdivd 2))
2090 ;; Divide a real by a complex
2093 ((frob (float-type fcmp fadd fmul fdiv fneg fabs cost)
2094 (let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT"))
2095 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2096 (real-reg (symbolicate float-type "-REG"))
2097 (r-type (symbolicate float-type "-FLOAT"))
2098 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2099 (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2100 (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2101 `(define-vop (,vop-name)
2102 (:args (x :scs (,real-reg))
2103 (y :scs (,complex-reg)))
2104 (:results (r :scs (,complex-reg)))
2105 (:arg-types ,r-type ,c-type)
2106 (:result-types ,c-type)
2107 (:policy :fast-safe)
2108 (:note "inline complex float division")
2110 (:temporary (:sc ,real-reg) ratio)
2111 (:temporary (:sc ,real-reg) den)
2112 (:temporary (:sc ,real-reg) temp)
2114 (let ((yr (,real-tn y))
2118 (bigger (gen-label))
2122 (inst ,fcmp ratio den)
2123 #!-:sparc-v9 (inst nop)
2124 (inst fb :ge bigger)
2126 ;; The case of |yi| <= |yr|
2127 (inst ,fdiv ratio yi yr) ; ratio = yi/yr
2128 (inst ,fmul den ratio yi)
2129 (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
2131 (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
2132 (inst ,fdiv rr x den) ; rr = x/den
2134 (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
2137 ;; The case of |yi| > |yr|
2138 (inst ,fdiv ratio yr yi) ; ratio = yr/yi
2139 (inst ,fmul den ratio yr)
2140 (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
2142 (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
2143 (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
2144 (inst ,fdiv temp x den) ; temp = x/den
2147 (,@fneg ri temp)))))))
2149 (frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
2150 (frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
2152 ;; Conjugate of a complex number
2155 ((frob (float-type fneg fmov cost)
2156 (let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT"))
2157 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2158 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2159 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2160 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2161 `(define-vop (,vop-name)
2162 (:args (x :scs (,complex-reg)))
2163 (:results (r :scs (,complex-reg)))
2164 (:arg-types ,c-type)
2165 (:result-types ,c-type)
2166 (:policy :fast-safe)
2167 (:note "inline complex conjugate")
2168 (:translate conjugate)
2170 (let ((xr (,real-part x))
2173 (ri (,imag-part r)))
2175 (unless (location= rr xr)
2176 (,@fmov rr xr))))))))
2178 (frob single (inst fnegs) (inst fmovs) 4)
2179 (frob double (negate-double-reg) (move-double-reg) 4))
2181 ;; Compare a float with a complex or a complex with a float
2184 ((frob (name name-r f-type c-type)
2186 (defknown ,name (,f-type ,c-type) t)
2187 (defknown ,name-r (,c-type ,f-type) t)
2189 (declare (type ,f-type x)
2192 (defun ,name-r (x y)
2193 (declare (type ,c-type x)
2197 (frob %compare-complex-single-single %compare-single-complex-single
2198 single-float (complex single-float))
2199 (frob %compare-complex-double-double %compare-double-complex-double
2200 double-float (complex double-float)))
2204 ((frob (trans-1 trans-2 float-type fcmp fsub)
2206 (symbolicate "COMPLEX-" float-type "-FLOAT-"
2207 float-type "-FLOAT-COMPARE"))
2209 (symbolicate float-type "-FLOAT-COMPLEX-"
2210 float-type "-FLOAT-COMPARE"))
2211 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2212 (real-reg (symbolicate float-type "-REG"))
2213 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2214 (r-type (symbolicate float-type "-FLOAT"))
2215 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2216 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2218 ;; (= float complex)
2219 (define-vop (,vop-name)
2220 (:args (x :scs (,real-reg))
2221 (y :scs (,complex-reg)))
2222 (:arg-types ,r-type ,c-type)
2223 (:translate ,trans-1)
2225 (:info target not-p)
2226 (:policy :fast-safe)
2227 (:note "inline complex float/float comparison")
2229 (:save-p :compute-only)
2230 (:temporary (:sc ,real-reg) fp-zero)
2231 (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
2233 (note-this-location vop :internal-error)
2234 (let ((yr (,real-part y))
2235 (yi (,imag-part y)))
2236 ;; Set fp-zero to zero
2237 (inst ,fsub fp-zero fp-zero fp-zero)
2240 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2241 (inst ,fcmp yi fp-zero)
2243 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2245 ;; (= complex float)
2246 (define-vop (,vop-name-r)
2247 (:args (y :scs (,complex-reg))
2248 (x :scs (,real-reg)))
2249 (:arg-types ,c-type ,r-type)
2250 (:translate ,trans-2)
2252 (:info target not-p)
2253 (:policy :fast-safe)
2254 (:note "inline complex float/float comparison")
2256 (:save-p :compute-only)
2257 (:temporary (:sc ,real-reg) fp-zero)
2258 (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
2260 (note-this-location vop :internal-error)
2261 (let ((yr (,real-part y))
2262 (yi (,imag-part y)))
2263 ;; Set fp-zero to zero
2264 (inst ,fsub fp-zero fp-zero fp-zero)
2267 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2268 (inst ,fcmp yi fp-zero)
2270 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2272 (frob %compare-complex-single-single %compare-single-complex-single
2274 (frob %compare-complex-double-double %compare-double-complex-double
2275 double fcmpd fsubd))
2277 ;; Compare two complex numbers for equality
2279 ((frob (float-type fcmp)
2281 (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
2282 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2283 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2284 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2285 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2286 `(define-vop (,vop-name)
2287 (:args (x :scs (,complex-reg))
2288 (y :scs (,complex-reg)))
2289 (:arg-types ,c-type ,c-type)
2292 (:info target not-p)
2293 (:policy :fast-safe)
2294 (:note "inline complex float comparison")
2296 (:save-p :compute-only)
2297 (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
2299 (note-this-location vop :internal-error)
2300 (let ((xr (,real-part x))
2303 (yi (,imag-part y)))
2306 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2309 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2312 (frob double fcmpd))
2314 ;; Compare a complex with a complex, for V9
2316 ((frob (float-type fcmp)
2318 (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
2319 (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2320 (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2321 (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2322 (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2323 `(define-vop (,vop-name)
2324 (:args (x :scs (,complex-reg))
2325 (y :scs (,complex-reg)))
2326 (:arg-types ,c-type ,c-type)
2329 (:info target not-p)
2330 (:policy :fast-safe)
2331 (:note "inline complex float comparison")
2333 (:save-p :compute-only)
2334 (:temporary (:sc descriptor-reg) true)
2335 (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
2337 (note-this-location vop :internal-error)
2338 (let ((xr (,real-part x))
2341 (yi (,imag-part y)))
2342 ;; Assume comparison is true
2343 (load-symbol true t)
2345 (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
2347 (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
2348 (inst cmp true null-tn)
2349 (inst b (if not-p :eq :ne) target :pt)
2352 (frob double fcmpd))
2354 ) ; end progn complex-fp-vops
2359 ;; Vops to take advantage of the conditional move instruction
2360 ;; available on the Sparc V9
2362 (defknown (%%max %%min) ((or (unsigned-byte #.n-word-bits)
2363 (signed-byte #.n-word-bits)
2364 single-float double-float)
2365 (or (unsigned-byte #.n-word-bits)
2366 (signed-byte #.n-word-bits)
2367 single-float double-float))
2368 (or (unsigned-byte #.n-word-bits)
2369 (signed-byte #.n-word-bits)
2370 single-float double-float)
2371 (movable foldable flushable))
2373 ;; We need these definitions for byte-compiled code
2375 (declare (type (or (unsigned-byte 32) (signed-byte 32)
2376 single-float double-float) x y))
2381 (declare (type (or (unsigned-byte 32) (signed-byte 32)
2382 single-float double-float) x y))
2387 ((frob (name sc-type type compare cmov cost cc max min note)
2388 (let ((vop-name (symbolicate name "-" type "=>" type))
2389 (trans-name (symbolicate "%%" name)))
2390 `(define-vop (,vop-name)
2391 (:args (x :scs (,sc-type))
2392 (y :scs (,sc-type)))
2393 (:results (r :scs (,sc-type)))
2394 (:arg-types ,type ,type)
2395 (:result-types ,type)
2396 (:policy :fast-safe)
2398 (:translate ,trans-name)
2399 (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
2402 (cond ((location= r x)
2403 ;; If x < y, need to move y to r, otherwise r already has
2405 (inst ,cmov ,min r y ,cc))
2407 ;; If x > y, need to move x to r, otherwise r already has
2409 (inst ,cmov ,max r x ,cc))
2411 ;; It doesn't matter what R is, just copy the min to R.
2412 (inst ,cmov ,max r x ,cc)
2413 (inst ,cmov ,min r y ,cc))))))))
2414 (frob max single-reg single-float fcmps cfmovs 3
2415 :fcc0 :ge :l "inline float max")
2416 (frob max double-reg double-float fcmpd cfmovd 3
2417 :fcc0 :ge :l "inline float max")
2418 (frob min single-reg single-float fcmps cfmovs 3
2419 :fcc0 :l :ge "inline float min")
2420 (frob min double-reg double-float fcmpd cfmovd 3
2421 :fcc0 :l :ge "inline float min")
2422 ;; Strictly speaking these aren't float ops, but it's convenient to
2425 ;; The cost is here is the worst case number of instructions. For
2426 ;; 32-bit integer operands, we add 2 more to account for the
2427 ;; untagging of fixnums, if necessary.
2428 (frob max signed-reg signed-num cmp cmove 5
2429 :icc :ge :lt "inline (signed-byte 32) max")
2430 (frob max unsigned-reg unsigned-num cmp cmove 5
2431 :icc :ge :lt "inline (unsigned-byte 32) max")
2432 ;; For fixnums, make the cost lower so we don't have to untag the
2434 (frob max any-reg tagged-num cmp cmove 3
2435 :icc :ge :lt "inline fixnum max")
2436 (frob min signed-reg signed-num cmp cmove 5
2437 :icc :lt :ge "inline (signed-byte 32) min")
2438 (frob min unsigned-reg unsigned-num cmp cmove 5
2439 :icc :lt :ge "inline (unsigned-byte 32) min")
2440 ;; For fixnums, make the cost lower so we don't have to untag the
2442 (frob min any-reg tagged-num cmp cmove 3
2443 :icc :lt :ge "inline fixnum min"))
2446 (define-vop (max-boxed-double-float=>boxed-double-float)
2447 (:args (x :scs (descriptor-reg))
2448 (y :scs (descriptor-reg)))
2449 (:results (r :scs (descriptor-reg)))
2450 (:arg-types double-float double-float)
2451 (:result-types double-float)
2452 (:policy :fast-safe)
2453 (:note "inline float max/min")
2454 (:translate %max-double-float)
2455 (:temporary (:scs (double-reg)) xval)
2456 (:temporary (:scs (double-reg)) yval)
2457 (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
2460 (let ((offset (- (* double-float-value-slot n-word-bytes)
2461 other-pointer-lowtag)))
2462 (inst lddf xval x offset)
2463 (inst lddf yval y offset)
2464 (inst fcmpd xval yval)
2465 (cond ((location= r x)
2466 ;; If x < y, need to move y to r, otherwise r already has
2468 (inst cmove :l r y :fcc0))
2470 ;; If x > y, need to move x to r, otherwise r already has
2472 (inst cmove :ge r x :fcc0))
2474 ;; It doesn't matter what R is, just copy the min to R.
2475 (inst cmove :ge r x :fcc0)
2476 (inst cmove :l r y :fcc0))))))
2485 ;;; The sparc-v9 architecture has conditional move instructions that
2486 ;;; can be used. This should be faster than using the obvious if
2487 ;;; expression since we don't have to do branches.
2489 (def-source-transform min (&rest args)
2491 ((0 2) (values nil t))
2492 (1 `(values ,(first args)))
2493 (t (sb!c::associate-arguments 'min (first args) (rest args)))))
2495 (def-source-transform max (&rest args)
2497 ((0 2) (values nil t))
2498 (1 `(values ,(first args)))
2499 (t (sb!c::associate-arguments 'max (first args) (rest args)))))
2501 ;; Derive the types of max and min
2502 (defoptimizer (max derive-type) ((x y))
2503 (multiple-value-bind (definitely-< definitely->=)
2504 (ir1-transform-<-helper x y)
2506 (continuation-type y))
2508 (continuation-type x))
2510 (make-canonical-union-type (list (continuation-type x)
2511 (continuation-type y)))))))
2513 (defoptimizer (min derive-type) ((x y))
2514 (multiple-value-bind (definitely-< definitely->=)
2515 (ir1-transform-<-helper x y)
2517 (continuation-type x))
2519 (continuation-type y))
2521 (make-canonical-union-type (list (continuation-type x)
2522 (continuation-type y)))))))
2524 (deftransform max ((x y) (number number) * :when :both)
2525 (let ((x-type (continuation-type x))
2526 (y-type (continuation-type y))
2527 (signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
2528 (unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
2529 (d-float (specifier-type 'double-float))
2530 (s-float (specifier-type 'single-float)))
2531 ;; Use %%max if both args are good types of the same type. As a
2532 ;; last resort, use the obvious comparison to select the desired
2534 (cond ((and (csubtypep x-type signed)
2535 (csubtypep y-type signed))
2537 ((and (csubtypep x-type unsigned)
2538 (csubtypep y-type unsigned))
2540 ((and (csubtypep x-type d-float)
2541 (csubtypep y-type d-float))
2543 ((and (csubtypep x-type s-float)
2544 (csubtypep y-type s-float))
2547 (let ((arg1 (gensym))
2554 (deftransform min ((x y) (real real) * :when :both)
2555 (let ((x-type (continuation-type x))
2556 (y-type (continuation-type y))
2557 (signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
2558 (unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
2559 (d-float (specifier-type 'double-float))
2560 (s-float (specifier-type 'single-float)))
2561 (cond ((and (csubtypep x-type signed)
2562 (csubtypep y-type signed))
2564 ((and (csubtypep x-type unsigned)
2565 (csubtypep y-type unsigned))
2567 ((and (csubtypep x-type d-float)
2568 (csubtypep y-type d-float))
2570 ((and (csubtypep x-type s-float)
2571 (csubtypep y-type s-float))
2574 (let ((arg1 (gensym))