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