1 ;;;; the HPPA 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.
15 (define-move-fun (load-fp-zero 1) (vop x y)
16 ((fp-single-zero) (single-reg)
17 (fp-double-zero) (double-reg))
18 (inst funop :copy x y))
20 (defun ld-float (offset base r)
21 (cond ((< offset (ash 1 4))
22 (inst flds offset base r))
23 ((and (< offset (ash 1 13))
25 (inst ldo offset zero-tn lip-tn)
26 (inst fldx lip-tn base r))
28 (error "ld-float: bad offset: ~s~%" offset))))
30 (define-move-fun (load-float 1) (vop x y)
31 ((single-stack) (single-reg)
32 (double-stack) (double-reg))
33 (let ((offset (* (tn-offset x) n-word-bytes)))
34 (ld-float offset (current-nfp-tn vop) y)))
36 (defun str-float (x offset base)
37 (cond ((< offset (ash 1 4))
38 ;(note-next-instruction vop :internal-error)
39 (inst fsts x offset base))
40 ((and (< offset (ash 1 13))
42 ;; FIXME-lav, ok with GC to use lip-tn for arbitrary offsets ?
43 (inst ldo offset zero-tn lip-tn)
44 ;(note-next-instruction vop :internal-error)
45 (inst fstx x lip-tn base))
47 (error "str-float: bad offset: ~s~%" offset))))
49 (define-move-fun (store-float 1) (vop x y)
50 ((single-reg) (single-stack)
51 (double-reg) (double-stack))
52 (let ((offset (* (tn-offset y) n-word-bytes)))
53 (str-float x offset (current-nfp-tn vop))))
56 (define-vop (move-float)
57 (:args (x :scs (single-reg double-reg)
59 :load-if (not (location= x y))))
60 (:results (y :scs (single-reg double-reg)
61 :load-if (not (location= x y))))
64 (unless (location= y x)
65 (inst funop :copy x y))))
66 (define-move-vop move-float :move (single-reg) (single-reg))
67 (define-move-vop move-float :move (double-reg) (double-reg))
69 (define-vop (move-from-float)
71 (:results (y :scs (descriptor-reg)))
72 (:temporary (:scs (non-descriptor-reg)) ndescr)
73 (:variant-vars size type data)
74 (:note "float to pointer coercion")
76 (with-fixed-allocation (y nil ndescr type size nil)
77 (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))))
79 (macrolet ((frob (name sc &rest args)
81 (define-vop (,name move-from-float)
82 (:args (x :scs (,sc) :to :save))
84 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
85 (frob move-from-single single-reg
86 single-float-size single-float-widetag single-float-value-slot)
87 (frob move-from-double double-reg
88 double-float-size double-float-widetag double-float-value-slot))
90 (define-vop (move-to-float)
91 (:args (x :scs (descriptor-reg)))
93 (:variant-vars offset)
94 (:note "pointer to float coercion")
96 (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
98 (macrolet ((frob (name sc offset)
100 (define-vop (,name move-to-float)
101 (:results (y :scs (,sc)))
103 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
104 (frob move-to-single single-reg single-float-value-slot)
105 (frob move-to-double double-reg double-float-value-slot))
107 (define-vop (move-float-arg)
108 (:args (x :scs (single-reg double-reg) :target y)
110 :load-if (not (sc-is y single-reg double-reg))))
112 (:note "float argument move")
115 ((single-reg double-reg)
116 (unless (location= x y)
117 (inst funop :copy x y)))
118 ((single-stack double-stack)
119 (let ((offset (* (tn-offset y) n-word-bytes)))
120 (str-float x offset nfp))))))
121 (define-move-vop move-float-arg :move-arg
122 (single-reg descriptor-reg) (single-reg))
123 (define-move-vop move-float-arg :move-arg
124 (double-reg descriptor-reg) (double-reg))
126 ;;;; Complex float move functions
127 (defun complex-single-reg-real-tn (x)
128 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
129 :offset (tn-offset x)))
130 (defun complex-single-reg-imag-tn (x)
131 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
132 :offset (1+ (tn-offset x))))
134 (defun complex-double-reg-real-tn (x)
135 (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg)
136 :offset (tn-offset x)))
137 (defun complex-double-reg-imag-tn (x)
138 (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg)
139 :offset (1+ (tn-offset x))))
142 ((def-move-fun (dir type size from to)
143 `(define-move-fun (,(symbolicate dir "-" type) ,size) (vop x y)
144 ((,(symbolicate type "-" from)) (,(symbolicate type "-" to)))
145 (let ((nfp (current-nfp-tn vop))
146 (offset (* (tn-offset ,(if (eq dir 'load) 'x 'y)) n-word-bytes)))
148 `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") y)))
149 (ld-float offset nfp real-tn))
150 (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") y)))
151 (ld-float (+ offset n-word-bytes) nfp imag-tn)))
152 `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") x)))
153 (str-float real-tn offset nfp))
154 (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") x)))
156 (+ offset (* ,(/ size 2) n-word-bytes))
158 (def-move-fun load complex-single 2 stack reg)
159 (def-move-fun store complex-single 2 reg stack)
160 (def-move-fun load complex-double 4 stack reg)
161 (def-move-fun store complex-double 4 reg stack))
163 ;;; Complex float register to register moves.
164 (define-vop (complex-single-move)
165 (:args (x :scs (complex-single-reg) :target y
166 :load-if (not (location= x y))))
167 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
168 (:note "complex single float move")
170 (unless (location= x y)
171 ;; Note the complex-float-regs are aligned to every second
172 ;; float register so there is not need to worry about overlap.
173 (let ((x-real (complex-single-reg-real-tn x))
174 (y-real (complex-single-reg-real-tn y)))
175 (inst funop :copy x-real y-real))
176 (let ((x-imag (complex-single-reg-imag-tn x))
177 (y-imag (complex-single-reg-imag-tn y)))
178 (inst funop :copy x-imag y-imag)))))
179 (define-move-vop complex-single-move :move
180 (complex-single-reg) (complex-single-reg))
182 (define-vop (complex-double-move)
183 (:args (x :scs (complex-double-reg)
184 :target y :load-if (not (location= x y))))
185 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
186 (:note "complex double float move")
188 (unless (location= x y)
189 ;; Note the complex-float-regs are aligned to every second
190 ;; float register so there is not need to worry about overlap.
191 (let ((x-real (complex-double-reg-real-tn x))
192 (y-real (complex-double-reg-real-tn y)))
193 (inst funop :copy x-real y-real))
194 (let ((x-imag (complex-double-reg-imag-tn x))
195 (y-imag (complex-double-reg-imag-tn y)))
196 (inst funop :copy x-imag y-imag)))))
197 (define-move-vop complex-double-move :move
198 (complex-double-reg) (complex-double-reg))
200 ;;; Move from a complex float to a descriptor register allocating a
201 ;;; new complex float object in the process.
202 (define-vop (move-from-complex-single)
203 (:args (x :scs (complex-single-reg) :to :save))
204 (:results (y :scs (descriptor-reg)))
205 (:temporary (:scs (non-descriptor-reg)) ndescr)
206 (:note "complex single float to pointer coercion")
208 (with-fixed-allocation (y nil ndescr complex-single-float-widetag
209 complex-single-float-size nil)
210 (let ((real-tn (complex-single-reg-real-tn x)))
211 (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes)
212 other-pointer-lowtag) y))
213 (let ((imag-tn (complex-single-reg-imag-tn x)))
214 (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes)
215 other-pointer-lowtag) y)))))
216 (define-move-vop move-from-complex-single :move
217 (complex-single-reg) (descriptor-reg))
219 (define-vop (move-from-complex-double)
220 (:args (x :scs (complex-double-reg) :to :save))
221 (:results (y :scs (descriptor-reg)))
222 (:temporary (:scs (non-descriptor-reg)) ndescr)
223 (:note "complex double float to pointer coercion")
225 (with-fixed-allocation (y nil ndescr complex-double-float-widetag
226 complex-double-float-size nil)
227 (let ((real-tn (complex-double-reg-real-tn x)))
228 (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes)
229 other-pointer-lowtag) y))
230 (let ((imag-tn (complex-double-reg-imag-tn x)))
231 (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes)
232 other-pointer-lowtag) y)))))
233 (define-move-vop move-from-complex-double :move
234 (complex-double-reg) (descriptor-reg))
236 ;;; Move from a descriptor to a complex float register
237 (define-vop (move-to-complex-single)
238 (:args (x :scs (descriptor-reg)))
239 (:results (y :scs (complex-single-reg)))
240 (:note "pointer to complex float coercion")
242 (let ((real-tn (complex-single-reg-real-tn y)))
243 (inst flds (- (* complex-single-float-real-slot n-word-bytes)
244 other-pointer-lowtag)
246 (let ((imag-tn (complex-single-reg-imag-tn y)))
247 (inst flds (- (* complex-single-float-imag-slot n-word-bytes)
248 other-pointer-lowtag)
250 (define-move-vop move-to-complex-single :move
251 (descriptor-reg) (complex-single-reg))
253 (define-vop (move-to-complex-double)
254 (:args (x :scs (descriptor-reg)))
255 (:results (y :scs (complex-double-reg)))
256 (:note "pointer to complex float coercion")
258 (let ((real-tn (complex-double-reg-real-tn y)))
259 (inst flds (- (* complex-double-float-real-slot n-word-bytes)
260 other-pointer-lowtag)
262 (let ((imag-tn (complex-double-reg-imag-tn y)))
263 (inst flds (- (* complex-double-float-imag-slot n-word-bytes)
264 other-pointer-lowtag)
266 (define-move-vop move-to-complex-double :move
267 (descriptor-reg) (complex-double-reg))
269 ;;; Complex float move-arg vop
270 (define-vop (move-complex-single-float-arg)
271 (:args (x :scs (complex-single-reg) :target y)
272 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
274 (:note "float argument move")
278 (unless (location= x y)
279 (let ((x-real (complex-single-reg-real-tn x))
280 (y-real (complex-single-reg-real-tn y)))
281 (inst funop :copy x-real y-real))
282 (let ((x-imag (complex-single-reg-imag-tn x))
283 (y-imag (complex-single-reg-imag-tn y)))
284 (inst funop :copy x-imag y-imag))))
285 (complex-single-stack
286 (let ((offset (* (tn-offset y) n-word-bytes)))
287 (let ((real-tn (complex-single-reg-real-tn x)))
288 (str-float real-tn offset nfp))
289 (let ((imag-tn (complex-single-reg-imag-tn x)))
290 (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
291 (define-move-vop move-complex-single-float-arg :move-arg
292 (complex-single-reg descriptor-reg) (complex-single-reg))
294 (define-vop (move-complex-double-float-arg)
295 (:args (x :scs (complex-double-reg) :target y)
296 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
298 (:note "float argument move")
302 (unless (location= x y)
303 (let ((x-real (complex-double-reg-real-tn x))
304 (y-real (complex-double-reg-real-tn y)))
305 (inst funop :copy x-real y-real))
306 (let ((x-imag (complex-double-reg-imag-tn x))
307 (y-imag (complex-double-reg-imag-tn y)))
308 (inst funop :copy x-imag y-imag))))
309 (complex-double-stack
310 (let ((offset (* (tn-offset y) n-word-bytes)))
311 (let ((real-tn (complex-double-reg-real-tn x)))
312 (str-float real-tn offset nfp))
313 (let ((imag-tn (complex-double-reg-imag-tn x)))
314 (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
315 (define-move-vop move-complex-double-float-arg :move-arg
316 (complex-double-reg descriptor-reg) (complex-double-reg))
318 (define-move-vop move-arg :move-arg
319 (single-reg double-reg complex-single-reg complex-double-reg)
322 ;;;; stuff for c-call float-in-int-register arguments
323 (define-vop (move-to-single-int-reg)
324 (:note "pointer to float-in-int coercion")
325 (:args (x :scs (single-reg descriptor-reg)))
326 (:results (y :scs (single-int-carg-reg) :load-if nil))
330 (inst funop :copy x y))
332 (inst ldw (- (* single-float-value-slot n-word-bytes)
333 other-pointer-lowtag) x y)))))
334 (define-move-vop move-to-single-int-reg
335 :move (single-reg descriptor-reg) (single-int-carg-reg))
337 (define-vop (move-single-int-reg)
338 (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
339 (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
340 (:results (y :scs (single-int-carg-reg) :load-if nil))
342 (unless (location= x y)
343 (error "Huh? why did it do that?"))))
344 (define-move-vop move-single-int-reg :move-arg
345 (single-int-carg-reg) (single-int-carg-reg))
347 ; move contents of float register x to register y
348 (define-vop (move-to-double-int-reg)
349 (:note "pointer to float-in-int coercion")
350 (:args (x :scs (double-reg descriptor-reg)))
351 (:results (y :scs (double-int-carg-reg) :load-if nil))
352 (:temporary (:scs (signed-stack) :to (:result 0)) temp)
353 (:temporary (:scs (signed-reg) :to (:result 0) :target y) old1)
354 (:temporary (:scs (signed-reg) :to (:result 0) :target y) old2)
356 (:save-p :compute-only)
360 (let* ((nfp (current-nfp-tn vop))
363 (double-int-carg-reg temp)))
364 (offset (* (tn-offset stack-tn) n-word-bytes)))
365 ;; save 8 bytes of stack to two register,
366 ;; write down float in stack and load it back
367 ;; into result register. Notice the result hack,
368 ;; we are writing to one extra register.
369 ;; Double float argument convention uses two registers,
370 ;; but we only know about one (thanks to c-call).
371 (inst ldw offset nfp old1)
372 (inst ldw (+ offset n-word-bytes) nfp old2)
373 (str-float x offset nfp) ; writes 8 bytes
374 (inst ldw offset nfp y)
375 (inst ldw (+ offset n-word-bytes) nfp
376 (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
377 (sc-number-or-lose 'unsigned-reg)
378 (+ 1 (tn-offset y))))
379 (inst stw old1 offset nfp)
380 (inst stw old2 (+ offset n-word-bytes) nfp)))
382 (inst ldw (- (* double-float-value-slot n-word-bytes)
383 other-pointer-lowtag) x y)
384 (inst ldw (- (* (1+ double-float-value-slot) n-word-bytes)
385 other-pointer-lowtag) x
386 (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
387 (sc-number-or-lose 'unsigned-reg)
388 (+ 1 (tn-offset y))))))))
389 (define-move-vop move-to-double-int-reg
390 :move (double-reg descriptor-reg) (double-int-carg-reg))
392 (define-vop (move-double-int-reg)
393 (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
394 (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
395 (:results (y :scs (double-int-carg-reg) :load-if nil))
397 (unless (location= x y)
398 (error "Huh? why did it do that?"))))
399 (define-move-vop move-double-int-reg :move-arg
400 (double-int-carg-reg) (double-int-carg-reg))
402 ;;;; Arithmetic VOPs.
404 (define-vop (float-op)
407 (:variant-vars operation)
409 (:note "inline float arithmetic")
411 (:save-p :compute-only)
413 (note-this-location vop :internal-error)
414 (inst fbinop operation x y r)))
416 (macrolet ((frob (name sc zero-sc ptype)
417 `(define-vop (,name float-op)
418 (:args (x :scs (,sc ,zero-sc))
419 (y :scs (,sc ,zero-sc)))
420 (:results (r :scs (,sc)))
421 (:arg-types ,ptype ,ptype)
422 (:result-types ,ptype))))
423 (frob single-float-op single-reg fp-single-zero single-float)
424 (frob double-float-op double-reg fp-double-zero double-float))
426 (macrolet ((frob (translate op sname scost dname dcost)
428 (define-vop (,sname single-float-op)
429 (:translate ,translate)
431 (:variant-cost ,scost))
432 (define-vop (,dname double-float-op)
433 (:translate ,translate)
435 (:variant-cost ,dcost)))))
436 (frob + :add +/single-float 2 +/double-float 2)
437 (frob - :sub -/single-float 2 -/double-float 2)
438 (frob * :mpy */single-float 4 */double-float 5)
439 (frob / :div //single-float 12 //double-float 19))
441 (macrolet ((frob (name translate sc type inst)
443 (:args (x :scs (,sc)))
444 (:results (y :scs (,sc)))
445 (:translate ,translate)
448 (:result-types ,type)
449 (:note "inline float arithmetic")
451 (:save-p :compute-only)
453 (note-this-location vop :internal-error)
455 (frob abs/single-float abs single-reg single-float
456 (inst funop :abs x y))
457 (frob abs/double-float abs double-reg double-float
458 (inst funop :abs x y))
459 (frob %negate/single-float %negate single-reg single-float
460 (inst fbinop :sub fp-single-zero-tn x y))
461 (frob %negate/double-float %negate double-reg double-float
462 (inst fbinop :sub fp-double-zero-tn x y)))
467 (define-vop (float-compare)
471 (:variant-vars condition complement)
473 (:note "inline float comparison")
475 (:save-p :compute-only)
477 (note-this-location vop :internal-error)
478 ;; This is the condition to nullify the branch, so it is inverted.
479 (inst fcmp (if not-p condition complement) x y)
481 (inst b target :nullify t)))
483 (macrolet ((frob (name sc zero-sc ptype)
484 `(define-vop (,name float-compare)
485 (:args (x :scs (,sc ,zero-sc))
486 (y :scs (,sc ,zero-sc)))
487 (:arg-types ,ptype ,ptype))))
488 (frob single-float-compare single-reg fp-single-zero single-float)
489 (frob double-float-compare double-reg fp-double-zero double-float))
491 (macrolet ((frob (translate condition complement sname dname)
493 (define-vop (,sname single-float-compare)
494 (:translate ,translate)
495 (:variant ,condition ,complement))
496 (define-vop (,dname double-float-compare)
497 (:translate ,translate)
498 (:variant ,condition ,complement)))))
499 ;; FIXME-lav: let 'inst cmp' translate keywords into raw binary instead of giving it here
500 (frob < #b01001 #b10101 </single-float </double-float)
501 (frob > #b10001 #b01101 >/single-float >/double-float)
502 (frob = #b00101 #b11001 eql/single-float eql/double-float))
507 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
509 (:args (x :scs (,from-sc)))
510 (:results (y :scs (,to-sc)))
511 (:arg-types ,from-type)
512 (:result-types ,to-type)
514 (:note "inline float coercion")
515 (:translate ,translate)
517 (:save-p :compute-only)
519 (note-this-location vop :internal-error)
520 (inst fcnvff x y)))))
521 (frob %single-float/double-float %single-float
522 double-reg double-float
523 single-reg single-float)
524 (frob %double-float/single-float %double-float
525 single-reg single-float
526 double-reg double-float))
528 ; convert register-integer to registersingle/double by
529 ; putting it on single-float-stack and then float-loading it into
530 ; an float register, and finally convert the float-register and
531 ; storing the result into y
532 (macrolet ((frob (name translate to-sc to-type)
534 (:args (x :scs (signed-reg)
535 :load-if (not (sc-is x signed-stack))
537 (:arg-types signed-num)
538 (:results (y :scs (,to-sc)))
539 (:result-types ,to-type)
541 (:note "inline float coercion")
542 (:translate ,translate)
544 (:save-p :compute-only)
545 (:temporary (:scs (signed-stack) :from (:argument 0))
547 (:temporary (:scs (single-reg) :to (:result 0) :target y)
549 (:temporary (:scs (any-reg) :from (:argument 0)
550 :to (:result 0)) index)
552 (let* ((nfp (current-nfp-tn vop))
558 (storew x nfp (tn-offset stack-temp))
560 (offset (* (tn-offset stack-tn) n-word-bytes)))
561 (cond ((< offset (ash 1 4))
562 (inst flds offset nfp fp-temp))
563 ((and (< offset (ash 1 13))
565 (inst ldo offset zero-tn index)
566 (inst fldx index nfp fp-temp))
568 (error "in vop ~s offset ~s is out-of-range" ',name offset)))
569 (note-this-location vop :internal-error)
570 (inst fcnvxf fp-temp y))))))
571 (frob %single-float/signed %single-float
572 single-reg single-float)
573 (frob %double-float/signed %double-float
574 double-reg double-float))
576 (macrolet ((frob (trans from-sc from-type inst note)
577 `(define-vop (,(symbolicate trans "/" from-type))
578 (:args (x :scs (,from-sc)
580 (:results (y :scs (signed-reg)
581 :load-if (not (sc-is y signed-stack))))
582 (:arg-types ,from-type)
583 (:result-types signed-num)
588 (:save-p :compute-only)
589 (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
590 (:temporary (:scs (signed-stack) :to (:result 0) :target y)
592 (:temporary (:scs (any-reg) :from (:argument 0)
593 :to (:result 0)) index)
595 (let* ((nfp (current-nfp-tn vop))
599 (signed-reg stack-temp)))
600 (offset (* (tn-offset stack-tn) n-word-bytes)))
601 (inst ,inst x fp-temp)
602 (cond ((< offset (ash 1 4))
603 (note-next-instruction vop :internal-error)
604 (inst fsts fp-temp offset nfp))
605 ((and (< offset (ash 1 13))
607 (inst ldo offset zero-tn index)
608 (note-next-instruction vop :internal-error)
609 (inst fstx fp-temp index nfp))
611 (error "unary error, ldo offset too high")))
612 (unless (eq y stack-tn)
613 (loadw y nfp (tn-offset stack-tn))))))))
614 (frob %unary-round single-reg single-float fcnvfx "inline float round")
615 (frob %unary-round double-reg double-float fcnvfx "inline float round")
616 (frob %unary-truncate single-reg single-float fcnvfxt
617 "inline float truncate")
618 (frob %unary-truncate double-reg double-float fcnvfxt
619 "inline float truncate"))
621 (define-vop (make-single-float)
622 (:args (bits :scs (signed-reg)
623 :load-if (or (not (sc-is bits signed-stack))
624 (sc-is res single-stack))
626 (:results (res :scs (single-reg)
627 :load-if (not (sc-is bits single-stack))))
628 (:arg-types signed-num)
629 (:result-types single-float)
630 (:translate make-single-float)
633 (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
634 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
636 (let ((nfp (current-nfp-tn vop)))
641 (let ((offset (* (tn-offset temp) n-word-bytes)))
642 (inst stw bits offset nfp)
643 (cond ((< offset (ash 1 4))
644 (inst flds offset nfp res))
645 ((and (< offset (ash 1 13))
647 (inst ldo offset zero-tn index)
648 (inst fldx index nfp res))
650 (error "make-single-float error, ldo offset too large")))))
652 (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
656 (let ((offset (* (tn-offset bits) n-word-bytes)))
657 (cond ((< offset (ash 1 4))
658 (inst flds offset nfp res))
659 ((and (< offset (ash 1 13))
661 (inst ldo offset zero-tn index)
662 (inst fldx index nfp res))
664 (error "make-single-float error, ldo offset too large")))))))))))
666 (define-vop (make-double-float)
667 (:args (hi-bits :scs (signed-reg))
668 (lo-bits :scs (unsigned-reg)))
669 (:results (res :scs (double-reg)
670 :load-if (not (sc-is res double-stack))))
671 (:arg-types signed-num unsigned-num)
672 (:result-types double-float)
673 (:translate make-double-float)
675 (:temporary (:scs (double-stack) :to (:result 0)) temp)
676 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
679 (let* ((nfp (current-nfp-tn vop))
680 (stack-tn (sc-case res
683 (offset (* (tn-offset stack-tn) n-word-bytes)))
684 (inst stw hi-bits offset nfp)
685 (inst stw lo-bits (+ offset n-word-bytes) nfp)
686 (cond ((eq stack-tn res))
687 ((< offset (ash 1 4))
688 (inst flds offset nfp res))
689 ((and (< offset (ash 1 13))
691 (inst ldo offset zero-tn index)
692 (inst fldx index nfp res))
694 (error "make-single-float error, ldo offset too large"))))))
697 ((float-bits (name reg rreg stack rstack atype anum side offset)
699 (:args (float :scs (,reg)
700 :load-if (not (sc-is float ,stack))))
701 (:results (bits :scs (,rreg)
702 :load-if (or (not (sc-is bits ,rstack))
703 (sc-is float ,stack))))
705 (:result-types ,anum)
709 (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
710 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
712 (let ((nfp (current-nfp-tn vop)))
717 (let ((offset (* (tn-offset temp) n-word-bytes)))
718 (cond ((< offset (ash 1 4))
720 `((inst fsts float offset nfp :side ,side))
721 `((inst fsts float offset nfp))))
722 ((and (< offset (ash 1 13))
724 (inst ldo offset zero-tn index)
726 `((inst fstx float index nfp :side ,side))
727 `((inst fstx float index nfp))))
729 (error ,(format nil "~s,~s: inst-LDO offset too large"
731 (inst ldw offset nfp bits)))
733 (let ((offset (* (tn-offset bits) n-word-bytes)))
734 (cond ((< offset (ash 1 4))
736 `((inst fsts float offset nfp :side ,side))
737 `((inst fsts float offset nfp))))
738 ((and (< offset (ash 1 13))
740 (inst ldo offset zero-tn index)
742 `((inst fstx float index nfp :side ,side))
743 `((inst fstx float index nfp))))
745 (error ,(format nil "~s,~s: inst-LDO offset too large"
750 (inst ldw (* (+ (tn-offset float) ,offset) n-word-bytes)
752 (float-bits single-float-bits single-reg signed-reg single-stack
753 signed-stack single-float signed-num nil 0)
754 (float-bits double-float-high-bits double-reg signed-reg
755 double-stack signed-stack double-float signed-num 0 0)
756 (float-bits double-float-low-bits double-reg unsigned-reg
757 double-stack unsigned-stack double-float unsigned-num 1 1))
759 ;;;; Float mode hackery:
761 (sb!xc:deftype float-modes () '(unsigned-byte 32))
762 (defknown floating-point-modes () float-modes (flushable))
763 (defknown ((setf floating-point-modes)) (float-modes)
766 (define-vop (floating-point-modes)
767 (:results (res :scs (unsigned-reg)
768 :load-if (not (sc-is res unsigned-stack))))
769 (:result-types unsigned-num)
770 (:translate floating-point-modes)
772 (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
773 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
776 (let* ((nfp (current-nfp-tn vop))
777 (stack-tn (sc-case res
779 (unsigned-reg temp)))
780 (offset (* (tn-offset stack-tn) n-word-bytes)))
781 (cond ((< offset (ash 1 4))
782 (inst fsts fp-single-zero-tn offset nfp))
783 ((and (< offset (ash 1 13))
785 (inst ldo offset zero-tn index)
786 (inst fstx fp-single-zero-tn index nfp))
788 (error "floating-point-modes error, ldo offset too large")))
789 (unless (eq stack-tn res)
790 (inst ldw offset nfp res)))))
792 (define-vop (set-floating-point-modes)
793 (:args (new :scs (unsigned-reg)
794 :load-if (not (sc-is new unsigned-stack))))
795 (:results (res :scs (unsigned-reg)))
796 (:arg-types unsigned-num)
797 (:result-types unsigned-num)
798 (:translate (setf floating-point-modes))
800 (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
801 (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
804 (let* ((nfp (current-nfp-tn vop))
805 (stack-tn (sc-case new
807 (unsigned-reg temp)))
808 (offset (* (tn-offset stack-tn) n-word-bytes)))
809 (unless (eq new stack-tn)
810 (inst stw new offset nfp))
811 (cond ((< offset (ash 1 4))
812 (inst flds offset nfp fp-single-zero-tn))
813 ((and (< offset (ash 1 13))
815 (inst ldo offset zero-tn index)
816 (inst fldx index nfp fp-single-zero-tn))
818 (error "set-floating-point-modes error, ldo offset too large")))
819 (inst ldw offset nfp res))))
821 ;;;; Complex float VOPs
823 (define-vop (make-complex-single-float)
825 (:args (real :scs (single-reg) :target r)
826 (imag :scs (single-reg) :to :save))
827 (:arg-types single-float single-float)
828 (:results (r :scs (complex-single-reg) :from (:argument 0)
829 :load-if (not (sc-is r complex-single-stack))))
830 (:result-types complex-single-float)
831 (:note "inline complex single-float creation")
837 (let ((r-real (complex-single-reg-real-tn r)))
838 (unless (location= real r-real)
839 (inst funop :copy real r-real)))
840 (let ((r-imag (complex-single-reg-imag-tn r)))
841 (unless (location= imag r-imag)
842 (inst funop :copy imag r-imag))))
843 (complex-single-stack
844 (let ((nfp (current-nfp-tn vop))
845 (offset (* (tn-offset r) n-word-bytes)))
846 (str-float real offset nfp)
847 (str-float imag (+ offset n-word-bytes) nfp))))))
849 (define-vop (make-complex-double-float)
851 (:args (real :scs (double-reg) :target r)
852 (imag :scs (double-reg) :to :save))
853 (:arg-types double-float double-float)
854 (:results (r :scs (complex-double-reg) :from (:argument 0)
855 :load-if (not (sc-is r complex-double-stack))))
856 (:result-types complex-double-float)
857 (:note "inline complex double-float creation")
863 (let ((r-real (complex-double-reg-real-tn r)))
864 (unless (location= real r-real)
865 (inst funop :copy real r-real)))
866 (let ((r-imag (complex-double-reg-imag-tn r)))
867 (unless (location= imag r-imag)
868 (inst funop :copy imag r-imag))))
869 (complex-double-stack
870 (let ((nfp (current-nfp-tn vop))
871 (offset (* (tn-offset r) n-word-bytes)))
872 (str-float real offset nfp)
873 (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
875 (define-vop (complex-single-float-value)
876 (:args (x :scs (complex-single-reg) :target r
877 :load-if (not (sc-is x complex-single-stack))))
878 (:arg-types complex-single-float)
879 (:results (r :scs (single-reg)))
880 (:result-types single-float)
887 (let ((value-tn (ecase slot
888 (:real (complex-single-reg-real-tn x))
889 (:imag (complex-single-reg-imag-tn x)))))
890 (unless (location= value-tn r)
891 (inst funop :copy value-tn r))))
892 (complex-single-stack
893 (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
895 (current-nfp-tn vop) r)))))
897 (define-vop (realpart/complex-single-float complex-single-float-value)
898 (:translate realpart)
899 (:note "complex single float realpart")
902 (define-vop (imagpart/complex-single-float complex-single-float-value)
903 (:translate imagpart)
904 (:note "complex single float imagpart")
907 (define-vop (complex-double-float-value)
908 (:args (x :scs (complex-double-reg) :target r
909 :load-if (not (sc-is x complex-double-stack))))
910 (:arg-types complex-double-float)
911 (:results (r :scs (double-reg)))
912 (:result-types double-float)
919 (let ((value-tn (ecase slot
920 (:real (complex-double-reg-real-tn x))
921 (:imag (complex-double-reg-imag-tn x)))))
922 (unless (location= value-tn r)
923 (inst funop :copy value-tn r))))
924 (complex-double-stack
925 (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
927 (current-nfp-tn vop) r)))))
929 (define-vop (realpart/complex-double-float complex-double-float-value)
930 (:translate realpart)
931 (:note "complex double float realpart")
934 (define-vop (imagpart/complex-double-float complex-double-float-value)
935 (:translate imagpart)
936 (:note "complex double float imagpart")