src/compiler/x86-64/float.lisp

   1 ;;;; floating point support for the x86
   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 (macrolet ((ea-for-xf-desc (tn slot)
  15              `(make-ea
  16                :qword :base ,tn
  17                :disp (- (* ,slot n-word-bytes)
  18                         other-pointer-lowtag))))
  19   (defun ea-for-df-desc (tn)
  20     (ea-for-xf-desc tn double-float-value-slot))
  21   ;; complex floats
  22   (defun ea-for-csf-real-desc (tn)
  23     (ea-for-xf-desc tn complex-single-float-real-slot))
  24   (defun ea-for-csf-imag-desc (tn)
  25     (ea-for-xf-desc tn complex-single-float-imag-slot))
  26   (defun ea-for-cdf-real-desc (tn)
  27     (ea-for-xf-desc tn complex-double-float-real-slot))
  28   (defun ea-for-cdf-imag-desc (tn)
  29     (ea-for-xf-desc tn complex-double-float-imag-slot)))
  30
  31 (macrolet ((ea-for-xf-stack (tn kind)
  32              (declare (ignore kind))
  33              `(make-ea
  34                :qword :base rbp-tn
  35                :disp (frame-byte-offset (tn-offset ,tn)))))
  36   (defun ea-for-sf-stack (tn)
  37     (ea-for-xf-stack tn :single))
  38   (defun ea-for-df-stack (tn)
  39     (ea-for-xf-stack tn :double)))
  40
  41 ;;; complex float stack EAs
  42 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
  43              (declare (ignore kind))
  44              `(make-ea
  45                :qword :base ,base
  46                :disp (frame-byte-offset
  47                       (+ (tn-offset ,tn)
  48                        (cond ((= (tn-offset ,base) rsp-offset)
  49                               sp->fp-offset)
  50                              ((= (tn-offset ,base) rbp-offset)
  51                               0)
  52                              (t (error "Unexpected offset.")))
  53                        (ecase ,slot (:real 0) (:imag 1)))))))
  54   (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
  55     (ea-for-cxf-stack tn :single :real base))
  56   (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
  57     (ea-for-cxf-stack tn :single :imag base))
  58   (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
  59     (ea-for-cxf-stack tn :double :real base))
  60   (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
  61     (ea-for-cxf-stack tn :double :imag base)))
  62
  63 \f
  64 ;;;; move functions
  65
  66 ;;; X is source, Y is destination.
  67
  68 (define-move-fun (load-fp-zero 1) (vop x y)
  69   ((fp-single-zero) (single-reg)
  70    (fp-double-zero) (double-reg))
  71   (identity x)
  72   (sc-case y
  73     (single-reg (inst xorps y y))
  74     (double-reg (inst xorpd y y))))
  75
  76 (define-move-fun (load-single 2) (vop x y)
  77   ((single-stack) (single-reg))
  78   (inst movss y (ea-for-sf-stack x)))
  79
  80 (define-move-fun (store-single 2) (vop x y)
  81   ((single-reg) (single-stack))
  82   (inst movss (ea-for-sf-stack y) x))
  83
  84 (define-move-fun (load-double 2) (vop x y)
  85   ((double-stack) (double-reg))
  86   (inst movsd y (ea-for-df-stack x)))
  87
  88 (define-move-fun (store-double 2) (vop x y)
  89   ((double-reg) (double-stack))
  90   (inst movsd  (ea-for-df-stack y) x))
  91
  92 (eval-when (:compile-toplevel :execute)
  93   (setf *read-default-float-format* 'single-float))
  94 \f
  95 ;;;; complex float move functions
  96
  97 (defun complex-single-reg-real-tn (x)
  98   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
  99                   :offset (tn-offset x)))
 100 (defun complex-single-reg-imag-tn (x)
 101   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 102                   :offset (1+ (tn-offset x))))
 103
 104 (defun complex-double-reg-real-tn (x)
 105   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 106                   :offset (tn-offset x)))
 107 (defun complex-double-reg-imag-tn (x)
 108   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 109                   :offset (1+ (tn-offset x))))
 110
 111 ;;; X is source, Y is destination.
 112 (define-move-fun (load-complex-single 2) (vop x y)
 113   ((complex-single-stack) (complex-single-reg))
 114   (let ((real-tn (complex-single-reg-real-tn y)))
 115     (inst movss real-tn (ea-for-csf-real-stack x)))
 116   (let ((imag-tn (complex-single-reg-imag-tn y)))
 117     (inst movss imag-tn (ea-for-csf-imag-stack x))))
 118
 119 (define-move-fun (store-complex-single 2) (vop x y)
 120   ((complex-single-reg) (complex-single-stack))
 121   (let ((real-tn (complex-single-reg-real-tn x))
 122         (imag-tn (complex-single-reg-imag-tn x)))
 123     (inst movss (ea-for-csf-real-stack y) real-tn)
 124     (inst movss (ea-for-csf-imag-stack y) imag-tn)))
 125
 126 (define-move-fun (load-complex-double 2) (vop x y)
 127   ((complex-double-stack) (complex-double-reg))
 128   (let ((real-tn (complex-double-reg-real-tn y)))
 129     (inst movsd real-tn (ea-for-cdf-real-stack x)))
 130   (let ((imag-tn (complex-double-reg-imag-tn y)))
 131     (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
 132
 133 (define-move-fun (store-complex-double 2) (vop x y)
 134   ((complex-double-reg) (complex-double-stack))
 135   (let ((real-tn (complex-double-reg-real-tn x))
 136         (imag-tn (complex-double-reg-imag-tn x)))
 137     (inst movsd (ea-for-cdf-real-stack y) real-tn)
 138     (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
 139
 140 \f
 141 ;;;; move VOPs
 142
 143 ;;; float register to register moves
 144 (macrolet ((frob (vop sc)
 145              `(progn
 146                 (define-vop (,vop)
 147                   (:args (x :scs (,sc)
 148                             :target y
 149                             :load-if (not (location= x y))))
 150                   (:results (y :scs (,sc)
 151                                :load-if (not (location= x y))))
 152                   (:note "float move")
 153                   (:generator 0
 154                     (unless (location= y x)
 155                       (inst movq y x))))
 156                 (define-move-vop ,vop :move (,sc) (,sc)))))
 157   (frob single-move single-reg)
 158   (frob double-move double-reg))
 159
 160 ;;; complex float register to register moves
 161 (define-vop (complex-float-move)
 162   (:args (x :target y :load-if (not (location= x y))))
 163   (:results (y :load-if (not (location= x y))))
 164   (:note "complex float move")
 165   (:generator 0
 166      (unless (location= x y)
 167        ;; Note the complex-float-regs are aligned to every second
 168        ;; float register so there is not need to worry about overlap.
 169        ;; (It would be better to put the imagpart in the top half of the
 170        ;; register, or something, but let's worry about that later)
 171        (let ((x-real (complex-single-reg-real-tn x))
 172              (y-real (complex-single-reg-real-tn y)))
 173          (inst movq y-real x-real))
 174        (let ((x-imag (complex-single-reg-imag-tn x))
 175              (y-imag (complex-single-reg-imag-tn y)))
 176          (inst movq y-imag x-imag)))))
 177
 178 (define-vop (complex-single-move complex-float-move)
 179   (:args (x :scs (complex-single-reg) :target y
 180             :load-if (not (location= x y))))
 181   (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
 182 (define-move-vop complex-single-move :move
 183   (complex-single-reg) (complex-single-reg))
 184
 185 (define-vop (complex-double-move complex-float-move)
 186   (:args (x :scs (complex-double-reg)
 187             :target y :load-if (not (location= x y))))
 188   (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
 189 (define-move-vop complex-double-move :move
 190   (complex-double-reg) (complex-double-reg))
 191
 192 \f
 193 ;;; Move from float to a descriptor reg. allocating a new float
 194 ;;; object in the process.
 195 (define-vop (move-from-single)
 196   (:args (x :scs (single-reg) :to :save))
 197   (:results (y :scs (descriptor-reg)))
 198   (:note "float to pointer coercion")
 199   (:generator 4
 200     (inst movd y x)
 201     (inst shl y 32)
 202     (inst or y single-float-widetag)))
 203
 204 (define-move-vop move-from-single :move
 205   (single-reg) (descriptor-reg))
 206
 207 (define-vop (move-from-double)
 208   (:args (x :scs (double-reg) :to :save))
 209   (:results (y :scs (descriptor-reg)))
 210   (:node-var node)
 211   (:note "float to pointer coercion")
 212   (:generator 13
 213      (with-fixed-allocation (y
 214                              double-float-widetag
 215                              double-float-size
 216                              node)
 217        (inst movsd (ea-for-df-desc y) x))))
 218 (define-move-vop move-from-double :move
 219   (double-reg) (descriptor-reg))
 220
 221 ;;; Move from a descriptor to a float register.
 222 (define-vop (move-to-single)
 223   (:args (x :scs (descriptor-reg) :target tmp))
 224   (:temporary (:sc unsigned-reg) tmp)
 225   (:results (y :scs (single-reg)))
 226   (:note "pointer to float coercion")
 227   (:generator 2
 228     (move tmp x)
 229     (inst shr tmp 32)
 230     (inst movd y tmp)))
 231
 232 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
 233
 234 (define-vop (move-to-double)
 235   (:args (x :scs (descriptor-reg)))
 236   (:results (y :scs (double-reg)))
 237   (:note "pointer to float coercion")
 238   (:generator 2
 239     (inst movsd y (ea-for-df-desc x))))
 240 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
 241
 242 \f
 243 ;;; Move from complex float to a descriptor reg. allocating a new
 244 ;;; complex float object in the process.
 245 (define-vop (move-from-complex-single)
 246   (:args (x :scs (complex-single-reg) :to :save))
 247   (:results (y :scs (descriptor-reg)))
 248   (:node-var node)
 249   (:note "complex float to pointer coercion")
 250   (:generator 13
 251      (with-fixed-allocation (y
 252                              complex-single-float-widetag
 253                              complex-single-float-size
 254                              node)
 255        (let ((real-tn (complex-single-reg-real-tn x)))
 256          (inst movss (ea-for-csf-real-desc y) real-tn))
 257        (let ((imag-tn (complex-single-reg-imag-tn x)))
 258          (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
 259 (define-move-vop move-from-complex-single :move
 260   (complex-single-reg) (descriptor-reg))
 261
 262 (define-vop (move-from-complex-double)
 263   (:args (x :scs (complex-double-reg) :to :save))
 264   (:results (y :scs (descriptor-reg)))
 265   (:node-var node)
 266   (:note "complex float to pointer coercion")
 267   (:generator 13
 268      (with-fixed-allocation (y
 269                              complex-double-float-widetag
 270                              complex-double-float-size
 271                              node)
 272        (let ((real-tn (complex-double-reg-real-tn x)))
 273          (inst movsd (ea-for-cdf-real-desc y) real-tn))
 274        (let ((imag-tn (complex-double-reg-imag-tn x)))
 275          (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
 276 (define-move-vop move-from-complex-double :move
 277   (complex-double-reg) (descriptor-reg))
 278
 279 ;;; Move from a descriptor to a complex float register.
 280 (macrolet ((frob (name sc format)
 281              `(progn
 282                 (define-vop (,name)
 283                   (:args (x :scs (descriptor-reg)))
 284                   (:results (y :scs (,sc)))
 285                   (:note "pointer to complex float coercion")
 286                   (:generator 2
 287                     (let ((real-tn (complex-double-reg-real-tn y)))
 288                       ,@(ecase
 289                          format
 290                          (:single
 291                           '((inst movss real-tn (ea-for-csf-real-desc x))))
 292                          (:double
 293                           '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
 294                     (let ((imag-tn (complex-double-reg-imag-tn y)))
 295                       ,@(ecase
 296                          format
 297                          (:single
 298                           '((inst movss imag-tn (ea-for-csf-imag-desc x))))
 299                          (:double
 300                           '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
 301                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 302   (frob move-to-complex-single complex-single-reg :single)
 303   (frob move-to-complex-double complex-double-reg :double))
 304 \f
 305 ;;;; the move argument vops
 306 ;;;;
 307 ;;;; Note these are also used to stuff fp numbers onto the c-call
 308 ;;;; stack so the order is different than the lisp-stack.
 309
 310 ;;; the general MOVE-ARG VOP
 311 (macrolet ((frob (name sc stack-sc format)
 312              `(progn
 313                 (define-vop (,name)
 314                   (:args (x :scs (,sc) :target y)
 315                          (fp :scs (any-reg)
 316                              :load-if (not (sc-is y ,sc))))
 317                   (:results (y))
 318                   (:note "float argument move")
 319                   (:generator ,(case format (:single 2) (:double 3) )
 320                     (sc-case y
 321                       (,sc
 322                        (unless (location= x y)
 323                          (inst movq y x)))
 324                       (,stack-sc
 325                        (if (= (tn-offset fp) esp-offset)
 326                            (let* ((offset (* (tn-offset y) n-word-bytes))
 327                                   (ea (make-ea :dword :base fp :disp offset)))
 328                              ,@(ecase format
 329                                       (:single '((inst movss ea x)))
 330                                       (:double '((inst movsd ea x)))))
 331                            (let ((ea (make-ea
 332                                       :dword :base fp
 333                                       :disp (frame-byte-offset (tn-offset y)))))
 334                              ,@(ecase format
 335                                  (:single '((inst movss ea x)))
 336                                  (:double '((inst movsd ea x))))))))))
 337                 (define-move-vop ,name :move-arg
 338                   (,sc descriptor-reg) (,sc)))))
 339   (frob move-single-float-arg single-reg single-stack :single)
 340   (frob move-double-float-arg double-reg double-stack :double))
 341
 342 ;;;; complex float MOVE-ARG VOP
 343 (macrolet ((frob (name sc stack-sc format)
 344              `(progn
 345                 (define-vop (,name)
 346                   (:args (x :scs (,sc) :target y)
 347                          (fp :scs (any-reg)
 348                              :load-if (not (sc-is y ,sc))))
 349                   (:results (y))
 350                   (:note "complex float argument move")
 351                   (:generator ,(ecase format (:single 2) (:double 3))
 352                     (sc-case y
 353                       (,sc
 354                        (unless (location= x y)
 355                          (let ((x-real (complex-double-reg-real-tn x))
 356                                (y-real (complex-double-reg-real-tn y)))
 357                            (inst movsd y-real x-real))
 358                          (let ((x-imag (complex-double-reg-imag-tn x))
 359                                (y-imag (complex-double-reg-imag-tn y)))
 360                            (inst movsd y-imag x-imag))))
 361                       (,stack-sc
 362                        (let ((real-tn (complex-double-reg-real-tn x)))
 363                          ,@(ecase format
 364                                   (:single
 365                                    '((inst movss
 366                                       (ea-for-csf-real-stack y fp)
 367                                       real-tn)))
 368                                   (:double
 369                                    '((inst movsd
 370                                       (ea-for-cdf-real-stack y fp)
 371                                       real-tn)))))
 372                        (let ((imag-tn (complex-double-reg-imag-tn x)))
 373                          ,@(ecase format
 374                                   (:single
 375                                    '((inst movss
 376                                       (ea-for-csf-imag-stack y fp) imag-tn)))
 377                                   (:double
 378                                    '((inst movsd
 379                                       (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
 380                 (define-move-vop ,name :move-arg
 381                   (,sc descriptor-reg) (,sc)))))
 382   (frob move-complex-single-float-arg
 383         complex-single-reg complex-single-stack :single)
 384   (frob move-complex-double-float-arg
 385         complex-double-reg complex-double-stack :double))
 386
 387 (define-move-vop move-arg :move-arg
 388   (single-reg double-reg
 389    complex-single-reg complex-double-reg)
 390   (descriptor-reg))
 391
 392 \f
 393 ;;;; arithmetic VOPs
 394
 395 (define-vop (float-op)
 396   (:args (x) (y))
 397   (:results (r))
 398   (:policy :fast-safe)
 399   (:note "inline float arithmetic")
 400   (:vop-var vop)
 401   (:save-p :compute-only))
 402
 403 (macrolet ((frob (name sc ptype)
 404              `(define-vop (,name float-op)
 405                 (:args (x :scs (,sc) :target r)
 406                        (y :scs (,sc)))
 407                 (:results (r :scs (,sc)))
 408                 (:arg-types ,ptype ,ptype)
 409                 (:result-types ,ptype))))
 410   (frob single-float-op single-reg single-float)
 411   (frob double-float-op double-reg double-float))
 412
 413 (macrolet ((generate (movinst opinst commutative)
 414              `(progn
 415                 (cond
 416                   ((location= x r)
 417                    (inst ,opinst x y))
 418                   ((and ,commutative (location= y r))
 419                    (inst ,opinst y x))
 420                   ((not (location= r y))
 421                    (inst ,movinst r x)
 422                    (inst ,opinst r y))
 423                   (t
 424                    (inst ,movinst tmp x)
 425                    (inst ,opinst tmp y)
 426                    (inst ,movinst r tmp)))))
 427            (frob (op sinst sname scost dinst dname dcost commutative)
 428              `(progn
 429                 (define-vop (,sname single-float-op)
 430                     (:translate ,op)
 431                   (:temporary (:sc single-reg) tmp)
 432                   (:generator ,scost
 433                     (generate movss ,sinst ,commutative)))
 434                 (define-vop (,dname double-float-op)
 435                   (:translate ,op)
 436                   (:temporary (:sc single-reg) tmp)
 437                   (:generator ,dcost
 438                     (generate movsd ,dinst ,commutative))))))
 439   (frob + addss +/single-float 2 addsd +/double-float 2 t)
 440   (frob - subss -/single-float 2 subsd -/double-float 2 nil)
 441   (frob * mulss */single-float 4 mulsd */double-float 5 t)
 442   (frob / divss //single-float 12 divsd //double-float 19 nil))
 443
 444 (define-vop (fsqrt)
 445   (:args (x :scs (double-reg)))
 446   (:results (y :scs (double-reg)))
 447   (:translate %sqrt)
 448   (:policy :fast-safe)
 449   (:arg-types double-float)
 450   (:result-types double-float)
 451   (:note "inline float arithmetic")
 452   (:vop-var vop)
 453   (:save-p :compute-only)
 454   (:generator 1
 455      (note-this-location vop :internal-error)
 456      (inst sqrtsd y x)))
 457 \f
 458 (macrolet ((frob ((name translate sc type) &body body)
 459              `(define-vop (,name)
 460                   (:args (x :scs (,sc)))
 461                 (:results (y :scs (,sc)))
 462                 (:translate ,translate)
 463                 (:policy :fast-safe)
 464                 (:arg-types ,type)
 465                 (:result-types ,type)
 466                 (:temporary (:sc any-reg) hex8)
 467                 (:temporary
 468                  (:sc ,sc) xmm)
 469                 (:note "inline float arithmetic")
 470                 (:vop-var vop)
 471                 (:save-p :compute-only)
 472                 (:generator 1
 473                             (note-this-location vop :internal-error)
 474                             ;; we should be able to do this better.  what we
 475                             ;; really would like to do is use the target as the
 476                             ;; temp whenever it's not also the source
 477                             (unless (location= x y)
 478                               (inst movq y x))
 479                             ,@body))))
 480   (frob (%negate/double-float %negate double-reg double-float)
 481         (inst lea hex8 (make-ea :qword :disp 1))
 482         (inst ror hex8 1)               ; #x8000000000000000
 483         (inst movd xmm hex8)
 484         (inst xorpd y xmm))
 485   (frob (%negate/single-float %negate single-reg single-float)
 486         (inst lea hex8 (make-ea :qword :disp 1))
 487         (inst rol hex8 31)
 488         (inst movd xmm hex8)
 489         (inst xorps y xmm))
 490   (frob (abs/double-float abs  double-reg double-float)
 491         (inst mov hex8 -1)
 492         (inst shr hex8 1)
 493         (inst movd xmm hex8)
 494         (inst andpd y xmm))
 495   (frob (abs/single-float abs  single-reg single-float)
 496         (inst mov hex8 -1)
 497         (inst shr hex8 33)
 498         (inst movd xmm hex8)
 499         (inst andps y xmm)))
 500 \f
 501 ;;;; comparison
 502
 503 (define-vop (float-compare)
 504   (:policy :fast-safe)
 505   (:vop-var vop)
 506   (:save-p :compute-only)
 507   (:note "inline float comparison"))
 508
 509 ;;; comiss and comisd can cope with one or other arg in memory: we
 510 ;;; could (should, indeed) extend these to cope with descriptor args
 511 ;;; and stack args
 512
 513 (define-vop (single-float-compare float-compare)
 514   (:args (x :scs (single-reg)) (y :scs (single-reg)))
 515   (:arg-types single-float single-float))
 516 (define-vop (double-float-compare float-compare)
 517   (:args (x :scs (double-reg)) (y :scs (double-reg)))
 518   (:arg-types double-float double-float))
 519
 520 (define-vop (=/single-float single-float-compare)
 521     (:translate =)
 522   (:info)
 523   (:conditional not :p :ne)
 524   (:vop-var vop)
 525   (:generator 3
 526     (note-this-location vop :internal-error)
 527     (inst comiss x y)
 528     ;; if PF&CF, there was a NaN involved => not equal
 529     ;; otherwise, ZF => equal
 530     ))
 531
 532 (define-vop (=/double-float double-float-compare)
 533     (:translate =)
 534   (:info)
 535   (:conditional not :p :ne)
 536   (:vop-var vop)
 537   (:generator 3
 538     (note-this-location vop :internal-error)
 539     (inst comisd x y)))
 540
 541 (define-vop (<double-float double-float-compare)
 542   (:translate <)
 543   (:info)
 544   (:conditional not :p :nc)
 545   (:generator 3
 546     (inst comisd x y)))
 547
 548 (define-vop (<single-float single-float-compare)
 549   (:translate <)
 550   (:info)
 551   (:conditional not :p :nc)
 552   (:generator 3
 553     (inst comiss x y)))
 554
 555 (define-vop (>double-float double-float-compare)
 556   (:translate >)
 557   (:info)
 558   (:conditional not :p :na)
 559   (:generator 3
 560     (inst comisd x y)))
 561
 562 (define-vop (>single-float single-float-compare)
 563   (:translate >)
 564   (:info)
 565   (:conditional not :p :na)
 566   (:generator 3
 567     (inst comiss x y)))
 568
 569
 570 \f
 571 ;;;; conversion
 572
 573 (macrolet ((frob (name translate inst to-sc to-type)
 574              `(define-vop (,name)
 575                 (:args (x :scs (signed-stack signed-reg) :target temp))
 576                 (:temporary (:sc signed-stack) temp)
 577                 (:results (y :scs (,to-sc)))
 578                 (:arg-types signed-num)
 579                 (:result-types ,to-type)
 580                 (:policy :fast-safe)
 581                 (:note "inline float coercion")
 582                 (:translate ,translate)
 583                 (:vop-var vop)
 584                 (:save-p :compute-only)
 585                 (:generator 5
 586                   (sc-case x
 587                     (signed-reg
 588                      (inst mov temp x)
 589                      (note-this-location vop :internal-error)
 590                      (inst ,inst y temp))
 591                     (signed-stack
 592                      (note-this-location vop :internal-error)
 593                      (inst ,inst y x)))))))
 594   (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
 595   (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
 596
 597 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
 598              `(define-vop (,name)
 599                (:args (x :scs (,from-sc) :target y))
 600                (:results (y :scs (,to-sc)))
 601                (:arg-types ,from-type)
 602                (:result-types ,to-type)
 603                (:policy :fast-safe)
 604                (:note "inline float coercion")
 605                (:translate ,translate)
 606                (:vop-var vop)
 607                (:save-p :compute-only)
 608                (:generator 2
 609                 (note-this-location vop :internal-error)
 610                 (inst ,inst y x)))))
 611   (frob %single-float/double-float %single-float cvtsd2ss double-reg
 612         double-float single-reg single-float)
 613
 614   (frob %double-float/single-float %double-float cvtss2sd
 615         single-reg single-float double-reg double-float))
 616
 617 (macrolet ((frob (trans inst from-sc from-type round-p)
 618              (declare (ignore round-p))
 619              `(define-vop (,(symbolicate trans "/" from-type))
 620                (:args (x :scs (,from-sc)))
 621                (:temporary (:sc any-reg) temp-reg)
 622                (:results (y :scs (signed-reg)))
 623                (:arg-types ,from-type)
 624                (:result-types signed-num)
 625                (:translate ,trans)
 626                (:policy :fast-safe)
 627                (:note "inline float truncate")
 628                (:vop-var vop)
 629                (:save-p :compute-only)
 630                (:generator 5
 631                  (sc-case y
 632                           (signed-stack
 633                            (inst ,inst temp-reg x)
 634                            (move y temp-reg))
 635                           (signed-reg
 636                            (inst ,inst y x)
 637                            ))))))
 638   (frob %unary-truncate cvttss2si single-reg single-float nil)
 639   (frob %unary-truncate cvttsd2si double-reg double-float nil)
 640
 641   (frob %unary-round cvtss2si single-reg single-float t)
 642   (frob %unary-round cvtsd2si double-reg double-float t))
 643
 644 (define-vop (make-single-float)
 645   (:args (bits :scs (signed-reg) :target res
 646                :load-if (not (or (and (sc-is bits signed-stack)
 647                                       (sc-is res single-reg))
 648                                  (and (sc-is bits signed-stack)
 649                                       (sc-is res single-stack)
 650                                       (location= bits res))))))
 651   (:results (res :scs (single-reg single-stack)))
 652   (:arg-types signed-num)
 653   (:result-types single-float)
 654   (:translate make-single-float)
 655   (:policy :fast-safe)
 656   (:vop-var vop)
 657   (:generator 4
 658     (sc-case res
 659        (single-stack
 660         (sc-case bits
 661           (signed-reg
 662            (inst mov res bits))
 663           (signed-stack
 664            (aver (location= bits res)))))
 665        (single-reg
 666         (sc-case bits
 667           (signed-reg
 668            (inst movd res bits))
 669           (signed-stack
 670            (inst movd res bits)))))))
 671
 672 (define-vop (make-double-float)
 673   (:args (hi-bits :scs (signed-reg))
 674          (lo-bits :scs (unsigned-reg)))
 675   (:results (res :scs (double-reg)))
 676   (:temporary (:sc unsigned-reg) temp)
 677   (:arg-types signed-num unsigned-num)
 678   (:result-types double-float)
 679   (:translate make-double-float)
 680   (:policy :fast-safe)
 681   (:vop-var vop)
 682   (:generator 2
 683     (move temp hi-bits)
 684     (inst shl temp 32)
 685     (inst or temp lo-bits)
 686     (inst movd res temp)))
 687
 688 (define-vop (single-float-bits)
 689   (:args (float :scs (single-reg descriptor-reg)
 690                 :load-if (not (sc-is float single-stack))))
 691   (:results (bits :scs (signed-reg)))
 692   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
 693   (:arg-types single-float)
 694   (:result-types signed-num)
 695   (:translate single-float-bits)
 696   (:policy :fast-safe)
 697   (:vop-var vop)
 698   (:generator 4
 699     (sc-case bits
 700       (signed-reg
 701        (sc-case float
 702          (single-reg
 703           (inst movss stack-temp float)
 704           (move bits stack-temp))
 705          (single-stack
 706           (move bits float))
 707          (descriptor-reg
 708           (move bits float)
 709           (inst shr bits 32))))
 710       (signed-stack
 711        (sc-case float
 712          (single-reg
 713           (inst movss bits float)))))
 714     ;; Sign-extend
 715     (inst shl bits 32)
 716     (inst sar bits 32)))
 717
 718 (define-vop (double-float-high-bits)
 719   (:args (float :scs (double-reg descriptor-reg)
 720                 :load-if (not (sc-is float double-stack))))
 721   (:results (hi-bits :scs (signed-reg)))
 722   (:temporary (:sc signed-stack :from :argument :to :result) temp)
 723   (:arg-types double-float)
 724   (:result-types signed-num)
 725   (:translate double-float-high-bits)
 726   (:policy :fast-safe)
 727   (:vop-var vop)
 728   (:generator 5
 729      (sc-case float
 730        (double-reg
 731         (inst movsd temp float)
 732         (move hi-bits temp))
 733        (double-stack
 734         (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
 735        (descriptor-reg
 736         (loadw hi-bits float double-float-value-slot
 737                other-pointer-lowtag)))
 738      (inst sar hi-bits 32)))
 739
 740 (define-vop (double-float-low-bits)
 741   (:args (float :scs (double-reg descriptor-reg)
 742                 :load-if (not (sc-is float double-stack))))
 743   (:results (lo-bits :scs (unsigned-reg)))
 744   (:temporary (:sc signed-stack :from :argument :to :result) temp)
 745   (:arg-types double-float)
 746   (:result-types unsigned-num)
 747   (:translate double-float-low-bits)
 748   (:policy :fast-safe)
 749   (:vop-var vop)
 750   (:generator 5
 751      (sc-case float
 752        (double-reg
 753         (inst movsd temp float)
 754         (move lo-bits temp))
 755        (double-stack
 756         (loadw lo-bits ebp-tn (frame-word-offset (tn-offset float))))
 757        (descriptor-reg
 758         (loadw lo-bits float double-float-value-slot
 759                other-pointer-lowtag)))
 760      (inst shl lo-bits 32)
 761      (inst shr lo-bits 32)))
 762
 763 \f
 764
 765 ;;;; complex float VOPs
 766
 767 (define-vop (make-complex-single-float)
 768   (:translate complex)
 769   (:args (real :scs (single-reg) :to :result :target r
 770                :load-if (not (location= real r)))
 771          (imag :scs (single-reg) :to :save))
 772   (:arg-types single-float single-float)
 773   (:results (r :scs (complex-single-reg) :from (:argument 0)
 774                :load-if (not (sc-is r complex-single-stack))))
 775   (:result-types complex-single-float)
 776   (:note "inline complex single-float creation")
 777   (:policy :fast-safe)
 778   (:generator 5
 779     (sc-case r
 780       (complex-single-reg
 781        (let ((r-real (complex-single-reg-real-tn r)))
 782          (unless (location= real r-real)
 783            (inst movss r-real real)))
 784        (let ((r-imag (complex-single-reg-imag-tn r)))
 785          (unless (location= imag r-imag)
 786            (inst movss r-imag imag))))
 787       (complex-single-stack
 788        (unless (location= real r)
 789          (inst movss (ea-for-csf-real-stack r) real))
 790        (inst movss (ea-for-csf-imag-stack r) imag)))))
 791
 792 (define-vop (make-complex-double-float)
 793   (:translate complex)
 794   (:args (real :scs (double-reg) :target r
 795                :load-if (not (location= real r)))
 796          (imag :scs (double-reg) :to :save))
 797   (:arg-types double-float double-float)
 798   (:results (r :scs (complex-double-reg) :from (:argument 0)
 799                :load-if (not (sc-is r complex-double-stack))))
 800   (:result-types complex-double-float)
 801   (:note "inline complex double-float creation")
 802   (:policy :fast-safe)
 803   (:generator 5
 804     (sc-case r
 805       (complex-double-reg
 806        (let ((r-real (complex-double-reg-real-tn r)))
 807          (unless (location= real r-real)
 808            (inst movsd r-real real)))
 809        (let ((r-imag (complex-double-reg-imag-tn r)))
 810          (unless (location= imag r-imag)
 811            (inst movsd r-imag imag))))
 812       (complex-double-stack
 813        (unless (location= real r)
 814          (inst movsd (ea-for-cdf-real-stack r) real))
 815        (inst movsd (ea-for-cdf-imag-stack r) imag)))))
 816
 817 (define-vop (complex-float-value)
 818   (:args (x :target r))
 819   (:results (r))
 820   (:variant-vars offset)
 821   (:policy :fast-safe)
 822   (:generator 3
 823     (cond ((sc-is x complex-single-reg complex-double-reg)
 824            (let ((value-tn
 825                   (make-random-tn :kind :normal
 826                                   :sc (sc-or-lose 'double-reg)
 827                                   :offset (+ offset (tn-offset x)))))
 828              (unless (location= value-tn r)
 829                (if (sc-is x complex-single-reg)
 830                    (inst movss r value-tn)
 831                    (inst movsd r value-tn)))))
 832           ((sc-is r single-reg)
 833            (let ((ea (sc-case x
 834                        (complex-single-stack
 835                         (ecase offset
 836                           (0 (ea-for-csf-real-stack x))
 837                           (1 (ea-for-csf-imag-stack x))))
 838                        (descriptor-reg
 839                         (ecase offset
 840                           (0 (ea-for-csf-real-desc x))
 841                           (1 (ea-for-csf-imag-desc x)))))))
 842              (inst movss r ea)))
 843           ((sc-is r double-reg)
 844            (let ((ea (sc-case x
 845                        (complex-double-stack
 846                         (ecase offset
 847                           (0 (ea-for-cdf-real-stack x))
 848                           (1 (ea-for-cdf-imag-stack x))))
 849                        (descriptor-reg
 850                         (ecase offset
 851                           (0 (ea-for-cdf-real-desc x))
 852                           (1 (ea-for-cdf-imag-desc x)))))))
 853              (inst movsd r ea)))
 854           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
 855
 856 (define-vop (realpart/complex-single-float complex-float-value)
 857   (:translate realpart)
 858   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
 859             :target r))
 860   (:arg-types complex-single-float)
 861   (:results (r :scs (single-reg)))
 862   (:result-types single-float)
 863   (:note "complex float realpart")
 864   (:variant 0))
 865
 866 (define-vop (realpart/complex-double-float complex-float-value)
 867   (:translate realpart)
 868   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
 869             :target r))
 870   (:arg-types complex-double-float)
 871   (:results (r :scs (double-reg)))
 872   (:result-types double-float)
 873   (:note "complex float realpart")
 874   (:variant 0))
 875
 876 (define-vop (imagpart/complex-single-float complex-float-value)
 877   (:translate imagpart)
 878   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
 879             :target r))
 880   (:arg-types complex-single-float)
 881   (:results (r :scs (single-reg)))
 882   (:result-types single-float)
 883   (:note "complex float imagpart")
 884   (:variant 1))
 885
 886 (define-vop (imagpart/complex-double-float complex-float-value)
 887   (:translate imagpart)
 888   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
 889             :target r))
 890   (:arg-types complex-double-float)
 891   (:results (r :scs (double-reg)))
 892   (:result-types double-float)
 893   (:note "complex float imagpart")
 894   (:variant 1))
 895
 896 \f
 897 ;;; hack dummy VOPs to bias the representation selection of their
 898 ;;; arguments towards a FP register, which can help avoid consing at
 899 ;;; inappropriate locations
 900 (defknown double-float-reg-bias (double-float) (values))
 901 (define-vop (double-float-reg-bias)
 902   (:translate double-float-reg-bias)
 903   (:args (x :scs (double-reg double-stack) :load-if nil))
 904   (:arg-types double-float)
 905   (:policy :fast-safe)
 906   (:note "inline dummy FP register bias")
 907   (:ignore x)
 908   (:generator 0))
 909 (defknown single-float-reg-bias (single-float) (values))
 910 (define-vop (single-float-reg-bias)
 911   (:translate single-float-reg-bias)
 912   (:args (x :scs (single-reg single-stack) :load-if nil))
 913   (:arg-types single-float)
 914   (:policy :fast-safe)
 915   (:note "inline dummy FP register bias")
 916   (:ignore x)
 917   (:generator 0))