1 ;;;; the MIPS VM definition of floating point operations
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.
16 (define-move-fun (load-single 1) (vop x y
)
17 ((single-stack) (single-reg))
18 (inst lwc1 y
(current-nfp-tn vop
) (* (tn-offset x
) n-word-bytes
))
21 (define-move-fun (store-single 1) (vop x y
)
22 ((single-reg) (single-stack))
23 (inst swc1 x
(current-nfp-tn vop
) (* (tn-offset y
) n-word-bytes
)))
25 (defun ld-double (r base offset
)
26 (ecase *backend-byte-order
*
28 (inst lwc1 r base
(+ offset n-word-bytes
))
29 (inst lwc1-odd r base offset
))
31 (inst lwc1 r base offset
)
32 (inst lwc1-odd r base
(+ offset n-word-bytes
)))))
34 (define-move-fun (load-double 2) (vop x y
)
35 ((double-stack) (double-reg))
36 (let ((nfp (current-nfp-tn vop
))
37 (offset (* (tn-offset x
) n-word-bytes
)))
38 (ld-double y nfp offset
))
41 (defun str-double (x base offset
)
42 (ecase *backend-byte-order
*
44 (inst swc1 x base
(+ offset n-word-bytes
))
45 (inst swc1-odd x base offset
))
47 (inst swc1 x base offset
)
48 (inst swc1-odd x base
(+ offset n-word-bytes
)))))
50 (define-move-fun (store-double 2) (vop x y
)
51 ((double-reg) (double-stack))
52 (let ((nfp (current-nfp-tn vop
))
53 (offset (* (tn-offset y
) n-word-bytes
)))
54 (str-double x nfp offset
)))
57 (macrolet ((frob (vop sc format
)
62 :load-if
(not (location= x y
))))
63 (:results
(y :scs
(,sc
)
64 :load-if
(not (location= x y
))))
67 (unless (location= y x
)
68 (inst fmove
,format y x
))))
69 (define-move-vop ,vop
:move
(,sc
) (,sc
)))))
70 (frob single-move single-reg
:single
)
71 (frob double-move double-reg
:double
))
73 (define-vop (move-from-float)
76 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
77 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
78 (:variant-vars double-p size type data
)
79 (:note
"float to pointer coercion")
81 (with-fixed-allocation (y pa-flag ndescr type size nil
)
83 (str-double x y
(- (* data n-word-bytes
) other-pointer-lowtag
))
84 (inst swc1 x y
(- (* data n-word-bytes
) other-pointer-lowtag
))))))
86 (macrolet ((frob (name sc
&rest args
)
88 (define-vop (,name move-from-float
)
89 (:args
(x :scs
(,sc
) :to
:save
))
90 (:results
(y :scs
(descriptor-reg)))
92 (define-move-vop ,name
:move
(,sc
) (descriptor-reg)))))
93 (frob move-from-single single-reg
94 nil single-float-size single-float-widetag single-float-value-slot
)
95 (frob move-from-double double-reg
96 t double-float-size double-float-widetag double-float-value-slot
))
98 (macrolet ((frob (name sc double-p value
)
101 (:args
(x :scs
(descriptor-reg)))
102 (:results
(y :scs
(,sc
)))
103 (:note
"pointer to float coercion")
105 ,@(ecase *backend-byte-order
*
109 `((inst lwc1 y x
(- (* (1+ ,value
) n-word-bytes
)
110 other-pointer-lowtag
))
111 (inst lwc1-odd y x
(- (* ,value n-word-bytes
)
112 other-pointer-lowtag
))))
114 `((inst lwc1 y x
(- (* ,value n-word-bytes
)
115 other-pointer-lowtag
))))))
117 `((inst lwc1 y x
(- (* ,value n-word-bytes
)
118 other-pointer-lowtag
))
121 (- (* (1+ ,value
) n-word-bytes
)
122 other-pointer-lowtag
)))))))
124 (define-move-vop ,name
:move
(descriptor-reg) (,sc
)))))
125 (frob move-to-single single-reg nil single-float-value-slot
)
126 (frob move-to-double double-reg t double-float-value-slot
))
128 (macrolet ((frob (name sc stack-sc format double-p
)
131 (:args
(x :scs
(,sc
) :target y
)
133 :load-if
(not (sc-is y
,sc
))))
135 (:note
"float argument move")
136 (:generator
,(if double-p
2 1)
139 (unless (location= x y
)
140 (inst fmove
,format y x
)))
142 (let ((offset (* (tn-offset y
) n-word-bytes
)))
143 ,@(ecase *backend-byte-order
*
147 '((inst swc1 x nfp
(+ offset n-word-bytes
))
148 (inst swc1-odd x nfp offset
)))
150 '((inst swc1 x nfp offset
)))))
152 `((inst swc1 x nfp offset
)
154 '((inst swc1-odd x nfp
155 (+ offset n-word-bytes
))))))))))))
156 (define-move-vop ,name
:move-arg
157 (,sc descriptor-reg
) (,sc
)))))
158 (frob move-single-float-arg single-reg single-stack
:single nil
)
159 (frob move-double-float-arg double-reg double-stack
:double t
))
161 ;;;; Complex float move functions
163 (defun complex-single-reg-real-tn (x)
164 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'single-reg
)
165 :offset
(tn-offset x
)))
166 (defun complex-single-reg-imag-tn (x)
167 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'single-reg
)
168 :offset
(+ (tn-offset x
) 2)))
170 (defun complex-double-reg-real-tn (x)
171 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
)
172 :offset
(tn-offset x
)))
173 (defun complex-double-reg-imag-tn (x)
174 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
)
175 :offset
(+ (tn-offset x
) 2)))
177 (define-move-fun (load-complex-single 2) (vop x y
)
178 ((complex-single-stack) (complex-single-reg))
179 (let ((nfp (current-nfp-tn vop
))
180 (offset (* (tn-offset x
) n-word-bytes
)))
181 (let ((real-tn (complex-single-reg-real-tn y
)))
182 (inst lwc1 real-tn nfp offset
))
183 (let ((imag-tn (complex-single-reg-imag-tn y
)))
184 (inst lwc1 imag-tn nfp
(+ offset n-word-bytes
))))
187 (define-move-fun (store-complex-single 2) (vop x y
)
188 ((complex-single-reg) (complex-single-stack))
189 (let ((nfp (current-nfp-tn vop
))
190 (offset (* (tn-offset y
) n-word-bytes
)))
191 (let ((real-tn (complex-single-reg-real-tn x
)))
192 (inst swc1 real-tn nfp offset
))
193 (let ((imag-tn (complex-single-reg-imag-tn x
)))
194 (inst swc1 imag-tn nfp
(+ offset n-word-bytes
)))))
196 (define-move-fun (load-complex-double 4) (vop x y
)
197 ((complex-double-stack) (complex-double-reg))
198 (let ((nfp (current-nfp-tn vop
))
199 (offset (* (tn-offset x
) n-word-bytes
)))
200 (let ((real-tn (complex-double-reg-real-tn y
)))
201 (ld-double real-tn nfp offset
))
202 (let ((imag-tn (complex-double-reg-imag-tn y
)))
203 (ld-double imag-tn nfp
(+ offset
(* 2 n-word-bytes
))))
206 (define-move-fun (store-complex-double 4) (vop x y
)
207 ((complex-double-reg) (complex-double-stack))
208 (let ((nfp (current-nfp-tn vop
))
209 (offset (* (tn-offset y
) n-word-bytes
)))
210 (let ((real-tn (complex-double-reg-real-tn x
)))
211 (str-double real-tn nfp offset
))
212 (let ((imag-tn (complex-double-reg-imag-tn x
)))
213 (str-double imag-tn nfp
(+ offset
(* 2 n-word-bytes
))))))
215 ;;; Complex float register to register moves.
216 (define-vop (complex-single-move)
217 (:args
(x :scs
(complex-single-reg) :target y
218 :load-if
(not (location= x y
))))
219 (:results
(y :scs
(complex-single-reg) :load-if
(not (location= x y
))))
220 (:note
"complex single float move")
222 (unless (location= x y
)
223 ;; Note the complex-float-regs are aligned to every second
224 ;; float register so there is not need to worry about overlap.
225 (let ((x-real (complex-single-reg-real-tn x
))
226 (y-real (complex-single-reg-real-tn y
)))
227 (inst fmove
:single y-real x-real
))
228 (let ((x-imag (complex-single-reg-imag-tn x
))
229 (y-imag (complex-single-reg-imag-tn y
)))
230 (inst fmove
:single y-imag x-imag
)))))
231 (define-move-vop complex-single-move
:move
232 (complex-single-reg) (complex-single-reg))
234 (define-vop (complex-double-move)
235 (:args
(x :scs
(complex-double-reg)
236 :target y
:load-if
(not (location= x y
))))
237 (:results
(y :scs
(complex-double-reg) :load-if
(not (location= x y
))))
238 (:note
"complex double float move")
240 (unless (location= x y
)
241 ;; Note the complex-float-regs are aligned to every second
242 ;; float register so there is not need to worry about overlap.
243 (let ((x-real (complex-double-reg-real-tn x
))
244 (y-real (complex-double-reg-real-tn y
)))
245 (inst fmove
:double y-real x-real
))
246 (let ((x-imag (complex-double-reg-imag-tn x
))
247 (y-imag (complex-double-reg-imag-tn y
)))
248 (inst fmove
:double y-imag x-imag
)))))
249 (define-move-vop complex-double-move
:move
250 (complex-double-reg) (complex-double-reg))
252 ;;; Move from a complex float to a descriptor register allocating a
253 ;;; new complex float object in the process.
254 (define-vop (move-from-complex-single)
255 (:args
(x :scs
(complex-single-reg) :to
:save
))
256 (:results
(y :scs
(descriptor-reg)))
257 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
258 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
259 (:note
"complex single float to pointer coercion")
261 (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
262 complex-single-float-size nil
)
263 (let ((real-tn (complex-single-reg-real-tn x
)))
264 (inst swc1 real-tn y
(- (* complex-single-float-real-slot
266 other-pointer-lowtag
)))
267 (let ((imag-tn (complex-single-reg-imag-tn x
)))
268 (inst swc1 imag-tn y
(- (* complex-single-float-imag-slot
270 other-pointer-lowtag
))))))
271 (define-move-vop move-from-complex-single
:move
272 (complex-single-reg) (descriptor-reg))
274 (define-vop (move-from-complex-double)
275 (:args
(x :scs
(complex-double-reg) :to
:save
))
276 (:results
(y :scs
(descriptor-reg)))
277 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
278 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
279 (:note
"complex double float to pointer coercion")
281 (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
282 complex-double-float-size nil
)
283 (let ((real-tn (complex-double-reg-real-tn x
)))
284 (str-double real-tn y
(- (* complex-double-float-real-slot
286 other-pointer-lowtag
)))
287 (let ((imag-tn (complex-double-reg-imag-tn x
)))
288 (str-double imag-tn y
(- (* complex-double-float-imag-slot
290 other-pointer-lowtag
))))))
291 (define-move-vop move-from-complex-double
:move
292 (complex-double-reg) (descriptor-reg))
294 ;;; Move from a descriptor to a complex float register
295 (define-vop (move-to-complex-single)
296 (:args
(x :scs
(descriptor-reg)))
297 (:results
(y :scs
(complex-single-reg)))
298 (:note
"pointer to complex float coercion")
300 (let ((real-tn (complex-single-reg-real-tn y
)))
301 (inst lwc1 real-tn x
(- (* complex-single-float-real-slot n-word-bytes
)
302 other-pointer-lowtag
)))
303 (let ((imag-tn (complex-single-reg-imag-tn y
)))
304 (inst lwc1 imag-tn x
(- (* complex-single-float-imag-slot n-word-bytes
)
305 other-pointer-lowtag
)))
307 (define-move-vop move-to-complex-single
:move
308 (descriptor-reg) (complex-single-reg))
310 (define-vop (move-to-complex-double)
311 (:args
(x :scs
(descriptor-reg)))
312 (:results
(y :scs
(complex-double-reg)))
313 (:note
"pointer to complex float coercion")
315 (let ((real-tn (complex-double-reg-real-tn y
)))
316 (ld-double real-tn x
(- (* complex-double-float-real-slot n-word-bytes
)
317 other-pointer-lowtag
)))
318 (let ((imag-tn (complex-double-reg-imag-tn y
)))
319 (ld-double imag-tn x
(- (* complex-double-float-imag-slot n-word-bytes
)
320 other-pointer-lowtag
)))
322 (define-move-vop move-to-complex-double
:move
323 (descriptor-reg) (complex-double-reg))
325 ;;; complex float MOVE-ARG VOP
326 (define-vop (move-complex-single-float-arg)
327 (:args
(x :scs
(complex-single-reg) :target y
)
328 (nfp :scs
(any-reg) :load-if
(not (sc-is y complex-single-reg
))))
330 (:note
"complex single-float argument move")
334 (unless (location= x y
)
335 (let ((x-real (complex-single-reg-real-tn x
))
336 (y-real (complex-single-reg-real-tn y
)))
337 (inst fmove
:single y-real x-real
))
338 (let ((x-imag (complex-single-reg-imag-tn x
))
339 (y-imag (complex-single-reg-imag-tn y
)))
340 (inst fmove
:single y-imag x-imag
))))
341 (complex-single-stack
342 (let ((offset (* (tn-offset y
) n-word-bytes
)))
343 (let ((real-tn (complex-single-reg-real-tn x
)))
344 (inst swc1 real-tn nfp offset
))
345 (let ((imag-tn (complex-single-reg-imag-tn x
)))
346 (inst swc1 imag-tn nfp
(+ offset n-word-bytes
))))))))
347 (define-move-vop move-complex-single-float-arg
:move-arg
348 (complex-single-reg descriptor-reg
) (complex-single-reg))
350 (define-vop (move-complex-double-float-arg)
351 (:args
(x :scs
(complex-double-reg) :target y
)
352 (nfp :scs
(any-reg) :load-if
(not (sc-is y complex-double-reg
))))
354 (:note
"complex double-float argument move")
358 (unless (location= x y
)
359 (let ((x-real (complex-double-reg-real-tn x
))
360 (y-real (complex-double-reg-real-tn y
)))
361 (inst fmove
:double y-real x-real
))
362 (let ((x-imag (complex-double-reg-imag-tn x
))
363 (y-imag (complex-double-reg-imag-tn y
)))
364 (inst fmove
:double y-imag x-imag
))))
365 (complex-double-stack
366 (let ((offset (* (tn-offset y
) n-word-bytes
)))
367 (let ((real-tn (complex-double-reg-real-tn x
)))
368 (str-double real-tn nfp offset
))
369 (let ((imag-tn (complex-double-reg-imag-tn x
)))
370 (str-double imag-tn nfp
(+ offset
(* 2 n-word-bytes
)))))))))
371 (define-move-vop move-complex-double-float-arg
:move-arg
372 (complex-double-reg descriptor-reg
) (complex-double-reg))
374 (define-move-vop move-arg
:move-arg
375 (single-reg double-reg complex-single-reg complex-double-reg
)
379 ;;;; stuff for c-call float-in-int-register arguments
380 (define-vop (move-to-single-int-reg)
381 (:args
(x :scs
(single-reg descriptor-reg
)))
382 (:results
(y :scs
(single-int-carg-reg) :load-if nil
))
383 (:note
"pointer to float-in-int coercion")
389 (inst lw y x
(- (* single-float-value-slot n-word-bytes
)
390 other-pointer-lowtag
))))
391 (inst nop
))) ;nop needed here?
392 (define-move-vop move-to-single-int-reg
393 :move
(single-reg descriptor-reg
) (single-int-carg-reg))
395 (define-vop (move-single-int-reg)
396 (:args
(x :target y
:scs
(single-int-carg-reg) :load-if nil
)
397 (fp :scs
(any-reg) :load-if
(not (sc-is y single-int-carg-reg
))))
398 (:results
(y :scs
(single-int-carg-reg) :load-if nil
))
400 (unless (location= x y
)
401 (error "Huh? why did it do that?"))))
402 (define-move-vop move-single-int-reg
:move-arg
403 (single-int-carg-reg) (single-int-carg-reg))
405 (define-vop (move-to-double-int-reg)
406 (:args
(x :scs
(double-reg descriptor-reg
)))
407 (:results
(y :scs
(double-int-carg-reg) :load-if nil
))
408 (:note
"pointer to float-in-int coercion")
412 (ecase *backend-byte-order
*
418 (inst mfc1-odd3 y x
))))
420 (inst lw y x
(- (* double-float-value-slot n-word-bytes
)
421 other-pointer-lowtag
))
422 (inst lw-odd y x
(- (* (1+ double-float-value-slot
) n-word-bytes
)
423 other-pointer-lowtag
))))
424 (inst nop
))) ;nop needed here?
425 (define-move-vop move-to-double-int-reg
426 :move
(double-reg descriptor-reg
) (double-int-carg-reg))
428 (define-vop (move-double-int-reg)
429 (:args
(x :target y
:scs
(double-int-carg-reg) :load-if nil
)
430 (fp :scs
(any-reg) :load-if
(not (sc-is y double-int-carg-reg
))))
431 (:results
(y :scs
(double-int-carg-reg) :load-if nil
))
433 (unless (location= x y
)
434 (error "Huh? why did it do that?"))))
435 (define-move-vop move-double-int-reg
:move-arg
436 (double-int-carg-reg) (double-int-carg-reg))
439 ;;;; Arithmetic VOPs:
441 (define-vop (float-op)
444 (:variant-vars format operation
)
446 (:note
"inline float arithmetic")
448 (:save-p
:compute-only
)
450 (note-this-location vop
:internal-error
)
451 (inst float-op operation format r x y
)))
453 (macrolet ((frob (name sc ptype
)
454 `(define-vop (,name float-op
)
455 (:args
(x :scs
(,sc
))
457 (:results
(r :scs
(,sc
)))
458 (:arg-types
,ptype
,ptype
)
459 (:result-types
,ptype
))))
460 (frob single-float-op single-reg single-float
)
461 (frob double-float-op double-reg double-float
))
463 (macrolet ((frob (op sname scost dname dcost
)
465 (define-vop (,sname single-float-op
)
467 (:variant
:single
',op
)
468 (:variant-cost
,scost
))
469 (define-vop (,dname double-float-op
)
471 (:variant
:double
',op
)
472 (:variant-cost
,dcost
)))))
473 (frob + +/single-float
2 +/double-float
2)
474 (frob - -
/single-float
2 -
/double-float
2)
475 (frob * */single-float
4 */double-float
5)
476 (frob / //single-float
12 //double-float
19))
478 (macrolet ((frob (name inst translate format sc type
)
480 (:args
(x :scs
(,sc
)))
481 (:results
(y :scs
(,sc
)))
482 (:translate
,translate
)
485 (:result-types
,type
)
486 (:note
"inline float arithmetic")
488 (:save-p
:compute-only
)
490 (note-this-location vop
:internal-error
)
491 (inst ,inst
,format y x
)))))
492 (frob abs
/single-float fabs abs
:single single-reg single-float
)
493 (frob abs
/double-float fabs abs
:double double-reg double-float
)
494 (frob %negate
/single-float fneg %negate
:single single-reg single-float
)
495 (frob %negate
/double-float fneg %negate
:double double-reg double-float
))
500 (define-vop (float-compare)
504 (:variant-vars format operation complement
)
506 (:note
"inline float comparison")
508 (:save-p
:compute-only
)
510 (note-this-location vop
:internal-error
)
511 (inst fcmp operation format x y
)
513 (if (if complement
(not not-p
) not-p
)
518 (macrolet ((frob (name sc ptype
)
519 `(define-vop (,name float-compare
)
520 (:args
(x :scs
(,sc
))
522 (:arg-types
,ptype
,ptype
))))
523 (frob single-float-compare single-reg single-float
)
524 (frob double-float-compare double-reg double-float
))
526 (macrolet ((frob (translate op complement sname dname
)
528 (define-vop (,sname single-float-compare
)
529 (:translate
,translate
)
530 (:variant
:single
,op
,complement
))
531 (define-vop (,dname double-float-compare
)
532 (:translate
,translate
)
533 (:variant
:double
,op
,complement
)))))
534 (frob < :lt nil
</single-float
</double-float
)
535 (frob > :ngt t
>/single-float
>/double-float
)
536 (frob = :seq nil
=/single-float
=/double-float
))
541 (macrolet ((frob (name translate
542 from-sc from-type from-format
543 to-sc to-type to-format
)
544 (let ((word-p (eq from-format
:word
)))
546 (:args
(x :scs
(,from-sc
)))
547 (:results
(y :scs
(,to-sc
)))
548 (:arg-types
,from-type
)
549 (:result-types
,to-type
)
551 (:note
"inline float coercion")
552 (:translate
,translate
)
554 (:save-p
:compute-only
)
555 (:generator
,(if word-p
3 2)
559 (note-this-location vop
:internal-error
)
560 (inst fcvt
,to-format
:word y y
))
561 `((note-this-location vop
:internal-error
)
562 (inst fcvt
,to-format
,from-format y x
))))))))
563 (frob %single-float
/signed %single-float
564 signed-reg signed-num
:word
565 single-reg single-float
:single
)
566 (frob %double-float
/signed %double-float
567 signed-reg signed-num
:word
568 double-reg double-float
:double
)
569 (frob %single-float
/double-float %single-float
570 double-reg double-float
:double
571 single-reg single-float
:single
)
572 (frob %double-float
/single-float %double-float
573 single-reg single-float
:single
574 double-reg double-float
:double
))
577 (macrolet ((frob (name from-sc from-type from-format
)
579 (:args
(x :scs
(,from-sc
)))
580 (:results
(y :scs
(signed-reg)))
581 (:temporary
(:from
(:argument
0) :sc
,from-sc
) temp
)
582 (:arg-types
,from-type
)
583 (:result-types signed-num
)
584 (:translate %unary-round
)
586 (:note
"inline float round")
588 (:save-p
:compute-only
)
590 (note-this-location vop
:internal-error
)
591 (inst fcvt
:word
,from-format temp x
)
594 (frob %unary-round
/single-float single-reg single-float
:single
)
595 (frob %unary-round
/double-float double-reg double-float
:double
))
598 ;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
599 ;;; the desired round-to-zero behavior.
601 (macrolet ((frob (name from-sc from-type from-format
)
603 (:args
(x :scs
(,from-sc
)))
604 (:results
(y :scs
(signed-reg)))
605 (:temporary
(:from
(:argument
0) :sc
,from-sc
) temp
)
606 (:temporary
(:sc non-descriptor-reg
) status-save new-status
)
607 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
)
609 (:arg-types
,from-type
)
610 (:result-types signed-num
)
613 (:note
"inline float truncate")
615 (:save-p
:compute-only
)
617 (pseudo-atomic (pa-flag)
618 (inst cfc1 status-save
31)
619 (inst li new-status
(lognot 3))
620 (inst and new-status status-save
)
621 (inst or new-status float-round-to-zero
)
622 (inst ctc1 new-status
31)
624 ;; These instructions seem to be necessary to ensure that
625 ;; the new modes affect the fcvt instruction.
627 (inst cfc1 new-status
31)
629 (note-this-location vop
:internal-error
)
630 (inst fcvt
:word
,from-format temp x
)
633 (inst ctc1 status-save
31))))))
634 (frob %unary-truncate
/single-float single-reg single-float
:single
)
635 (frob %unary-truncate
/double-float double-reg double-float
:double
))
638 (define-vop (make-single-float)
639 (:args
(bits :scs
(signed-reg)))
640 (:results
(res :scs
(single-reg)))
641 (:arg-types signed-num
)
642 (:result-types single-float
)
643 (:translate make-single-float
)
649 (define-vop (make-double-float)
650 (:args
(hi-bits :scs
(signed-reg))
651 (lo-bits :scs
(unsigned-reg)))
652 (:results
(res :scs
(double-reg)))
653 (:arg-types signed-num unsigned-num
)
654 (:result-types double-float
)
655 (:translate make-double-float
)
658 (inst mtc1 res lo-bits
)
659 (inst mtc1-odd res hi-bits
)
662 (define-vop (single-float-bits)
663 (:args
(float :scs
(single-reg)))
664 (:results
(bits :scs
(signed-reg)))
665 (:arg-types single-float
)
666 (:result-types signed-num
)
667 (:translate single-float-bits
)
670 (inst mfc1 bits float
)
673 (define-vop (double-float-high-bits)
674 (:args
(float :scs
(double-reg)))
675 (:results
(hi-bits :scs
(signed-reg)))
676 (:arg-types double-float
)
677 (:result-types signed-num
)
678 (:translate double-float-high-bits
)
681 (inst mfc1-odd hi-bits float
)
684 (define-vop (double-float-low-bits)
685 (:args
(float :scs
(double-reg)))
686 (:results
(lo-bits :scs
(unsigned-reg)))
687 (:arg-types double-float
)
688 (:result-types unsigned-num
)
689 (:translate double-float-low-bits
)
692 (inst mfc1 lo-bits float
)
696 ;;;; Complex float VOPs
698 (define-vop (make-complex-single-float)
700 (:args
(real :scs
(single-reg) :target r
)
701 (imag :scs
(single-reg) :to
:save
))
702 (:arg-types single-float single-float
)
703 (:results
(r :scs
(complex-single-reg) :from
(:argument
0)
704 :load-if
(not (sc-is r complex-single-stack
))))
705 (:result-types complex-single-float
)
706 (:note
"inline complex single-float creation")
712 (let ((r-real (complex-single-reg-real-tn r
)))
713 (unless (location= real r-real
)
714 (inst fmove
:single r-real real
)))
715 (let ((r-imag (complex-single-reg-imag-tn r
)))
716 (unless (location= imag r-imag
)
717 (inst fmove
:single r-imag imag
))))
718 (complex-single-stack
719 (let ((nfp (current-nfp-tn vop
))
720 (offset (* (tn-offset r
) n-word-bytes
)))
721 (inst swc1 real nfp offset
)
722 (inst swc1 imag nfp
(+ offset n-word-bytes
)))))))
724 (define-vop (make-complex-double-float)
726 (:args
(real :scs
(double-reg) :target r
)
727 (imag :scs
(double-reg) :to
:save
))
728 (:arg-types double-float double-float
)
729 (:results
(r :scs
(complex-double-reg) :from
(:argument
0)
730 :load-if
(not (sc-is r complex-double-stack
))))
731 (:result-types complex-double-float
)
732 (:note
"inline complex double-float creation")
738 (let ((r-real (complex-double-reg-real-tn r
)))
739 (unless (location= real r-real
)
740 (inst fmove
:double r-real real
)))
741 (let ((r-imag (complex-double-reg-imag-tn r
)))
742 (unless (location= imag r-imag
)
743 (inst fmove
:double r-imag imag
))))
744 (complex-double-stack
745 (let ((nfp (current-nfp-tn vop
))
746 (offset (* (tn-offset r
) n-word-bytes
)))
747 (str-double real nfp offset
)
748 (str-double imag nfp
(+ offset
(* 2 n-word-bytes
))))))))
751 (define-vop (complex-single-float-value)
752 (:args
(x :scs
(complex-single-reg) :target r
753 :load-if
(not (sc-is x complex-single-stack
))))
754 (:arg-types complex-single-float
)
755 (:results
(r :scs
(single-reg)))
756 (:result-types single-float
)
763 (let ((value-tn (ecase slot
764 (:real
(complex-single-reg-real-tn x
))
765 (:imag
(complex-single-reg-imag-tn x
)))))
766 (unless (location= value-tn r
)
767 (inst fmove
:single r value-tn
))))
768 (complex-single-stack
769 (inst lwc1 r
(current-nfp-tn vop
) (* (+ (ecase slot
(:real
0) (:imag
1))
774 (define-vop (realpart/complex-single-float complex-single-float-value
)
775 (:translate realpart
)
776 (:note
"complex single float realpart")
779 (define-vop (imagpart/complex-single-float complex-single-float-value
)
780 (:translate imagpart
)
781 (:note
"complex single float imagpart")
784 (define-vop (complex-double-float-value)
785 (:args
(x :scs
(complex-double-reg) :target r
786 :load-if
(not (sc-is x complex-double-stack
))))
787 (:arg-types complex-double-float
)
788 (:results
(r :scs
(double-reg)))
789 (:result-types double-float
)
796 (let ((value-tn (ecase slot
797 (:real
(complex-double-reg-real-tn x
))
798 (:imag
(complex-double-reg-imag-tn x
)))))
799 (unless (location= value-tn r
)
800 (inst fmove
:double r value-tn
))))
801 (complex-double-stack
802 (ld-double r
(current-nfp-tn vop
) (* (+ (ecase slot
(:real
0) (:imag
2))
807 (define-vop (realpart/complex-double-float complex-double-float-value
)
808 (:translate realpart
)
809 (:note
"complex double float realpart")
812 (define-vop (imagpart/complex-double-float complex-double-float-value
)
813 (:translate imagpart
)
814 (:note
"complex double float imagpart")