src/compiler/mips/float.lisp

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