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