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