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) 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) 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) 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) 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 n-word-bytes) other-pointer-lowtag))
  69           (inst stfs x y (- (* data n-word-bytes) 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 single-float-size single-float-widetag single-float-value-slot)
  80   (frob move-from-double double-reg
  81     t double-float-size double-float-widetag 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 n-word-bytes) other-pointer-lowtag))))
  92                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
  93   (frob move-to-single single-reg nil single-float-value-slot)
  94   (frob move-to-double double-reg t 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) 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) 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 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) 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 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) 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 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) 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 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 complex-single-float-widetag
 229                                complex-single-float-size)
 230        (let ((real-tn (complex-single-reg-real-tn x)))
 231          (inst stfs real-tn y (- (* complex-single-float-real-slot
 232                                     n-word-bytes)
 233                                  other-pointer-lowtag)))
 234        (let ((imag-tn (complex-single-reg-imag-tn x)))
 235          (inst stfs imag-tn y (- (* complex-single-float-imag-slot
 236                                     n-word-bytes)
 237                                  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 complex-double-float-widetag
 250                                complex-double-float-size)
 251        (let ((real-tn (complex-double-reg-real-tn x)))
 252          (inst stfd real-tn y (- (* complex-double-float-real-slot
 253                                     n-word-bytes)
 254                                  other-pointer-lowtag)))
 255        (let ((imag-tn (complex-double-reg-imag-tn x)))
 256          (inst stfd imag-tn y (- (* complex-double-float-imag-slot
 257                                     n-word-bytes)
 258                                  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) n-word-bytes))
 465                          (nfp-tn (current-nfp-tn vop))
 466                          (temp-offset-high (* stack-offset n-word-bytes))
 467                          (temp-offset-low (* (1+ stack-offset) 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 to-sc to-type)
 482             `(define-vop (,name)
 483                (:args (x :scs (unsigned-reg)))
 484                (:temporary (:scs (double-stack)) temp)
 485                (:temporary (:scs (double-reg)) fmagic)
 486                (:temporary (:scs (signed-reg)) rtemp)
 487                (:results (y :scs (,to-sc)))
 488                (:arg-types unsigned-num)
 489                (:result-types ,to-type)
 490                (:policy :fast-safe)
 491                (:note "inline float coercion")
 492                (:translate ,translate)
 493                (:vop-var vop)
 494                (:save-p :compute-only)
 495                (:generator 5
 496                  (let* ((stack-offset (* (tn-offset temp) n-word-bytes))
 497                          (nfp-tn (current-nfp-tn vop))
 498                          (temp-offset-high (* stack-offset n-word-bytes))
 499                          (temp-offset-low (* (1+ stack-offset) n-word-bytes)))
 500                     (inst lis rtemp #x4330)   ; High word of magic constant
 501                     (inst stw rtemp nfp-tn temp-offset-high)
 502                     (inst stw zero-tn nfp-tn temp-offset-low)
 503                     (inst lfd fmagic nfp-tn temp-offset-high)
 504                     (inst stw x nfp-tn temp-offset-low)
 505                     (inst lfd y nfp-tn temp-offset-high)
 506                    (note-this-location vop :internal-error)
 507                    (inst ,inst y y fmagic))))))
 508   (frob %single-float/unsigned %single-float fsubs single-reg single-float)
 509   (frob %double-float/unsigned %double-float fsub double-reg double-float))
 510
 511 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
 512              `(define-vop (,name)
 513                 (:args (x :scs (,from-sc)))
 514                 (:results (y :scs (,to-sc)))
 515                 (:arg-types ,from-type)
 516                 (:result-types ,to-type)
 517                 (:policy :fast-safe)
 518                 (:note "inline float coercion")
 519                 (:translate ,translate)
 520                 (:vop-var vop)
 521                 (:save-p :compute-only)
 522                 (:generator 2
 523                   (note-this-location vop :internal-error)
 524                   (inst ,inst y x)))))
 525   (frob %single-float/double-float %single-float frsp
 526     double-reg double-float single-reg single-float)
 527   (frob %double-float/single-float %double-float fmr
 528     single-reg single-float double-reg double-float))
 529
 530 (macrolet ((frob (trans from-sc from-type inst)
 531              `(define-vop (,(symbolicate trans "/" from-type))
 532                 (:args (x :scs (,from-sc) :target temp))
 533                 (:temporary (:from (:argument 0) :sc single-reg) temp)
 534                 (:temporary (:scs (double-stack)) stack-temp)
 535                 (:results (y :scs (signed-reg)))
 536                 (:arg-types ,from-type)
 537                 (:result-types signed-num)
 538                 (:translate ,trans)
 539                 (:policy :fast-safe)
 540                 (:note "inline float truncate")
 541                 (:vop-var vop)
 542                 (:save-p :compute-only)
 543                 (:generator 5
 544                   (note-this-location vop :internal-error)
 545                   (inst ,inst temp x)
 546                   (inst stfd temp (current-nfp-tn vop)
 547                         (* (tn-offset stack-temp) n-word-bytes))
 548                   (inst lwz y (current-nfp-tn vop)
 549                         (+ 4 (* (tn-offset stack-temp) n-word-bytes)))))))
 550   (frob %unary-truncate/single-float single-reg single-float fctiwz)
 551   (frob %unary-truncate/double-float double-reg double-float fctiwz)
 552   (frob %unary-round single-reg single-float fctiw)
 553   (frob %unary-round double-reg double-float fctiw))
 554
 555 (define-vop (make-single-float)
 556   (:args (bits :scs (signed-reg) :target res
 557                :load-if (not (sc-is bits signed-stack))))
 558   (:results (res :scs (single-reg)
 559                  :load-if (not (sc-is res single-stack))))
 560   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
 561   (:temporary (:scs (signed-stack)) stack-temp)
 562   (:arg-types signed-num)
 563   (:result-types single-float)
 564   (:translate make-single-float)
 565   (:policy :fast-safe)
 566   (:vop-var vop)
 567   (:generator 4
 568     (sc-case bits
 569       (signed-reg
 570        (sc-case res
 571          (single-reg
 572           (inst stw bits (current-nfp-tn vop)
 573                 (* (tn-offset stack-temp) n-word-bytes))
 574           (inst lfs res (current-nfp-tn vop)
 575                 (* (tn-offset stack-temp) n-word-bytes)))
 576          (single-stack
 577           (inst stw bits (current-nfp-tn vop)
 578                 (* (tn-offset res) n-word-bytes)))))
 579       (signed-stack
 580        (sc-case res
 581          (single-reg
 582           (inst lfs res (current-nfp-tn vop)
 583                 (* (tn-offset bits) n-word-bytes)))
 584          (single-stack
 585           (unless (location= bits res)
 586             (inst lwz temp (current-nfp-tn vop)
 587                   (* (tn-offset bits) n-word-bytes))
 588             (inst stw temp (current-nfp-tn vop)
 589                   (* (tn-offset res) n-word-bytes)))))))))
 590
 591 (define-vop (make-double-float)
 592   (:args (hi-bits :scs (signed-reg))
 593          (lo-bits :scs (unsigned-reg)))
 594   (:results (res :scs (double-reg)
 595                  :load-if (not (sc-is res double-stack))))
 596   (:temporary (:scs (double-stack)) temp)
 597   (:arg-types signed-num unsigned-num)
 598   (:result-types double-float)
 599   (:translate make-double-float)
 600   (:policy :fast-safe)
 601   (:vop-var vop)
 602   (:generator 2
 603     (let ((stack-tn (sc-case res
 604                       (double-stack res)
 605                       (double-reg temp))))
 606       (inst stw hi-bits (current-nfp-tn vop)
 607             (* (tn-offset stack-tn) n-word-bytes))
 608       (inst stw lo-bits (current-nfp-tn vop)
 609             (* (1+ (tn-offset stack-tn)) n-word-bytes)))
 610     (when (sc-is res double-reg)
 611       (inst lfd res (current-nfp-tn vop)
 612             (* (tn-offset temp) n-word-bytes)))))
 613
 614 (define-vop (single-float-bits)
 615   (:args (float :scs (single-reg descriptor-reg)
 616                 :load-if (not (sc-is float single-stack))))
 617   (:results (bits :scs (signed-reg)
 618                   :load-if (or (sc-is float descriptor-reg single-stack)
 619                                (not (sc-is bits signed-stack)))))
 620   (:temporary (:scs (signed-stack)) stack-temp)
 621   (:arg-types single-float)
 622   (:result-types signed-num)
 623   (:translate single-float-bits)
 624   (:policy :fast-safe)
 625   (:vop-var vop)
 626   (:generator 4
 627     (sc-case bits
 628       (signed-reg
 629        (sc-case float
 630          (single-reg
 631           (inst stfs float (current-nfp-tn vop)
 632                 (* (tn-offset stack-temp) n-word-bytes))
 633           (inst lwz bits (current-nfp-tn vop)
 634                 (* (tn-offset stack-temp) n-word-bytes)))
 635          (single-stack
 636           (inst lwz bits (current-nfp-tn vop)
 637                 (* (tn-offset float) n-word-bytes)))
 638          (descriptor-reg
 639           (loadw bits float single-float-value-slot other-pointer-lowtag))))
 640       (signed-stack
 641        (sc-case float
 642          (single-reg
 643           (inst stfs float (current-nfp-tn vop)
 644                 (* (tn-offset bits) n-word-bytes))))))))
 645
 646 (define-vop (double-float-high-bits)
 647   (:args (float :scs (double-reg descriptor-reg)
 648                 :load-if (not (sc-is float double-stack))))
 649   (:results (hi-bits :scs (signed-reg)))
 650   (:temporary (:scs (double-stack)) stack-temp)
 651   (:arg-types double-float)
 652   (:result-types signed-num)
 653   (:translate double-float-high-bits)
 654   (:policy :fast-safe)
 655   (:vop-var vop)
 656   (:generator 5
 657     (sc-case float
 658       (double-reg
 659         (inst stfd float (current-nfp-tn vop)
 660               (* (tn-offset stack-temp) n-word-bytes))
 661         (inst lwz hi-bits (current-nfp-tn vop)
 662               (* (tn-offset stack-temp) n-word-bytes)))
 663       (double-stack
 664         (inst lwz hi-bits (current-nfp-tn vop)
 665               (* (tn-offset float) n-word-bytes)))
 666       (descriptor-reg
 667         (loadw hi-bits float double-float-value-slot
 668                other-pointer-lowtag)))))
 669
 670 (define-vop (double-float-low-bits)
 671   (:args (float :scs (double-reg descriptor-reg)
 672                 :load-if (not (sc-is float double-stack))))
 673   (:results (lo-bits :scs (unsigned-reg)))
 674   (:temporary (:scs (double-stack)) stack-temp)
 675   (:arg-types double-float)
 676   (:result-types unsigned-num)
 677   (:translate double-float-low-bits)
 678   (:policy :fast-safe)
 679   (:vop-var vop)
 680   (:generator 5
 681     (sc-case float
 682       (double-reg
 683         (inst stfd float (current-nfp-tn vop)
 684               (* (tn-offset stack-temp) n-word-bytes))
 685         (inst lwz lo-bits (current-nfp-tn vop)
 686               (* (1+ (tn-offset stack-temp)) n-word-bytes)))
 687       (double-stack
 688         (inst lwz lo-bits (current-nfp-tn vop)
 689               (* (1+ (tn-offset float)) n-word-bytes)))
 690       (descriptor-reg
 691         (loadw lo-bits float (1+ double-float-value-slot)
 692                other-pointer-lowtag)))))
 693 \f
 694 ;;;; Float mode hackery:
 695
 696 (sb!xc:deftype float-modes () '(unsigned-byte 32))
 697 (defknown floating-point-modes () float-modes (flushable))
 698 (defknown ((setf floating-point-modes)) (float-modes)
 699   float-modes)
 700
 701 (define-vop (floating-point-modes)
 702   (:results (res :scs (unsigned-reg)))
 703   (:result-types unsigned-num)
 704   (:translate floating-point-modes)
 705   (:policy :fast-safe)
 706   (:vop-var vop)
 707   (:temporary (:sc double-stack) temp)
 708   (:temporary (:sc single-reg) fp-temp)
 709   (:generator 3
 710     (let ((nfp (current-nfp-tn vop)))
 711       (inst mffs fp-temp)
 712       (inst stfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
 713       (loadw res nfp (1+ (tn-offset temp))))))
 714
 715 (define-vop (set-floating-point-modes)
 716   (:args (new :scs (unsigned-reg) :target res))
 717   (:results (res :scs (unsigned-reg)))
 718   (:arg-types unsigned-num)
 719   (:result-types unsigned-num)
 720   (:translate (setf floating-point-modes))
 721   (:policy :fast-safe)
 722   (:temporary (:sc double-stack) temp)
 723   (:temporary (:sc single-reg) fp-temp)
 724   (:vop-var vop)
 725   (:generator 3
 726     (let ((nfp (current-nfp-tn vop)))
 727       (storew new nfp (1+ (tn-offset temp)))
 728       (inst lfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
 729       (inst mtfsf 255 fp-temp)
 730       (move res new))))
 731
 732 \f
 733 ;;;; Complex float VOPs
 734
 735 (define-vop (make-complex-single-float)
 736   (:translate complex)
 737   (:args (real :scs (single-reg) :target r
 738                :load-if (not (location= real r)))
 739          (imag :scs (single-reg) :to :save))
 740   (:arg-types single-float single-float)
 741   (:results (r :scs (complex-single-reg) :from (:argument 0)
 742                :load-if (not (sc-is r complex-single-stack))))
 743   (:result-types complex-single-float)
 744   (:note "inline complex single-float creation")
 745   (:policy :fast-safe)
 746   (:vop-var vop)
 747   (:generator 5
 748     (sc-case r
 749       (complex-single-reg
 750        (let ((r-real (complex-single-reg-real-tn r)))
 751          (unless (location= real r-real)
 752            (inst fmr r-real real)))
 753        (let ((r-imag (complex-single-reg-imag-tn r)))
 754          (unless (location= imag r-imag)
 755            (inst fmr r-imag imag))))
 756       (complex-single-stack
 757        (let ((nfp (current-nfp-tn vop))
 758              (offset (* (tn-offset r) n-word-bytes)))
 759          (unless (location= real r)
 760            (inst stfs real nfp offset))
 761          (inst stfs imag nfp (+ offset n-word-bytes)))))))
 762
 763 (define-vop (make-complex-double-float)
 764   (:translate complex)
 765   (:args (real :scs (double-reg) :target r
 766                :load-if (not (location= real r)))
 767          (imag :scs (double-reg) :to :save))
 768   (:arg-types double-float double-float)
 769   (:results (r :scs (complex-double-reg) :from (:argument 0)
 770                :load-if (not (sc-is r complex-double-stack))))
 771   (:result-types complex-double-float)
 772   (:note "inline complex double-float creation")
 773   (:policy :fast-safe)
 774   (:vop-var vop)
 775   (:generator 5
 776     (sc-case r
 777       (complex-double-reg
 778        (let ((r-real (complex-double-reg-real-tn r)))
 779          (unless (location= real r-real)
 780            (inst fmr r-real real)))
 781        (let ((r-imag (complex-double-reg-imag-tn r)))
 782          (unless (location= imag r-imag)
 783            (inst fmr r-imag imag))))
 784       (complex-double-stack
 785        (let ((nfp (current-nfp-tn vop))
 786              (offset (* (tn-offset r) n-word-bytes)))
 787          (unless (location= real r)
 788            (inst stfd real nfp offset))
 789          (inst stfd imag nfp (+ offset (* 2 n-word-bytes))))))))
 790
 791
 792 (define-vop (complex-single-float-value)
 793   (:args (x :scs (complex-single-reg) :target r
 794             :load-if (not (sc-is x complex-single-stack))))
 795   (:arg-types complex-single-float)
 796   (:results (r :scs (single-reg)))
 797   (:result-types single-float)
 798   (:variant-vars slot)
 799   (:policy :fast-safe)
 800   (:vop-var vop)
 801   (:generator 3
 802     (sc-case x
 803       (complex-single-reg
 804        (let ((value-tn (ecase slot
 805                          (:real (complex-single-reg-real-tn x))
 806                          (:imag (complex-single-reg-imag-tn x)))))
 807          (unless (location= value-tn r)
 808            (inst fmr r value-tn))))
 809       (complex-single-stack
 810        (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
 811                                               (tn-offset x))
 812                                            n-word-bytes))))))
 813
 814 (define-vop (realpart/complex-single-float complex-single-float-value)
 815   (:translate realpart)
 816   (:note "complex single float realpart")
 817   (:variant :real))
 818
 819 (define-vop (imagpart/complex-single-float complex-single-float-value)
 820   (:translate imagpart)
 821   (:note "complex single float imagpart")
 822   (:variant :imag))
 823
 824 (define-vop (complex-double-float-value)
 825   (:args (x :scs (complex-double-reg) :target r
 826             :load-if (not (sc-is x complex-double-stack))))
 827   (:arg-types complex-double-float)
 828   (:results (r :scs (double-reg)))
 829   (:result-types double-float)
 830   (:variant-vars slot)
 831   (:policy :fast-safe)
 832   (:vop-var vop)
 833   (:generator 3
 834     (sc-case x
 835       (complex-double-reg
 836        (let ((value-tn (ecase slot
 837                          (:real (complex-double-reg-real-tn x))
 838                          (:imag (complex-double-reg-imag-tn x)))))
 839          (unless (location= value-tn r)
 840            (inst fmr r value-tn))))
 841       (complex-double-stack
 842        (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
 843                                               (tn-offset x))
 844                                            n-word-bytes))))))
 845
 846 (define-vop (realpart/complex-double-float complex-double-float-value)
 847   (:translate realpart)
 848   (:note "complex double float realpart")
 849   (:variant :real))
 850
 851 (define-vop (imagpart/complex-double-float complex-double-float-value)
 852   (:translate imagpart)
 853   (:note "complex double float imagpart")
 854   (:variant :imag))
 855
 856 ;; This vop and the next are intended to be used only for moving a
 857 ;; float to an integer arg location (register or stack) for C callout.
 858 ;; See %alien-funcall ir2convert in aliencomp.lisp.
 859
 860 #!+darwin
 861 (define-vop (move-double-to-int-arg)
 862   (:args (float :scs (double-reg)))
 863   (:results (hi-bits :scs (signed-reg signed-stack))
 864             (lo-bits :scs (unsigned-reg unsigned-stack)))
 865   (:temporary (:scs (double-stack)) stack-temp)
 866   (:temporary (:scs (signed-reg)) temp)
 867   (:arg-types double-float)
 868   (:result-types signed-num unsigned-num)
 869   (:policy :fast-safe)
 870   (:vop-var vop)
 871   (:generator 5
 872     (sc-case float
 873       (double-reg
 874        (inst stfd float (current-nfp-tn vop)
 875              (* (tn-offset stack-temp) n-word-bytes))
 876        (sc-case hi-bits
 877          (signed-reg
 878           (inst lwz hi-bits (current-nfp-tn vop)
 879                 (* (tn-offset stack-temp) n-word-bytes)))
 880          (signed-stack
 881           (inst lwz temp (current-nfp-tn vop)
 882                 (* (tn-offset stack-temp) n-word-bytes))
 883           (inst stw temp nsp-tn
 884                 (* (tn-offset hi-bits) n-word-bytes))))
 885        (sc-case lo-bits
 886          (unsigned-reg
 887           (inst lwz lo-bits (current-nfp-tn vop)
 888                 (* (1+ (tn-offset stack-temp)) n-word-bytes)))
 889          (unsigned-stack
 890           (inst lwz temp (current-nfp-tn vop)
 891                 (* (1+ (tn-offset stack-temp)) n-word-bytes))
 892           (inst stw temp nsp-tn
 893                 (* (tn-offset lo-bits) n-word-bytes))))))))
 894
 895 #!+darwin
 896 (define-vop (move-single-to-int-arg)
 897   (:args (float :scs (single-reg)))
 898   (:results (bits :scs (signed-reg signed-stack)))
 899   (:temporary (:scs (double-stack)) stack-temp)
 900   (:temporary (:scs (signed-reg)) temp)
 901   (:arg-types single-float)
 902   (:result-types signed-num)
 903   (:policy :fast-safe)
 904   (:vop-var vop)
 905   (:generator 5
 906     (sc-case float
 907       (single-reg
 908        (inst stfs float (current-nfp-tn vop)
 909              (* (tn-offset stack-temp) n-word-bytes))
 910        (sc-case bits
 911          (signed-reg
 912           (inst lwz bits (current-nfp-tn vop)
 913                 (* (tn-offset stack-temp) n-word-bytes)))
 914          (signed-stack
 915           (inst lwz temp (current-nfp-tn vop)
 916                 (* (tn-offset stack-temp) n-word-bytes))
 917           (inst stw temp nsp-tn
 918                 (* (tn-offset bits) n-word-bytes))))))))
 919