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-arg
 122                   (,sc descriptor-reg) (,sc)))))
 123   (frob move-single-float-arg single-reg single-stack nil)
 124   (frob move-double-float-arg 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-ARG VOP
 310 ;;;
 311 (define-vop (move-complex-single-float-arg)
 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-arg :move-arg
 333   (complex-single-reg descriptor-reg) (complex-single-reg))
 334
 335 (define-vop (move-complex-double-float-arg)
 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-arg :move-arg
 357   (complex-double-reg descriptor-reg) (complex-double-reg))
 358
 359
 360 (define-move-vop move-arg :move-arg
 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)
 482            `(define-vop (,name)
 483               (:args (x :scs (signed-reg) :target temp
 484                         :load-if (not (sc-is x signed-stack))))
 485              (:temporary (:scs (,to-sc)) freg1)
 486              (:temporary (:scs (,to-sc)) freg2)
 487              (:temporary (:scs (single-stack)) temp)
 488
 489              (:results (y :scs (,to-sc)))
 490               (:arg-types signed-num)
 491               (:result-types ,to-type)
 492               (:policy :fast-safe)
 493               (:note "inline float coercion")
 494               (:translate ,translate)
 495               (:vop-var vop)
 496               (:save-p :compute-only)
 497               (:generator 5
 498                           (let ((stack-tn
 499                                  (sc-case x
 500                                           (signed-reg
 501                                            (inst stl x
 502                                                  (* (tn-offset temp)
 503                                                     n-word-bytes)
 504                                                  (current-nfp-tn vop))
 505                                            temp)
 506                                           (signed-stack
 507                                            x))))
 508                             (inst ,ld-inst freg1
 509                                   (* (tn-offset stack-tn) n-word-bytes)
 510                                   (current-nfp-tn vop))
 511                             (note-this-location vop :internal-error)
 512                             (inst cvtlq freg1 freg2)
 513                             (inst ,inst freg2 y)
 514                             (inst excb)
 515                             )))))
 516   (frob %single-float/signed %single-float cvtqs_sui lds single-reg single-float)
 517   (frob %double-float/signed %double-float cvtqt_sui lds double-reg double-float))
 518
 519 ;;; see previous comment about software trap handlers: also applies here
 520 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
 521              `(define-vop (,name)
 522                (:args (x :scs (,from-sc)))
 523                (:results (y :scs (,to-sc) :from :load))
 524                (:arg-types ,from-type)
 525                (:result-types ,to-type)
 526                (:policy :fast-safe)
 527                (:note "inline float coercion")
 528                (:translate ,translate)
 529                (:vop-var vop)
 530                (:save-p :compute-only)
 531                (:generator 2
 532                 (note-this-location vop :internal-error)
 533                 (inst ,inst x y)
 534                 (inst excb)
 535                 ))))
 536   (frob %single-float/double-float %single-float cvtts_su
 537         double-reg double-float single-reg single-float)
 538   (frob %double-float/single-float %double-float fmove
 539         single-reg single-float double-reg double-float))
 540
 541 (macrolet
 542     ((frob (trans from-sc from-type inst &optional single)
 543        (declare (ignorable single))
 544        `(define-vop (,(symbolicate trans "/" from-type))
 545          (:args (x :scs (,from-sc) :target temp))
 546          (:temporary (:from :load ;(:argument 0)
 547                       :sc single-reg) temp)
 548          (:temporary (:scs (signed-stack)) stack-temp)
 549          (:results (y :scs (signed-reg)
 550                     :load-if (not (sc-is y signed-stack))))
 551          (:arg-types ,from-type)
 552          (:result-types signed-num)
 553          (:translate ,trans)
 554          (:policy :fast-safe)
 555          (:note "inline float truncate")
 556          (:vop-var vop)
 557          (:save-p :compute-only)
 558          (:generator 5
 559           (note-this-location vop :internal-error)
 560           (inst ,inst x temp)
 561           (sc-case y
 562            (signed-stack
 563             (inst stt temp
 564                   (* (tn-offset y) n-word-bytes)
 565                   (current-nfp-tn vop)))
 566            (signed-reg
 567             (inst stt temp
 568                   (* (tn-offset stack-temp)
 569                      n-word-bytes)
 570                   (current-nfp-tn vop))
 571             (inst ldq y
 572                   (* (tn-offset stack-temp) n-word-bytes)
 573                   (current-nfp-tn vop))))
 574           (inst excb)
 575           ))))
 576   (frob %unary-truncate/single-float single-reg single-float cvttq/c_sv t)
 577   (frob %unary-truncate/double-float double-reg double-float cvttq/c_sv)
 578   (frob %unary-round single-reg single-float cvttq_sv t)
 579   (frob %unary-round double-reg double-float cvttq_sv))
 580
 581 (define-vop (make-single-float)
 582   (:args (bits :scs (signed-reg) :target res
 583                :load-if (not (sc-is bits signed-stack))))
 584   (:results (res :scs (single-reg)
 585                  :load-if (not (sc-is res single-stack))))
 586   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
 587   (:temporary (:scs (signed-stack)) stack-temp)
 588   (:arg-types signed-num)
 589   (:result-types single-float)
 590   (:translate make-single-float)
 591   (:policy :fast-safe)
 592   (:vop-var vop)
 593   (:generator 4
 594     (sc-case bits
 595       (signed-reg
 596        (sc-case res
 597          (single-reg
 598           (inst stl bits
 599                 (* (tn-offset stack-temp) n-word-bytes)
 600                 (current-nfp-tn vop))
 601           (inst lds res
 602                 (* (tn-offset stack-temp) n-word-bytes)
 603                 (current-nfp-tn vop)))
 604          (single-stack
 605           (inst stl bits
 606                 (* (tn-offset res) n-word-bytes)
 607                 (current-nfp-tn vop)))))
 608       (signed-stack
 609        (sc-case res
 610          (single-reg
 611           (inst lds res
 612                 (* (tn-offset bits) n-word-bytes)
 613                 (current-nfp-tn vop)))
 614          (single-stack
 615           (unless (location= bits res)
 616             (inst ldl temp
 617                   (* (tn-offset bits) n-word-bytes)
 618                   (current-nfp-tn vop))
 619             (inst stl temp
 620                   (* (tn-offset res) n-word-bytes)
 621                   (current-nfp-tn vop)))))))))
 622
 623 (define-vop (make-double-float)
 624   (:args (hi-bits :scs (signed-reg))
 625          (lo-bits :scs (unsigned-reg)))
 626   (:results (res :scs (double-reg)
 627                  :load-if (not (sc-is res double-stack))))
 628   (:temporary (:scs (double-stack)) temp)
 629   (:arg-types signed-num unsigned-num)
 630   (:result-types double-float)
 631   (:translate make-double-float)
 632   (:policy :fast-safe)
 633   (:vop-var vop)
 634   (:generator 2
 635     (let ((stack-tn (sc-case res
 636                       (double-stack res)
 637                       (double-reg temp))))
 638       (inst stl hi-bits
 639             (* (1+ (tn-offset stack-tn)) n-word-bytes)
 640             (current-nfp-tn vop))
 641       (inst stl lo-bits
 642             (* (tn-offset stack-tn) n-word-bytes)
 643             (current-nfp-tn vop)))
 644     (when (sc-is res double-reg)
 645       (inst ldt res
 646             (* (tn-offset temp) n-word-bytes)
 647             (current-nfp-tn vop)))))
 648
 649 (define-vop (single-float-bits)
 650   (:args (float :scs (single-reg descriptor-reg)
 651                 :load-if (not (sc-is float single-stack))))
 652   (:results (bits :scs (signed-reg)
 653                   :load-if (or (sc-is float descriptor-reg single-stack)
 654                                (not (sc-is bits signed-stack)))))
 655   (:temporary (:scs (signed-stack)) stack-temp)
 656   (:arg-types single-float)
 657   (:result-types signed-num)
 658   (:translate single-float-bits)
 659   (:policy :fast-safe)
 660   (:vop-var vop)
 661   (:generator 4
 662     (sc-case bits
 663       (signed-reg
 664        (sc-case float
 665          (single-reg
 666           (inst sts float
 667                 (* (tn-offset stack-temp) n-word-bytes)
 668                 (current-nfp-tn vop))
 669           (inst ldl bits
 670                 (* (tn-offset stack-temp) n-word-bytes)
 671                 (current-nfp-tn vop)))
 672          (single-stack
 673           (inst ldl bits
 674                 (* (tn-offset float) n-word-bytes)
 675                 (current-nfp-tn vop)))
 676          (descriptor-reg
 677           (loadw bits float single-float-value-slot
 678                  other-pointer-lowtag))))
 679       (signed-stack
 680        (sc-case float
 681          (single-reg
 682           (inst sts float
 683                 (* (tn-offset bits) n-word-bytes)
 684                 (current-nfp-tn vop))))))))
 685
 686 (define-vop (double-float-high-bits)
 687   (:args (float :scs (double-reg descriptor-reg)
 688                 :load-if (not (sc-is float double-stack))))
 689   (:results (hi-bits :scs (signed-reg)))
 690   (:temporary (:scs (double-stack)) stack-temp)
 691   (:arg-types double-float)
 692   (:result-types signed-num)
 693   (:translate double-float-high-bits)
 694   (:policy :fast-safe)
 695   (:vop-var vop)
 696   (:generator 5
 697     (sc-case float
 698       (double-reg
 699         (inst stt float
 700               (* (tn-offset stack-temp) n-word-bytes)
 701               (current-nfp-tn vop))
 702         (inst ldl hi-bits
 703               (* (1+ (tn-offset stack-temp)) n-word-bytes)
 704               (current-nfp-tn vop)))
 705       (double-stack
 706         (inst ldl hi-bits
 707               (* (1+ (tn-offset float)) n-word-bytes)
 708               (current-nfp-tn vop)))
 709       (descriptor-reg
 710         (loadw hi-bits float (1+ double-float-value-slot)
 711                other-pointer-lowtag)))))
 712
 713 (define-vop (double-float-low-bits)
 714   (:args (float :scs (double-reg descriptor-reg)
 715                 :load-if (not (sc-is float double-stack))))
 716   (:results (lo-bits :scs (unsigned-reg)))
 717   (:temporary (:scs (double-stack)) stack-temp)
 718   (:arg-types double-float)
 719   (:result-types unsigned-num)
 720   (:translate double-float-low-bits)
 721   (:policy :fast-safe)
 722   (:vop-var vop)
 723   (:generator 5
 724     (sc-case float
 725       (double-reg
 726         (inst stt float
 727               (* (tn-offset stack-temp) n-word-bytes)
 728               (current-nfp-tn vop))
 729         (inst ldl lo-bits
 730               (* (tn-offset stack-temp) n-word-bytes)
 731               (current-nfp-tn vop)))
 732       (double-stack
 733        (inst ldl lo-bits
 734              (* (tn-offset float) n-word-bytes)
 735              (current-nfp-tn vop)))
 736       (descriptor-reg
 737        (loadw lo-bits float double-float-value-slot
 738               other-pointer-lowtag)))
 739     (inst mskll lo-bits 4 lo-bits)))
 740
 741 \f
 742 ;;;; float mode hackery has moved to alpha-vm.lisp
 743
 744 \f
 745 ;;;; complex float VOPs
 746
 747 (define-vop (make-complex-single-float)
 748   (:translate complex)
 749   (:args (real :scs (single-reg) :target r)
 750          (imag :scs (single-reg) :to :save))
 751   (:arg-types single-float single-float)
 752   (:results (r :scs (complex-single-reg) :from (:argument 0)
 753                :load-if (not (sc-is r complex-single-stack))))
 754   (:result-types complex-single-float)
 755   (:note "inline complex single-float creation")
 756   (:policy :fast-safe)
 757   (:vop-var vop)
 758   (:generator 5
 759     (sc-case r
 760       (complex-single-reg
 761        (let ((r-real (complex-single-reg-real-tn r)))
 762          (unless (location= real r-real)
 763            (inst fmove real r-real)))
 764        (let ((r-imag (complex-single-reg-imag-tn r)))
 765          (unless (location= imag r-imag)
 766            (inst fmove imag r-imag))))
 767       (complex-single-stack
 768        (let ((nfp (current-nfp-tn vop))
 769              (offset (* (tn-offset r) n-word-bytes)))
 770          (inst sts real offset nfp)
 771          (inst sts imag (+ offset n-word-bytes) nfp))))))
 772
 773 (define-vop (make-complex-double-float)
 774   (:translate complex)
 775   (:args (real :scs (double-reg) :target r)
 776          (imag :scs (double-reg) :to :save))
 777   (:arg-types double-float double-float)
 778   (:results (r :scs (complex-double-reg) :from (:argument 0)
 779                :load-if (not (sc-is r complex-double-stack))))
 780   (:result-types complex-double-float)
 781   (:note "inline complex double-float creation")
 782   (:policy :fast-safe)
 783   (:vop-var vop)
 784   (:generator 5
 785     (sc-case r
 786       (complex-double-reg
 787        (let ((r-real (complex-double-reg-real-tn r)))
 788          (unless (location= real r-real)
 789            (inst fmove real r-real)))
 790        (let ((r-imag (complex-double-reg-imag-tn r)))
 791          (unless (location= imag r-imag)
 792            (inst fmove imag r-imag))))
 793       (complex-double-stack
 794        (let ((nfp (current-nfp-tn vop))
 795              (offset (* (tn-offset r) n-word-bytes)))
 796          (inst stt real offset nfp)
 797          (inst stt imag (+ offset (* 2 n-word-bytes)) nfp))))))
 798
 799 (define-vop (complex-single-float-value)
 800   (:args (x :scs (complex-single-reg) :target r
 801             :load-if (not (sc-is x complex-single-stack))))
 802   (:arg-types complex-single-float)
 803   (:results (r :scs (single-reg)))
 804   (:result-types single-float)
 805   (:variant-vars slot)
 806   (:policy :fast-safe)
 807   (:vop-var vop)
 808   (:generator 3
 809     (sc-case x
 810       (complex-single-reg
 811        (let ((value-tn (ecase slot
 812                          (:real (complex-single-reg-real-tn x))
 813                          (:imag (complex-single-reg-imag-tn x)))))
 814          (unless (location= value-tn r)
 815            (inst fmove value-tn r))))
 816       (complex-single-stack
 817        (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
 818                       n-word-bytes)
 819              (current-nfp-tn vop))))))
 820
 821 (define-vop (realpart/complex-single-float complex-single-float-value)
 822   (:translate realpart)
 823   (:note "complex single float realpart")
 824   (:variant :real))
 825
 826 (define-vop (imagpart/complex-single-float complex-single-float-value)
 827   (:translate imagpart)
 828   (:note "complex single float imagpart")
 829   (:variant :imag))
 830
 831 (define-vop (complex-double-float-value)
 832   (:args (x :scs (complex-double-reg) :target r
 833             :load-if (not (sc-is x complex-double-stack))))
 834   (:arg-types complex-double-float)
 835   (:results (r :scs (double-reg)))
 836   (:result-types double-float)
 837   (:variant-vars slot)
 838   (:policy :fast-safe)
 839   (:vop-var vop)
 840   (:generator 3
 841     (sc-case x
 842       (complex-double-reg
 843        (let ((value-tn (ecase slot
 844                          (:real (complex-double-reg-real-tn x))
 845                          (:imag (complex-double-reg-imag-tn x)))))
 846          (unless (location= value-tn r)
 847            (inst fmove value-tn r))))
 848       (complex-double-stack
 849        (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
 850                       n-word-bytes)
 851              (current-nfp-tn vop))))))
 852
 853 (define-vop (realpart/complex-double-float complex-double-float-value)
 854   (:translate realpart)
 855   (:note "complex double float realpart")
 856   (:variant :real))
 857
 858 (define-vop (imagpart/complex-double-float complex-double-float-value)
 859   (:translate imagpart)
 860   (:note "complex double float imagpart")
 861   (:variant :imag))
 862