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