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) n-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) n-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) n-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) n-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 n-word-bytes) other-pointer-lowtag) y)
  71           (inst sts x (- (* data n-word-bytes) other-pointer-lowtag) 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-widetag single-float-value-slot)
  82   (frob move-from-double double-reg
  83     t double-float-size double-float-widetag 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 n-word-bytes)
  94                                            other-pointer-lowtag)
  95                                   x))
  96                           `((inst lds y (- (* ,value n-word-bytes)
  97                                           other-pointer-lowtag)
  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) n-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) n-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 n-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) n-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 n-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) n-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 n-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) n-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 n-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 complex-single-float-widetag
 233                                complex-single-float-size)
 234        (let ((real-tn (complex-single-reg-real-tn x)))
 235          (inst sts real-tn (- (* complex-single-float-real-slot
 236                                  n-word-bytes)
 237                               other-pointer-lowtag)
 238                y))
 239        (let ((imag-tn (complex-single-reg-imag-tn x)))
 240          (inst sts imag-tn (- (* complex-single-float-imag-slot
 241                                  n-word-bytes)
 242                               other-pointer-lowtag)
 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 complex-double-float-widetag
 255                                complex-double-float-size)
 256        (let ((real-tn (complex-double-reg-real-tn x)))
 257          (inst stt real-tn (- (* complex-double-float-real-slot
 258                                  n-word-bytes)
 259                               other-pointer-lowtag)
 260                y))
 261        (let ((imag-tn (complex-double-reg-imag-tn x)))
 262          (inst stt imag-tn (- (* complex-double-float-imag-slot
 263                                  n-word-bytes)
 264                               other-pointer-lowtag)
 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
 280                               n-word-bytes)
 281                            other-pointer-lowtag)
 282             x))
 283     (let ((imag-tn (complex-single-reg-imag-tn y)))
 284       (inst lds imag-tn (- (* complex-single-float-imag-slot
 285                               n-word-bytes)
 286                            other-pointer-lowtag)
 287             x))))
 288 (define-move-vop move-to-complex-single :move
 289   (descriptor-reg) (complex-single-reg))
 290
 291 (define-vop (move-to-complex-double)
 292   (:args (x :scs (descriptor-reg)))
 293   (:results (y :scs (complex-double-reg)))
 294   (:note "pointer to complex float coercion")
 295   (:generator 2
 296     (let ((real-tn (complex-double-reg-real-tn y)))
 297       (inst ldt real-tn (- (* complex-double-float-real-slot
 298                               n-word-bytes)
 299                            other-pointer-lowtag)
 300             x))
 301     (let ((imag-tn (complex-double-reg-imag-tn y)))
 302       (inst ldt imag-tn (- (* complex-double-float-imag-slot
 303                               n-word-bytes)
 304                            other-pointer-lowtag)
 305             x))))
 306 (define-move-vop move-to-complex-double :move
 307   (descriptor-reg) (complex-double-reg))
 308
 309 ;;;
 310 ;;; complex float move-argument vop
 311 ;;;
 312 (define-vop (move-complex-single-float-argument)
 313   (:args (x :scs (complex-single-reg) :target y)
 314          (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
 315   (:results (y))
 316   (:note "complex single float argument move")
 317   (:generator 1
 318     (sc-case y
 319       (complex-single-reg
 320        (unless (location= x y)
 321          (let ((x-real (complex-single-reg-real-tn x))
 322                (y-real (complex-single-reg-real-tn y)))
 323            (inst fmove x-real y-real))
 324          (let ((x-imag (complex-single-reg-imag-tn x))
 325                (y-imag (complex-single-reg-imag-tn y)))
 326            (inst fmove x-imag y-imag))))
 327       (complex-single-stack
 328        (let ((offset (* (tn-offset y) n-word-bytes)))
 329          (let ((real-tn (complex-single-reg-real-tn x)))
 330            (inst sts real-tn offset nfp))
 331          (let ((imag-tn (complex-single-reg-imag-tn x)))
 332            (inst sts imag-tn (+ offset n-word-bytes) nfp)))))))
 333 (define-move-vop move-complex-single-float-argument :move-argument
 334   (complex-single-reg descriptor-reg) (complex-single-reg))
 335
 336 (define-vop (move-complex-double-float-argument)
 337   (:args (x :scs (complex-double-reg) :target y)
 338          (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
 339   (:results (y))
 340   (:note "complex double float argument move")
 341   (:generator 2
 342     (sc-case y
 343       (complex-double-reg
 344        (unless (location= x y)
 345          (let ((x-real (complex-double-reg-real-tn x))
 346                (y-real (complex-double-reg-real-tn y)))
 347            (inst fmove x-real y-real))
 348          (let ((x-imag (complex-double-reg-imag-tn x))
 349                (y-imag (complex-double-reg-imag-tn y)))
 350            (inst fmove x-imag y-imag))))
 351       (complex-double-stack
 352        (let ((offset (* (tn-offset y) n-word-bytes)))
 353          (let ((real-tn (complex-double-reg-real-tn x)))
 354            (inst stt real-tn offset nfp))
 355          (let ((imag-tn (complex-double-reg-imag-tn x)))
 356            (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
 357 (define-move-vop move-complex-double-float-argument :move-argument
 358   (complex-double-reg descriptor-reg) (complex-double-reg))
 359
 360
 361 (define-move-vop move-argument :move-argument
 362   (single-reg double-reg complex-single-reg complex-double-reg)
 363   (descriptor-reg))
 364
 365 \f
 366 ;;;; float arithmetic VOPs
 367
 368 (define-vop (float-op)
 369   (:args (x) (y))
 370   (:results (r))
 371   (:policy :fast-safe)
 372   (:note "inline float arithmetic")
 373   (:vop-var vop)
 374   (:save-p :compute-only))
 375
 376 ;;; We need to insure that ops that can cause traps do not clobber an
 377 ;;; argument register with invalid results. This so the software trap
 378 ;;; handler can re-execute the instruction and produce correct IEEE
 379 ;;; result. The :from :load hopefully does that.
 380 (macrolet ((frob (name sc ptype)
 381              `(define-vop (,name float-op)
 382                 (:args (x :scs (,sc))
 383                        (y :scs (,sc)))
 384                 (:results (r :scs (,sc) :from :load))
 385                 (:arg-types ,ptype ,ptype)
 386                 (:result-types ,ptype))))
 387   (frob single-float-op single-reg single-float)
 388   (frob double-float-op double-reg double-float))
 389
 390 ;; This is resumption-safe with underflow traps enabled,
 391 ;; with software handling and (notyet) dynamic rounding mode.
 392 (macrolet ((frob (op sinst sname scost dinst dname dcost)
 393              `(progn
 394                 (define-vop (,sname single-float-op)
 395                   (:translate ,op)
 396                   (:variant-cost ,scost)
 397                   (:generator ,scost
 398                     (inst ,sinst x y r)
 399                     (note-this-location vop :internal-error)
 400                     (inst trapb)))
 401                 (define-vop (,dname double-float-op)
 402                   (:translate ,op)
 403                   (:variant-cost ,dcost)
 404                   (:generator ,dcost
 405                     (inst ,dinst x y r)
 406                     (note-this-location vop :internal-error)
 407                     (inst trapb))))))
 408   ;; Not sure these cost number are right. +*- about same / is 4x
 409   (frob + adds_su +/single-float 1 addt_su +/double-float 1)
 410   (frob - subs_su -/single-float 1 subt_su -/double-float 1)
 411   (frob * muls_su */single-float 1 mult_su */double-float 1)
 412   (frob / divs_su //single-float 4 divt_su //double-float 4))
 413
 414 (macrolet ((frob (name inst translate sc type)
 415              `(define-vop (,name)
 416                 (:args (x :scs (,sc) :target y))
 417                 (:results (y :scs (,sc)))
 418                 (:translate ,translate)
 419                 (:policy :fast-safe)
 420                 (:arg-types ,type)
 421                 (:result-types ,type)
 422                 (:note "inline float arithmetic")
 423                 (:vop-var vop)
 424                 (:save-p :compute-only)
 425                 (:generator 1
 426                   (note-this-location vop :internal-error)
 427                   (inst ,inst x y)))))
 428   (frob abs/single-float fabs abs single-reg single-float)
 429   (frob abs/double-float fabs abs double-reg double-float)
 430   (frob %negate/single-float fneg %negate single-reg single-float)
 431   (frob %negate/double-float fneg %negate double-reg double-float))
 432
 433 \f
 434 ;;;; float comparison
 435
 436 (define-vop (float-compare)
 437   (:args (x) (y))
 438   (:conditional)
 439   (:info target not-p)
 440   (:variant-vars eq complement)
 441   (:temporary (:scs (single-reg)) temp)
 442   (:policy :fast-safe)
 443   (:note "inline float comparison")
 444   (:vop-var vop)
 445   (:save-p :compute-only)
 446   (:generator 3
 447     (note-this-location vop :internal-error)
 448     (if eq
 449         (inst cmpteq x y temp)
 450         (if complement
 451             (inst cmptle x y temp)
 452             (inst cmptlt x y temp)))
 453     (inst trapb)
 454     (if (if complement (not not-p) not-p)
 455         (inst fbeq temp target)
 456         (inst fbne temp target))))
 457
 458 (macrolet ((frob (name sc ptype)
 459              `(define-vop (,name float-compare)
 460                 (:args (x :scs (,sc))
 461                        (y :scs (,sc)))
 462                 (:arg-types ,ptype ,ptype))))
 463   (frob single-float-compare single-reg single-float)
 464   (frob double-float-compare double-reg double-float))
 465
 466 (macrolet ((frob (translate complement sname dname eq)
 467              `(progn
 468                 (define-vop (,sname single-float-compare)
 469                   (:translate ,translate)
 470                   (:variant ,eq ,complement))
 471                 (define-vop (,dname double-float-compare)
 472                   (:translate ,translate)
 473                   (:variant ,eq ,complement)))))
 474   (frob < nil </single-float </double-float nil)
 475   (frob > t >/single-float >/double-float nil)
 476   (frob = nil =/single-float =/double-float t))
 477
 478 \f
 479 ;;;; float conversion
 480
 481 (macrolet
 482     ((frob (name translate inst ld-inst to-sc to-type &optional single)
 483            (declare (ignorable single))
 484            `(define-vop (,name)
 485               (:args (x :scs (signed-reg) :target temp
 486                         :load-if (not (sc-is x signed-stack))))
 487               (:temporary (:scs (single-stack)) temp)
 488               (:results (y :scs (,to-sc)))
 489               (:arg-types signed-num)
 490               (:result-types ,to-type)
 491               (:policy :fast-safe)
 492               (:note "inline float coercion")
 493               (:translate ,translate)
 494               (:vop-var vop)
 495               (:save-p :compute-only)
 496               (:generator 5
 497                           (let ((stack-tn
 498                                  (sc-case x
 499                                           (signed-reg
 500                                            (inst stl x
 501                                                  (* (tn-offset temp)
 502                                                     n-word-bytes)
 503                                                  (current-nfp-tn vop))
 504                                            temp)
 505                                           (signed-stack
 506                                            x))))
 507                             (inst ,ld-inst y
 508                                   (* (tn-offset stack-tn) n-word-bytes)
 509                                   (current-nfp-tn vop))
 510                             (note-this-location vop :internal-error)
 511                             ,@(when single
 512                                 `((inst cvtlq y y)))
 513                             (inst ,inst y y))))))
 514   (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
 515   (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
 516
 517 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
 518              `(define-vop (,name)
 519                 (:args (x :scs (,from-sc)))
 520                 (:results (y :scs (,to-sc)))
 521                 (:arg-types ,from-type)
 522                 (:result-types ,to-type)
 523                 (:policy :fast-safe)
 524                 (:note "inline float coercion")
 525                 (:translate ,translate)
 526                 (:vop-var vop)
 527                 (:save-p :compute-only)
 528                 (:generator 2
 529                   (note-this-location vop :internal-error)
 530                   (inst ,inst x y)))))
 531   (frob %single-float/double-float %single-float cvtts
 532     double-reg double-float single-reg single-float)
 533   (frob %double-float/single-float %double-float fmove
 534     single-reg single-float double-reg double-float))
 535
 536 (macrolet
 537     ((frob (trans from-sc from-type inst &optional single)
 538            (declare (ignorable single))
 539            `(define-vop (,(symbolicate trans "/" from-type))
 540               (:args (x :scs (,from-sc) :target temp))
 541               (:temporary (:from (:argument 0) :sc single-reg) temp)
 542               (:temporary (:scs (signed-stack)) stack-temp)
 543               (:results (y :scs (signed-reg)
 544                            :load-if (not (sc-is y signed-stack))))
 545               (:arg-types ,from-type)
 546               (:result-types signed-num)
 547               (:translate ,trans)
 548               (:policy :fast-safe)
 549               (:note "inline float truncate")
 550               (:vop-var vop)
 551               (:save-p :compute-only)
 552               (:generator 5
 553                           (note-this-location vop :internal-error)
 554                           (inst ,inst x temp)
 555                           (sc-case y
 556                                    (signed-stack
 557                                     (inst stt temp
 558                                           (* (tn-offset y) n-word-bytes)
 559                                           (current-nfp-tn vop)))
 560                                    (signed-reg
 561                                     (inst stt temp
 562                                           (* (tn-offset stack-temp)
 563                                              n-word-bytes)
 564                                           (current-nfp-tn vop))
 565                                     (inst ldq y
 566                            (* (tn-offset stack-temp) n-word-bytes)
 567                            (current-nfp-tn vop))))))))
 568   (frob %unary-truncate single-reg single-float cvttq/c t)
 569   (frob %unary-truncate double-reg double-float cvttq/c)
 570   (frob %unary-round single-reg single-float cvttq t)
 571   (frob %unary-round double-reg double-float cvttq))
 572
 573 (define-vop (make-single-float)
 574   (:args (bits :scs (signed-reg) :target res
 575                :load-if (not (sc-is bits signed-stack))))
 576   (:results (res :scs (single-reg)
 577                  :load-if (not (sc-is res single-stack))))
 578   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
 579   (:temporary (:scs (signed-stack)) stack-temp)
 580   (:arg-types signed-num)
 581   (:result-types single-float)
 582   (:translate make-single-float)
 583   (:policy :fast-safe)
 584   (:vop-var vop)
 585   (:generator 4
 586     (sc-case bits
 587       (signed-reg
 588        (sc-case res
 589          (single-reg
 590           (inst stl bits
 591                 (* (tn-offset stack-temp) n-word-bytes)
 592                 (current-nfp-tn vop))
 593           (inst lds res
 594                 (* (tn-offset stack-temp) n-word-bytes)
 595                 (current-nfp-tn vop)))
 596          (single-stack
 597           (inst stl bits
 598                 (* (tn-offset res) n-word-bytes)
 599                 (current-nfp-tn vop)))))
 600       (signed-stack
 601        (sc-case res
 602          (single-reg
 603           (inst lds res
 604                 (* (tn-offset bits) n-word-bytes)
 605                 (current-nfp-tn vop)))
 606          (single-stack
 607           (unless (location= bits res)
 608             (inst ldl temp
 609                   (* (tn-offset bits) n-word-bytes)
 610                   (current-nfp-tn vop))
 611             (inst stl temp
 612                   (* (tn-offset res) n-word-bytes)
 613                   (current-nfp-tn vop)))))))))
 614
 615 (define-vop (make-double-float)
 616   (:args (hi-bits :scs (signed-reg))
 617          (lo-bits :scs (unsigned-reg)))
 618   (:results (res :scs (double-reg)
 619                  :load-if (not (sc-is res double-stack))))
 620   (:temporary (:scs (double-stack)) temp)
 621   (:arg-types signed-num unsigned-num)
 622   (:result-types double-float)
 623   (:translate make-double-float)
 624   (:policy :fast-safe)
 625   (:vop-var vop)
 626   (:generator 2
 627     (let ((stack-tn (sc-case res
 628                       (double-stack res)
 629                       (double-reg temp))))
 630       (inst stl hi-bits
 631             (* (1+ (tn-offset stack-tn)) n-word-bytes)
 632             (current-nfp-tn vop))
 633       (inst stl lo-bits
 634             (* (tn-offset stack-tn) n-word-bytes)
 635             (current-nfp-tn vop)))
 636     (when (sc-is res double-reg)
 637       (inst ldt res
 638             (* (tn-offset temp) n-word-bytes)
 639             (current-nfp-tn vop)))))
 640
 641 (define-vop (single-float-bits)
 642   (:args (float :scs (single-reg descriptor-reg)
 643                 :load-if (not (sc-is float single-stack))))
 644   (:results (bits :scs (signed-reg)
 645                   :load-if (or (sc-is float descriptor-reg single-stack)
 646                                (not (sc-is bits signed-stack)))))
 647   (:temporary (:scs (signed-stack)) stack-temp)
 648   (:arg-types single-float)
 649   (:result-types signed-num)
 650   (:translate single-float-bits)
 651   (:policy :fast-safe)
 652   (:vop-var vop)
 653   (:generator 4
 654     (sc-case bits
 655       (signed-reg
 656        (sc-case float
 657          (single-reg
 658           (inst sts float
 659                 (* (tn-offset stack-temp) n-word-bytes)
 660                 (current-nfp-tn vop))
 661           (inst ldl bits
 662                 (* (tn-offset stack-temp) n-word-bytes)
 663                 (current-nfp-tn vop)))
 664          (single-stack
 665           (inst ldl bits
 666                 (* (tn-offset float) n-word-bytes)
 667                 (current-nfp-tn vop)))
 668          (descriptor-reg
 669           (loadw bits float single-float-value-slot
 670                  other-pointer-lowtag))))
 671       (signed-stack
 672        (sc-case float
 673          (single-reg
 674           (inst sts float
 675                 (* (tn-offset bits) n-word-bytes)
 676                 (current-nfp-tn vop))))))))
 677
 678 (define-vop (double-float-high-bits)
 679   (:args (float :scs (double-reg descriptor-reg)
 680                 :load-if (not (sc-is float double-stack))))
 681   (:results (hi-bits :scs (signed-reg)))
 682   (:temporary (:scs (double-stack)) stack-temp)
 683   (:arg-types double-float)
 684   (:result-types signed-num)
 685   (:translate double-float-high-bits)
 686   (:policy :fast-safe)
 687   (:vop-var vop)
 688   (:generator 5
 689     (sc-case float
 690       (double-reg
 691         (inst stt float
 692               (* (tn-offset stack-temp) n-word-bytes)
 693               (current-nfp-tn vop))
 694         (inst ldl hi-bits
 695               (* (1+ (tn-offset stack-temp)) n-word-bytes)
 696               (current-nfp-tn vop)))
 697       (double-stack
 698         (inst ldl hi-bits
 699               (* (1+ (tn-offset float)) n-word-bytes)
 700               (current-nfp-tn vop)))
 701       (descriptor-reg
 702         (loadw hi-bits float (1+ double-float-value-slot)
 703                other-pointer-lowtag)))))
 704
 705 (define-vop (double-float-low-bits)
 706   (:args (float :scs (double-reg descriptor-reg)
 707                 :load-if (not (sc-is float double-stack))))
 708   (:results (lo-bits :scs (unsigned-reg)))
 709   (:temporary (:scs (double-stack)) stack-temp)
 710   (:arg-types double-float)
 711   (:result-types unsigned-num)
 712   (:translate double-float-low-bits)
 713   (:policy :fast-safe)
 714   (:vop-var vop)
 715   (:generator 5
 716     (sc-case float
 717       (double-reg
 718         (inst stt float
 719               (* (tn-offset stack-temp) n-word-bytes)
 720               (current-nfp-tn vop))
 721         (inst ldl lo-bits
 722               (* (tn-offset stack-temp) n-word-bytes)
 723               (current-nfp-tn vop)))
 724       (double-stack
 725        (inst ldl lo-bits
 726              (* (tn-offset float) n-word-bytes)
 727              (current-nfp-tn vop)))
 728       (descriptor-reg
 729        (loadw lo-bits float double-float-value-slot
 730               other-pointer-lowtag)))
 731     (inst mskll lo-bits 4 lo-bits)))
 732
 733 \f
 734 ;;;; float mode hackery
 735
 736 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
 737 (defknown floating-point-modes () float-modes (flushable))
 738 (defknown ((setf floating-point-modes)) (float-modes)
 739   float-modes)
 740
 741 ;;; Modes bits are (byte 12 52) of fpcr. Grab and return in low bits.
 742 (define-vop (floating-point-modes)
 743   (:results (res :scs (unsigned-reg)))
 744   (:result-types unsigned-num)
 745   (:translate floating-point-modes)
 746   (:policy :fast-safe)
 747   (:vop-var vop)
 748   (:temporary (:sc double-stack) temp)
 749   (:temporary (:sc double-reg) temp1)
 750   (:generator 5
 751     (let ((nfp (current-nfp-tn vop)))
 752       (inst excb)
 753       (inst mf_fpcr temp1 temp1 temp1)
 754       (inst excb)
 755       (inst stt temp1 (* n-word-bytes (tn-offset temp)) nfp)
 756       (inst ldl res   (* (1+ (tn-offset temp)) n-word-bytes) nfp)
 757       (inst srl res 49 res))))
 758
 759 (define-vop (set-floating-point-modes)
 760   (:args (new :scs (unsigned-reg) :target res))
 761   (:results (res :scs (unsigned-reg)))
 762   (:arg-types unsigned-num)
 763   (:result-types unsigned-num)
 764   (:translate (setf floating-point-modes))
 765   (:policy :fast-safe)
 766   (:temporary (:sc double-stack) temp)
 767   (:temporary (:sc double-reg) temp1)
 768   (:vop-var vop)
 769   (:generator 8
 770     (let ((nfp (current-nfp-tn vop)))
 771       (inst sll new  49 res)
 772       (inst stl zero-tn  (* (tn-offset temp) n-word-bytes) nfp)
 773       (inst stl res   (* (1+ (tn-offset temp)) n-word-bytes) nfp)
 774       (inst ldt temp1 (* (tn-offset temp) n-word-bytes) nfp)
 775       (inst excb)
 776       (inst mt_fpcr temp1 temp1 temp1)
 777       (inst excb)
 778       (move res new))))
 779
 780 \f
 781 ;;;; complex float VOPs
 782
 783 (define-vop (make-complex-single-float)
 784   (:translate complex)
 785   (:args (real :scs (single-reg) :target r)
 786          (imag :scs (single-reg) :to :save))
 787   (:arg-types single-float single-float)
 788   (:results (r :scs (complex-single-reg) :from (:argument 0)
 789                :load-if (not (sc-is r complex-single-stack))))
 790   (:result-types complex-single-float)
 791   (:note "inline complex single-float creation")
 792   (:policy :fast-safe)
 793   (:vop-var vop)
 794   (:generator 5
 795     (sc-case r
 796       (complex-single-reg
 797        (let ((r-real (complex-single-reg-real-tn r)))
 798          (unless (location= real r-real)
 799            (inst fmove real r-real)))
 800        (let ((r-imag (complex-single-reg-imag-tn r)))
 801          (unless (location= imag r-imag)
 802            (inst fmove imag r-imag))))
 803       (complex-single-stack
 804        (let ((nfp (current-nfp-tn vop))
 805              (offset (* (tn-offset r) n-word-bytes)))
 806          (inst sts real offset nfp)
 807          (inst sts imag (+ offset n-word-bytes) nfp))))))
 808
 809 (define-vop (make-complex-double-float)
 810   (:translate complex)
 811   (:args (real :scs (double-reg) :target r)
 812          (imag :scs (double-reg) :to :save))
 813   (:arg-types double-float double-float)
 814   (:results (r :scs (complex-double-reg) :from (:argument 0)
 815                :load-if (not (sc-is r complex-double-stack))))
 816   (:result-types complex-double-float)
 817   (:note "inline complex double-float creation")
 818   (:policy :fast-safe)
 819   (:vop-var vop)
 820   (:generator 5
 821     (sc-case r
 822       (complex-double-reg
 823        (let ((r-real (complex-double-reg-real-tn r)))
 824          (unless (location= real r-real)
 825            (inst fmove real r-real)))
 826        (let ((r-imag (complex-double-reg-imag-tn r)))
 827          (unless (location= imag r-imag)
 828            (inst fmove imag r-imag))))
 829       (complex-double-stack
 830        (let ((nfp (current-nfp-tn vop))
 831              (offset (* (tn-offset r) n-word-bytes)))
 832          (inst stt real offset nfp)
 833          (inst stt imag (+ offset (* 2 n-word-bytes)) nfp))))))
 834
 835 (define-vop (complex-single-float-value)
 836   (:args (x :scs (complex-single-reg) :target r
 837             :load-if (not (sc-is x complex-single-stack))))
 838   (:arg-types complex-single-float)
 839   (:results (r :scs (single-reg)))
 840   (:result-types single-float)
 841   (:variant-vars slot)
 842   (:policy :fast-safe)
 843   (:vop-var vop)
 844   (:generator 3
 845     (sc-case x
 846       (complex-single-reg
 847        (let ((value-tn (ecase slot
 848                          (:real (complex-single-reg-real-tn x))
 849                          (:imag (complex-single-reg-imag-tn x)))))
 850          (unless (location= value-tn r)
 851            (inst fmove value-tn r))))
 852       (complex-single-stack
 853        (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
 854                       n-word-bytes)
 855              (current-nfp-tn vop))))))
 856
 857 (define-vop (realpart/complex-single-float complex-single-float-value)
 858   (:translate realpart)
 859   (:note "complex single float realpart")
 860   (:variant :real))
 861
 862 (define-vop (imagpart/complex-single-float complex-single-float-value)
 863   (:translate imagpart)
 864   (:note "complex single float imagpart")
 865   (:variant :imag))
 866
 867 (define-vop (complex-double-float-value)
 868   (:args (x :scs (complex-double-reg) :target r
 869             :load-if (not (sc-is x complex-double-stack))))
 870   (:arg-types complex-double-float)
 871   (:results (r :scs (double-reg)))
 872   (:result-types double-float)
 873   (:variant-vars slot)
 874   (:policy :fast-safe)
 875   (:vop-var vop)
 876   (:generator 3
 877     (sc-case x
 878       (complex-double-reg
 879        (let ((value-tn (ecase slot
 880                          (:real (complex-double-reg-real-tn x))
 881                          (:imag (complex-double-reg-imag-tn x)))))
 882          (unless (location= value-tn r)
 883            (inst fmove value-tn r))))
 884       (complex-double-stack
 885        (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
 886                       n-word-bytes)
 887              (current-nfp-tn vop))))))
 888
 889 (define-vop (realpart/complex-double-float complex-double-float-value)
 890   (:translate realpart)
 891   (:note "complex double float realpart")
 892   (:variant :real))
 893
 894 (define-vop (imagpart/complex-double-float complex-double-float-value)
 895   (:translate imagpart)
 896   (:note "complex double float imagpart")
 897   (:variant :imag))