src/compiler/ppc/float.lisp

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