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))