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         ((and (< offset (ash 1 13))
  24               (> offset 0))
  25          (inst ldo offset zero-tn lip-tn)
  26          (inst fldx lip-tn base r))
  27         (t
  28           (error "ld-float: bad offset: ~s~%" offset))))
  29
  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)))
  35
  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))
  41               (> offset 0))
  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))
  46         (t
  47           (error "str-float: bad offset: ~s~%" offset))))
  48
  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))))
  54 \f
  55 ;;;; Move VOPs
  56 (define-vop (move-float)
  57   (:args (x :scs (single-reg double-reg)
  58             :target y
  59             :load-if (not (location= x y))))
  60   (:results (y :scs (single-reg double-reg)
  61                :load-if (not (location= x y))))
  62   (:note "float move")
  63   (:generator 0
  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))
  68
  69 (define-vop (move-from-float)
  70   (:args (x :to :save))
  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")
  75   (:generator 13
  76     (with-fixed-allocation (y nil ndescr type size nil)
  77       (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))))
  78
  79 (macrolet ((frob (name sc &rest args)
  80              `(progn
  81                 (define-vop (,name move-from-float)
  82                   (:args (x :scs (,sc) :to :save))
  83                   (:variant ,@args))
  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))
  89
  90 (define-vop (move-to-float)
  91   (:args (x :scs (descriptor-reg)))
  92   (:results (y))
  93   (:variant-vars offset)
  94   (:note "pointer to float coercion")
  95   (:generator 2
  96     (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
  97
  98 (macrolet ((frob (name sc offset)
  99              `(progn
 100                 (define-vop (,name move-to-float)
 101                   (:results (y :scs (,sc)))
 102                   (:variant ,offset))
 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))
 106
 107 (define-vop (move-float-arg)
 108   (:args (x :scs (single-reg double-reg) :target y)
 109          (nfp :scs (any-reg)
 110               :load-if (not (sc-is y single-reg double-reg))))
 111   (:results (y))
 112   (:note "float argument move")
 113   (:generator 1
 114     (sc-case y
 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))
 125 \f
 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))))
 133
 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))))
 140
 141 (macrolet
 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)))
 147           ,@(if (eq dir 'load)
 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)))
 155                   (str-float imag-tn
 156                              (+ offset (* ,(/ size 2) n-word-bytes))
 157                              nfp))))))))
 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))
 162
 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")
 169   (:generator 0
 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))
 181
 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")
 187   (:generator 0
 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))
 199
 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")
 207   (:generator 13
 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))
 218
 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")
 224   (:generator 13
 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))
 235
 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")
 241   (:generator 2
 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)
 245                  x real-tn))
 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)
 249                  x imag-tn))))
 250 (define-move-vop move-to-complex-single :move
 251   (descriptor-reg) (complex-single-reg))
 252
 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")
 257   (:generator 2
 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)
 261             x real-tn))
 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)
 265             x imag-tn))))
 266 (define-move-vop move-to-complex-double :move
 267   (descriptor-reg) (complex-double-reg))
 268
 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))))
 273   (:results (y))
 274   (:note "float argument move")
 275   (:generator 1
 276     (sc-case y
 277       (complex-single-reg
 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))
 293
 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))))
 297   (:results (y))
 298   (:note "float argument move")
 299   (:generator 1
 300     (sc-case y
 301       (complex-double-reg
 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))
 317
 318 (define-move-vop move-arg :move-arg
 319   (single-reg double-reg complex-single-reg complex-double-reg)
 320   (descriptor-reg))
 321 \f
 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))
 327   (:generator 1
 328     (sc-case x
 329       (single-reg
 330         (inst funop :copy x y))
 331       (descriptor-reg
 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))
 336
 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))
 341   (:generator 1
 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))
 346
 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)
 355   (:vop-var vop)
 356   (:save-p :compute-only)
 357   (:generator 2
 358     (sc-case x
 359       (double-reg
 360         (let* ((nfp (current-nfp-tn vop))
 361                (stack-tn (sc-case y
 362                            (double-stack y)
 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)))
 381       (descriptor-reg
 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))
 391
 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))
 396   (:generator 2
 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))
 401
 402 ;;;; Arithmetic VOPs.
 403
 404 (define-vop (float-op)
 405   (:args (x) (y))
 406   (:results (r))
 407   (:variant-vars operation)
 408   (:policy :fast-safe)
 409   (:note "inline float arithmetic")
 410   (:vop-var vop)
 411   (:save-p :compute-only)
 412   (:generator 0
 413     (note-this-location vop :internal-error)
 414     (inst fbinop operation x y r)))
 415
 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))
 425
 426 (macrolet ((frob (translate op sname scost dname dcost)
 427              `(progn
 428                 (define-vop (,sname single-float-op)
 429                   (:translate ,translate)
 430                   (:variant ,op)
 431                   (:variant-cost ,scost))
 432                 (define-vop (,dname double-float-op)
 433                   (:translate ,translate)
 434                   (:variant ,op)
 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))
 440
 441 (macrolet ((frob (name translate sc type inst)
 442              `(define-vop (,name)
 443                 (:args (x :scs (,sc)))
 444                 (:results (y :scs (,sc)))
 445                 (:translate ,translate)
 446                 (:policy :fast-safe)
 447                 (:arg-types ,type)
 448                 (:result-types ,type)
 449                 (:note "inline float arithmetic")
 450                 (:vop-var vop)
 451                 (:save-p :compute-only)
 452                 (:generator 1
 453                   (note-this-location vop :internal-error)
 454                   ,inst))))
 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)))
 463
 464 \f
 465 ;;;; Comparison:
 466
 467 (define-vop (float-compare)
 468   (:args (x) (y))
 469   (:conditional)
 470   (:info target not-p)
 471   (:variant-vars condition complement)
 472   (:policy :fast-safe)
 473   (:note "inline float comparison")
 474   (:vop-var vop)
 475   (:save-p :compute-only)
 476   (:generator 3
 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)
 480     (inst ftest)
 481     (inst b target :nullify t)))
 482
 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))
 490
 491 (macrolet ((frob (translate condition complement sname dname)
 492              `(progn
 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))
 503
 504 \f
 505 ;;;; Conversion:
 506
 507 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
 508              `(define-vop (,name)
 509                 (:args (x :scs (,from-sc)))
 510                 (:results (y :scs (,to-sc)))
 511                 (:arg-types ,from-type)
 512                 (:result-types ,to-type)
 513                 (:policy :fast-safe)
 514                 (:note "inline float coercion")
 515                 (:translate ,translate)
 516                 (:vop-var vop)
 517                 (:save-p :compute-only)
 518                 (:generator 2
 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))
 527
 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)
 533              `(define-vop (,name)
 534                 (:args (x :scs (signed-reg)
 535                           :load-if (not (sc-is x signed-stack))
 536                           :target stack-temp))
 537                 (:arg-types signed-num)
 538                 (:results (y :scs (,to-sc)))
 539                 (:result-types ,to-type)
 540                 (:policy :fast-safe)
 541                 (:note "inline float coercion")
 542                 (:translate ,translate)
 543                 (:vop-var vop)
 544                 (:save-p :compute-only)
 545                 (:temporary (:scs (signed-stack) :from (:argument 0))
 546                             stack-temp)
 547                 (:temporary (:scs (single-reg) :to (:result 0) :target y)
 548                             fp-temp)
 549                 (:temporary (:scs (any-reg) :from (:argument 0)
 550                                   :to (:result 0)) index)
 551                 (:generator 5
 552                   (let* ((nfp (current-nfp-tn vop))
 553                          (stack-tn
 554                           (sc-case x
 555                             (signed-stack
 556                              x)
 557                             (signed-reg
 558                              (storew x nfp (tn-offset stack-temp))
 559                              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))
 564                                 (> offset 0))
 565                            (inst ldo offset zero-tn index)
 566                            (inst fldx index nfp fp-temp))
 567                           (t
 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))
 575
 576 (macrolet ((frob (trans from-sc from-type inst note)
 577              `(define-vop (,(symbolicate trans "/" from-type))
 578                 (:args (x :scs (,from-sc)
 579                           :target fp-temp))
 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)
 584                 (:translate ,trans)
 585                 (:policy :fast-safe)
 586                 (:note ,note)
 587                 (:vop-var vop)
 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)
 591                             stack-temp)
 592                 (:temporary (:scs (any-reg) :from (:argument 0)
 593                                   :to (:result 0)) index)
 594                 (:generator 3
 595                   (let* ((nfp (current-nfp-tn vop))
 596                          (stack-tn
 597                           (sc-case y
 598                             (signed-stack y)
 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))
 606                                 (> offset 0))
 607                            (inst ldo offset zero-tn index)
 608                            (note-next-instruction vop :internal-error)
 609                            (inst fstx fp-temp index nfp))
 610                           (t
 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-float single-reg single-float fcnvfxt
 617     "inline float truncate")
 618   (frob %unary-truncate/double-float double-reg double-float fcnvfxt
 619     "inline float truncate"))
 620
 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))
 625                :target res))
 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)
 631   (:policy :fast-safe)
 632   (:vop-var vop)
 633   (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
 634   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 635   (:generator 2
 636     (let ((nfp (current-nfp-tn vop)))
 637       (sc-case bits
 638         (signed-reg
 639          (sc-case res
 640            (single-reg
 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))
 646                           (> offset 0))
 647                      (inst ldo offset zero-tn index)
 648                      (inst fldx index nfp res))
 649                     (t
 650                      (error "make-single-float error, ldo offset too large")))))
 651            (single-stack
 652             (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
 653         (signed-stack
 654          (sc-case res
 655            (single-reg
 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))
 660                           (> offset 0))
 661                      (inst ldo offset zero-tn index)
 662                      (inst fldx index nfp res))
 663                     (t
 664                      (error "make-single-float error, ldo offset too large")))))))))))
 665
 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)
 674   (:policy :fast-safe)
 675   (:temporary (:scs (double-stack) :to (:result 0)) temp)
 676   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 677   (:vop-var vop)
 678   (:generator 2
 679     (let* ((nfp (current-nfp-tn vop))
 680            (stack-tn (sc-case res
 681                        (double-stack res)
 682                        (double-reg temp)))
 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))
 690                   (> offset 0))
 691              (inst ldo offset zero-tn index)
 692              (inst fldx index nfp res))
 693             (t
 694              (error "make-single-float error, ldo offset too large"))))))
 695
 696 (macrolet
 697   ((float-bits (name reg rreg stack rstack atype anum side offset)
 698    `(define-vop (,name)
 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))))
 704     (:arg-types ,atype)
 705     (:result-types ,anum)
 706     (:translate ,name)
 707     (:policy :fast-safe)
 708     (:vop-var vop)
 709     (:temporary (:scs (signed-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           (,reg
 715            (sc-case bits
 716              (,rreg
 717               (let ((offset (* (tn-offset temp) n-word-bytes)))
 718                 (cond ((< offset (ash 1 4))
 719                        ,@(if side
 720                            `((inst fsts float offset nfp :side ,side))
 721                            `((inst fsts float offset nfp))))
 722                       ((and (< offset (ash 1 13))
 723                             (> offset 0))
 724                        (inst ldo offset zero-tn index)
 725                        ,@(if side
 726                          `((inst fstx float index nfp :side ,side))
 727                          `((inst fstx float index nfp))))
 728                       (t
 729                        (error ,(format nil "~s,~s: inst-LDO offset too large"
 730                                        name rreg))))
 731                 (inst ldw offset nfp bits)))
 732              (,rstack
 733               (let ((offset (* (tn-offset bits) n-word-bytes)))
 734                 (cond ((< offset (ash 1 4))
 735                        ,@(if side
 736                          `((inst fsts float offset nfp :side ,side))
 737                          `((inst fsts float offset nfp))))
 738                       ((and (< offset (ash 1 13))
 739                             (> offset 0))
 740                        (inst ldo offset zero-tn index)
 741                        ,@(if side
 742                            `((inst fstx float index nfp :side ,side))
 743                            `((inst fstx float index nfp))))
 744                       (t
 745                        (error ,(format nil "~s,~s: inst-LDO offset too large"
 746                                        name rstack))))))))
 747           (,stack
 748            (sc-case bits
 749              (,rreg
 750               (inst ldw (* (+ (tn-offset float) ,offset) n-word-bytes)
 751                     nfp bits))))))))))
 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))
 758
 759 ;;;; Float mode hackery:
 760
 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)
 764             float-modes)
 765
 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)
 771             (:policy :fast-safe)
 772             (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
 773             (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 774             (:vop-var vop)
 775   (:generator 3
 776               (let* ((nfp (current-nfp-tn vop))
 777                      (stack-tn (sc-case res
 778                                         (unsigned-stack 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))
 784                             (> offset 0))
 785                        (inst ldo offset zero-tn index)
 786                        (inst fstx fp-single-zero-tn index nfp))
 787                       (t
 788                        (error "floating-point-modes error, ldo offset too large")))
 789                 (unless (eq stack-tn res)
 790                   (inst ldw offset nfp res)))))
 791
 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))
 799             (:policy :fast-safe)
 800             (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
 801             (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 802             (:vop-var vop)
 803   (:generator 3
 804               (let* ((nfp (current-nfp-tn vop))
 805                      (stack-tn (sc-case new
 806                                         (unsigned-stack 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))
 814                             (> offset 0))
 815                         (inst ldo offset zero-tn index)
 816                         (inst fldx index nfp fp-single-zero-tn))
 817                       (t
 818                        (error "set-floating-point-modes error, ldo offset too large")))
 819                 (inst ldw offset nfp res))))
 820 \f
 821 ;;;; Complex float VOPs
 822
 823 (define-vop (make-complex-single-float)
 824   (:translate complex)
 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")
 832   (:policy :fast-safe)
 833   (:vop-var vop)
 834   (:generator 5
 835     (sc-case r
 836       (complex-single-reg
 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))))))
 848
 849 (define-vop (make-complex-double-float)
 850   (:translate complex)
 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")
 858   (:policy :fast-safe)
 859   (:vop-var vop)
 860   (:generator 5
 861     (sc-case r
 862       (complex-double-reg
 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))))))
 874
 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)
 881   (:variant-vars slot)
 882   (:policy :fast-safe)
 883   (:vop-var vop)
 884   (:generator 3
 885     (sc-case x
 886       (complex-single-reg
 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))
 894                     n-word-bytes)
 895                  (current-nfp-tn vop) r)))))
 896
 897 (define-vop (realpart/complex-single-float complex-single-float-value)
 898   (:translate realpart)
 899   (:note "complex single float realpart")
 900   (:variant :real))
 901
 902 (define-vop (imagpart/complex-single-float complex-single-float-value)
 903   (:translate imagpart)
 904   (:note "complex single float imagpart")
 905   (:variant :imag))
 906
 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)
 913   (:variant-vars slot)
 914   (:policy :fast-safe)
 915   (:vop-var vop)
 916   (:generator 3
 917     (sc-case x
 918       (complex-double-reg
 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))
 926                     n-word-bytes)
 927                  (current-nfp-tn vop) r)))))
 928
 929 (define-vop (realpart/complex-double-float complex-double-float-value)
 930   (:translate realpart)
 931   (:note "complex double float realpart")
 932   (:variant :real))
 933
 934 (define-vop (imagpart/complex-double-float complex-double-float-value)
 935   (:translate imagpart)
 936   (:note "complex double float imagpart")
 937   (:variant :imag))