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