6 (define-move-fun (load-fp-zero 1) (vop x y)
7 ((fp-single-zero) (single-reg)
8 (fp-double-zero) (double-reg))
9 (inst funop :copy x y))
11 (defun ld-float (offset base r)
12 (cond ((< offset (ash 1 4))
13 (inst flds offset base r))
15 (inst ldo offset zero-tn lip-tn)
16 (inst fldx lip-tn base r))))
18 (define-move-fun (load-float 1) (vop x y)
19 ((single-stack) (single-reg)
20 (double-stack) (double-reg))
21 (let ((offset (* (tn-offset x) n-word-bytes)))
22 (ld-float offset (current-nfp-tn vop) y)))
24 (defun str-float (x offset base)
25 (cond ((< offset (ash 1 4))
26 (inst fsts x offset base))
28 (inst ldo offset zero-tn lip-tn)
29 (inst fstx x lip-tn base))))
31 (define-move-fun (store-float 1) (vop x y)
32 ((single-reg) (single-stack)
33 (double-reg) (double-stack))
34 (let ((offset (* (tn-offset y) n-word-bytes)))
35 (str-float x offset (current-nfp-tn vop))))
40 (define-vop (move-float)
41 (:args (x :scs (single-reg double-reg)
43 :load-if (not (location= x y))))
44 (:results (y :scs (single-reg double-reg)
45 :load-if (not (location= x y))))
48 (unless (location= y x)
49 (inst funop :copy x y))))
51 (define-move-vop move-float :move (single-reg) (single-reg))
52 (define-move-vop move-float :move (double-reg) (double-reg))
55 (define-vop (move-from-float)
57 (:results (y :scs (descriptor-reg)))
58 (:temporary (:scs (non-descriptor-reg)) ndescr)
59 (:variant-vars size type data)
60 (:note "float to pointer coercion")
62 (with-fixed-allocation (y ndescr type size))
63 (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y)))
65 (macrolet ((frob (name sc &rest args)
67 (define-vop (,name move-from-float)
68 (:args (x :scs (,sc) :to :save))
70 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
71 (frob move-from-single single-reg
72 single-float-size single-float-widetag single-float-value-slot)
73 (frob move-from-double double-reg
74 double-float-size double-float-widetag double-float-value-slot))
76 (define-vop (move-to-float)
77 (:args (x :scs (descriptor-reg)))
79 (:variant-vars offset)
80 (:note "pointer to float coercion")
82 (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
84 (macrolet ((frob (name sc offset)
86 (define-vop (,name move-to-float)
87 (:results (y :scs (,sc)))
89 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
90 (frob move-to-single single-reg single-float-value-slot)
91 (frob move-to-double double-reg double-float-value-slot))
94 (define-vop (move-float-argument)
95 (:args (x :scs (single-reg double-reg) :target y)
97 :load-if (not (sc-is y single-reg double-reg))))
99 (:note "float argument move")
102 ((single-reg double-reg)
103 (unless (location= x y)
104 (inst funop :copy x y)))
105 ((single-stack double-stack)
106 (let ((offset (* (tn-offset y) n-word-bytes)))
107 (str-float x offset nfp))))))
109 (define-move-vop move-float-argument :move-arg
110 (single-reg descriptor-reg) (single-reg))
111 (define-move-vop move-float-argument :move-arg
112 (double-reg descriptor-reg) (double-reg))
115 ;;;; Complex float move functions
117 (defun complex-single-reg-real-tn (x)
118 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
119 :offset (tn-offset x)))
120 (defun complex-single-reg-imag-tn (x)
121 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
122 :offset (1+ (tn-offset x))))
124 (defun complex-double-reg-real-tn (x)
125 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
126 :offset (tn-offset x)))
127 (defun complex-double-reg-imag-tn (x)
128 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
129 :offset (1+ (tn-offset x))))
132 (define-move-fun (load-complex-single 2) (vop x y)
133 ((complex-single-stack) (complex-single-reg))
134 (let ((nfp (current-nfp-tn vop))
135 (offset (* (tn-offset x) n-word-bytes)))
136 (let ((real-tn (complex-single-reg-real-tn y)))
137 (ld-float offset nfp real-tn))
138 (let ((imag-tn (complex-single-reg-imag-tn y)))
139 (ld-float (+ offset n-word-bytes) nfp imag-tn))))
141 (define-move-fun (store-complex-single 2) (vop x y)
142 ((complex-single-reg) (complex-single-stack))
143 (let ((nfp (current-nfp-tn vop))
144 (offset (* (tn-offset y) n-word-bytes)))
145 (let ((real-tn (complex-single-reg-real-tn x)))
146 (str-float real-tn offset nfp))
147 (let ((imag-tn (complex-single-reg-imag-tn x)))
148 (str-float imag-tn (+ offset n-word-bytes) nfp))))
151 (define-move-fun (load-complex-double 4) (vop x y)
152 ((complex-double-stack) (complex-double-reg))
153 (let ((nfp (current-nfp-tn vop))
154 (offset (* (tn-offset x) n-word-bytes)))
155 (let ((real-tn (complex-double-reg-real-tn y)))
156 (ld-float offset nfp real-tn))
157 (let ((imag-tn (complex-double-reg-imag-tn y)))
158 (ld-float (+ offset (* 2 n-word-bytes)) nfp imag-tn))))
160 (define-move-fun (store-complex-double 4) (vop x y)
161 ((complex-double-reg) (complex-double-stack))
162 (let ((nfp (current-nfp-tn vop))
163 (offset (* (tn-offset y) n-word-bytes)))
164 (let ((real-tn (complex-double-reg-real-tn x)))
165 (str-float real-tn offset nfp))
166 (let ((imag-tn (complex-double-reg-imag-tn x)))
167 (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
170 ;;; Complex float register to register moves.
172 (define-vop (complex-single-move)
173 (:args (x :scs (complex-single-reg) :target y
174 :load-if (not (location= x y))))
175 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
176 (:note "complex single float move")
178 (unless (location= x y)
179 ;; Note the complex-float-regs are aligned to every second
180 ;; float register so there is not need to worry about overlap.
181 (let ((x-real (complex-single-reg-real-tn x))
182 (y-real (complex-single-reg-real-tn y)))
183 (inst funop :copy x-real y-real))
184 (let ((x-imag (complex-single-reg-imag-tn x))
185 (y-imag (complex-single-reg-imag-tn y)))
186 (inst funop :copy x-imag y-imag)))))
188 (define-move-vop complex-single-move :move
189 (complex-single-reg) (complex-single-reg))
191 (define-vop (complex-double-move)
192 (:args (x :scs (complex-double-reg)
193 :target y :load-if (not (location= x y))))
194 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
195 (:note "complex double float move")
197 (unless (location= x y)
198 ;; Note the complex-float-regs are aligned to every second
199 ;; float register so there is not need to worry about overlap.
200 (let ((x-real (complex-double-reg-real-tn x))
201 (y-real (complex-double-reg-real-tn y)))
202 (inst funop :copy x-real y-real))
203 (let ((x-imag (complex-double-reg-imag-tn x))
204 (y-imag (complex-double-reg-imag-tn y)))
205 (inst funop :copy x-imag y-imag)))))
207 (define-move-vop complex-double-move :move
208 (complex-double-reg) (complex-double-reg))
211 ;;; Move from a complex float to a descriptor register allocating a
212 ;;; new complex float object in the process.
214 (define-vop (move-from-complex-single)
215 (:args (x :scs (complex-single-reg) :to :save))
216 (:results (y :scs (descriptor-reg)))
217 (:temporary (:scs (non-descriptor-reg)) ndescr)
218 (:note "complex single float to pointer coercion")
220 (with-fixed-allocation (y ndescr complex-single-float-widetag
221 complex-single-float-size))
222 (let ((real-tn (complex-single-reg-real-tn x)))
223 (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes)
224 other-pointer-lowtag)
226 (let ((imag-tn (complex-single-reg-imag-tn x)))
227 (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes)
228 other-pointer-lowtag)
231 (define-move-vop move-from-complex-single :move
232 (complex-single-reg) (descriptor-reg))
234 (define-vop (move-from-complex-double)
235 (:args (x :scs (complex-double-reg) :to :save))
236 (:results (y :scs (descriptor-reg)))
237 (:temporary (:scs (non-descriptor-reg)) ndescr)
238 (:note "complex double float to pointer coercion")
240 (with-fixed-allocation (y ndescr complex-double-float-widetag
241 complex-double-float-size))
242 (let ((real-tn (complex-double-reg-real-tn x)))
243 (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes)
244 other-pointer-lowtag)
246 (let ((imag-tn (complex-double-reg-imag-tn x)))
247 (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes)
248 other-pointer-lowtag)
251 (define-move-vop move-from-complex-double :move
252 (complex-double-reg) (descriptor-reg))
255 ;;; Move from a descriptor to a complex float register
257 (define-vop (move-to-complex-single)
258 (:args (x :scs (descriptor-reg)))
259 (:results (y :scs (complex-single-reg)))
260 (:note "pointer to complex float coercion")
262 (let ((real-tn (complex-single-reg-real-tn y)))
263 (inst flds (- (* complex-single-float-real-slot n-word-bytes)
264 other-pointer-lowtag)
266 (let ((imag-tn (complex-single-reg-imag-tn y)))
267 (inst flds (- (* complex-single-float-imag-slot n-word-bytes)
268 other-pointer-lowtag)
270 (define-move-vop move-to-complex-single :move
271 (descriptor-reg) (complex-single-reg))
273 (define-vop (move-to-complex-double)
274 (:args (x :scs (descriptor-reg)))
275 (:results (y :scs (complex-double-reg)))
276 (:note "pointer to complex float coercion")
278 (let ((real-tn (complex-double-reg-real-tn y)))
279 (inst flds (- (* complex-double-float-real-slot n-word-bytes)
280 other-pointer-lowtag)
282 (let ((imag-tn (complex-double-reg-imag-tn y)))
283 (inst flds (- (* complex-double-float-imag-slot n-word-bytes)
284 other-pointer-lowtag)
286 (define-move-vop move-to-complex-double :move
287 (descriptor-reg) (complex-double-reg))
290 ;;; Complex float move-argument vop
292 (define-vop (move-complex-single-float-argument)
293 (:args (x :scs (complex-single-reg) :target y)
294 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
296 (:note "float argument move")
300 (unless (location= x y)
301 (let ((x-real (complex-single-reg-real-tn x))
302 (y-real (complex-single-reg-real-tn y)))
303 (inst funop :copy x-real y-real))
304 (let ((x-imag (complex-single-reg-imag-tn x))
305 (y-imag (complex-single-reg-imag-tn y)))
306 (inst funop :copy x-imag y-imag))))
307 (complex-single-stack
308 (let ((offset (* (tn-offset y) n-word-bytes)))
309 (let ((real-tn (complex-single-reg-real-tn x)))
310 (str-float real-tn offset nfp))
311 (let ((imag-tn (complex-single-reg-imag-tn x)))
312 (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
314 (define-move-vop move-complex-single-float-argument :move-arg
315 (complex-single-reg descriptor-reg) (complex-single-reg))
317 (define-vop (move-complex-double-float-argument)
318 (:args (x :scs (complex-double-reg) :target y)
319 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
321 (:note "float argument move")
325 (unless (location= x y)
326 (let ((x-real (complex-double-reg-real-tn x))
327 (y-real (complex-double-reg-real-tn y)))
328 (inst funop :copy x-real y-real))
329 (let ((x-imag (complex-double-reg-imag-tn x))
330 (y-imag (complex-double-reg-imag-tn y)))
331 (inst funop :copy x-imag y-imag))))
332 (complex-double-stack
333 (let ((offset (* (tn-offset y) n-word-bytes)))
334 (let ((real-tn (complex-double-reg-real-tn x)))
335 (str-float real-tn offset nfp))
336 (let ((imag-tn (complex-double-reg-imag-tn x)))
337 (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
339 (define-move-vop move-complex-double-float-argument :move-arg
340 (complex-double-reg descriptor-reg) (complex-double-reg))
343 (define-move-vop move-argument :move-arg
344 (single-reg double-reg complex-single-reg complex-double-reg)
348 ;;;; Arithmetic VOPs.
350 (define-vop (float-op)
353 (:variant-vars operation)
355 (:note "inline float arithmetic")
357 (:save-p :compute-only)
360 (inst fbinop operation x y r)
361 (when (policy node (or (= debug 3) (> safety speed)))
362 (note-next-instruction vop :internal-error)
363 (inst fsts fp-single-zero-tn 0 csp-tn))))
365 (macrolet ((frob (name sc zero-sc ptype)
366 `(define-vop (,name float-op)
367 (:args (x :scs (,sc ,zero-sc))
368 (y :scs (,sc ,zero-sc)))
369 (:results (r :scs (,sc)))
370 (:arg-types ,ptype ,ptype)
371 (:result-types ,ptype))))
372 (frob single-float-op single-reg fp-single-zero single-float)
373 (frob double-float-op double-reg fp-double-zero double-float))
375 (macrolet ((frob (translate op sname scost dname dcost)
377 (define-vop (,sname single-float-op)
378 (:translate ,translate)
380 (:variant-cost ,scost))
381 (define-vop (,dname double-float-op)
382 (:translate ,translate)
384 (:variant-cost ,dcost)))))
385 (frob + :add +/single-float 2 +/double-float 2)
386 (frob - :sub -/single-float 2 -/double-float 2)
387 (frob * :mpy */single-float 4 */double-float 5)
388 (frob / :div //single-float 12 //double-float 19))
391 (macrolet ((frob (name translate sc type inst)
393 (:args (x :scs (,sc)))
394 (:results (y :scs (,sc)))
395 (:translate ,translate)
398 (:result-types ,type)
399 (:note "inline float arithmetic")
401 (:save-p :compute-only)
405 (when (policy node (or (= debug 3) (> safety speed)))
406 (note-next-instruction vop :internal-error)
407 (inst fsts fp-single-zero-tn 0 csp-tn))))))
408 (frob abs/single-float abs single-reg single-float
409 (inst funop :abs x y))
410 (frob abs/double-float abs double-reg double-float
411 (inst funop :abs x y))
412 (frob %negate/single-float %negate single-reg single-float
413 (inst fbinop :sub fp-single-zero-tn x y))
414 (frob %negate/double-float %negate double-reg double-float
415 (inst fbinop :sub fp-double-zero-tn x y)))
420 (define-vop (float-compare)
424 (:variant-vars condition complement)
426 (:note "inline float comparison")
428 (:save-p :compute-only)
430 ;; This is the condition to nullify the branch, so it is inverted.
431 (inst fcmp (if not-p condition complement) x y)
432 (note-next-instruction vop :internal-error)
434 (inst b target :nullify t)))
436 (macrolet ((frob (name sc zero-sc ptype)
437 `(define-vop (,name float-compare)
438 (:args (x :scs (,sc ,zero-sc))
439 (y :scs (,sc ,zero-sc)))
440 (:arg-types ,ptype ,ptype))))
441 (frob single-float-compare single-reg fp-single-zero single-float)
442 (frob double-float-compare double-reg fp-double-zero double-float))
444 (macrolet ((frob (translate condition complement sname dname)
446 (define-vop (,sname single-float-compare)
447 (:translate ,translate)
448 (:variant ,condition ,complement))
449 (define-vop (,dname double-float-compare)
450 (:translate ,translate)
451 (:variant ,condition ,complement)))))
452 (frob < #b01001 #b10101 </single-float </double-float)
453 (frob > #b10001 #b01101 >/single-float >/double-float)
454 (frob = #b00101 #b11001 eql/single-float eql/double-float))
459 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
461 (:args (x :scs (,from-sc)))
462 (:results (y :scs (,to-sc)))
463 (:arg-types ,from-type)
464 (:result-types ,to-type)
466 (:note "inline float coercion")
467 (:translate ,translate)
469 (:save-p :compute-only)
473 (when (policy node (or (= debug 3) (> safety speed)))
474 (note-next-instruction vop :internal-error)
475 (inst fsts fp-single-zero-tn 0 csp-tn))))))
476 (frob %single-float/double-float %single-float
477 double-reg double-float
478 single-reg single-float)
479 (frob %double-float/single-float %double-float
480 single-reg single-float
481 double-reg double-float))
483 (macrolet ((frob (name translate to-sc to-type)
485 (:args (x :scs (signed-reg)
486 :load-if (not (sc-is x signed-stack))
488 (:arg-types signed-num)
489 (:results (y :scs (,to-sc)))
490 (:result-types ,to-type)
492 (:note "inline float coercion")
493 (:translate ,translate)
495 (:save-p :compute-only)
497 (:temporary (:scs (signed-stack) :from (:argument 0))
499 (:temporary (:scs (single-reg) :to (:result 0) :target y)
501 (:temporary (:scs (any-reg) :from (:argument 0)
502 :to (:result 0)) index)
504 (let* ((nfp (current-nfp-tn vop))
510 (storew x nfp (tn-offset stack-temp))
512 (offset (* (tn-offset stack-tn) n-word-bytes)))
513 (cond ((< offset (ash 1 4))
514 (inst flds offset nfp fp-temp))
516 (inst ldo offset zero-tn index)
517 (inst fldx index nfp fp-temp)))
518 (inst fcnvxf fp-temp y)
519 (when (policy node (or (= debug 3) (> safety speed)))
520 (note-next-instruction vop :internal-error)
521 (inst fsts fp-single-zero-tn 0 csp-tn)))))))
522 (frob %single-float/signed %single-float
523 single-reg single-float)
524 (frob %double-float/signed %double-float
525 double-reg double-float))
528 (macrolet ((frob (trans from-sc from-type inst note)
529 `(define-vop (,(symbolicate trans "/" from-type))
530 (:args (x :scs (,from-sc)
532 (:results (y :scs (signed-reg)
533 :load-if (not (sc-is y signed-stack))))
534 (:arg-types ,from-type)
535 (:result-types signed-num)
540 (:save-p :compute-only)
541 (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
542 (:temporary (:scs (signed-stack) :to (:result 0) :target y)
544 (:temporary (:scs (any-reg) :from (:argument 0)
545 :to (:result 0)) index)
547 (let* ((nfp (current-nfp-tn vop))
551 (signed-reg stack-temp)))
552 (offset (* (tn-offset stack-tn) n-word-bytes)))
553 (inst ,inst x fp-temp)
554 (cond ((< offset (ash 1 4))
555 (note-next-instruction vop :internal-error)
556 (inst fsts fp-temp offset nfp))
558 (inst ldo offset zero-tn index)
559 (note-next-instruction vop :internal-error)
560 (inst fstx fp-temp index nfp)))
561 (unless (eq y stack-tn)
562 (loadw y nfp (tn-offset stack-tn))))))))
563 (frob %unary-round single-reg single-float fcnvfx "inline float round")
564 (frob %unary-round double-reg double-float fcnvfx "inline float round")
565 (frob %unary-truncate single-reg single-float fcnvfxt
566 "inline float truncate")
567 (frob %unary-truncate double-reg double-float fcnvfxt
568 "inline float truncate"))
571 (define-vop (make-single-float)
572 (:args (bits :scs (signed-reg)
573 :load-if (or (not (sc-is bits signed-stack))
574 (sc-is res single-stack))
576 (:results (res :scs (single-reg)
577 :load-if (not (sc-is bits single-stack))))
578 (:arg-types signed-num)
579 (:result-types single-float)
580 (:translate make-single-float)
583 (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
584 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
586 (let ((nfp (current-nfp-tn vop)))
591 (let ((offset (* (tn-offset temp) n-word-bytes)))
592 (inst stw bits offset nfp)
593 (cond ((< offset (ash 1 4))
594 (inst flds offset nfp res))
596 (inst ldo offset zero-tn index)
597 (inst fldx index nfp res)))))
599 (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
603 (let ((offset (* (tn-offset bits) n-word-bytes)))
604 (cond ((< offset (ash 1 4))
605 (inst flds offset nfp res))
607 (inst ldo offset zero-tn index)
608 (inst fldx index nfp res)))))))))))
610 (define-vop (make-double-float)
611 (:args (hi-bits :scs (signed-reg))
612 (lo-bits :scs (unsigned-reg)))
613 (:results (res :scs (double-reg)
614 :load-if (not (sc-is res double-stack))))
615 (:arg-types signed-num unsigned-num)
616 (:result-types double-float)
617 (:translate make-double-float)
619 (:temporary (:scs (double-stack) :to (:result 0)) temp)
620 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
623 (let* ((nfp (current-nfp-tn vop))
624 (stack-tn (sc-case res
627 (offset (* (tn-offset stack-tn) n-word-bytes)))
628 (inst stw hi-bits offset nfp)
629 (inst stw lo-bits (+ offset n-word-bytes) nfp)
630 (cond ((eq stack-tn res))
631 ((< offset (ash 1 4))
632 (inst flds offset nfp res))
634 (inst ldo offset zero-tn index)
635 (inst fldx index nfp res))))))
638 (define-vop (single-float-bits)
639 (:args (float :scs (single-reg)
640 :load-if (not (sc-is float single-stack))))
641 (:results (bits :scs (signed-reg)
642 :load-if (or (not (sc-is bits signed-stack))
643 (sc-is float single-stack))))
644 (:arg-types single-float)
645 (:result-types signed-num)
646 (:translate single-float-bits)
649 (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
650 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
652 (let ((nfp (current-nfp-tn vop)))
657 (let ((offset (* (tn-offset temp) n-word-bytes)))
658 (cond ((< offset (ash 1 4))
659 (inst fsts float offset nfp))
661 (inst ldo offset zero-tn index)
662 (inst fstx float index nfp)))
663 (inst ldw offset nfp bits)))
665 (let ((offset (* (tn-offset bits) n-word-bytes)))
666 (cond ((< offset (ash 1 4))
667 (inst fsts float offset nfp))
669 (inst ldo offset zero-tn index)
670 (inst fstx float index nfp)))))))
674 (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))
676 (define-vop (double-float-high-bits)
677 (:args (float :scs (double-reg)
678 :load-if (not (sc-is float double-stack))))
679 (:results (hi-bits :scs (signed-reg)
680 :load-if (or (not (sc-is hi-bits signed-stack))
681 (sc-is float double-stack))))
682 (:arg-types double-float)
683 (:result-types signed-num)
684 (:translate double-float-high-bits)
687 (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
688 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
690 (let ((nfp (current-nfp-tn vop)))
695 (let ((offset (* (tn-offset temp) n-word-bytes)))
696 (cond ((< offset (ash 1 4))
697 (inst fsts float offset nfp :side 0))
699 (inst ldo offset zero-tn index)
700 (inst fstx float index nfp :side 0)))
701 (inst ldw offset nfp hi-bits)))
703 (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
704 (cond ((< offset (ash 1 4))
705 (inst fsts float offset nfp :side 0))
707 (inst ldo offset zero-tn index)
708 (inst fstx float index nfp :side 0)))))))
712 (let ((offset (* (tn-offset float) n-word-bytes)))
713 (inst ldw offset nfp hi-bits)))))))))
715 (define-vop (double-float-low-bits)
716 (:args (float :scs (double-reg)
717 :load-if (not (sc-is float double-stack))))
718 (:results (lo-bits :scs (unsigned-reg)
719 :load-if (or (not (sc-is lo-bits unsigned-stack))
720 (sc-is float double-stack))))
721 (:arg-types double-float)
722 (:result-types unsigned-num)
723 (:translate double-float-low-bits)
726 (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
727 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
729 (let ((nfp (current-nfp-tn vop)))
734 (let ((offset (* (tn-offset temp) n-word-bytes)))
735 (cond ((< offset (ash 1 4))
736 (inst fsts float offset nfp :side 1))
738 (inst ldo offset zero-tn index)
739 (inst fstx float index nfp :side 1)))
740 (inst ldw offset nfp lo-bits)))
742 (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
743 (cond ((< offset (ash 1 4))
744 (inst fsts float offset nfp :side 1))
746 (inst ldo offset zero-tn index)
747 (inst fstx float index nfp :side 1)))))))
751 (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
752 (inst ldw offset nfp lo-bits)))))))))
756 ;;;; Float mode hackery:
758 (sb!xc:deftype float-modes () '(unsigned-byte 32))
759 (defknown floating-point-modes () float-modes (flushable))
760 (defknown ((setf floating-point-modes)) (float-modes)
763 (define-vop (floating-point-modes)
764 (:results (res :scs (unsigned-reg)
765 :load-if (not (sc-is res unsigned-stack))))
766 (:result-types unsigned-num)
767 (:translate floating-point-modes)
769 (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
770 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
773 (let* ((nfp (current-nfp-tn vop))
774 (stack-tn (sc-case res
776 (unsigned-reg temp)))
777 (offset (* (tn-offset stack-tn) n-word-bytes)))
778 (cond ((< offset (ash 1 4))
779 (inst fsts fp-single-zero-tn offset nfp))
781 (inst ldo offset zero-tn index)
782 (inst fstx fp-single-zero-tn index nfp)))
783 (unless (eq stack-tn res)
784 (inst ldw offset nfp res)))))
786 (define-vop (set-floating-point-modes)
787 (:args (new :scs (unsigned-reg)
788 :load-if (not (sc-is new unsigned-stack))))
789 (:results (res :scs (unsigned-reg)))
790 (:arg-types unsigned-num)
791 (:result-types unsigned-num)
792 (:translate (setf floating-point-modes))
794 (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
795 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
798 (let* ((nfp (current-nfp-tn vop))
799 (stack-tn (sc-case new
801 (unsigned-reg temp)))
802 (offset (* (tn-offset stack-tn) n-word-bytes)))
803 (unless (eq new stack-tn)
804 (inst stw new offset nfp))
805 (cond ((< offset (ash 1 4))
806 (inst flds offset nfp fp-single-zero-tn))
808 (inst ldo offset zero-tn index)
809 (inst fldx index nfp fp-single-zero-tn)))
810 (inst ldw offset nfp res))))
813 ;;;; Complex float VOPs
815 (define-vop (make-complex-single-float)
817 (:args (real :scs (single-reg) :target r)
818 (imag :scs (single-reg) :to :save))
819 (:arg-types single-float single-float)
820 (:results (r :scs (complex-single-reg) :from (:argument 0)
821 :load-if (not (sc-is r complex-single-stack))))
822 (:result-types complex-single-float)
823 (:note "inline complex single-float creation")
829 (let ((r-real (complex-single-reg-real-tn r)))
830 (unless (location= real r-real)
831 (inst funop :copy real r-real)))
832 (let ((r-imag (complex-single-reg-imag-tn r)))
833 (unless (location= imag r-imag)
834 (inst funop :copy imag r-imag))))
835 (complex-single-stack
836 (let ((nfp (current-nfp-tn vop))
837 (offset (* (tn-offset r) n-word-bytes)))
838 (str-float real offset nfp)
839 (str-float imag (+ offset n-word-bytes) nfp))))))
841 (define-vop (make-complex-double-float)
843 (:args (real :scs (double-reg) :target r)
844 (imag :scs (double-reg) :to :save))
845 (:arg-types double-float double-float)
846 (:results (r :scs (complex-double-reg) :from (:argument 0)
847 :load-if (not (sc-is r complex-double-stack))))
848 (:result-types complex-double-float)
849 (:note "inline complex double-float creation")
855 (let ((r-real (complex-double-reg-real-tn r)))
856 (unless (location= real r-real)
857 (inst funop :copy real r-real)))
858 (let ((r-imag (complex-double-reg-imag-tn r)))
859 (unless (location= imag r-imag)
860 (inst funop :copy imag r-imag))))
861 (complex-double-stack
862 (let ((nfp (current-nfp-tn vop))
863 (offset (* (tn-offset r) n-word-bytes)))
864 (str-float real offset nfp)
865 (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
868 (define-vop (complex-single-float-value)
869 (:args (x :scs (complex-single-reg) :target r
870 :load-if (not (sc-is x complex-single-stack))))
871 (:arg-types complex-single-float)
872 (:results (r :scs (single-reg)))
873 (:result-types single-float)
880 (let ((value-tn (ecase slot
881 (:real (complex-single-reg-real-tn x))
882 (:imag (complex-single-reg-imag-tn x)))))
883 (unless (location= value-tn r)
884 (inst funop :copy value-tn r))))
885 (complex-single-stack
886 (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
888 (current-nfp-tn vop) r)))))
890 (define-vop (realpart/complex-single-float complex-single-float-value)
891 (:translate realpart)
892 (:note "complex single float realpart")
895 (define-vop (imagpart/complex-single-float complex-single-float-value)
896 (:translate imagpart)
897 (:note "complex single float imagpart")
900 (define-vop (complex-double-float-value)
901 (:args (x :scs (complex-double-reg) :target r
902 :load-if (not (sc-is x complex-double-stack))))
903 (:arg-types complex-double-float)
904 (:results (r :scs (double-reg)))
905 (:result-types double-float)
912 (let ((value-tn (ecase slot
913 (:real (complex-double-reg-real-tn x))
914 (:imag (complex-double-reg-imag-tn x)))))
915 (unless (location= value-tn r)
916 (inst funop :copy value-tn r))))
917 (complex-double-stack
918 (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
920 (current-nfp-tn vop) r)))))
922 (define-vop (realpart/complex-double-float complex-double-float-value)
923 (:translate realpart)
924 (:note "complex double float realpart")
927 (define-vop (imagpart/complex-double-float complex-double-float-value)
928 (:translate imagpart)
929 (:note "complex double float imagpart")