src/compiler/alpha/float.lisp

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