1.0.19.16: derive the type of (AREF (THE STRING X) Y) as CHARACTER
[sbcl.git] / src / compiler / hppa / float.lisp
1 ;;;; the HPPA VM definition of floating point operations
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; Move functions.
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))
19
20 (defun ld-float (offset base r)
21   (cond ((< offset (ash 1 4))
22          (inst flds offset base r))
23         (t
24          (inst ldo offset zero-tn lip-tn)
25          (inst fldx lip-tn base r))))
26
27 (define-move-fun (load-float 1) (vop x y)
28   ((single-stack) (single-reg)
29    (double-stack) (double-reg))
30   (let ((offset (* (tn-offset x) n-word-bytes)))
31     (ld-float offset (current-nfp-tn vop) y)))
32
33 (defun str-float (x offset base)
34   (cond ((< offset (ash 1 4))
35          (inst fsts x offset base))
36         (t
37          (inst ldo offset zero-tn lip-tn)
38          (inst fstx x lip-tn base))))
39
40 (define-move-fun (store-float 1) (vop x y)
41   ((single-reg) (single-stack)
42    (double-reg) (double-stack))
43   (let ((offset (* (tn-offset y) n-word-bytes)))
44     (str-float x offset (current-nfp-tn vop))))
45 \f
46 ;;;; Move VOPs
47 (define-vop (move-float)
48   (:args (x :scs (single-reg double-reg)
49             :target y
50             :load-if (not (location= x y))))
51   (:results (y :scs (single-reg double-reg)
52                :load-if (not (location= x y))))
53   (:note "float move")
54   (:generator 0
55     (unless (location= y x)
56       (inst funop :copy x y))))
57 (define-move-vop move-float :move (single-reg) (single-reg))
58 (define-move-vop move-float :move (double-reg) (double-reg))
59
60 (define-vop (move-from-float)
61   (:args (x :to :save))
62   (:results (y :scs (descriptor-reg)))
63   (:temporary (:scs (non-descriptor-reg)) ndescr)
64   (:variant-vars size type data)
65   (:note "float to pointer coercion")
66   (:generator 13
67     (with-fixed-allocation (y ndescr type size)
68       (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))))
69
70 (macrolet ((frob (name sc &rest args)
71              `(progn
72                 (define-vop (,name move-from-float)
73                   (:args (x :scs (,sc) :to :save))
74                   (:variant ,@args))
75                 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
76   (frob move-from-single single-reg
77     single-float-size single-float-widetag single-float-value-slot)
78   (frob move-from-double double-reg
79     double-float-size double-float-widetag double-float-value-slot))
80
81 (define-vop (move-to-float)
82   (:args (x :scs (descriptor-reg)))
83   (:results (y))
84   (:variant-vars offset)
85   (:note "pointer to float coercion")
86   (:generator 2
87     (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
88
89 (macrolet ((frob (name sc offset)
90              `(progn
91                 (define-vop (,name move-to-float)
92                   (:results (y :scs (,sc)))
93                   (:variant ,offset))
94                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
95   (frob move-to-single single-reg single-float-value-slot)
96   (frob move-to-double double-reg double-float-value-slot))
97
98 (define-vop (move-float-arg)
99   (:args (x :scs (single-reg double-reg) :target y)
100          (nfp :scs (any-reg)
101               :load-if (not (sc-is y single-reg double-reg))))
102   (:results (y))
103   (:note "float argument move")
104   (:generator 1
105     (sc-case y
106       ((single-reg double-reg)
107        (unless (location= x y)
108          (inst funop :copy x y)))
109       ((single-stack double-stack)
110        (let ((offset (* (tn-offset y) n-word-bytes)))
111          (str-float x offset nfp))))))
112 (define-move-vop move-float-arg :move-arg
113   (single-reg descriptor-reg) (single-reg))
114 (define-move-vop move-float-arg :move-arg
115   (double-reg descriptor-reg) (double-reg))
116 \f
117 ;;;; Complex float move functions
118 (defun complex-single-reg-real-tn (x)
119   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
120                   :offset (tn-offset x)))
121 (defun complex-single-reg-imag-tn (x)
122   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
123                   :offset (1+ (tn-offset x))))
124
125 (defun complex-double-reg-real-tn (x)
126   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
127                   :offset (tn-offset x)))
128 (defun complex-double-reg-imag-tn (x)
129   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
130                   :offset (1+ (tn-offset x))))
131
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))))
140
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))))
149
150 (define-move-fun (load-complex-double 4) (vop x y)
151   ((complex-double-stack) (complex-double-reg))
152   (let ((nfp (current-nfp-tn vop))
153         (offset (* (tn-offset x) n-word-bytes)))
154     (let ((real-tn (complex-double-reg-real-tn y)))
155       (ld-float offset nfp real-tn))
156     (let ((imag-tn (complex-double-reg-imag-tn y)))
157       (ld-float (+ offset (* 2 n-word-bytes)) nfp imag-tn))))
158
159 (define-move-fun (store-complex-double 4) (vop x y)
160   ((complex-double-reg) (complex-double-stack))
161   (let ((nfp (current-nfp-tn vop))
162         (offset (* (tn-offset y) n-word-bytes)))
163     (let ((real-tn (complex-double-reg-real-tn x)))
164       (str-float real-tn offset nfp))
165     (let ((imag-tn (complex-double-reg-imag-tn x)))
166       (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp))))
167
168 ;;; Complex float register to register moves.
169 (define-vop (complex-single-move)
170   (:args (x :scs (complex-single-reg) :target y
171             :load-if (not (location= x y))))
172   (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
173   (:note "complex single float move")
174   (:generator 0
175      (unless (location= x y)
176        ;; Note the complex-float-regs are aligned to every second
177        ;; float register so there is not need to worry about overlap.
178        (let ((x-real (complex-single-reg-real-tn x))
179              (y-real (complex-single-reg-real-tn y)))
180          (inst funop :copy x-real y-real))
181        (let ((x-imag (complex-single-reg-imag-tn x))
182              (y-imag (complex-single-reg-imag-tn y)))
183          (inst funop :copy x-imag y-imag)))))
184 (define-move-vop complex-single-move :move
185   (complex-single-reg) (complex-single-reg))
186
187 (define-vop (complex-double-move)
188   (:args (x :scs (complex-double-reg)
189             :target y :load-if (not (location= x y))))
190   (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
191   (:note "complex double float move")
192   (:generator 0
193      (unless (location= x y)
194        ;; Note the complex-float-regs are aligned to every second
195        ;; float register so there is not need to worry about overlap.
196        (let ((x-real (complex-double-reg-real-tn x))
197              (y-real (complex-double-reg-real-tn y)))
198          (inst funop :copy x-real y-real))
199        (let ((x-imag (complex-double-reg-imag-tn x))
200              (y-imag (complex-double-reg-imag-tn y)))
201          (inst funop :copy x-imag y-imag)))))
202 (define-move-vop complex-double-move :move
203   (complex-double-reg) (complex-double-reg))
204
205 ;;; Move from a complex float to a descriptor register allocating a
206 ;;; new complex float object in the process.
207 (define-vop (move-from-complex-single)
208   (:args (x :scs (complex-single-reg) :to :save))
209   (:results (y :scs (descriptor-reg)))
210   (:temporary (:scs (non-descriptor-reg)) ndescr)
211   (:note "complex single float to pointer coercion")
212   (:generator 13
213      (with-fixed-allocation (y ndescr complex-single-float-widetag
214                                complex-single-float-size)
215        (let ((real-tn (complex-single-reg-real-tn x)))
216          (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes)
217                                other-pointer-lowtag)
218                y))
219        (let ((imag-tn (complex-single-reg-imag-tn x)))
220          (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes)
221                                other-pointer-lowtag)
222                y)))))
223 (define-move-vop move-from-complex-single :move
224   (complex-single-reg) (descriptor-reg))
225
226 (define-vop (move-from-complex-double)
227   (:args (x :scs (complex-double-reg) :to :save))
228   (:results (y :scs (descriptor-reg)))
229   (:temporary (:scs (non-descriptor-reg)) ndescr)
230   (:note "complex double float to pointer coercion")
231   (:generator 13
232      (with-fixed-allocation (y ndescr complex-double-float-widetag
233                                complex-double-float-size)
234        (let ((real-tn (complex-double-reg-real-tn x)))
235          (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes)
236                                other-pointer-lowtag)
237                y))
238        (let ((imag-tn (complex-double-reg-imag-tn x)))
239          (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes)
240                                other-pointer-lowtag)
241                y)))))
242 (define-move-vop move-from-complex-double :move
243   (complex-double-reg) (descriptor-reg))
244
245 ;;; Move from a descriptor to a complex float register
246 (define-vop (move-to-complex-single)
247   (:args (x :scs (descriptor-reg)))
248   (:results (y :scs (complex-single-reg)))
249   (:note "pointer to complex float coercion")
250   (:generator 2
251     (let ((real-tn (complex-single-reg-real-tn y)))
252       (inst flds (- (* complex-single-float-real-slot n-word-bytes)
253                     other-pointer-lowtag)
254             x real-tn))
255     (let ((imag-tn (complex-single-reg-imag-tn y)))
256       (inst flds (- (* complex-single-float-imag-slot n-word-bytes)
257                     other-pointer-lowtag)
258             x imag-tn))))
259 (define-move-vop move-to-complex-single :move
260   (descriptor-reg) (complex-single-reg))
261
262 (define-vop (move-to-complex-double)
263   (:args (x :scs (descriptor-reg)))
264   (:results (y :scs (complex-double-reg)))
265   (:note "pointer to complex float coercion")
266   (:generator 2
267     (let ((real-tn (complex-double-reg-real-tn y)))
268       (inst flds (- (* complex-double-float-real-slot n-word-bytes)
269                     other-pointer-lowtag)
270             x real-tn))
271     (let ((imag-tn (complex-double-reg-imag-tn y)))
272       (inst flds (- (* complex-double-float-imag-slot n-word-bytes)
273                     other-pointer-lowtag)
274             x imag-tn))))
275 (define-move-vop move-to-complex-double :move
276   (descriptor-reg) (complex-double-reg))
277
278 ;;; Complex float move-arg vop
279 (define-vop (move-complex-single-float-arg)
280   (:args (x :scs (complex-single-reg) :target y)
281          (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
282   (:results (y))
283   (:note "float argument move")
284   (:generator 1
285     (sc-case y
286       (complex-single-reg
287        (unless (location= x y)
288          (let ((x-real (complex-single-reg-real-tn x))
289                (y-real (complex-single-reg-real-tn y)))
290            (inst funop :copy x-real y-real))
291          (let ((x-imag (complex-single-reg-imag-tn x))
292                (y-imag (complex-single-reg-imag-tn y)))
293            (inst funop :copy x-imag y-imag))))
294       (complex-single-stack
295        (let ((offset (* (tn-offset y) n-word-bytes)))
296          (let ((real-tn (complex-single-reg-real-tn x)))
297            (str-float real-tn offset nfp))
298          (let ((imag-tn (complex-single-reg-imag-tn x)))
299            (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
300 (define-move-vop move-complex-single-float-arg :move-arg
301   (complex-single-reg descriptor-reg) (complex-single-reg))
302
303 (define-vop (move-complex-double-float-arg)
304   (:args (x :scs (complex-double-reg) :target y)
305          (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
306   (:results (y))
307   (:note "float argument move")
308   (:generator 1
309     (sc-case y
310       (complex-double-reg
311        (unless (location= x y)
312          (let ((x-real (complex-double-reg-real-tn x))
313                (y-real (complex-double-reg-real-tn y)))
314            (inst funop :copy x-real y-real))
315          (let ((x-imag (complex-double-reg-imag-tn x))
316                (y-imag (complex-double-reg-imag-tn y)))
317            (inst funop :copy x-imag y-imag))))
318       (complex-double-stack
319        (let ((offset (* (tn-offset y) n-word-bytes)))
320          (let ((real-tn (complex-double-reg-real-tn x)))
321            (str-float real-tn offset nfp))
322          (let ((imag-tn (complex-double-reg-imag-tn x)))
323            (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
324 (define-move-vop move-complex-double-float-arg :move-arg
325   (complex-double-reg descriptor-reg) (complex-double-reg))
326
327 (define-move-vop move-arg :move-arg
328   (single-reg double-reg complex-single-reg complex-double-reg)
329   (descriptor-reg))
330 \f
331 ;;;; Arithmetic VOPs.
332
333 (define-vop (float-op)
334   (:args (x) (y))
335   (:results (r))
336   (:variant-vars operation)
337   (:policy :fast-safe)
338   (:note "inline float arithmetic")
339   (:vop-var vop)
340   (:save-p :compute-only)
341   (:node-var node)
342   (:generator 0
343     (inst fbinop operation x y r)
344     (when (policy node (or (= debug 3) (> safety speed)))
345       (note-next-instruction vop :internal-error)
346       (inst fsts fp-single-zero-tn 0 csp-tn))))
347
348 (macrolet ((frob (name sc zero-sc ptype)
349              `(define-vop (,name float-op)
350                 (:args (x :scs (,sc ,zero-sc))
351                        (y :scs (,sc ,zero-sc)))
352                 (:results (r :scs (,sc)))
353                 (:arg-types ,ptype ,ptype)
354                 (:result-types ,ptype))))
355   (frob single-float-op single-reg fp-single-zero single-float)
356   (frob double-float-op double-reg fp-double-zero double-float))
357
358 (macrolet ((frob (translate op sname scost dname dcost)
359              `(progn
360                 (define-vop (,sname single-float-op)
361                   (:translate ,translate)
362                   (:variant ,op)
363                   (:variant-cost ,scost))
364                 (define-vop (,dname double-float-op)
365                   (:translate ,translate)
366                   (:variant ,op)
367                   (:variant-cost ,dcost)))))
368   (frob + :add +/single-float 2 +/double-float 2)
369   (frob - :sub -/single-float 2 -/double-float 2)
370   (frob * :mpy */single-float 4 */double-float 5)
371   (frob / :div //single-float 12 //double-float 19))
372
373
374 (macrolet ((frob (name translate sc type inst)
375              `(define-vop (,name)
376                 (:args (x :scs (,sc)))
377                 (:results (y :scs (,sc)))
378                 (:translate ,translate)
379                 (:policy :fast-safe)
380                 (:arg-types ,type)
381                 (:result-types ,type)
382                 (:note "inline float arithmetic")
383                 (:vop-var vop)
384                 (:save-p :compute-only)
385                 (:node-var node)
386                 (:generator 1
387                   ,inst
388                   (when (policy node (or (= debug 3) (> safety speed)))
389                     (note-next-instruction vop :internal-error)
390                     (inst fsts fp-single-zero-tn 0 csp-tn))))))
391   (frob abs/single-float abs single-reg single-float
392     (inst funop :abs x y))
393   (frob abs/double-float abs double-reg double-float
394     (inst funop :abs x y))
395   (frob %negate/single-float %negate single-reg single-float
396     (inst fbinop :sub fp-single-zero-tn x y))
397   (frob %negate/double-float %negate double-reg double-float
398     (inst fbinop :sub fp-double-zero-tn x y)))
399
400 \f
401 ;;;; Comparison:
402
403 (define-vop (float-compare)
404   (:args (x) (y))
405   (:conditional)
406   (:info target not-p)
407   (:variant-vars condition complement)
408   (:policy :fast-safe)
409   (:note "inline float comparison")
410   (:vop-var vop)
411   (:save-p :compute-only)
412   (:generator 3
413     ;; This is the condition to nullify the branch, so it is inverted.
414     (inst fcmp (if not-p condition complement) x y)
415     (note-next-instruction vop :internal-error)
416     (inst ftest)
417     (inst b target :nullify t)))
418
419 (macrolet ((frob (name sc zero-sc ptype)
420              `(define-vop (,name float-compare)
421                 (:args (x :scs (,sc ,zero-sc))
422                        (y :scs (,sc ,zero-sc)))
423                 (:arg-types ,ptype ,ptype))))
424   (frob single-float-compare single-reg fp-single-zero single-float)
425   (frob double-float-compare double-reg fp-double-zero double-float))
426
427 (macrolet ((frob (translate condition complement sname dname)
428              `(progn
429                 (define-vop (,sname single-float-compare)
430                   (:translate ,translate)
431                   (:variant ,condition ,complement))
432                 (define-vop (,dname double-float-compare)
433                   (:translate ,translate)
434                   (:variant ,condition ,complement)))))
435   (frob < #b01001 #b10101 </single-float </double-float)
436   (frob > #b10001 #b01101 >/single-float >/double-float)
437   (frob = #b00101 #b11001 eql/single-float eql/double-float))
438
439 \f
440 ;;;; Conversion:
441
442 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
443              `(define-vop (,name)
444                 (:args (x :scs (,from-sc)))
445                 (:results (y :scs (,to-sc)))
446                 (:arg-types ,from-type)
447                 (:result-types ,to-type)
448                 (:policy :fast-safe)
449                 (:note "inline float coercion")
450                 (:translate ,translate)
451                 (:vop-var vop)
452                 (:save-p :compute-only)
453                 (:node-var node)
454                 (:generator 2
455                   (inst fcnvff x y)
456                   (when (policy node (or (= debug 3) (> safety speed)))
457                     (note-next-instruction vop :internal-error)
458                     (inst fsts fp-single-zero-tn 0 csp-tn))))))
459   (frob %single-float/double-float %single-float
460     double-reg double-float
461     single-reg single-float)
462   (frob %double-float/single-float %double-float
463     single-reg single-float
464     double-reg double-float))
465
466 (macrolet ((frob (name translate to-sc to-type)
467              `(define-vop (,name)
468                 (:args (x :scs (signed-reg)
469                           :load-if (not (sc-is x signed-stack))
470                           :target stack-temp))
471                 (:arg-types signed-num)
472                 (:results (y :scs (,to-sc)))
473                 (:result-types ,to-type)
474                 (:policy :fast-safe)
475                 (:note "inline float coercion")
476                 (:translate ,translate)
477                 (:vop-var vop)
478                 (:save-p :compute-only)
479                 (:node-var node)
480                 (:temporary (:scs (signed-stack) :from (:argument 0))
481                             stack-temp)
482                 (:temporary (:scs (single-reg) :to (:result 0) :target y)
483                             fp-temp)
484                 (:temporary (:scs (any-reg) :from (:argument 0)
485                                   :to (:result 0)) index)
486                 (:generator 5
487                   (let* ((nfp (current-nfp-tn vop))
488                          (stack-tn
489                           (sc-case x
490                             (signed-stack
491                              x)
492                             (signed-reg
493                              (storew x nfp (tn-offset stack-temp))
494                              stack-temp)))
495                          (offset (* (tn-offset stack-tn) n-word-bytes)))
496                     (cond ((< offset (ash 1 4))
497                            (inst flds offset nfp fp-temp))
498                           (t
499                            (inst ldo offset zero-tn index)
500                            (inst fldx index nfp fp-temp)))
501                     (inst fcnvxf fp-temp y)
502                     (when (policy node (or (= debug 3) (> safety speed)))
503                       (note-next-instruction vop :internal-error)
504                       (inst fsts fp-single-zero-tn 0 csp-tn)))))))
505   (frob %single-float/signed %single-float
506     single-reg single-float)
507   (frob %double-float/signed %double-float
508     double-reg double-float))
509
510
511 (macrolet ((frob (trans from-sc from-type inst note)
512              `(define-vop (,(symbolicate trans "/" from-type))
513                 (:args (x :scs (,from-sc)
514                           :target fp-temp))
515                 (:results (y :scs (signed-reg)
516                              :load-if (not (sc-is y signed-stack))))
517                 (:arg-types ,from-type)
518                 (:result-types signed-num)
519                 (:translate ,trans)
520                 (:policy :fast-safe)
521                 (:note ,note)
522                 (:vop-var vop)
523                 (:save-p :compute-only)
524                 (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
525                 (:temporary (:scs (signed-stack) :to (:result 0) :target y)
526                             stack-temp)
527                 (:temporary (:scs (any-reg) :from (:argument 0)
528                                   :to (:result 0)) index)
529                 (:generator 3
530                   (let* ((nfp (current-nfp-tn vop))
531                          (stack-tn
532                           (sc-case y
533                             (signed-stack y)
534                             (signed-reg stack-temp)))
535                          (offset (* (tn-offset stack-tn) n-word-bytes)))
536                     (inst ,inst x fp-temp)
537                     (cond ((< offset (ash 1 4))
538                            (note-next-instruction vop :internal-error)
539                            (inst fsts fp-temp offset nfp))
540                           (t
541                            (inst ldo offset zero-tn index)
542                            (note-next-instruction vop :internal-error)
543                            (inst fstx fp-temp index nfp)))
544                     (unless (eq y stack-tn)
545                       (loadw y nfp (tn-offset stack-tn))))))))
546   (frob %unary-round single-reg single-float fcnvfx "inline float round")
547   (frob %unary-round double-reg double-float fcnvfx "inline float round")
548   (frob %unary-truncate single-reg single-float fcnvfxt
549     "inline float truncate")
550   (frob %unary-truncate double-reg double-float fcnvfxt
551     "inline float truncate"))
552
553
554 (define-vop (make-single-float)
555   (:args (bits :scs (signed-reg)
556                :load-if (or (not (sc-is bits signed-stack))
557                             (sc-is res single-stack))
558                :target res))
559   (:results (res :scs (single-reg)
560                  :load-if (not (sc-is bits single-stack))))
561   (:arg-types signed-num)
562   (:result-types single-float)
563   (:translate make-single-float)
564   (:policy :fast-safe)
565   (:vop-var vop)
566   (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
567   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
568   (:generator 2
569     (let ((nfp (current-nfp-tn vop)))
570       (sc-case bits
571         (signed-reg
572          (sc-case res
573            (single-reg
574             (let ((offset (* (tn-offset temp) n-word-bytes)))
575               (inst stw bits offset nfp)
576               (cond ((< offset (ash 1 4))
577                      (inst flds offset nfp res))
578                     (t
579                      (inst ldo offset zero-tn index)
580                      (inst fldx index nfp res)))))
581            (single-stack
582             (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
583         (signed-stack
584          (sc-case res
585            (single-reg
586             (let ((offset (* (tn-offset bits) n-word-bytes)))
587               (cond ((< offset (ash 1 4))
588                      (inst flds offset nfp res))
589                     (t
590                      (inst ldo offset zero-tn index)
591                      (inst fldx index nfp res)))))))))))
592
593 (define-vop (make-double-float)
594   (:args (hi-bits :scs (signed-reg))
595          (lo-bits :scs (unsigned-reg)))
596   (:results (res :scs (double-reg)
597                  :load-if (not (sc-is res double-stack))))
598   (:arg-types signed-num unsigned-num)
599   (:result-types double-float)
600   (:translate make-double-float)
601   (:policy :fast-safe)
602   (:temporary (:scs (double-stack) :to (:result 0)) temp)
603   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
604   (:vop-var vop)
605   (:generator 2
606     (let* ((nfp (current-nfp-tn vop))
607            (stack-tn (sc-case res
608                        (double-stack res)
609                        (double-reg temp)))
610            (offset (* (tn-offset stack-tn) n-word-bytes)))
611       (inst stw hi-bits offset nfp)
612       (inst stw lo-bits (+ offset n-word-bytes) nfp)
613       (cond ((eq stack-tn res))
614             ((< offset (ash 1 4))
615              (inst flds offset nfp res))
616             (t
617              (inst ldo offset zero-tn index)
618              (inst fldx index nfp res))))))
619
620
621 (define-vop (single-float-bits)
622   (:args (float :scs (single-reg)
623                 :load-if (not (sc-is float single-stack))))
624   (:results (bits :scs (signed-reg)
625                   :load-if (or (not (sc-is bits signed-stack))
626                                (sc-is float single-stack))))
627   (:arg-types single-float)
628   (:result-types signed-num)
629   (:translate single-float-bits)
630   (:policy :fast-safe)
631   (:vop-var vop)
632   (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
633   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
634   (:generator 2
635     (let ((nfp (current-nfp-tn vop)))
636       (sc-case float
637         (single-reg
638          (sc-case bits
639            (signed-reg
640             (let ((offset (* (tn-offset temp) n-word-bytes)))
641               (cond ((< offset (ash 1 4))
642                      (inst fsts float offset nfp))
643                     (t
644                      (inst ldo offset zero-tn index)
645                      (inst fstx float index nfp)))
646               (inst ldw offset nfp bits)))
647            (signed-stack
648             (let ((offset (* (tn-offset bits) n-word-bytes)))
649               (cond ((< offset (ash 1 4))
650                      (inst fsts float offset nfp))
651                     (t
652                      (inst ldo offset zero-tn index)
653                      (inst fstx float index nfp)))))))
654         (single-stack
655          (sc-case bits
656            (signed-reg
657             (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))
658
659 (define-vop (double-float-high-bits)
660   (:args (float :scs (double-reg)
661                 :load-if (not (sc-is float double-stack))))
662   (:results (hi-bits :scs (signed-reg)
663                      :load-if (or (not (sc-is hi-bits signed-stack))
664                                   (sc-is float double-stack))))
665   (:arg-types double-float)
666   (:result-types signed-num)
667   (:translate double-float-high-bits)
668   (:policy :fast-safe)
669   (:vop-var vop)
670   (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
671   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
672   (:generator 2
673     (let ((nfp (current-nfp-tn vop)))
674       (sc-case float
675         (double-reg
676          (sc-case hi-bits
677            (signed-reg
678             (let ((offset (* (tn-offset temp) n-word-bytes)))
679               (cond ((< offset (ash 1 4))
680                      (inst fsts float offset nfp :side 0))
681                     (t
682                      (inst ldo offset zero-tn index)
683                      (inst fstx float index nfp :side 0)))
684               (inst ldw offset nfp hi-bits)))
685            (signed-stack
686             (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
687               (cond ((< offset (ash 1 4))
688                      (inst fsts float offset nfp :side 0))
689                     (t
690                      (inst ldo offset zero-tn index)
691                      (inst fstx float index nfp :side 0)))))))
692         (double-stack
693          (sc-case hi-bits
694            (signed-reg
695             (let ((offset (* (tn-offset float) n-word-bytes)))
696               (inst ldw offset nfp hi-bits)))))))))
697
698 (define-vop (double-float-low-bits)
699   (:args (float :scs (double-reg)
700                 :load-if (not (sc-is float double-stack))))
701   (:results (lo-bits :scs (unsigned-reg)
702                      :load-if (or (not (sc-is lo-bits unsigned-stack))
703                                   (sc-is float double-stack))))
704   (:arg-types double-float)
705   (:result-types unsigned-num)
706   (:translate double-float-low-bits)
707   (:policy :fast-safe)
708   (:vop-var vop)
709   (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
710   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
711   (:generator 2
712     (let ((nfp (current-nfp-tn vop)))
713       (sc-case float
714         (double-reg
715          (sc-case lo-bits
716            (unsigned-reg
717             (let ((offset (* (tn-offset temp) n-word-bytes)))
718               (cond ((< offset (ash 1 4))
719                      (inst fsts float offset nfp :side 1))
720                     (t
721                      (inst ldo offset zero-tn index)
722                      (inst fstx float index nfp :side 1)))
723               (inst ldw offset nfp lo-bits)))
724            (unsigned-stack
725             (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
726               (cond ((< offset (ash 1 4))
727                      (inst fsts float offset nfp :side 1))
728                     (t
729                      (inst ldo offset zero-tn index)
730                      (inst fstx float index nfp :side 1)))))))
731         (double-stack
732          (sc-case lo-bits
733            (unsigned-reg
734             (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
735               (inst ldw offset nfp lo-bits)))))))))
736
737
738 \f
739 ;;;; Float mode hackery:
740
741 (sb!xc:deftype float-modes () '(unsigned-byte 32))
742 (defknown floating-point-modes () float-modes (flushable))
743 (defknown ((setf floating-point-modes)) (float-modes)
744   float-modes)
745
746 (define-vop (floating-point-modes)
747   (:results (res :scs (unsigned-reg)
748                  :load-if (not (sc-is res unsigned-stack))))
749   (:result-types unsigned-num)
750   (:translate floating-point-modes)
751   (:policy :fast-safe)
752   (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
753   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
754   (:vop-var vop)
755   (:generator 3
756     (let* ((nfp (current-nfp-tn vop))
757            (stack-tn (sc-case res
758                        (unsigned-stack res)
759                        (unsigned-reg temp)))
760            (offset (* (tn-offset stack-tn) n-word-bytes)))
761       (cond ((< offset (ash 1 4))
762              (inst fsts fp-single-zero-tn offset nfp))
763             (t
764              (inst ldo offset zero-tn index)
765              (inst fstx fp-single-zero-tn index nfp)))
766       (unless (eq stack-tn res)
767         (inst ldw offset nfp res)))))
768
769 (define-vop (set-floating-point-modes)
770   (:args (new :scs (unsigned-reg)
771               :load-if (not (sc-is new unsigned-stack))))
772   (:results (res :scs (unsigned-reg)))
773   (:arg-types unsigned-num)
774   (:result-types unsigned-num)
775   (:translate (setf floating-point-modes))
776   (:policy :fast-safe)
777   (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
778   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
779   (:vop-var vop)
780   (:generator 3
781     (let* ((nfp (current-nfp-tn vop))
782            (stack-tn (sc-case new
783                        (unsigned-stack new)
784                        (unsigned-reg temp)))
785            (offset (* (tn-offset stack-tn) n-word-bytes)))
786       (unless (eq new stack-tn)
787         (inst stw new offset nfp))
788       (cond ((< offset (ash 1 4))
789              (inst flds offset nfp fp-single-zero-tn))
790             (t
791              (inst ldo offset zero-tn index)
792              (inst fldx index nfp fp-single-zero-tn)))
793       (inst ldw offset nfp res))))
794
795 \f
796 ;;;; Complex float VOPs
797
798 (define-vop (make-complex-single-float)
799   (:translate complex)
800   (:args (real :scs (single-reg) :target r)
801          (imag :scs (single-reg) :to :save))
802   (:arg-types single-float single-float)
803   (:results (r :scs (complex-single-reg) :from (:argument 0)
804                :load-if (not (sc-is r complex-single-stack))))
805   (:result-types complex-single-float)
806   (:note "inline complex single-float creation")
807   (:policy :fast-safe)
808   (:vop-var vop)
809   (:generator 5
810     (sc-case r
811       (complex-single-reg
812        (let ((r-real (complex-single-reg-real-tn r)))
813          (unless (location= real r-real)
814            (inst funop :copy real r-real)))
815        (let ((r-imag (complex-single-reg-imag-tn r)))
816          (unless (location= imag r-imag)
817            (inst funop :copy imag r-imag))))
818       (complex-single-stack
819        (let ((nfp (current-nfp-tn vop))
820              (offset (* (tn-offset r) n-word-bytes)))
821          (str-float real offset nfp)
822          (str-float imag (+ offset n-word-bytes) nfp))))))
823
824 (define-vop (make-complex-double-float)
825   (:translate complex)
826   (:args (real :scs (double-reg) :target r)
827          (imag :scs (double-reg) :to :save))
828   (:arg-types double-float double-float)
829   (:results (r :scs (complex-double-reg) :from (:argument 0)
830                :load-if (not (sc-is r complex-double-stack))))
831   (:result-types complex-double-float)
832   (:note "inline complex double-float creation")
833   (:policy :fast-safe)
834   (:vop-var vop)
835   (:generator 5
836     (sc-case r
837       (complex-double-reg
838        (let ((r-real (complex-double-reg-real-tn r)))
839          (unless (location= real r-real)
840            (inst funop :copy real r-real)))
841        (let ((r-imag (complex-double-reg-imag-tn r)))
842          (unless (location= imag r-imag)
843            (inst funop :copy imag r-imag))))
844       (complex-double-stack
845        (let ((nfp (current-nfp-tn vop))
846              (offset (* (tn-offset r) n-word-bytes)))
847          (str-float real offset nfp)
848          (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
849
850
851 (define-vop (complex-single-float-value)
852   (:args (x :scs (complex-single-reg) :target r
853             :load-if (not (sc-is x complex-single-stack))))
854   (:arg-types complex-single-float)
855   (:results (r :scs (single-reg)))
856   (:result-types single-float)
857   (:variant-vars slot)
858   (:policy :fast-safe)
859   (:vop-var vop)
860   (:generator 3
861     (sc-case x
862       (complex-single-reg
863        (let ((value-tn (ecase slot
864                          (:real (complex-single-reg-real-tn x))
865                          (:imag (complex-single-reg-imag-tn x)))))
866          (unless (location= value-tn r)
867            (inst funop :copy value-tn r))))
868       (complex-single-stack
869        (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
870                     n-word-bytes)
871                  (current-nfp-tn vop) r)))))
872
873 (define-vop (realpart/complex-single-float complex-single-float-value)
874   (:translate realpart)
875   (:note "complex single float realpart")
876   (:variant :real))
877
878 (define-vop (imagpart/complex-single-float complex-single-float-value)
879   (:translate imagpart)
880   (:note "complex single float imagpart")
881   (:variant :imag))
882
883 (define-vop (complex-double-float-value)
884   (:args (x :scs (complex-double-reg) :target r
885             :load-if (not (sc-is x complex-double-stack))))
886   (:arg-types complex-double-float)
887   (:results (r :scs (double-reg)))
888   (:result-types double-float)
889   (:variant-vars slot)
890   (:policy :fast-safe)
891   (:vop-var vop)
892   (:generator 3
893     (sc-case x
894       (complex-double-reg
895        (let ((value-tn (ecase slot
896                          (:real (complex-double-reg-real-tn x))
897                          (:imag (complex-double-reg-imag-tn x)))))
898          (unless (location= value-tn r)
899            (inst funop :copy value-tn r))))
900       (complex-double-stack
901        (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
902                     n-word-bytes)
903                  (current-nfp-tn vop) r)))))
904
905 (define-vop (realpart/complex-double-float complex-double-float-value)
906   (:translate realpart)
907   (:note "complex double float realpart")
908   (:variant :real))
909
910 (define-vop (imagpart/complex-double-float complex-double-float-value)
911   (:translate imagpart)
912   (:note "complex double float imagpart")
913   (:variant :imag))