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 ((member :sparc-v9
*backend-subfeatures
*)
42 (inst ldqf reg base offset
))
44 (let ((reg0 (make-random-tn :kind
:normal
45 :sc
(sc-or-lose 'double-reg
)
46 :offset
(tn-offset reg
)))
47 (reg2 (make-random-tn :kind
:normal
48 :sc
(sc-or-lose 'double-reg
)
49 :offset
(+ 2 (tn-offset reg
)))))
50 (cond ((integerp offset
)
51 (inst lddf reg0 base offset
)
52 (inst lddf reg2 base
(+ offset
(* 2 n-word-bytes
))))
54 (inst lddf reg0 base offset
)
55 (inst add offset
(* 2 n-word-bytes
))
56 (inst lddf reg2 base offset
)
58 (inst sub offset
(* 2 n-word-bytes
)))))))))
61 (define-move-fun (load-long 2) (vop x y
)
62 ((long-stack) (long-reg))
63 (let ((nfp (current-nfp-tn vop
))
64 (offset (* (tn-offset x
) n-word-bytes
)))
65 (load-long-reg y nfp offset
)))
67 ;;; The offset may be an integer or a TN in which case it will be
68 ;;; temporarily modified but is restored if restore-offset is true.
69 (defun store-long-reg (reg base offset
&optional
(restore-offset t
))
71 ((member :sparc-v9
*backend-subfeatures
*)
72 (inst stqf reg base offset
))
74 (let ((reg0 (make-random-tn :kind
:normal
75 :sc
(sc-or-lose 'double-reg
)
76 :offset
(tn-offset reg
)))
77 (reg2 (make-random-tn :kind
:normal
78 :sc
(sc-or-lose 'double-reg
)
79 :offset
(+ 2 (tn-offset reg
)))))
80 (cond ((integerp offset
)
81 (inst stdf reg0 base offset
)
82 (inst stdf reg2 base
(+ offset
(* 2 n-word-bytes
))))
84 (inst stdf reg0 base offset
)
85 (inst add offset
(* 2 n-word-bytes
))
86 (inst stdf reg2 base offset
)
88 (inst sub offset
(* 2 n-word-bytes
)))))))))
91 (define-move-fun (store-long 2) (vop x y
)
92 ((long-reg) (long-stack))
93 (let ((nfp (current-nfp-tn vop
))
94 (offset (* (tn-offset y
) n-word-bytes
)))
95 (store-long-reg x nfp offset
)))
100 ;;; Exploit the V9 double-float move instruction. This is conditional
101 ;;; on the :sparc-v9 feature.
102 (defun move-double-reg (dst src
)
104 ((member :sparc-v9
*backend-subfeatures
*)
105 (inst fmovd dst src
))
108 (let ((dst (make-random-tn :kind
:normal
109 :sc
(sc-or-lose 'single-reg
)
110 :offset
(+ i
(tn-offset dst
))))
111 (src (make-random-tn :kind
:normal
112 :sc
(sc-or-lose 'single-reg
)
113 :offset
(+ i
(tn-offset src
)))))
114 (inst fmovs dst src
))))))
116 ;;; Exploit the V9 long-float move instruction. This is conditional
117 ;;; on the :sparc-v9 feature.
118 (defun move-long-reg (dst src
)
120 ((member :sparc-v9
*backend-subfeatures
*)
121 (inst fmovq dst src
))
124 (let ((dst (make-random-tn :kind
:normal
125 :sc
(sc-or-lose 'single-reg
)
126 :offset
(+ i
(tn-offset dst
))))
127 (src (make-random-tn :kind
:normal
128 :sc
(sc-or-lose 'single-reg
)
129 :offset
(+ i
(tn-offset src
)))))
130 (inst fmovs dst src
))))))
132 (macrolet ((frob (vop sc format
)
137 :load-if
(not (location= x y
))))
138 (:results
(y :scs
(,sc
)
139 :load-if
(not (location= x y
))))
142 (unless (location= y x
)
144 (:single
`((inst fmovs y x
)))
145 (:double
`((move-double-reg y x
)))
146 (:long
`((move-long-reg y x
)))))))
147 (define-move-vop ,vop
:move
(,sc
) (,sc
)))))
148 (frob single-move single-reg
:single
)
149 (frob double-move double-reg
:double
)
151 (frob long-move long-reg
:long
))
154 (define-vop (move-from-float)
155 (:args
(x :to
:save
))
157 (:note
"float to pointer coercion")
158 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
159 (:variant-vars format size type data
)
161 (with-fixed-allocation (y ndescr type size
))
164 (inst stf x y
(- (* data n-word-bytes
) other-pointer-lowtag
)))
166 (inst stdf x y
(- (* data n-word-bytes
) other-pointer-lowtag
)))
168 (store-long-reg x y
(- (* data n-word-bytes
)
169 other-pointer-lowtag
))))))
171 (macrolet ((frob (name sc
&rest args
)
173 (define-vop (,name move-from-float
)
174 (:args
(x :scs
(,sc
) :to
:save
))
175 (:results
(y :scs
(descriptor-reg)))
177 (define-move-vop ,name
:move
(,sc
) (descriptor-reg)))))
178 (frob move-from-single single-reg
:single
179 single-float-size single-float-widetag single-float-value-slot
)
180 (frob move-from-double double-reg
:double
181 double-float-size double-float-widetag double-float-value-slot
)
183 (frob move-from-long long-reg
:long
184 long-float-size long-float-widetag long-float-value-slot
))
186 (macrolet ((frob (name sc format value
)
189 (:args
(x :scs
(descriptor-reg)))
190 (:results
(y :scs
(,sc
)))
191 (:note
"pointer to float coercion")
197 (- (* ,value n-word-bytes
) other-pointer-lowtag
))))
198 (define-move-vop ,name
:move
(descriptor-reg) (,sc
)))))
199 (frob move-to-single single-reg
:single single-float-value-slot
)
200 (frob move-to-double double-reg
:double double-float-value-slot
))
203 (define-vop (move-to-long)
204 (:args
(x :scs
(descriptor-reg)))
205 (:results
(y :scs
(long-reg)))
206 (:note
"pointer to float coercion")
208 (load-long-reg y x
(- (* long-float-value-slot n-word-bytes
)
209 other-pointer-lowtag
))))
211 (define-move-vop move-to-long
:move
(descriptor-reg) (long-reg))
213 (macrolet ((frob (name sc stack-sc format
)
216 (:args
(x :scs
(,sc
) :target y
)
218 :load-if
(not (sc-is y
,sc
))))
220 (:note
"float argument move")
221 (:generator
,(ecase format
(:single
1) (:double
2))
224 (unless (location= x y
)
226 (:single
'((inst fmovs y x
)))
227 (:double
'((move-double-reg y x
))))))
229 (let ((offset (* (tn-offset y
) n-word-bytes
)))
234 (define-move-vop ,name
:move-arg
235 (,sc descriptor-reg
) (,sc
)))))
236 (frob move-single-float-arg single-reg single-stack
:single
)
237 (frob move-double-float-arg double-reg double-stack
:double
))
240 (define-vop (move-long-float-arg)
241 (:args
(x :scs
(long-reg) :target y
)
242 (nfp :scs
(any-reg) :load-if
(not (sc-is y long-reg
))))
244 (:note
"float argument move")
248 (unless (location= x y
)
249 (move-long-reg y x
)))
251 (let ((offset (* (tn-offset y
) n-word-bytes
)))
252 (store-long-reg x nfp offset
))))))
255 (define-move-vop move-long-float-arg
:move-arg
256 (long-reg descriptor-reg
) (long-reg))
259 ;;;; Complex float move functions
261 (defun complex-single-reg-real-tn (x)
262 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'single-reg
)
263 :offset
(tn-offset x
)))
264 (defun complex-single-reg-imag-tn (x)
265 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'single-reg
)
266 :offset
(1+ (tn-offset x
))))
268 (defun complex-double-reg-real-tn (x)
269 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
)
270 :offset
(tn-offset x
)))
271 (defun complex-double-reg-imag-tn (x)
272 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
)
273 :offset
(+ (tn-offset x
) 2)))
276 (defun complex-long-reg-real-tn (x)
277 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'long-reg
)
278 :offset
(tn-offset x
)))
280 (defun complex-long-reg-imag-tn (x)
281 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'long-reg
)
282 :offset
(+ (tn-offset x
) 4)))
285 (define-move-fun (load-complex-single 2) (vop x y
)
286 ((complex-single-stack) (complex-single-reg))
287 (let ((nfp (current-nfp-tn vop
))
288 (offset (* (tn-offset x
) n-word-bytes
)))
289 (let ((real-tn (complex-single-reg-real-tn y
)))
290 (inst ldf real-tn nfp offset
))
291 (let ((imag-tn (complex-single-reg-imag-tn y
)))
292 (inst ldf imag-tn nfp
(+ offset n-word-bytes
)))))
294 (define-move-fun (store-complex-single 2) (vop x y
)
295 ((complex-single-reg) (complex-single-stack))
296 (let ((nfp (current-nfp-tn vop
))
297 (offset (* (tn-offset y
) n-word-bytes
)))
298 (let ((real-tn (complex-single-reg-real-tn x
)))
299 (inst stf real-tn nfp offset
))
300 (let ((imag-tn (complex-single-reg-imag-tn x
)))
301 (inst stf imag-tn nfp
(+ offset n-word-bytes
)))))
304 (define-move-fun (load-complex-double 4) (vop x y
)
305 ((complex-double-stack) (complex-double-reg))
306 (let ((nfp (current-nfp-tn vop
))
307 (offset (* (tn-offset x
) n-word-bytes
)))
308 (let ((real-tn (complex-double-reg-real-tn y
)))
309 (inst lddf real-tn nfp offset
))
310 (let ((imag-tn (complex-double-reg-imag-tn y
)))
311 (inst lddf imag-tn nfp
(+ offset
(* 2 n-word-bytes
))))))
313 (define-move-fun (store-complex-double 4) (vop x y
)
314 ((complex-double-reg) (complex-double-stack))
315 (let ((nfp (current-nfp-tn vop
))
316 (offset (* (tn-offset y
) n-word-bytes
)))
317 (let ((real-tn (complex-double-reg-real-tn x
)))
318 (inst stdf real-tn nfp offset
))
319 (let ((imag-tn (complex-double-reg-imag-tn x
)))
320 (inst stdf imag-tn nfp
(+ offset
(* 2 n-word-bytes
))))))
324 (define-move-fun (load-complex-long 5) (vop x y
)
325 ((complex-long-stack) (complex-long-reg))
326 (let ((nfp (current-nfp-tn vop
))
327 (offset (* (tn-offset x
) n-word-bytes
)))
328 (let ((real-tn (complex-long-reg-real-tn y
)))
329 (load-long-reg real-tn nfp offset
))
330 (let ((imag-tn (complex-long-reg-imag-tn y
)))
331 (load-long-reg imag-tn nfp
(+ offset
(* 4 n-word-bytes
))))))
334 (define-move-fun (store-complex-long 5) (vop x y
)
335 ((complex-long-reg) (complex-long-stack))
336 (let ((nfp (current-nfp-tn vop
))
337 (offset (* (tn-offset y
) n-word-bytes
)))
338 (let ((real-tn (complex-long-reg-real-tn x
)))
339 (store-long-reg real-tn nfp offset
))
340 (let ((imag-tn (complex-long-reg-imag-tn x
)))
341 (store-long-reg imag-tn nfp
(+ offset
(* 4 n-word-bytes
))))))
344 ;;; Complex float register to register moves.
346 (define-vop (complex-single-move)
347 (:args
(x :scs
(complex-single-reg) :target y
348 :load-if
(not (location= x y
))))
349 (:results
(y :scs
(complex-single-reg) :load-if
(not (location= x y
))))
350 (:note
"complex single float move")
352 (unless (location= x y
)
353 ;; Note the complex-float-regs are aligned to every second
354 ;; float register so there is not need to worry about overlap.
355 (let ((x-real (complex-single-reg-real-tn x
))
356 (y-real (complex-single-reg-real-tn y
)))
357 (inst fmovs y-real x-real
))
358 (let ((x-imag (complex-single-reg-imag-tn x
))
359 (y-imag (complex-single-reg-imag-tn y
)))
360 (inst fmovs y-imag x-imag
)))))
362 (define-move-vop complex-single-move
:move
363 (complex-single-reg) (complex-single-reg))
365 (define-vop (complex-double-move)
366 (:args
(x :scs
(complex-double-reg)
367 :target y
:load-if
(not (location= x y
))))
368 (:results
(y :scs
(complex-double-reg) :load-if
(not (location= x y
))))
369 (:note
"complex double float move")
371 (unless (location= x y
)
372 ;; Note the complex-float-regs are aligned to every second
373 ;; float register so there is not need to worry about overlap.
374 (let ((x-real (complex-double-reg-real-tn x
))
375 (y-real (complex-double-reg-real-tn y
)))
376 (move-double-reg y-real x-real
))
377 (let ((x-imag (complex-double-reg-imag-tn x
))
378 (y-imag (complex-double-reg-imag-tn y
)))
379 (move-double-reg y-imag x-imag
)))))
381 (define-move-vop complex-double-move
:move
382 (complex-double-reg) (complex-double-reg))
385 (define-vop (complex-long-move)
386 (:args
(x :scs
(complex-long-reg)
387 :target y
:load-if
(not (location= x y
))))
388 (:results
(y :scs
(complex-long-reg) :load-if
(not (location= x y
))))
389 (:note
"complex long float move")
391 (unless (location= x y
)
392 ;; Note the complex-float-regs are aligned to every second
393 ;; float register so there is not need to worry about overlap.
394 (let ((x-real (complex-long-reg-real-tn x
))
395 (y-real (complex-long-reg-real-tn y
)))
396 (move-long-reg y-real x-real
))
397 (let ((x-imag (complex-long-reg-imag-tn x
))
398 (y-imag (complex-long-reg-imag-tn y
)))
399 (move-long-reg y-imag x-imag
)))))
402 (define-move-vop complex-long-move
:move
403 (complex-long-reg) (complex-long-reg))
406 ;;; Move from a complex float to a descriptor register allocating a
407 ;;; new complex float object in the process.
409 (define-vop (move-from-complex-single)
410 (:args
(x :scs
(complex-single-reg) :to
:save
))
411 (:results
(y :scs
(descriptor-reg)))
412 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
413 (:note
"complex single float to pointer coercion")
415 (with-fixed-allocation (y ndescr complex-single-float-widetag
416 complex-single-float-size
))
417 (let ((real-tn (complex-single-reg-real-tn x
)))
418 (inst stf real-tn y
(- (* complex-single-float-real-slot
420 other-pointer-lowtag
)))
421 (let ((imag-tn (complex-single-reg-imag-tn x
)))
422 (inst stf imag-tn y
(- (* complex-single-float-imag-slot
424 other-pointer-lowtag
)))))
426 (define-move-vop move-from-complex-single
:move
427 (complex-single-reg) (descriptor-reg))
429 (define-vop (move-from-complex-double)
430 (:args
(x :scs
(complex-double-reg) :to
:save
))
431 (:results
(y :scs
(descriptor-reg)))
432 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
433 (:note
"complex double float to pointer coercion")
435 (with-fixed-allocation (y ndescr complex-double-float-widetag
436 complex-double-float-size
))
437 (let ((real-tn (complex-double-reg-real-tn x
)))
438 (inst stdf real-tn y
(- (* complex-double-float-real-slot
440 other-pointer-lowtag
)))
441 (let ((imag-tn (complex-double-reg-imag-tn x
)))
442 (inst stdf imag-tn y
(- (* complex-double-float-imag-slot
444 other-pointer-lowtag
)))))
446 (define-move-vop move-from-complex-double
:move
447 (complex-double-reg) (descriptor-reg))
450 (define-vop (move-from-complex-long)
451 (:args
(x :scs
(complex-long-reg) :to
:save
))
452 (:results
(y :scs
(descriptor-reg)))
453 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
454 (:note
"complex long float to pointer coercion")
456 (with-fixed-allocation (y ndescr complex-long-float-widetag
457 complex-long-float-size
))
458 (let ((real-tn (complex-long-reg-real-tn x
)))
459 (store-long-reg real-tn y
(- (* complex-long-float-real-slot
461 other-pointer-lowtag
)))
462 (let ((imag-tn (complex-long-reg-imag-tn x
)))
463 (store-long-reg imag-tn y
(- (* complex-long-float-imag-slot
465 other-pointer-lowtag
)))))
468 (define-move-vop move-from-complex-long
:move
469 (complex-long-reg) (descriptor-reg))
472 ;;; Move from a descriptor to a complex float register
474 (define-vop (move-to-complex-single)
475 (:args
(x :scs
(descriptor-reg)))
476 (:results
(y :scs
(complex-single-reg)))
477 (:note
"pointer to complex float coercion")
479 (let ((real-tn (complex-single-reg-real-tn y
)))
480 (inst ldf real-tn x
(- (* complex-single-float-real-slot n-word-bytes
)
481 other-pointer-lowtag
)))
482 (let ((imag-tn (complex-single-reg-imag-tn y
)))
483 (inst ldf imag-tn x
(- (* complex-single-float-imag-slot n-word-bytes
)
484 other-pointer-lowtag
)))))
485 (define-move-vop move-to-complex-single
:move
486 (descriptor-reg) (complex-single-reg))
488 (define-vop (move-to-complex-double)
489 (:args
(x :scs
(descriptor-reg)))
490 (:results
(y :scs
(complex-double-reg)))
491 (:note
"pointer to complex float coercion")
493 (let ((real-tn (complex-double-reg-real-tn y
)))
494 (inst lddf real-tn x
(- (* complex-double-float-real-slot n-word-bytes
)
495 other-pointer-lowtag
)))
496 (let ((imag-tn (complex-double-reg-imag-tn y
)))
497 (inst lddf imag-tn x
(- (* complex-double-float-imag-slot n-word-bytes
)
498 other-pointer-lowtag
)))))
499 (define-move-vop move-to-complex-double
:move
500 (descriptor-reg) (complex-double-reg))
503 (define-vop (move-to-complex-long)
504 (:args
(x :scs
(descriptor-reg)))
505 (:results
(y :scs
(complex-long-reg)))
506 (:note
"pointer to complex float coercion")
508 (let ((real-tn (complex-long-reg-real-tn y
)))
509 (load-long-reg real-tn x
(- (* complex-long-float-real-slot n-word-bytes
)
510 other-pointer-lowtag
)))
511 (let ((imag-tn (complex-long-reg-imag-tn y
)))
512 (load-long-reg imag-tn x
(- (* complex-long-float-imag-slot n-word-bytes
)
513 other-pointer-lowtag
)))))
515 (define-move-vop move-to-complex-long
:move
516 (descriptor-reg) (complex-long-reg))
519 ;;; Complex float move-arg vop
521 (define-vop (move-complex-single-float-arg)
522 (:args
(x :scs
(complex-single-reg) :target y
)
523 (nfp :scs
(any-reg) :load-if
(not (sc-is y complex-single-reg
))))
525 (:note
"complex single-float argument move")
529 (unless (location= x y
)
530 (let ((x-real (complex-single-reg-real-tn x
))
531 (y-real (complex-single-reg-real-tn y
)))
532 (inst fmovs y-real x-real
))
533 (let ((x-imag (complex-single-reg-imag-tn x
))
534 (y-imag (complex-single-reg-imag-tn y
)))
535 (inst fmovs y-imag x-imag
))))
536 (complex-single-stack
537 (let ((offset (* (tn-offset y
) n-word-bytes
)))
538 (let ((real-tn (complex-single-reg-real-tn x
)))
539 (inst stf real-tn nfp offset
))
540 (let ((imag-tn (complex-single-reg-imag-tn x
)))
541 (inst stf imag-tn nfp
(+ offset n-word-bytes
))))))))
542 (define-move-vop move-complex-single-float-arg
:move-arg
543 (complex-single-reg descriptor-reg
) (complex-single-reg))
545 (define-vop (move-complex-double-float-arg)
546 (:args
(x :scs
(complex-double-reg) :target y
)
547 (nfp :scs
(any-reg) :load-if
(not (sc-is y complex-double-reg
))))
549 (:note
"complex double-float argument move")
553 (unless (location= x y
)
554 (let ((x-real (complex-double-reg-real-tn x
))
555 (y-real (complex-double-reg-real-tn y
)))
556 (move-double-reg y-real x-real
))
557 (let ((x-imag (complex-double-reg-imag-tn x
))
558 (y-imag (complex-double-reg-imag-tn y
)))
559 (move-double-reg y-imag x-imag
))))
560 (complex-double-stack
561 (let ((offset (* (tn-offset y
) n-word-bytes
)))
562 (let ((real-tn (complex-double-reg-real-tn x
)))
563 (inst stdf real-tn nfp offset
))
564 (let ((imag-tn (complex-double-reg-imag-tn x
)))
565 (inst stdf imag-tn nfp
(+ offset
(* 2 n-word-bytes
)))))))))
566 (define-move-vop move-complex-double-float-arg
:move-arg
567 (complex-double-reg descriptor-reg
) (complex-double-reg))
570 (define-vop (move-complex-long-float-arg)
571 (:args
(x :scs
(complex-long-reg) :target y
)
572 (nfp :scs
(any-reg) :load-if
(not (sc-is y complex-long-reg
))))
574 (:note
"complex long-float argument move")
578 (unless (location= x y
)
579 (let ((x-real (complex-long-reg-real-tn x
))
580 (y-real (complex-long-reg-real-tn y
)))
581 (move-long-reg y-real x-real
))
582 (let ((x-imag (complex-long-reg-imag-tn x
))
583 (y-imag (complex-long-reg-imag-tn y
)))
584 (move-long-reg y-imag x-imag
))))
586 (let ((offset (* (tn-offset y
) n-word-bytes
)))
587 (let ((real-tn (complex-long-reg-real-tn x
)))
588 (store-long-reg real-tn nfp offset
))
589 (let ((imag-tn (complex-long-reg-imag-tn x
)))
590 (store-long-reg imag-tn nfp
(+ offset
(* 4 n-word-bytes
)))))))))
592 (define-move-vop move-complex-long-float-arg
:move-arg
593 (complex-long-reg descriptor-reg
) (complex-long-reg))
596 (define-move-vop move-arg
:move-arg
597 (single-reg double-reg
#!+long-float long-reg
598 complex-single-reg complex-double-reg
#!+long-float complex-long-reg
)
602 ;;;; Arithmetic VOPs:
604 (define-vop (float-op)
608 (:note
"inline float arithmetic")
610 (:save-p
:compute-only
))
612 (macrolet ((frob (name sc ptype
)
613 `(define-vop (,name float-op
)
614 (:args
(x :scs
(,sc
))
616 (:results
(r :scs
(,sc
)))
617 (:arg-types
,ptype
,ptype
)
618 (:result-types
,ptype
))))
619 (frob single-float-op single-reg single-float
)
620 (frob double-float-op double-reg double-float
)
622 (frob long-float-op long-reg long-float
))
624 (macrolet ((frob (op sinst sname scost dinst dname dcost
)
626 (define-vop (,sname single-float-op
)
629 (inst ,sinst r x y
)))
630 (define-vop (,dname double-float-op
)
633 (inst ,dinst r x y
))))))
634 (frob + fadds
+/single-float
2 faddd
+/double-float
2)
635 (frob - fsubs -
/single-float
2 fsubd -
/double-float
2)
636 (frob * fmuls
*/single-float
4 fmuld
*/double-float
5)
637 (frob / fdivs
//single-float
12 fdivd
//double-float
19))
640 (macrolet ((frob (op linst lname lcost
)
641 `(define-vop (,lname long-float-op
)
644 (inst ,linst r x y
)))))
645 (frob + faddq
+/long-float
2)
646 (frob - fsubq -
/long-float
2)
647 (frob * fmulq
*/long-float
6)
648 (frob / fdivq
//long-float
20))
651 (macrolet ((frob (name inst translate sc type
)
653 (:args
(x :scs
(,sc
)))
654 (:results
(y :scs
(,sc
)))
655 (:translate
,translate
)
658 (:result-types
,type
)
659 (:note
"inline float arithmetic")
661 (:save-p
:compute-only
)
663 (note-this-location vop
:internal-error
)
665 (frob abs
/single-float fabss abs single-reg single-float
)
666 (frob %negate
/single-float fnegs %negate single-reg single-float
))
668 (defun negate-double-reg (dst src
)
670 ((member :sparc-v9
*backend-subfeatures
*)
671 (inst fnegd dst src
))
673 ;; Negate the MS part of the numbers, then copy over the rest
676 (let ((dst-odd (make-random-tn :kind
:normal
677 :sc
(sc-or-lose 'single-reg
)
678 :offset
(+ 1 (tn-offset dst
))))
679 (src-odd (make-random-tn :kind
:normal
680 :sc
(sc-or-lose 'single-reg
)
681 :offset
(+ 1 (tn-offset src
)))))
682 (inst fmovs dst-odd src-odd
)))))
684 (defun abs-double-reg (dst src
)
686 ((member :sparc-v9
*backend-subfeatures
*)
687 (inst fabsd dst src
))
689 ;; Abs the MS part of the numbers, then copy over the rest
692 (let ((dst-2 (make-random-tn :kind
:normal
693 :sc
(sc-or-lose 'single-reg
)
694 :offset
(+ 1 (tn-offset dst
))))
695 (src-2 (make-random-tn :kind
:normal
696 :sc
(sc-or-lose 'single-reg
)
697 :offset
(+ 1 (tn-offset src
)))))
698 (inst fmovs dst-2 src-2
)))))
700 (define-vop (abs/double-float
)
701 (:args
(x :scs
(double-reg)))
702 (:results
(y :scs
(double-reg)))
705 (:arg-types double-float
)
706 (:result-types double-float
)
707 (:note
"inline float arithmetic")
709 (:save-p
:compute-only
)
711 (note-this-location vop
:internal-error
)
712 (abs-double-reg y x
)))
714 (define-vop (%negate
/double-float
)
715 (:args
(x :scs
(double-reg)))
716 (:results
(y :scs
(double-reg)))
719 (:arg-types double-float
)
720 (:result-types double-float
)
721 (:note
"inline float arithmetic")
723 (:save-p
:compute-only
)
725 (note-this-location vop
:internal-error
)
726 (negate-double-reg y x
)))
729 (define-vop (abs/long-float
)
730 (:args
(x :scs
(long-reg)))
731 (:results
(y :scs
(long-reg)))
734 (:arg-types long-float
)
735 (:result-types long-float
)
736 (:note
"inline float arithmetic")
738 (:save-p
:compute-only
)
740 (note-this-location vop
:internal-error
)
742 ((member :sparc-v9
*backend-subfeatures
*)
747 (let ((y-odd (make-random-tn
749 :sc
(sc-or-lose 'single-reg
)
750 :offset
(+ i
1 (tn-offset y
))))
751 (x-odd (make-random-tn
753 :sc
(sc-or-lose 'single-reg
)
754 :offset
(+ i
1 (tn-offset x
)))))
755 (inst fmovs y-odd x-odd
)))))))
758 (define-vop (%negate
/long-float
)
759 (:args
(x :scs
(long-reg)))
760 (:results
(y :scs
(long-reg)))
763 (:arg-types long-float
)
764 (:result-types long-float
)
765 (:note
"inline float arithmetic")
767 (:save-p
:compute-only
)
769 (note-this-location vop
:internal-error
)
771 ((member :sparc-v9
*backend-subfeatures
*)
776 (let ((y-odd (make-random-tn
778 :sc
(sc-or-lose 'single-reg
)
779 :offset
(+ i
1 (tn-offset y
))))
780 (x-odd (make-random-tn
782 :sc
(sc-or-lose 'single-reg
)
783 :offset
(+ i
1 (tn-offset x
)))))
784 (inst fmovs y-odd x-odd
)))))))
789 (define-vop (float-compare)
793 (:variant-vars format yep nope
)
795 (:note
"inline float comparison")
797 (:save-p
:compute-only
)
799 (note-this-location vop
:internal-error
)
801 (:single
(inst fcmps x y
))
802 (:double
(inst fcmpd x y
))
803 (:long
(inst fcmpq x y
)))
804 ;; The SPARC V9 doesn't need an instruction between a
805 ;; floating-point compare and a floating-point branch.
806 (unless (member :sparc-v9
*backend-subfeatures
*)
808 (inst fb
(if not-p nope yep
) target
)
811 (macrolet ((frob (name sc ptype
)
812 `(define-vop (,name float-compare
)
813 (:args
(x :scs
(,sc
))
815 (:arg-types
,ptype
,ptype
))))
816 (frob single-float-compare single-reg single-float
)
817 (frob double-float-compare double-reg double-float
)
819 (frob long-float-compare long-reg long-float
))
821 (macrolet ((frob (translate yep nope sname dname
#!+long-float lname
)
823 (define-vop (,sname single-float-compare
)
824 (:translate
,translate
)
825 (:variant
:single
,yep
,nope
))
826 (define-vop (,dname double-float-compare
)
827 (:translate
,translate
)
828 (:variant
:double
,yep
,nope
))
830 (define-vop (,lname long-float-compare
)
831 (:translate
,translate
)
832 (:variant
:long
,yep
,nope
)))))
833 (frob < :l
:ge
</single-float
</double-float
#!+long-float
</long-float
)
834 (frob > :g
:le
>/single-float
>/double-float
#!+long-float
>/long-float
)
835 (frob = :eq
:ne eql
/single-float eql
/double-float
#!+long-float eql
/long-float
))
838 (deftransform eql
((x y
) (long-float long-float
))
839 '(and (= (long-float-low-bits x
) (long-float-low-bits y
))
840 (= (long-float-mid-bits x
) (long-float-mid-bits y
))
841 (= (long-float-high-bits x
) (long-float-high-bits y
))
842 (= (long-float-exp-bits x
) (long-float-exp-bits y
))))
847 (macrolet ((frob (name translate inst to-sc to-type
)
849 (:args
(x :scs
(signed-reg) :target stack-temp
850 :load-if
(not (sc-is x signed-stack
))))
851 (:temporary
(:scs
(single-stack) :from
:argument
) stack-temp
)
852 (:temporary
(:scs
(single-reg) :to
:result
:target y
) temp
)
853 (:results
(y :scs
(,to-sc
)))
854 (:arg-types signed-num
)
855 (:result-types
,to-type
)
857 (:note
"inline float coercion")
858 (:translate
,translate
)
860 (:save-p
:compute-only
)
867 (* (tn-offset temp
) n-word-bytes
))
873 (* (tn-offset stack-tn
) n-word-bytes
))
874 (note-this-location vop
:internal-error
)
875 (inst ,inst y temp
))))))
876 (frob %single-float
/signed %single-float fitos single-reg single-float
)
877 (frob %double-float
/signed %double-float fitod double-reg double-float
)
879 (frob %long-float
/signed %long-float fitoq long-reg long-float
))
881 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type
)
883 (:args
(x :scs
(,from-sc
)))
884 (:results
(y :scs
(,to-sc
)))
885 (:arg-types
,from-type
)
886 (:result-types
,to-type
)
888 (:note
"inline float coercion")
889 (:translate
,translate
)
891 (:save-p
:compute-only
)
893 (note-this-location vop
:internal-error
)
895 (frob %single-float
/double-float %single-float fdtos
896 double-reg double-float single-reg single-float
)
898 (frob %single-float
/long-float %single-float fqtos
899 long-reg long-float single-reg single-float
)
900 (frob %double-float
/single-float %double-float fstod
901 single-reg single-float double-reg double-float
)
903 (frob %double-float
/long-float %double-float fqtod
904 long-reg long-float double-reg double-float
)
906 (frob %long-float
/single-float %long-float fstoq
907 single-reg single-float long-reg long-float
)
909 (frob %long-float
/double-float %long-float fdtoq
910 double-reg double-float long-reg long-float
))
912 (macrolet ((frob (trans from-sc from-type inst
)
913 `(define-vop (,(symbolicate trans
"/" from-type
))
914 (:args
(x :scs
(,from-sc
) :target temp
))
915 (:temporary
(:from
(:argument
0) :sc single-reg
) temp
)
916 (:temporary
(:scs
(signed-stack)) stack-temp
)
917 (:results
(y :scs
(signed-reg)
918 :load-if
(not (sc-is y signed-stack
))))
919 (:arg-types
,from-type
)
920 (:result-types signed-num
)
923 (:note
"inline float truncate")
925 (:save-p
:compute-only
)
927 (note-this-location vop
:internal-error
)
931 (inst stf temp
(current-nfp-tn vop
)
932 (* (tn-offset y
) n-word-bytes
)))
934 (inst stf temp
(current-nfp-tn vop
)
935 (* (tn-offset stack-temp
) n-word-bytes
))
936 (inst ld y
(current-nfp-tn vop
)
937 (* (tn-offset stack-temp
) n-word-bytes
))))))))
938 (frob %unary-truncate single-reg single-float fstoi
)
939 (frob %unary-truncate double-reg double-float fdtoi
)
941 (frob %unary-truncate long-reg long-float fqtoi
)
942 ;; KLUDGE -- these two forms were protected by #-sun4.
943 ;; (frob %unary-round single-reg single-float fstoir)
944 ;; (frob %unary-round double-reg double-float fdtoir)
947 (deftransform %unary-round
((x) (float) (signed-byte 32))
948 '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x
)))
951 (one-half (float 1/2 x
)))
955 (truly-the (signed-byte 32) (%unary-truncate
(+ x extra
)))
958 (define-vop (make-single-float)
959 (:args
(bits :scs
(signed-reg) :target res
960 :load-if
(not (sc-is bits signed-stack
))))
961 (:results
(res :scs
(single-reg)
962 :load-if
(not (sc-is res single-stack
))))
963 (:temporary
(:scs
(signed-reg) :from
(:argument
0) :to
(:result
0)) temp
)
964 (:temporary
(:scs
(signed-stack)) stack-temp
)
965 (:arg-types signed-num
)
966 (:result-types single-float
)
967 (:translate make-single-float
)
975 (inst st bits
(current-nfp-tn vop
)
976 (* (tn-offset stack-temp
) n-word-bytes
))
977 (inst ldf res
(current-nfp-tn vop
)
978 (* (tn-offset stack-temp
) n-word-bytes
)))
980 (inst st bits
(current-nfp-tn vop
)
981 (* (tn-offset res
) n-word-bytes
)))))
985 (inst ldf res
(current-nfp-tn vop
)
986 (* (tn-offset bits
) n-word-bytes
)))
988 (unless (location= bits res
)
989 (inst ld temp
(current-nfp-tn vop
)
990 (* (tn-offset bits
) n-word-bytes
))
991 (inst st temp
(current-nfp-tn vop
)
992 (* (tn-offset res
) n-word-bytes
)))))))))
994 (define-vop (make-double-float)
995 (:args
(hi-bits :scs
(signed-reg))
996 (lo-bits :scs
(unsigned-reg)))
997 (:results
(res :scs
(double-reg)
998 :load-if
(not (sc-is res double-stack
))))
999 (:temporary
(:scs
(double-stack)) temp
)
1000 (:arg-types signed-num unsigned-num
)
1001 (:result-types double-float
)
1002 (:translate make-double-float
)
1003 (:policy
:fast-safe
)
1006 (let ((stack-tn (sc-case res
1008 (double-reg temp
))))
1009 (inst st hi-bits
(current-nfp-tn vop
)
1010 (* (tn-offset stack-tn
) n-word-bytes
))
1011 (inst st lo-bits
(current-nfp-tn vop
)
1012 (* (1+ (tn-offset stack-tn
)) n-word-bytes
)))
1013 (when (sc-is res double-reg
)
1014 (inst lddf res
(current-nfp-tn vop
)
1015 (* (tn-offset temp
) n-word-bytes
)))))
1018 (define-vop (make-long-float)
1019 (:args
(hi-bits :scs
(signed-reg))
1020 (lo1-bits :scs
(unsigned-reg))
1021 (lo2-bits :scs
(unsigned-reg))
1022 (lo3-bits :scs
(unsigned-reg)))
1023 (:results
(res :scs
(long-reg)
1024 :load-if
(not (sc-is res long-stack
))))
1025 (:temporary
(:scs
(long-stack)) temp
)
1026 (:arg-types signed-num unsigned-num unsigned-num unsigned-num
)
1027 (:result-types long-float
)
1028 (:translate make-long-float
)
1029 (:policy
:fast-safe
)
1032 (let ((stack-tn (sc-case res
1035 (inst st hi-bits
(current-nfp-tn vop
)
1036 (* (tn-offset stack-tn
) n-word-bytes
))
1037 (inst st lo1-bits
(current-nfp-tn vop
)
1038 (* (1+ (tn-offset stack-tn
)) n-word-bytes
))
1039 (inst st lo2-bits
(current-nfp-tn vop
)
1040 (* (+ 2 (tn-offset stack-tn
)) n-word-bytes
))
1041 (inst st lo3-bits
(current-nfp-tn vop
)
1042 (* (+ 3 (tn-offset stack-tn
)) n-word-bytes
)))
1043 (when (sc-is res long-reg
)
1044 (load-long-reg res
(current-nfp-tn vop
)
1045 (* (tn-offset temp
) n-word-bytes
)))))
1047 (define-vop (single-float-bits)
1048 (:args
(float :scs
(single-reg descriptor-reg
)
1049 :load-if
(not (sc-is float single-stack
))))
1050 (:results
(bits :scs
(signed-reg)
1051 :load-if
(or (sc-is float descriptor-reg single-stack
)
1052 (not (sc-is bits signed-stack
)))))
1053 (:temporary
(:scs
(signed-stack)) stack-temp
)
1054 (:arg-types single-float
)
1055 (:result-types signed-num
)
1056 (:translate single-float-bits
)
1057 (:policy
:fast-safe
)
1064 (inst stf float
(current-nfp-tn vop
)
1065 (* (tn-offset stack-temp
) n-word-bytes
))
1066 (inst ld bits
(current-nfp-tn vop
)
1067 (* (tn-offset stack-temp
) n-word-bytes
)))
1069 (inst ld bits
(current-nfp-tn vop
)
1070 (* (tn-offset float
) n-word-bytes
)))
1072 (loadw bits float single-float-value-slot
1073 other-pointer-lowtag
))))
1077 (inst stf float
(current-nfp-tn vop
)
1078 (* (tn-offset bits
) n-word-bytes
))))))))
1080 (define-vop (double-float-high-bits)
1081 (:args
(float :scs
(double-reg descriptor-reg
)
1082 :load-if
(not (sc-is float double-stack
))))
1083 (:results
(hi-bits :scs
(signed-reg)))
1084 (:temporary
(:scs
(double-stack)) stack-temp
)
1085 (:arg-types double-float
)
1086 (:result-types signed-num
)
1087 (:translate double-float-high-bits
)
1088 (:policy
:fast-safe
)
1093 (inst stdf float
(current-nfp-tn vop
)
1094 (* (tn-offset stack-temp
) n-word-bytes
))
1095 (inst ld hi-bits
(current-nfp-tn vop
)
1096 (* (tn-offset stack-temp
) n-word-bytes
)))
1098 (inst ld hi-bits
(current-nfp-tn vop
)
1099 (* (tn-offset float
) n-word-bytes
)))
1101 (loadw hi-bits float double-float-value-slot
1102 other-pointer-lowtag
)))))
1104 (define-vop (double-float-low-bits)
1105 (:args
(float :scs
(double-reg descriptor-reg
)
1106 :load-if
(not (sc-is float double-stack
))))
1107 (:results
(lo-bits :scs
(unsigned-reg)))
1108 (:temporary
(:scs
(double-stack)) stack-temp
)
1109 (:arg-types double-float
)
1110 (:result-types unsigned-num
)
1111 (:translate double-float-low-bits
)
1112 (:policy
:fast-safe
)
1117 (inst stdf float
(current-nfp-tn vop
)
1118 (* (tn-offset stack-temp
) n-word-bytes
))
1119 (inst ld lo-bits
(current-nfp-tn vop
)
1120 (* (1+ (tn-offset stack-temp
)) n-word-bytes
)))
1122 (inst ld lo-bits
(current-nfp-tn vop
)
1123 (* (1+ (tn-offset float
)) n-word-bytes
)))
1125 (loadw lo-bits float
(1+ double-float-value-slot
)
1126 other-pointer-lowtag
)))))
1129 (define-vop (long-float-exp-bits)
1130 (:args
(float :scs
(long-reg descriptor-reg
)
1131 :load-if
(not (sc-is float long-stack
))))
1132 (:results
(exp-bits :scs
(signed-reg)))
1133 (:temporary
(:scs
(double-stack)) stack-temp
)
1134 (:arg-types long-float
)
1135 (:result-types signed-num
)
1136 (:translate long-float-exp-bits
)
1137 (:policy
:fast-safe
)
1142 (let ((float (make-random-tn :kind
:normal
1143 :sc
(sc-or-lose 'double-reg
)
1144 :offset
(tn-offset float
))))
1145 (inst stdf float
(current-nfp-tn vop
)
1146 (* (tn-offset stack-temp
) n-word-bytes
)))
1147 (inst ld exp-bits
(current-nfp-tn vop
)
1148 (* (tn-offset stack-temp
) n-word-bytes
)))
1150 (inst ld exp-bits
(current-nfp-tn vop
)
1151 (* (tn-offset float
) n-word-bytes
)))
1153 (loadw exp-bits float long-float-value-slot
1154 other-pointer-lowtag
)))))
1157 (define-vop (long-float-high-bits)
1158 (:args
(float :scs
(long-reg descriptor-reg
)
1159 :load-if
(not (sc-is float long-stack
))))
1160 (:results
(high-bits :scs
(unsigned-reg)))
1161 (:temporary
(:scs
(double-stack)) stack-temp
)
1162 (:arg-types long-float
)
1163 (:result-types unsigned-num
)
1164 (:translate long-float-high-bits
)
1165 (:policy
:fast-safe
)
1170 (let ((float (make-random-tn :kind
:normal
1171 :sc
(sc-or-lose 'double-reg
)
1172 :offset
(tn-offset float
))))
1173 (inst stdf float
(current-nfp-tn vop
)
1174 (* (tn-offset stack-temp
) n-word-bytes
)))
1175 (inst ld high-bits
(current-nfp-tn vop
)
1176 (* (1+ (tn-offset stack-temp
)) n-word-bytes
)))
1178 (inst ld high-bits
(current-nfp-tn vop
)
1179 (* (1+ (tn-offset float
)) n-word-bytes
)))
1181 (loadw high-bits float
(1+ long-float-value-slot
)
1182 other-pointer-lowtag
)))))
1185 (define-vop (long-float-mid-bits)
1186 (:args
(float :scs
(long-reg descriptor-reg
)
1187 :load-if
(not (sc-is float long-stack
))))
1188 (:results
(mid-bits :scs
(unsigned-reg)))
1189 (:temporary
(:scs
(double-stack)) stack-temp
)
1190 (:arg-types long-float
)
1191 (:result-types unsigned-num
)
1192 (:translate long-float-mid-bits
)
1193 (:policy
:fast-safe
)
1198 (let ((float (make-random-tn :kind
:normal
1199 :sc
(sc-or-lose 'double-reg
)
1200 :offset
(+ 2 (tn-offset float
)))))
1201 (inst stdf float
(current-nfp-tn vop
)
1202 (* (tn-offset stack-temp
) n-word-bytes
)))
1203 (inst ld mid-bits
(current-nfp-tn vop
)
1204 (* (tn-offset stack-temp
) n-word-bytes
)))
1206 (inst ld mid-bits
(current-nfp-tn vop
)
1207 (* (+ 2 (tn-offset float
)) n-word-bytes
)))
1209 (loadw mid-bits float
(+ 2 long-float-value-slot
)
1210 other-pointer-lowtag
)))))
1213 (define-vop (long-float-low-bits)
1214 (:args
(float :scs
(long-reg descriptor-reg
)
1215 :load-if
(not (sc-is float long-stack
))))
1216 (:results
(lo-bits :scs
(unsigned-reg)))
1217 (:temporary
(:scs
(double-stack)) stack-temp
)
1218 (:arg-types long-float
)
1219 (:result-types unsigned-num
)
1220 (:translate long-float-low-bits
)
1221 (:policy
:fast-safe
)
1226 (let ((float (make-random-tn :kind
:normal
1227 :sc
(sc-or-lose 'double-reg
)
1228 :offset
(+ 2 (tn-offset float
)))))
1229 (inst stdf float
(current-nfp-tn vop
)
1230 (* (tn-offset stack-temp
) n-word-bytes
)))
1231 (inst ld lo-bits
(current-nfp-tn vop
)
1232 (* (1+ (tn-offset stack-temp
)) n-word-bytes
)))
1234 (inst ld lo-bits
(current-nfp-tn vop
)
1235 (* (+ 3 (tn-offset float
)) n-word-bytes
)))
1237 (loadw lo-bits float
(+ 3 long-float-value-slot
)
1238 other-pointer-lowtag
)))))
1241 ;;;; Float mode hackery:
1243 (sb!xc
:deftype float-modes
() '(unsigned-byte 32))
1244 (defknown floating-point-modes
() float-modes
(flushable))
1245 (defknown ((setf floating-point-modes
)) (float-modes)
1248 (define-vop (floating-point-modes)
1249 (:results
(res :scs
(unsigned-reg)))
1250 (:result-types unsigned-num
)
1251 (:translate floating-point-modes
)
1252 (:policy
:fast-safe
)
1254 (:temporary
(:sc unsigned-stack
) temp
)
1256 (let ((nfp (current-nfp-tn vop
)))
1257 (inst stfsr nfp
(* n-word-bytes
(tn-offset temp
)))
1258 (loadw res nfp
(tn-offset temp
))
1262 (define-vop (floating-point-modes)
1263 (:results
(res :scs
(unsigned-reg)))
1264 (:result-types unsigned-num
)
1265 (:translate floating-point-modes
)
1266 (:policy
:fast-safe
)
1268 (:temporary
(:sc double-stack
) temp
)
1270 (let* ((nfp (current-nfp-tn vop
))
1271 (offset (* 4 (tn-offset temp
))))
1272 (inst stxfsr nfp offset
)
1273 ;; The desired FP mode data is in the least significant 32
1274 ;; bits, which is stored at the next higher word in memory.
1275 (loadw res nfp
(+ offset
4))
1276 ;; Is this nop needed? -- rtoy
1279 (define-vop (set-floating-point-modes)
1280 (:args
(new :scs
(unsigned-reg) :target res
))
1281 (:results
(res :scs
(unsigned-reg)))
1282 (:arg-types unsigned-num
)
1283 (:result-types unsigned-num
)
1284 (:translate
(setf floating-point-modes
))
1285 (:policy
:fast-safe
)
1286 (:temporary
(:sc unsigned-stack
) temp
)
1289 (let ((nfp (current-nfp-tn vop
)))
1290 (storew new nfp
(tn-offset temp
))
1291 (inst ldfsr nfp
(* n-word-bytes
(tn-offset temp
)))
1295 (define-vop (set-floating-point-modes)
1296 (:args
(new :scs
(unsigned-reg) :target res
))
1297 (:results
(res :scs
(unsigned-reg)))
1298 (:arg-types unsigned-num
)
1299 (:result-types unsigned-num
)
1300 (:translate
(setf floating-point-modes
))
1301 (:policy
:fast-safe
)
1302 (:temporary
(:sc double-stack
) temp
)
1303 (:temporary
(:sc unsigned-reg
) my-fsr
)
1306 (let ((nfp (current-nfp-tn vop
))
1307 (offset (* n-word-bytes
(tn-offset temp
))))
1309 ;; Get the current FSR, so we can get the new %fcc's
1310 (inst stxfsr nfp offset
)
1311 (inst ldx my-fsr nfp offset
)
1312 ;; Carefully merge in the new mode bits with the rest of the
1313 ;; FSR. This is only needed if we care about preserving the
1314 ;; high 32 bits of the FSR, which contain the additional
1315 ;; %fcc's on the sparc V9. If not, we don't need this, but we
1316 ;; do need to make sure that the unused bits are written as
1317 ;; zeroes, according the V9 architecture manual.
1319 (inst srlx my-fsr
32)
1320 (inst sllx my-fsr
32)
1321 (inst or my-fsr new
)
1322 ;; Save it back and load it into the fsr register
1323 (inst stx my-fsr nfp offset
)
1324 (inst ldxfsr nfp offset
)
1328 (define-vop (set-floating-point-modes)
1329 (:args
(new :scs
(unsigned-reg) :target res
))
1330 (:results
(res :scs
(unsigned-reg)))
1331 (:arg-types unsigned-num
)
1332 (:result-types unsigned-num
)
1333 (:translate
(setf floating-point-modes
))
1334 (:policy
:fast-safe
)
1335 (:temporary
(:sc double-stack
) temp
)
1336 (:temporary
(:sc unsigned-reg
) my-fsr
)
1339 (let ((nfp (current-nfp-tn vop
))
1340 (offset (* n-word-bytes
(tn-offset temp
))))
1341 (inst stx new nfp offset
)
1342 (inst ldxfsr nfp offset
)
1346 ;;;; Special functions.
1350 (:args
(x :scs
(double-reg)))
1351 (:results
(y :scs
(double-reg)))
1353 (:policy
:fast-safe
)
1354 (:guard
(or (member :sparc-v7
*backend-subfeatures
*)
1355 (member :sparc-v8
*backend-subfeatures
*)
1356 (member :sparc-v9
*backend-subfeatures
*)))
1357 (:arg-types double-float
)
1358 (:result-types double-float
)
1359 (:note
"inline float arithmetic")
1361 (:save-p
:compute-only
)
1363 (note-this-location vop
:internal-error
)
1367 (define-vop (fsqrt-long)
1368 (:args
(x :scs
(long-reg)))
1369 (:results
(y :scs
(long-reg)))
1371 (:policy
:fast-safe
)
1372 (:arg-types long-float
)
1373 (:result-types long-float
)
1374 (:note
"inline float arithmetic")
1376 (:save-p
:compute-only
)
1378 (note-this-location vop
:internal-error
)
1382 ;;;; Complex float VOPs
1384 (define-vop (make-complex-single-float)
1385 (:translate complex
)
1386 (:args
(real :scs
(single-reg) :target r
1387 :load-if
(not (location= real r
)))
1388 (imag :scs
(single-reg) :to
:save
))
1389 (:arg-types single-float single-float
)
1390 (:results
(r :scs
(complex-single-reg) :from
(:argument
0)
1391 :load-if
(not (sc-is r complex-single-stack
))))
1392 (:result-types complex-single-float
)
1393 (:note
"inline complex single-float creation")
1394 (:policy
:fast-safe
)
1399 (let ((r-real (complex-single-reg-real-tn r
)))
1400 (unless (location= real r-real
)
1401 (inst fmovs r-real real
)))
1402 (let ((r-imag (complex-single-reg-imag-tn r
)))
1403 (unless (location= imag r-imag
)
1404 (inst fmovs r-imag imag
))))
1405 (complex-single-stack
1406 (let ((nfp (current-nfp-tn vop
))
1407 (offset (* (tn-offset r
) n-word-bytes
)))
1408 (unless (location= real r
)
1409 (inst stf real nfp offset
))
1410 (inst stf imag nfp
(+ offset n-word-bytes
)))))))
1412 (define-vop (make-complex-double-float)
1413 (:translate complex
)
1414 (:args
(real :scs
(double-reg) :target r
1415 :load-if
(not (location= real r
)))
1416 (imag :scs
(double-reg) :to
:save
))
1417 (:arg-types double-float double-float
)
1418 (:results
(r :scs
(complex-double-reg) :from
(:argument
0)
1419 :load-if
(not (sc-is r complex-double-stack
))))
1420 (:result-types complex-double-float
)
1421 (:note
"inline complex double-float creation")
1422 (:policy
:fast-safe
)
1427 (let ((r-real (complex-double-reg-real-tn r
)))
1428 (unless (location= real r-real
)
1429 (move-double-reg r-real real
)))
1430 (let ((r-imag (complex-double-reg-imag-tn r
)))
1431 (unless (location= imag r-imag
)
1432 (move-double-reg r-imag imag
))))
1433 (complex-double-stack
1434 (let ((nfp (current-nfp-tn vop
))
1435 (offset (* (tn-offset r
) n-word-bytes
)))
1436 (unless (location= real r
)
1437 (inst stdf real nfp offset
))
1438 (inst stdf imag nfp
(+ offset
(* 2 n-word-bytes
))))))))
1441 (define-vop (make-complex-long-float)
1442 (:translate complex
)
1443 (:args
(real :scs
(long-reg) :target r
1444 :load-if
(not (location= real r
)))
1445 (imag :scs
(long-reg) :to
:save
))
1446 (:arg-types long-float long-float
)
1447 (:results
(r :scs
(complex-long-reg) :from
(:argument
0)
1448 :load-if
(not (sc-is r complex-long-stack
))))
1449 (:result-types complex-long-float
)
1450 (:note
"inline complex long-float creation")
1451 (:policy
:fast-safe
)
1456 (let ((r-real (complex-long-reg-real-tn r
)))
1457 (unless (location= real r-real
)
1458 (move-long-reg r-real real
)))
1459 (let ((r-imag (complex-long-reg-imag-tn r
)))
1460 (unless (location= imag r-imag
)
1461 (move-long-reg r-imag imag
))))
1463 (let ((nfp (current-nfp-tn vop
))
1464 (offset (* (tn-offset r
) n-word-bytes
)))
1465 (unless (location= real r
)
1466 (store-long-reg real nfp offset
))
1467 (store-long-reg imag nfp
(+ offset
(* 4 n-word-bytes
))))))))
1469 (define-vop (complex-single-float-value)
1470 (:args
(x :scs
(complex-single-reg) :target r
1471 :load-if
(not (sc-is x complex-single-stack
))))
1472 (:arg-types complex-single-float
)
1473 (:results
(r :scs
(single-reg)))
1474 (:result-types single-float
)
1475 (:variant-vars slot
)
1476 (:policy
:fast-safe
)
1481 (let ((value-tn (ecase slot
1482 (:real
(complex-single-reg-real-tn x
))
1483 (:imag
(complex-single-reg-imag-tn x
)))))
1484 (unless (location= value-tn r
)
1485 (inst fmovs r value-tn
))))
1486 (complex-single-stack
1487 (inst ldf r
(current-nfp-tn vop
) (* (+ (ecase slot
(:real
0) (:imag
1))
1491 (define-vop (realpart/complex-single-float complex-single-float-value
)
1492 (:translate realpart
)
1493 (:note
"complex single float realpart")
1496 (define-vop (imagpart/complex-single-float complex-single-float-value
)
1497 (:translate imagpart
)
1498 (:note
"complex single float imagpart")
1501 (define-vop (complex-double-float-value)
1502 (:args
(x :scs
(complex-double-reg) :target r
1503 :load-if
(not (sc-is x complex-double-stack
))))
1504 (:arg-types complex-double-float
)
1505 (:results
(r :scs
(double-reg)))
1506 (:result-types double-float
)
1507 (:variant-vars slot
)
1508 (:policy
:fast-safe
)
1513 (let ((value-tn (ecase slot
1514 (:real
(complex-double-reg-real-tn x
))
1515 (:imag
(complex-double-reg-imag-tn x
)))))
1516 (unless (location= value-tn r
)
1517 (move-double-reg r value-tn
))))
1518 (complex-double-stack
1519 (inst lddf r
(current-nfp-tn vop
) (* (+ (ecase slot
(:real
0) (:imag
2))
1523 (define-vop (realpart/complex-double-float complex-double-float-value
)
1524 (:translate realpart
)
1525 (:note
"complex double float realpart")
1528 (define-vop (imagpart/complex-double-float complex-double-float-value
)
1529 (:translate imagpart
)
1530 (:note
"complex double float imagpart")
1534 (define-vop (complex-long-float-value)
1535 (:args
(x :scs
(complex-long-reg) :target r
1536 :load-if
(not (sc-is x complex-long-stack
))))
1537 (:arg-types complex-long-float
)
1538 (:results
(r :scs
(long-reg)))
1539 (:result-types long-float
)
1540 (:variant-vars slot
)
1541 (:policy
:fast-safe
)
1546 (let ((value-tn (ecase slot
1547 (:real
(complex-long-reg-real-tn x
))
1548 (:imag
(complex-long-reg-imag-tn x
)))))
1549 (unless (location= value-tn r
)
1550 (move-long-reg r value-tn
))))
1552 (load-long-reg r
(current-nfp-tn vop
)
1553 (* (+ (ecase slot
(:real
0) (:imag
4)) (tn-offset x
))
1557 (define-vop (realpart/complex-long-float complex-long-float-value
)
1558 (:translate realpart
)
1559 (:note
"complex long float realpart")
1563 (define-vop (imagpart/complex-long-float complex-long-float-value
)
1564 (:translate imagpart
)
1565 (:note
"complex long float imagpart")
1570 ;;;; Complex float arithmetic
1577 ((frob (float-type fneg cost
)
1578 (let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type
))
1579 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
1580 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
1581 (real-tn (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
1582 (imag-tn (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
1583 `(define-vop (,vop-name
)
1584 (:args
(x :scs
(,complex-reg
)))
1585 (:arg-types
,c-type
)
1586 (:results
(r :scs
(,complex-reg
)))
1587 (:result-types
,c-type
)
1588 (:policy
:fast-safe
)
1589 (:note
"inline complex float arithmetic")
1590 (:translate %negate
)
1592 (let ((xr (,real-tn x
))
1597 (,@fneg ri xi
)))))))
1598 (frob single
(inst fnegs
) 4)
1599 (frob double
(negate-double-reg) 4))
1601 ;; Add and subtract for two complex arguments
1603 ((frob (op inst float-type cost
)
1604 (let* ((vop-name (symbolicate (symbol-name op
) "/COMPLEX-" float-type
"-FLOAT"))
1605 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
1606 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
1607 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
1608 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
1609 `(define-vop (,vop-name
)
1610 (:args
(x :scs
(,complex-reg
)) (y :scs
(,complex-reg
)))
1611 (:results
(r :scs
(,complex-reg
)))
1612 (:arg-types
,c-type
,c-type
)
1613 (:result-types
,c-type
)
1614 (:policy
:fast-safe
)
1615 (:note
"inline complex float arithmetic")
1618 (let ((xr (,real-part x
))
1623 (ri (,imag-part r
)))
1624 (inst ,inst rr xr yr
)
1625 (inst ,inst ri xi yi
)))))))
1626 (frob + fadds single
4)
1627 (frob + faddd double
4)
1628 (frob - fsubs single
4)
1629 (frob - fsubd double
4))
1631 ;; Add and subtract a complex and a float
1634 ((frob (size op fop fmov cost
)
1635 (let ((vop-name (symbolicate "COMPLEX-" size
"-FLOAT-"
1638 (complex-reg (symbolicate "COMPLEX-" size
"-REG"))
1639 (real-reg (symbolicate size
"-REG"))
1640 (c-type (symbolicate "COMPLEX-" size
"-FLOAT"))
1641 (r-type (symbolicate size
"-FLOAT"))
1642 (real-part (symbolicate "COMPLEX-" size
"-REG-REAL-TN"))
1643 (imag-part (symbolicate "COMPLEX-" size
"-REG-IMAG-TN")))
1644 `(define-vop (,vop-name
)
1645 (:args
(x :scs
(,complex-reg
))
1646 (y :scs
(,real-reg
)))
1647 (:results
(r :scs
(,complex-reg
)))
1648 (:arg-types
,c-type
,r-type
)
1649 (:result-types
,c-type
)
1650 (:policy
:fast-safe
)
1651 (:note
"inline complex float/float arithmetic")
1654 (let ((xr (,real-part x
))
1657 (ri (,imag-part r
)))
1659 (unless (location= ri xi
)
1660 (,@fmov ri xi
))))))))
1662 (frob single
+ fadds
(inst fmovs
) 2)
1663 (frob single - fsubs
(inst fmovs
) 2)
1664 (frob double
+ faddd
(move-double-reg) 4)
1665 (frob double - fsubd
(move-double-reg) 4))
1667 ;; Add a float and a complex
1669 ((frob (size fop fmov cost
)
1671 (symbolicate size
"-FLOAT-+-COMPLEX-" size
"-FLOAT"))
1672 (complex-reg (symbolicate "COMPLEX-" size
"-REG"))
1673 (real-reg (symbolicate size
"-REG"))
1674 (c-type (symbolicate "COMPLEX-" size
"-FLOAT"))
1675 (r-type (symbolicate size
"-FLOAT"))
1676 (real-part (symbolicate "COMPLEX-" size
"-REG-REAL-TN"))
1677 (imag-part (symbolicate "COMPLEX-" size
"-REG-IMAG-TN")))
1678 `(define-vop (,vop-name
)
1679 (:args
(y :scs
(,real-reg
))
1680 (x :scs
(,complex-reg
)))
1681 (:results
(r :scs
(,complex-reg
)))
1682 (:arg-types
,r-type
,c-type
)
1683 (:result-types
,c-type
)
1684 (:policy
:fast-safe
)
1685 (:note
"inline complex float/float arithmetic")
1688 (let ((xr (,real-part x
))
1691 (ri (,imag-part r
)))
1693 (unless (location= ri xi
)
1694 (,@fmov ri xi
))))))))
1695 (frob single fadds
(inst fmovs
) 1)
1696 (frob double faddd
(move-double-reg) 2))
1698 ;; Subtract a complex from a float
1701 ((frob (size fop fneg cost
)
1702 (let ((vop-name (symbolicate size
"-FLOAT---COMPLEX-" size
"-FLOAT"))
1703 (complex-reg (symbolicate "COMPLEX-" size
"-REG"))
1704 (real-reg (symbolicate size
"-REG"))
1705 (c-type (symbolicate "COMPLEX-" size
"-FLOAT"))
1706 (r-type (symbolicate size
"-FLOAT"))
1707 (real-part (symbolicate "COMPLEX-" size
"-REG-REAL-TN"))
1708 (imag-part (symbolicate "COMPLEX-" size
"-REG-IMAG-TN")))
1709 `(define-vop (single-float---complex-single-float)
1710 (:args
(x :scs
(,real-reg
)) (y :scs
(,complex-reg
)))
1711 (:results
(r :scs
(,complex-reg
)))
1712 (:arg-types
,r-type
,c-type
)
1713 (:result-types
,c-type
)
1714 (:policy
:fast-safe
)
1715 (:note
"inline complex float/float arithmetic")
1718 (let ((yr (,real-part y
))
1721 (ri (,imag-part r
)))
1726 (frob single fsubs
(inst fnegs
) 2)
1727 (frob double fsubd
(negate-double-reg) 2)))
1729 ;; Multiply two complex numbers
1733 ((frob (size fmul fadd fsub cost
)
1734 (let ((vop-name (symbolicate "*/COMPLEX-" size
"-FLOAT"))
1735 (complex-reg (symbolicate "COMPLEX-" size
"-REG"))
1736 (real-reg (symbolicate size
"-REG"))
1737 (c-type (symbolicate "COMPLEX-" size
"-FLOAT"))
1738 (real-part (symbolicate "COMPLEX-" size
"-REG-REAL-TN"))
1739 (imag-part (symbolicate "COMPLEX-" size
"-REG-IMAG-TN")))
1740 `(define-vop (,vop-name
)
1741 (:args
(x :scs
(,complex-reg
))
1742 (y :scs
(,complex-reg
)))
1743 (:results
(r :scs
(,complex-reg
)))
1744 (:arg-types
,c-type
,c-type
)
1745 (:result-types
,c-type
)
1746 (:policy
:fast-safe
)
1747 (:note
"inline complex float multiplication")
1749 (:temporary
(:scs
(,real-reg
)) prod-1 prod-2 prod-3 prod-4
)
1751 (let ((xr (,real-part x
))
1756 (ri (,imag-part r
)))
1757 ;; All of the temps are needed in case the result TN happens to
1758 ;; be the same as one of the arg TN's
1759 (inst ,fmul prod-1 xr yr
)
1760 (inst ,fmul prod-2 xi yi
)
1761 (inst ,fmul prod-3 xr yi
)
1762 (inst ,fmul prod-4 xi yr
)
1763 (inst ,fsub rr prod-1 prod-2
)
1764 (inst ,fadd ri prod-3 prod-4
)))))))
1766 (frob single fmuls fadds fsubs
6)
1767 (frob double fmuld faddd fsubd
6))
1770 ((frob (size fmul fadd fsub cost
)
1771 (let ((vop-name (symbolicate "*/COMPLEX-" size
"-FLOAT"))
1772 (complex-reg (symbolicate "COMPLEX-" size
"-REG"))
1773 (real-reg (symbolicate size
"-REG"))
1774 (c-type (symbolicate "COMPLEX-" size
"-FLOAT"))
1775 (real-part (symbolicate "COMPLEX-" size
"-REG-REAL-TN"))
1776 (imag-part (symbolicate "COMPLEX-" size
"-REG-IMAG-TN")))
1777 `(define-vop (,vop-name
)
1778 (:args
(x :scs
(,complex-reg
))
1779 (y :scs
(,complex-reg
)))
1780 (:results
(r :scs
(,complex-reg
)))
1781 (:arg-types
,c-type
,c-type
)
1782 (:result-types
,c-type
)
1783 (:policy
:fast-safe
)
1784 (:note
"inline complex float multiplication")
1786 (:temporary
(:scs
(,real-reg
)) p1 p2
)
1788 (let ((xr (,real-part x
))
1793 (ri (,imag-part r
)))
1794 (cond ((location= r x
)
1795 (inst ,fmul p1 xr yr
)
1796 (inst ,fmul p2 xr yi
)
1797 (inst ,fmul rr xi yi
)
1798 (inst ,fsub rr p1 xr
)
1799 (inst ,fmul p1 xi yr
)
1800 (inst ,fadd ri p2 p1
))
1802 (inst ,fmul p1 yr xr
)
1803 (inst ,fmul p2 yr xi
)
1804 (inst ,fmul rr yi xi
)
1805 (inst ,fsub rr p1 rr
)
1806 (inst ,fmul p1 yi xr
)
1807 (inst ,fadd ri p2 p1
))
1809 (inst ,fmul rr yr xr
)
1810 (inst ,fmul ri xi yi
)
1811 (inst ,fsub rr rr ri
)
1812 (inst ,fmul p1 xr yi
)
1813 (inst ,fmul ri xi yr
)
1814 (inst ,fadd ri ri p1
)))))))))
1816 (frob single fmuls fadds fsubs
6)
1817 (frob double fmuld faddd fsubd
6))
1819 ;; Multiply a complex by a float. The case of float * complex is
1820 ;; handled by a deftransform to convert it to the complex*float case.
1822 ((frob (float-type fmul mov cost
)
1823 (let* ((vop-name (symbolicate "COMPLEX-"
1828 (vop-name-r (symbolicate float-type
1832 (complex-sc-type (symbolicate "COMPLEX-" float-type
"-REG"))
1833 (real-sc-type (symbolicate float-type
"-REG"))
1834 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
1835 (r-type (symbolicate float-type
"-FLOAT"))
1836 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
1837 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
1840 (define-vop (,vop-name
)
1841 (:args
(x :scs
(,complex-sc-type
))
1842 (y :scs
(,real-sc-type
)))
1843 (:results
(r :scs
(,complex-sc-type
)))
1844 (:arg-types
,c-type
,r-type
)
1845 (:result-types
,c-type
)
1846 (:policy
:fast-safe
)
1847 (:note
"inline complex float arithmetic")
1849 (:temporary
(:scs
(,real-sc-type
)) temp
)
1851 (let ((xr (,real-part x
))
1854 (ri (,imag-part r
)))
1855 (cond ((location= y rr
)
1856 (inst ,fmul temp xr y
) ; xr * y
1857 (inst ,fmul ri xi y
) ; xi * yi
1860 (inst ,fmul rr xr y
)
1861 (inst ,fmul ri xi y
))))))
1863 (define-vop (,vop-name-r
)
1864 (:args
(y :scs
(,real-sc-type
))
1865 (x :scs
(,complex-sc-type
)))
1866 (:results
(r :scs
(,complex-sc-type
)))
1867 (:arg-types
,r-type
,c-type
)
1868 (:result-types
,c-type
)
1869 (:policy
:fast-safe
)
1870 (:note
"inline complex float arithmetic")
1872 (:temporary
(:scs
(,real-sc-type
)) temp
)
1874 (let ((xr (,real-part x
))
1877 (ri (,imag-part r
)))
1878 (cond ((location= y rr
)
1879 (inst ,fmul temp xr y
) ; xr * y
1880 (inst ,fmul ri xi y
) ; xi * yi
1883 (inst ,fmul rr xr y
)
1884 (inst ,fmul ri xi y
))))))))))
1885 (frob single fmuls
(inst fmovs
) 4)
1886 (frob double fmuld
(move-double-reg) 4))
1889 ;; Divide a complex by a complex
1891 ;; Here's how we do a complex division
1893 ;; Compute (xr + i*xi)/(yr + i*yi)
1895 ;; Assume |yi| < |yr|. Then
1897 ;; (xr + i*xi) (xr + i*xi)
1898 ;; ----------- = -----------------
1899 ;; (yr + i*yi) yr*(1 + i*(yi/yr))
1901 ;; (xr + i*xi)*(1 - i*(yi/yr))
1902 ;; = ---------------------------
1903 ;; yr*(1 + (yi/yr)^2)
1905 ;; (xr + (yi/yr)*xi) + i*(xi - (yi/yr)*xr)
1906 ;; = --------------------------------------
1910 ;; We do the similar thing when |yi| > |yr|. The result is
1913 ;; (xr + i*xi) (xr + i*xi)
1914 ;; ----------- = -----------------
1915 ;; (yr + i*yi) yi*((yr/yi) + i)
1917 ;; (xr + i*xi)*((yr/yi) - i)
1918 ;; = -------------------------
1919 ;; yi*((yr/yi)^2 + 1)
1921 ;; (xr*(yr/yi) + xi) + i*(xi*(yr/yi) - xr)
1922 ;; = ---------------------------------------
1928 ((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov cost
)
1929 (let ((vop-name (symbolicate "//COMPLEX-" float-type
"-FLOAT"))
1930 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
1931 (real-reg (symbolicate float-type
"-REG"))
1932 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
1933 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
1934 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
1935 `(define-vop (,vop-name
)
1936 (:args
(x :scs
(,complex-reg
))
1937 (y :scs
(,complex-reg
)))
1938 (:results
(r :scs
(,complex-reg
)))
1939 (:arg-types
,c-type
,c-type
)
1940 (:result-types
,c-type
)
1941 (:policy
:fast-safe
)
1942 (:note
"inline complex float division")
1944 (:temporary
(:sc
,real-reg
) ratio
)
1945 (:temporary
(:sc
,real-reg
) den
)
1946 (:temporary
(:sc
,real-reg
) temp-r
)
1947 (:temporary
(:sc
,real-reg
) temp-i
)
1949 (let ((xr (,real-part x
))
1955 (bigger (gen-label))
1959 (inst ,fcmp ratio den
)
1960 (unless (member :sparc-v9
*backend-subfeatures
*)
1962 (inst fb
:ge bigger
)
1964 ;; The case of |yi| <= |yr|
1965 (inst ,fdiv ratio yi yr
) ; ratio = yi/yr
1966 (inst ,fmul den ratio yi
)
1967 (inst ,fadd den den yr
) ; den = yr + (yi/yr)*yi
1969 (inst ,fmul temp-r ratio xi
)
1970 (inst ,fadd temp-r temp-r xr
) ; temp-r = xr + (yi/yr)*xi
1971 (inst ,fdiv temp-r temp-r den
)
1973 (inst ,fmul temp-i ratio xr
)
1974 (inst ,fsub temp-i xi temp-i
) ; temp-i = xi - (yi/yr)*xr
1976 (inst ,fdiv temp-i temp-i den
)
1979 ;; The case of |yi| > |yr|
1980 (inst ,fdiv ratio yr yi
) ; ratio = yr/yi
1981 (inst ,fmul den ratio yr
)
1982 (inst ,fadd den den yi
) ; den = yi + (yr/yi)*yr
1984 (inst ,fmul temp-r ratio xr
)
1985 (inst ,fadd temp-r temp-r xi
) ; temp-r = xi + xr*(yr/yi)
1986 (inst ,fdiv temp-r temp-r den
)
1988 (inst ,fmul temp-i ratio xi
)
1989 (inst ,fsub temp-i temp-i xr
) ; temp-i = xi*(yr/yi) - xr
1990 (inst ,fdiv temp-i temp-i den
)
1993 (unless (location= temp-r rr
)
1995 (unless (location= temp-i ri
)
1999 (frob single fcmps fadds fsubs fmuls fdivs
(inst fabss
) (inst fmovs
) 15)
2000 (frob double fcmpd faddd fsubd fmuld fdivd
(abs-double-reg) (move-double-reg) 15))
2003 ((frob (float-type fcmp fadd fsub fmul fdiv fabs cost
)
2004 (let ((vop-name (symbolicate "//COMPLEX-" float-type
"-FLOAT"))
2005 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
2006 (real-reg (symbolicate float-type
"-REG"))
2007 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2008 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2009 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2010 `(define-vop (,vop-name
)
2011 (:args
(x :scs
(,complex-reg
))
2012 (y :scs
(,complex-reg
)))
2013 (:results
(r :scs
(,complex-reg
)))
2014 (:arg-types
,c-type
,c-type
)
2015 (:result-types
,c-type
)
2016 (:policy
:fast-safe
)
2017 (:note
"inline complex float division")
2019 (:temporary
(:sc
,real-reg
) ratio
)
2020 (:temporary
(:sc
,real-reg
) den
)
2021 (:temporary
(:sc
,real-reg
) temp-r
)
2022 (:temporary
(:sc
,real-reg
) temp-i
)
2024 (let ((xr (,real-part x
))
2030 (bigger (gen-label))
2034 (inst ,fcmp ratio den
)
2035 (unless (member :sparc-v9
*backend-subfeatures
*)
2037 (inst fb
:ge bigger
)
2039 ;; The case of |yi| <= |yr|
2040 (inst ,fdiv ratio yi yr
) ; ratio = yi/yr
2041 (inst ,fmul den ratio yi
)
2042 (inst ,fmul temp-r ratio xi
)
2043 (inst ,fmul temp-i ratio xr
)
2045 (inst ,fadd den den yr
) ; den = yr + (yi/yr)*yi
2046 (inst ,fadd temp-r temp-r xr
) ; temp-r = xr + (yi/yr)*xi
2048 (inst ,fsub temp-i xi temp-i
) ; temp-i = xi - (yi/yr)*xr
2052 ;; The case of |yi| > |yr|
2053 (inst ,fdiv ratio yr yi
) ; ratio = yr/yi
2054 (inst ,fmul den ratio yr
)
2055 (inst ,fmul temp-r ratio xr
)
2056 (inst ,fmul temp-i ratio xi
)
2058 (inst ,fadd den den yi
) ; den = yi + (yr/yi)*yr
2059 (inst ,fadd temp-r temp-r xi
) ; temp-r = xi + xr*(yr/yi)
2061 (inst ,fsub temp-i temp-i xr
) ; temp-i = xi*(yr/yi) - xr
2065 (inst ,fdiv rr temp-r den
)
2066 (inst ,fdiv ri temp-i den
)
2069 (frob single fcmps fadds fsubs fmuls fdivs
(inst fabss
) 15)
2070 (frob double fcmpd faddd fsubd fmuld fdivd
(abs-double-reg) 15))
2073 ;; Divide a complex by a real
2075 ((frob (float-type fdiv cost
)
2076 (let* ((vop-name (symbolicate "COMPLEX-" float-type
"-FLOAT-/-" float-type
"-FLOAT"))
2077 (complex-sc-type (symbolicate "COMPLEX-" float-type
"-REG"))
2078 (real-sc-type (symbolicate float-type
"-REG"))
2079 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2080 (r-type (symbolicate float-type
"-FLOAT"))
2081 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2082 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2083 `(define-vop (,vop-name
)
2084 (:args
(x :scs
(,complex-sc-type
)) (y :scs
(,real-sc-type
)))
2085 (:results
(r :scs
(,complex-sc-type
)))
2086 (:arg-types
,c-type
,r-type
)
2087 (:result-types
,c-type
)
2088 (:policy
:fast-safe
)
2089 (:note
"inline complex float arithmetic")
2092 (let ((xr (,real-part x
))
2095 (ri (,imag-part r
)))
2096 (inst ,fdiv rr xr y
) ; xr * y
2097 (inst ,fdiv ri xi y
) ; xi * yi
2099 (frob single fdivs
2)
2100 (frob double fdivd
2))
2102 ;; Divide a real by a complex
2105 ((frob (float-type fcmp fadd fmul fdiv fneg fabs cost
)
2106 (let ((vop-name (symbolicate float-type
"-FLOAT-/-COMPLEX-" float-type
"-FLOAT"))
2107 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
2108 (real-reg (symbolicate float-type
"-REG"))
2109 (r-type (symbolicate float-type
"-FLOAT"))
2110 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2111 (real-tn (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2112 (imag-tn (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2113 `(define-vop (,vop-name
)
2114 (:args
(x :scs
(,real-reg
))
2115 (y :scs
(,complex-reg
)))
2116 (:results
(r :scs
(,complex-reg
)))
2117 (:arg-types
,r-type
,c-type
)
2118 (:result-types
,c-type
)
2119 (:policy
:fast-safe
)
2120 (:note
"inline complex float division")
2122 (:temporary
(:sc
,real-reg
) ratio
)
2123 (:temporary
(:sc
,real-reg
) den
)
2124 (:temporary
(:sc
,real-reg
) temp
)
2126 (let ((yr (,real-tn y
))
2130 (bigger (gen-label))
2134 (inst ,fcmp ratio den
)
2135 (unless (member :sparc-v9
*backend-subfeatures
*)
2137 (inst fb
:ge bigger
)
2139 ;; The case of |yi| <= |yr|
2140 (inst ,fdiv ratio yi yr
) ; ratio = yi/yr
2141 (inst ,fmul den ratio yi
)
2142 (inst ,fadd den den yr
) ; den = yr + (yi/yr)*yi
2144 (inst ,fmul temp ratio x
) ; temp = (yi/yr)*x
2145 (inst ,fdiv rr x den
) ; rr = x/den
2147 (inst ,fdiv temp temp den
) ; temp = (yi/yr)*x/den
2150 ;; The case of |yi| > |yr|
2151 (inst ,fdiv ratio yr yi
) ; ratio = yr/yi
2152 (inst ,fmul den ratio yr
)
2153 (inst ,fadd den den yi
) ; den = yi + (yr/yi)*yr
2155 (inst ,fmul temp ratio x
) ; temp = (yr/yi)*x
2156 (inst ,fdiv rr temp den
) ; rr = (yr/yi)*x/den
2157 (inst ,fdiv temp x den
) ; temp = x/den
2160 (,@fneg ri temp
)))))))
2162 (frob single fcmps fadds fmuls fdivs
(inst fnegs
) (inst fabss
) 10)
2163 (frob double fcmpd faddd fmuld fdivd
(negate-double-reg) (abs-double-reg) 10))
2165 ;; Conjugate of a complex number
2168 ((frob (float-type fneg fmov cost
)
2169 (let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type
"-FLOAT"))
2170 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
2171 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2172 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2173 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2174 `(define-vop (,vop-name
)
2175 (:args
(x :scs
(,complex-reg
)))
2176 (:results
(r :scs
(,complex-reg
)))
2177 (:arg-types
,c-type
)
2178 (:result-types
,c-type
)
2179 (:policy
:fast-safe
)
2180 (:note
"inline complex conjugate")
2181 (:translate conjugate
)
2183 (let ((xr (,real-part x
))
2186 (ri (,imag-part r
)))
2188 (unless (location= rr xr
)
2189 (,@fmov rr xr
))))))))
2191 (frob single
(inst fnegs
) (inst fmovs
) 4)
2192 (frob double
(negate-double-reg) (move-double-reg) 4))
2194 ;; Compare a float with a complex or a complex with a float
2197 ((frob (name name-r f-type c-type
)
2199 (defknown ,name
(,f-type
,c-type
) t
)
2200 (defknown ,name-r
(,c-type
,f-type
) t
)
2202 (declare (type ,f-type x
)
2205 (defun ,name-r
(x y
)
2206 (declare (type ,c-type x
)
2210 (frob %compare-complex-single-single %compare-single-complex-single
2211 single-float
(complex single-float
))
2212 (frob %compare-complex-double-double %compare-double-complex-double
2213 double-float
(complex double-float
)))
2217 ((frob (trans-1 trans-2 float-type fcmp fsub
)
2219 (symbolicate "COMPLEX-" float-type
"-FLOAT-"
2220 float-type
"-FLOAT-COMPARE"))
2222 (symbolicate float-type
"-FLOAT-COMPLEX-"
2223 float-type
"-FLOAT-COMPARE"))
2224 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
2225 (real-reg (symbolicate float-type
"-REG"))
2226 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2227 (r-type (symbolicate float-type
"-FLOAT"))
2228 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2229 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2231 ;; (= float complex)
2232 (define-vop (,vop-name
)
2233 (:args
(x :scs
(,real-reg
))
2234 (y :scs
(,complex-reg
)))
2235 (:arg-types
,r-type
,c-type
)
2236 (:translate
,trans-1
)
2238 (:info target not-p
)
2239 (:policy
:fast-safe
)
2240 (:note
"inline complex float/float comparison")
2242 (:save-p
:compute-only
)
2243 (:temporary
(:sc
,real-reg
) fp-zero
)
2244 (:guard
#!-
:sparc-v9 nil
#!+:sparc-v9 t
)
2246 (note-this-location vop
:internal-error
)
2247 (let ((yr (,real-part y
))
2248 (yi (,imag-part y
)))
2249 ;; Set fp-zero to zero
2250 (inst ,fsub fp-zero fp-zero fp-zero
)
2253 (inst fb
(if not-p
:ne
:eq
) target
#!+sparc-v9
:fcc0
#!+sparc-v9
:pn
)
2254 (inst ,fcmp yi fp-zero
)
2256 (inst fb
(if not-p
:ne
:eq
) target
#!+sparc-v9
:fcc0
#!+sparc-v9
:pn
)
2258 ;; (= complex float)
2259 (define-vop (,vop-name-r
)
2260 (:args
(y :scs
(,complex-reg
))
2261 (x :scs
(,real-reg
)))
2262 (:arg-types
,c-type
,r-type
)
2263 (:translate
,trans-2
)
2265 (:info target not-p
)
2266 (:policy
:fast-safe
)
2267 (:note
"inline complex float/float comparison")
2269 (:save-p
:compute-only
)
2270 (:temporary
(:sc
,real-reg
) fp-zero
)
2271 (:guard
#!-
:sparc-v9 t
#!+:sparc-v9 nil
)
2273 (note-this-location vop
:internal-error
)
2274 (let ((yr (,real-part y
))
2275 (yi (,imag-part y
)))
2276 ;; Set fp-zero to zero
2277 (inst ,fsub fp-zero fp-zero fp-zero
)
2280 (inst fb
(if not-p
:ne
:eq
) target
#!+sparc-v9
:fcc0
#!+sparc-v9
:pn
)
2281 (inst ,fcmp yi fp-zero
)
2283 (inst fb
(if not-p
:ne
:eq
) target
#!+sparc-v9
:fcc0
#!+sparc-v9
:pn
)
2285 (frob %compare-complex-single-single %compare-single-complex-single
2287 (frob %compare-complex-double-double %compare-double-complex-double
2288 double fcmpd fsubd
))
2290 ;; Compare two complex numbers for equality
2292 ((frob (float-type fcmp
)
2294 (symbolicate "COMPLEX-" float-type
"-FLOAT-COMPARE"))
2295 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
2296 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2297 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2298 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2299 `(define-vop (,vop-name
)
2300 (:args
(x :scs
(,complex-reg
))
2301 (y :scs
(,complex-reg
)))
2302 (:arg-types
,c-type
,c-type
)
2305 (:info target not-p
)
2306 (:policy
:fast-safe
)
2307 (:note
"inline complex float comparison")
2309 (:save-p
:compute-only
)
2311 (note-this-location vop
:internal-error
)
2312 (let ((xr (,real-part x
))
2315 (yi (,imag-part y
)))
2318 (inst fb
(if not-p
:ne
:eq
) target
#!+sparc-v9
:fcc0
#!+sparc-v9
:pn
)
2321 (inst fb
(if not-p
:ne
:eq
) target
#!+sparc-v9
:fcc0
#!+sparc-v9
:pn
)
2324 (frob double fcmpd
))
2326 ;; Compare a complex with a complex, for V9
2328 ((frob (float-type fcmp
)
2330 (symbolicate "V9-COMPLEX-" float-type
"-FLOAT-COMPARE"))
2331 (complex-reg (symbolicate "COMPLEX-" float-type
"-REG"))
2332 (c-type (symbolicate "COMPLEX-" float-type
"-FLOAT"))
2333 (real-part (symbolicate "COMPLEX-" float-type
"-REG-REAL-TN"))
2334 (imag-part (symbolicate "COMPLEX-" float-type
"-REG-IMAG-TN")))
2335 `(define-vop (,vop-name
)
2336 (:args
(x :scs
(,complex-reg
))
2337 (y :scs
(,complex-reg
)))
2338 (:arg-types
,c-type
,c-type
)
2341 (:info target not-p
)
2342 (:policy
:fast-safe
)
2343 (:note
"inline complex float comparison")
2345 (:save-p
:compute-only
)
2346 (:temporary
(:sc descriptor-reg
) true
)
2347 (:guard
(member :sparc-v9
*backend-subfeatures
*))
2349 (note-this-location vop
:internal-error
)
2350 (let ((xr (,real-part x
))
2353 (yi (,imag-part y
)))
2354 ;; Assume comparison is true
2355 (load-symbol true t
)
2357 (inst cmove
(if not-p
:eq
:ne
) true null-tn
:fcc0
)
2359 (inst cmove
(if not-p
:eq
:ne
) true null-tn
:fcc0
)
2360 (inst cmp true null-tn
)
2361 (inst b
(if not-p
:eq
:ne
) target
:pt
)
2364 (frob double fcmpd
))
2366 ) ; end progn complex-fp-vops
2371 ;;; The stuff below looks good, but we already have transforms for max
2372 ;;; and min. How should we arrange that?
2376 ;; Vops to take advantage of the conditional move instruction
2377 ;; available on the Sparc V9
2379 (defknown (%%max %%min
) ((or (unsigned-byte #.n-word-bits
)
2380 (signed-byte #.n-word-bits
)
2381 single-float double-float
)
2382 (or (unsigned-byte #.n-word-bits
)
2383 (signed-byte #.n-word-bits
)
2384 single-float double-float
))
2385 (or (unsigned-byte #.n-word-bits
)
2386 (signed-byte #.n-word-bits
)
2387 single-float double-float
)
2388 (movable foldable flushable
))
2390 ;; We need these definitions for byte-compiled code
2392 ;; Well, we (SBCL) probably don't, having deleted the byte
2393 ;; compiler. Let's see what happens if we comment out these
2397 (declare (type (or (unsigned-byte 32) (signed-byte 32)
2398 single-float double-float
) x y
))
2404 (declare (type (or (unsigned-byte 32) (signed-byte 32)
2405 single-float double-float
) x y
))
2410 ((frob (name sc-type type compare cmov cost cc max min note
)
2411 (let ((vop-name (symbolicate name
"-" type
"=>" type
))
2412 (trans-name (symbolicate "%%" name
)))
2413 `(define-vop (,vop-name
)
2414 (:args
(x :scs
(,sc-type
))
2415 (y :scs
(,sc-type
)))
2416 (:results
(r :scs
(,sc-type
)))
2417 (:arg-types
,type
,type
)
2418 (:result-types
,type
)
2419 (:policy
:fast-safe
)
2421 (:translate
,trans-name
)
2422 (:guard
(member :sparc-v9
*backend-subfeatures
*))
2425 (cond ((location= r x
)
2426 ;; If x < y, need to move y to r, otherwise r already has
2428 (inst ,cmov
,min r y
,cc
))
2430 ;; If x > y, need to move x to r, otherwise r already has
2432 (inst ,cmov
,max r x
,cc
))
2434 ;; It doesn't matter what R is, just copy the min to R.
2435 (inst ,cmov
,max r x
,cc
)
2436 (inst ,cmov
,min r y
,cc
))))))))
2437 (frob max single-reg single-float fcmps cfmovs
3
2438 :fcc0
:ge
:l
"inline float max")
2439 (frob max double-reg double-float fcmpd cfmovd
3
2440 :fcc0
:ge
:l
"inline float max")
2441 (frob min single-reg single-float fcmps cfmovs
3
2442 :fcc0
:l
:ge
"inline float min")
2443 (frob min double-reg double-float fcmpd cfmovd
3
2444 :fcc0
:l
:ge
"inline float min")
2445 ;; Strictly speaking these aren't float ops, but it's convenient to
2448 ;; The cost is here is the worst case number of instructions. For
2449 ;; 32-bit integer operands, we add 2 more to account for the
2450 ;; untagging of fixnums, if necessary.
2451 (frob max signed-reg signed-num cmp cmove
5
2452 :icc
:ge
:lt
"inline (signed-byte 32) max")
2453 (frob max unsigned-reg unsigned-num cmp cmove
5
2454 :icc
:ge
:lt
"inline (unsigned-byte 32) max")
2455 ;; For fixnums, make the cost lower so we don't have to untag the
2457 (frob max any-reg tagged-num cmp cmove
3
2458 :icc
:ge
:lt
"inline fixnum max")
2459 (frob min signed-reg signed-num cmp cmove
5
2460 :icc
:lt
:ge
"inline (signed-byte 32) min")
2461 (frob min unsigned-reg unsigned-num cmp cmove
5
2462 :icc
:lt
:ge
"inline (unsigned-byte 32) min")
2463 ;; For fixnums, make the cost lower so we don't have to untag the
2465 (frob min any-reg tagged-num cmp cmove
3
2466 :icc
:lt
:ge
"inline fixnum min"))
2469 (define-vop (max-boxed-double-float=>boxed-double-float
)
2470 (:args
(x :scs
(descriptor-reg))
2471 (y :scs
(descriptor-reg)))
2472 (:results
(r :scs
(descriptor-reg)))
2473 (:arg-types double-float double-float
)
2474 (:result-types double-float
)
2475 (:policy
:fast-safe
)
2476 (:note
"inline float max/min")
2477 (:translate %max-double-float
)
2478 (:temporary
(:scs
(double-reg)) xval
)
2479 (:temporary
(:scs
(double-reg)) yval
)
2480 (:guard
#!+:sparc-v9 t
#!-
:sparc-v9 nil
)
2483 (let ((offset (- (* double-float-value-slot n-word-bytes
)
2484 other-pointer-lowtag
)))
2485 (inst lddf xval x offset
)
2486 (inst lddf yval y offset
)
2487 (inst fcmpd xval yval
)
2488 (cond ((location= r x
)
2489 ;; If x < y, need to move y to r, otherwise r already has
2491 (inst cmove
:l r y
:fcc0
))
2493 ;; If x > y, need to move x to r, otherwise r already has
2495 (inst cmove
:ge r x
:fcc0
))
2497 ;; It doesn't matter what R is, just copy the min to R.
2498 (inst cmove
:ge r x
:fcc0
)
2499 (inst cmove
:l r y
:fcc0
))))))
2508 ;;; The sparc-v9 architecture has conditional move instructions that
2509 ;;; can be used. This should be faster than using the obvious if
2510 ;;; expression since we don't have to do branches.
2512 (define-source-transform min
(&rest args
)
2513 (if (member :sparc-v9
*backend-subfeatures
*)
2515 ((0 2) (values nil t
))
2516 (1 `(values ,(first args
)))
2517 (t (sb!c
::associate-arguments
'min
(first args
) (rest args
))))
2520 (define-source-transform max
(&rest args
)
2521 (if (member :sparc-v9
*backend-subfeatures
*)
2523 ((0 2) (values nil t
))
2524 (1 `(values ,(first args
)))
2525 (t (sb!c
::associate-arguments
'max
(first args
) (rest args
))))
2528 ;; Derive the types of max and min
2529 (defoptimizer (max derive-type
) ((x y
))
2530 (multiple-value-bind (definitely-< definitely-
>=)
2531 (ir1-transform-<-helper x y
)
2537 (make-canonical-union-type (list (lvar-type x
)
2540 (defoptimizer (min derive-type
) ((x y
))
2541 (multiple-value-bind (definitely-> definitely-
<=)
2542 (ir1-transform-<-helper y x
)
2543 (cond (definitely-<=
2548 (make-canonical-union-type (list (lvar-type x
)
2551 (deftransform max
((x y
) (number number
) *)
2552 (let ((x-type (lvar-type x
))
2553 (y-type (lvar-type y
))
2554 (signed (specifier-type '(signed-byte #.n-word-bits
)))
2555 (unsigned (specifier-type '(unsigned-byte #.n-word-bits
)))
2556 (d-float (specifier-type 'double-float
))
2557 (s-float (specifier-type 'single-float
)))
2558 ;; Use %%max if both args are good types of the same type. As a
2559 ;; last resort, use the obvious comparison to select the desired
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))
2578 (if (>= ,arg1
,arg2
)
2581 (deftransform min
((x y
) (real real
) *)
2582 (let ((x-type (lvar-type x
))
2583 (y-type (lvar-type y
))
2584 (signed (specifier-type '(signed-byte #.n-word-bits
)))
2585 (unsigned (specifier-type '(unsigned-byte #.n-word-bits
)))
2586 (d-float (specifier-type 'double-float
))
2587 (s-float (specifier-type 'single-float
)))
2588 (cond ((and (csubtypep x-type signed
)
2589 (csubtypep y-type signed
))
2591 ((and (csubtypep x-type unsigned
)
2592 (csubtypep y-type unsigned
))
2594 ((and (csubtypep x-type d-float
)
2595 (csubtypep y-type d-float
))
2597 ((and (csubtypep x-type s-float
)
2598 (csubtypep y-type s-float
))
2601 (let ((arg1 (gensym))
2605 (if (<= ,arg1
,arg2
)
