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                              :load-if (not (sc-is y signed-stack))))
 507                 (:arg-types ,from-type)
 508                 (:result-types signed-num)
 509                 (:translate ,trans)
 510                 (:policy :fast-safe)
 511                 (:note "inline float truncate")
 512                 (:vop-var vop)
 513                 (:save-p :compute-only)
 514                 (:generator 5
 515                   (note-this-location vop :internal-error)
 516                   (inst ,inst temp x)
 517                   (sc-case y
 518                     (signed-stack
 519                      (inst stfd temp (current-nfp-tn vop)
 520                            (* (tn-offset y) sb!vm:n-word-bytes)))
 521                     (signed-reg
 522                      (inst stfd temp (current-nfp-tn vop)
 523                            (* (tn-offset stack-temp) sb!vm:n-word-bytes))
 524                      (inst lwz y (current-nfp-tn vop)
 525                            (+ 4 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))))))))
 526   (frob %unary-truncate single-reg single-float fctiwz)
 527   (frob %unary-truncate double-reg double-float fctiwz)
 528   (frob %unary-round single-reg single-float fctiw)
 529   (frob %unary-round double-reg double-float fctiw))
 530
 531
 532
 533 (define-vop (make-single-float)
 534   (:args (bits :scs (signed-reg) :target res
 535                :load-if (not (sc-is bits signed-stack))))
 536   (:results (res :scs (single-reg)
 537                  :load-if (not (sc-is res single-stack))))
 538   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
 539   (:temporary (:scs (signed-stack)) stack-temp)
 540   (:arg-types signed-num)
 541   (:result-types single-float)
 542   (:translate make-single-float)
 543   (:policy :fast-safe)
 544   (:vop-var vop)
 545   (:generator 4
 546     (sc-case bits
 547       (signed-reg
 548        (sc-case res
 549          (single-reg
 550           (inst stw bits (current-nfp-tn vop)
 551                 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
 552           (inst lfs res (current-nfp-tn vop)
 553                 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
 554          (single-stack
 555           (inst stw bits (current-nfp-tn vop)
 556                 (* (tn-offset res) sb!vm:n-word-bytes)))))
 557       (signed-stack
 558        (sc-case res
 559          (single-reg
 560           (inst lfs res (current-nfp-tn vop)
 561                 (* (tn-offset bits) sb!vm:n-word-bytes)))
 562          (single-stack
 563           (unless (location= bits res)
 564             (inst lwz temp (current-nfp-tn vop)
 565                   (* (tn-offset bits) sb!vm:n-word-bytes))
 566             (inst stw temp (current-nfp-tn vop)
 567                   (* (tn-offset res) sb!vm:n-word-bytes)))))))))
 568
 569 (define-vop (make-double-float)
 570   (:args (hi-bits :scs (signed-reg))
 571          (lo-bits :scs (unsigned-reg)))
 572   (:results (res :scs (double-reg)
 573                  :load-if (not (sc-is res double-stack))))
 574   (:temporary (:scs (double-stack)) temp)
 575   (:arg-types signed-num unsigned-num)
 576   (:result-types double-float)
 577   (:translate make-double-float)
 578   (:policy :fast-safe)
 579   (:vop-var vop)
 580   (:generator 2
 581     (let ((stack-tn (sc-case res
 582                       (double-stack res)
 583                       (double-reg temp))))
 584       (inst stw hi-bits (current-nfp-tn vop)
 585             (* (tn-offset stack-tn) sb!vm:n-word-bytes))
 586       (inst stw lo-bits (current-nfp-tn vop)
 587             (* (1+ (tn-offset stack-tn)) sb!vm:n-word-bytes)))
 588     (when (sc-is res double-reg)
 589       (inst lfd res (current-nfp-tn vop)
 590             (* (tn-offset temp) sb!vm:n-word-bytes)))))
 591
 592 (define-vop (single-float-bits)
 593   (:args (float :scs (single-reg descriptor-reg)
 594                 :load-if (not (sc-is float single-stack))))
 595   (:results (bits :scs (signed-reg)
 596                   :load-if (or (sc-is float descriptor-reg single-stack)
 597                                (not (sc-is bits signed-stack)))))
 598   (:temporary (:scs (signed-stack)) stack-temp)
 599   (:arg-types single-float)
 600   (:result-types signed-num)
 601   (:translate single-float-bits)
 602   (:policy :fast-safe)
 603   (:vop-var vop)
 604   (:generator 4
 605     (sc-case bits
 606       (signed-reg
 607        (sc-case float
 608          (single-reg
 609           (inst stfs float (current-nfp-tn vop)
 610                 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
 611           (inst lwz bits (current-nfp-tn vop)
 612                 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
 613          (single-stack
 614           (inst lwz bits (current-nfp-tn vop)
 615                 (* (tn-offset float) sb!vm:n-word-bytes)))
 616          (descriptor-reg
 617           (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-lowtag))))
 618       (signed-stack
 619        (sc-case float
 620          (single-reg
 621           (inst stfs float (current-nfp-tn vop)
 622                 (* (tn-offset bits) sb!vm:n-word-bytes))))))))
 623
 624 (define-vop (double-float-high-bits)
 625   (:args (float :scs (double-reg descriptor-reg)
 626                 :load-if (not (sc-is float double-stack))))
 627   (:results (hi-bits :scs (signed-reg)
 628                      :load-if (or (sc-is float descriptor-reg double-stack)
 629                                   (not (sc-is hi-bits signed-stack)))))
 630   (:temporary (:scs (signed-stack)) stack-temp)
 631   (:arg-types double-float)
 632   (:result-types signed-num)
 633   (:translate double-float-high-bits)
 634   (:policy :fast-safe)
 635   (:vop-var vop)
 636   (:generator 5
 637     (sc-case hi-bits
 638       (signed-reg
 639        (sc-case float
 640          (double-reg
 641           (inst stfd float (current-nfp-tn vop)
 642                 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
 643           (inst lwz hi-bits (current-nfp-tn vop)
 644                 (* (tn-offset stack-temp) sb!vm:n-word-bytes)))
 645          (double-stack
 646           (inst lwz hi-bits (current-nfp-tn vop)
 647                 (* (tn-offset float) sb!vm:n-word-bytes)))
 648          (descriptor-reg
 649           (loadw hi-bits float sb!vm:double-float-value-slot
 650                  sb!vm:other-pointer-lowtag))))
 651       (signed-stack
 652        (sc-case float
 653          (double-reg
 654           (inst stfd float (current-nfp-tn vop)
 655                 (* (tn-offset hi-bits) sb!vm:n-word-bytes))))))))
 656
 657 (define-vop (double-float-low-bits)
 658   (:args (float :scs (double-reg descriptor-reg)
 659                 :load-if (not (sc-is float double-stack))))
 660   (:results (lo-bits :scs (unsigned-reg)
 661                      :load-if (or (sc-is float descriptor-reg double-stack)
 662                                   (not (sc-is lo-bits unsigned-stack)))))
 663   (:temporary (:scs (unsigned-stack)) stack-temp)
 664   (:arg-types double-float)
 665   (:result-types unsigned-num)
 666   (:translate double-float-low-bits)
 667   (:policy :fast-safe)
 668   (:vop-var vop)
 669   (:generator 5
 670     (sc-case lo-bits
 671       (unsigned-reg
 672        (sc-case float
 673          (double-reg
 674           (inst stfd float (current-nfp-tn vop)
 675                 (* (tn-offset stack-temp) sb!vm:n-word-bytes))
 676           (inst lwz lo-bits (current-nfp-tn vop)
 677                 (* (1+ (tn-offset stack-temp)) sb!vm:n-word-bytes)))
 678          (double-stack
 679           (inst lwz lo-bits (current-nfp-tn vop)
 680                 (* (1+ (tn-offset float)) sb!vm:n-word-bytes)))
 681          (descriptor-reg
 682           (loadw lo-bits float (1+ sb!vm:double-float-value-slot)
 683                  sb!vm:other-pointer-lowtag))))
 684       (unsigned-stack
 685        (sc-case float
 686          (double-reg
 687           (inst stfd float (current-nfp-tn vop)
 688                 (* (tn-offset lo-bits) sb!vm:n-word-bytes))))))))
 689
 690 \f
 691 ;;;; Float mode hackery:
 692
 693 (sb!xc:deftype float-modes () '(unsigned-byte 32))
 694 (defknown floating-point-modes () float-modes (flushable))
 695 (defknown ((setf floating-point-modes)) (float-modes)
 696   float-modes)
 697
 698 (define-vop (floating-point-modes)
 699   (:results (res :scs (unsigned-reg)))
 700   (:result-types unsigned-num)
 701   (:translate floating-point-modes)
 702   (:policy :fast-safe)
 703   (:vop-var vop)
 704   (:temporary (:sc double-stack) temp)
 705   (:temporary (:sc single-reg) fp-temp)
 706   (:generator 3
 707     (let ((nfp (current-nfp-tn vop)))
 708       (inst mffs fp-temp)
 709       (inst stfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
 710       (loadw res nfp (1+ (tn-offset temp))))))
 711
 712 (define-vop (set-floating-point-modes)
 713   (:args (new :scs (unsigned-reg) :target res))
 714   (:results (res :scs (unsigned-reg)))
 715   (:arg-types unsigned-num)
 716   (:result-types unsigned-num)
 717   (:translate (setf floating-point-modes))
 718   (:policy :fast-safe)
 719   (:temporary (:sc double-stack) temp)
 720   (:temporary (:sc single-reg) fp-temp)
 721   (:vop-var vop)
 722   (:generator 3
 723     (let ((nfp (current-nfp-tn vop)))
 724       (storew new nfp (1+ (tn-offset temp)))
 725       (inst lfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
 726       (inst mtfsf 255 fp-temp)
 727       (move res new))))
 728
 729 \f
 730 ;;;; Complex float VOPs
 731
 732 (define-vop (make-complex-single-float)
 733   (:translate complex)
 734   (:args (real :scs (single-reg) :target r
 735                :load-if (not (location= real r)))
 736          (imag :scs (single-reg) :to :save))
 737   (:arg-types single-float single-float)
 738   (:results (r :scs (complex-single-reg) :from (:argument 0)
 739                :load-if (not (sc-is r complex-single-stack))))
 740   (:result-types complex-single-float)
 741   (:note "inline complex single-float creation")
 742   (:policy :fast-safe)
 743   (:vop-var vop)
 744   (:generator 5
 745     (sc-case r
 746       (complex-single-reg
 747        (let ((r-real (complex-single-reg-real-tn r)))
 748          (unless (location= real r-real)
 749            (inst fmr r-real real)))
 750        (let ((r-imag (complex-single-reg-imag-tn r)))
 751          (unless (location= imag r-imag)
 752            (inst fmr r-imag imag))))
 753       (complex-single-stack
 754        (let ((nfp (current-nfp-tn vop))
 755              (offset (* (tn-offset r) sb!vm:n-word-bytes)))
 756          (unless (location= real r)
 757            (inst stfs real nfp offset))
 758          (inst stfs imag nfp (+ offset sb!vm:n-word-bytes)))))))
 759
 760 (define-vop (make-complex-double-float)
 761   (:translate complex)
 762   (:args (real :scs (double-reg) :target r
 763                :load-if (not (location= real r)))
 764          (imag :scs (double-reg) :to :save))
 765   (:arg-types double-float double-float)
 766   (:results (r :scs (complex-double-reg) :from (:argument 0)
 767                :load-if (not (sc-is r complex-double-stack))))
 768   (:result-types complex-double-float)
 769   (:note "inline complex double-float creation")
 770   (:policy :fast-safe)
 771   (:vop-var vop)
 772   (:generator 5
 773     (sc-case r
 774       (complex-double-reg
 775        (let ((r-real (complex-double-reg-real-tn r)))
 776          (unless (location= real r-real)
 777            (inst fmr r-real real)))
 778        (let ((r-imag (complex-double-reg-imag-tn r)))
 779          (unless (location= imag r-imag)
 780            (inst fmr r-imag imag))))
 781       (complex-double-stack
 782        (let ((nfp (current-nfp-tn vop))
 783              (offset (* (tn-offset r) sb!vm:n-word-bytes)))
 784          (unless (location= real r)
 785            (inst stfd real nfp offset))
 786          (inst stfd imag nfp (+ offset (* 2 sb!vm:n-word-bytes))))))))
 787
 788
 789 (define-vop (complex-single-float-value)
 790   (:args (x :scs (complex-single-reg) :target r
 791             :load-if (not (sc-is x complex-single-stack))))
 792   (:arg-types complex-single-float)
 793   (:results (r :scs (single-reg)))
 794   (:result-types single-float)
 795   (:variant-vars slot)
 796   (:policy :fast-safe)
 797   (:vop-var vop)
 798   (:generator 3
 799     (sc-case x
 800       (complex-single-reg
 801        (let ((value-tn (ecase slot
 802                          (:real (complex-single-reg-real-tn x))
 803                          (:imag (complex-single-reg-imag-tn x)))))
 804          (unless (location= value-tn r)
 805            (inst fmr r value-tn))))
 806       (complex-single-stack
 807        (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
 808                                               (tn-offset x))
 809                                            sb!vm:n-word-bytes))))))
 810
 811 (define-vop (realpart/complex-single-float complex-single-float-value)
 812   (:translate realpart)
 813   (:note "complex single float realpart")
 814   (:variant :real))
 815
 816 (define-vop (imagpart/complex-single-float complex-single-float-value)
 817   (:translate imagpart)
 818   (:note "complex single float imagpart")
 819   (:variant :imag))
 820
 821 (define-vop (complex-double-float-value)
 822   (:args (x :scs (complex-double-reg) :target r
 823             :load-if (not (sc-is x complex-double-stack))))
 824   (:arg-types complex-double-float)
 825   (:results (r :scs (double-reg)))
 826   (:result-types double-float)
 827   (:variant-vars slot)
 828   (:policy :fast-safe)
 829   (:vop-var vop)
 830   (:generator 3
 831     (sc-case x
 832       (complex-double-reg
 833        (let ((value-tn (ecase slot
 834                          (:real (complex-double-reg-real-tn x))
 835                          (:imag (complex-double-reg-imag-tn x)))))
 836          (unless (location= value-tn r)
 837            (inst fmr r value-tn))))
 838       (complex-double-stack
 839        (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
 840                                               (tn-offset x))
 841                                            sb!vm:n-word-bytes))))))
 842
 843 (define-vop (realpart/complex-double-float complex-double-float-value)
 844   (:translate realpart)
 845   (:note "complex double float realpart")
 846   (:variant :real))
 847
 848 (define-vop (imagpart/complex-double-float complex-double-float-value)
 849   (:translate imagpart)
 850   (:note "complex double float imagpart")
 851   (:variant :imag))
 852
 853 \f