src/compiler/ppc/float.lisp

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