src/compiler/alpha/float.lisp

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