src/compiler/x86/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-for-object-slot ,tn ,slot other-pointer-lowtag)))
  16   (defun ea-for-sf-desc (tn)
  17     (ea-for-xf-desc tn single-float-value-slot))
  18   (defun ea-for-df-desc (tn)
  19     (ea-for-xf-desc tn double-float-value-slot))
  20   #!+long-float
  21   (defun ea-for-lf-desc (tn)
  22     (ea-for-xf-desc tn long-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   #!+long-float
  33   (defun ea-for-clf-real-desc (tn)
  34     (ea-for-xf-desc tn complex-long-float-real-slot))
  35   #!+long-float
  36   (defun ea-for-clf-imag-desc (tn)
  37     (ea-for-xf-desc tn complex-long-float-imag-slot)))
  38
  39 (macrolet ((ea-for-xf-stack (tn kind)
  40              `(make-ea
  41                :dword :base ebp-tn
  42                :disp (frame-byte-offset
  43                       (+ (tn-offset ,tn)
  44                        (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
  45   (defun ea-for-sf-stack (tn)
  46     (ea-for-xf-stack tn :single))
  47   (defun ea-for-df-stack (tn)
  48     (ea-for-xf-stack tn :double))
  49   #!+long-float
  50   (defun ea-for-lf-stack (tn)
  51     (ea-for-xf-stack tn :long)))
  52
  53 ;;; Telling the FPU to wait is required in order to make signals occur
  54 ;;; at the expected place, but naturally slows things down.
  55 ;;;
  56 ;;; NODE is the node whose compilation policy controls the decision
  57 ;;; whether to just blast through carelessly or carefully emit wait
  58 ;;; instructions and whatnot.
  59 ;;;
  60 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
  61 ;;; #'NOTE-NEXT-INSTRUCTION.
  62 ;;;
  63 ;;; Until 2004-03-15, the implementation of this was buggy; it
  64 ;;; unconditionally emitted the WAIT instruction.  It turns out that
  65 ;;; this is the right thing to do anyway; omitting them can lead to
  66 ;;; system corruption on conforming code.  -- CSR
  67 (defun maybe-fp-wait (node &optional note-next-instruction)
  68   (declare (ignore node))
  69   #+nil
  70   (when (policy node (or (= debug 3) (> safety speed))))
  71   (when note-next-instruction
  72     (note-next-instruction note-next-instruction :internal-error))
  73   (inst wait))
  74
  75 ;;; complex float stack EAs
  76 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
  77              `(make-ea
  78                :dword :base ,base
  79                :disp (frame-byte-offset
  80                       (+ (tn-offset ,tn)
  81                        -1
  82                        (* (ecase ,kind
  83                             (:single 1)
  84                             (:double 2)
  85                             (:long 3))
  86                           (ecase ,slot (:real 1) (:imag 2))))))))
  87   (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
  88     (ea-for-cxf-stack tn :single :real base))
  89   (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
  90     (ea-for-cxf-stack tn :single :imag base))
  91   (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
  92     (ea-for-cxf-stack tn :double :real base))
  93   (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
  94     (ea-for-cxf-stack tn :double :imag base))
  95   #!+long-float
  96   (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
  97     (ea-for-cxf-stack tn :long :real base))
  98   #!+long-float
  99   (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
 100     (ea-for-cxf-stack tn :long :imag base)))
 101
 102 ;;; Abstract out the copying of a FP register to the FP stack top, and
 103 ;;; provide two alternatives for its implementation. Note: it's not
 104 ;;; necessary to distinguish between a single or double register move
 105 ;;; here.
 106 ;;;
 107 ;;; Using a Pop then load.
 108 (defun copy-fp-reg-to-fr0 (reg)
 109   (aver (not (zerop (tn-offset reg))))
 110   (inst fstp fr0-tn)
 111   (inst fld (make-random-tn :kind :normal
 112                             :sc (sc-or-lose 'double-reg)
 113                             :offset (1- (tn-offset reg)))))
 114 ;;; Using Fxch then Fst to restore the original reg contents.
 115 #+nil
 116 (defun copy-fp-reg-to-fr0 (reg)
 117   (aver (not (zerop (tn-offset reg))))
 118   (inst fxch reg)
 119   (inst fst  reg))
 120
 121 ;;; The x86 can't store a long-float to memory without popping the
 122 ;;; stack and marking a register as empty, so it is necessary to
 123 ;;; restore the register from memory.
 124 #!+long-float
 125 (defun store-long-float (ea)
 126    (inst fstpl ea)
 127    (inst fldl ea))
 128 \f
 129 ;;;; move functions
 130
 131 ;;; X is source, Y is destination.
 132 (define-move-fun (load-single 2) (vop x y)
 133   ((single-stack) (single-reg))
 134   (with-empty-tn@fp-top(y)
 135      (inst fld (ea-for-sf-stack x))))
 136
 137 (define-move-fun (store-single 2) (vop x y)
 138   ((single-reg) (single-stack))
 139   (cond ((zerop (tn-offset x))
 140          (inst fst (ea-for-sf-stack y)))
 141         (t
 142          (inst fxch x)
 143          (inst fst (ea-for-sf-stack y))
 144          ;; This may not be necessary as ST0 is likely invalid now.
 145          (inst fxch x))))
 146
 147 (define-move-fun (load-double 2) (vop x y)
 148   ((double-stack) (double-reg))
 149   (with-empty-tn@fp-top(y)
 150      (inst fldd (ea-for-df-stack x))))
 151
 152 (define-move-fun (store-double 2) (vop x y)
 153   ((double-reg) (double-stack))
 154   (cond ((zerop (tn-offset x))
 155          (inst fstd (ea-for-df-stack y)))
 156         (t
 157          (inst fxch x)
 158          (inst fstd (ea-for-df-stack y))
 159          ;; This may not be necessary as ST0 is likely invalid now.
 160          (inst fxch x))))
 161
 162 #!+long-float
 163 (define-move-fun (load-long 2) (vop x y)
 164   ((long-stack) (long-reg))
 165   (with-empty-tn@fp-top(y)
 166      (inst fldl (ea-for-lf-stack x))))
 167
 168 #!+long-float
 169 (define-move-fun (store-long 2) (vop x y)
 170   ((long-reg) (long-stack))
 171   (cond ((zerop (tn-offset x))
 172          (store-long-float (ea-for-lf-stack y)))
 173         (t
 174          (inst fxch x)
 175          (store-long-float (ea-for-lf-stack y))
 176          ;; This may not be necessary as ST0 is likely invalid now.
 177          (inst fxch x))))
 178
 179 ;;; The i387 has instructions to load some useful constants. This
 180 ;;; doesn't save much time but might cut down on memory access and
 181 ;;; reduce the size of the constant vector (CV). Intel claims they are
 182 ;;; stored in a more precise form on chip. Anyhow, might as well use
 183 ;;; the feature. It can be turned off by hacking the
 184 ;;; "immediate-constant-sc" in vm.lisp.
 185 (eval-when (:compile-toplevel :execute)
 186   (setf *read-default-float-format*
 187         #!+long-float 'long-float #!-long-float 'double-float))
 188 (define-move-fun (load-fp-constant 2) (vop x y)
 189   ((fp-constant) (single-reg double-reg #!+long-float long-reg))
 190   (let ((value (tn-value x)))
 191     (with-empty-tn@fp-top(y)
 192       (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0))
 193              (inst fldz))
 194             ((= value 1e0)
 195              (inst fld1))
 196             #!+long-float
 197             ((= value (coerce pi *read-default-float-format*))
 198              (inst fldpi))
 199             #!+long-float
 200             ((= value (log 10e0 2e0))
 201              (inst fldl2t))
 202             #!+long-float
 203             ((= value (log 2.718281828459045235360287471352662e0 2e0))
 204              (inst fldl2e))
 205             #!+long-float
 206             ((= value (log 2e0 10e0))
 207              (inst fldlg2))
 208             #!+long-float
 209             ((= value (log 2e0 2.718281828459045235360287471352662e0))
 210              (inst fldln2))
 211             (t (warn "ignoring bogus i387 constant ~A" value))))))
 212
 213 (define-move-fun (load-fp-immediate 2) (vop x y)
 214   ((fp-single-immediate) (single-reg)
 215    (fp-double-immediate) (double-reg))
 216   (let ((value (register-inline-constant (tn-value x))))
 217     (with-empty-tn@fp-top(y)
 218       (sc-case y
 219         (single-reg
 220          (inst fld value))
 221         (double-reg
 222          (inst fldd value))))))
 223 (eval-when (:compile-toplevel :execute)
 224   (setf *read-default-float-format* 'single-float))
 225 \f
 226 ;;;; complex float move functions
 227
 228 (defun complex-single-reg-real-tn (x)
 229   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 230                   :offset (tn-offset x)))
 231 (defun complex-single-reg-imag-tn (x)
 232   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 233                   :offset (1+ (tn-offset x))))
 234
 235 (defun complex-double-reg-real-tn (x)
 236   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 237                   :offset (tn-offset x)))
 238 (defun complex-double-reg-imag-tn (x)
 239   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 240                   :offset (1+ (tn-offset x))))
 241
 242 #!+long-float
 243 (defun complex-long-reg-real-tn (x)
 244   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
 245                   :offset (tn-offset x)))
 246 #!+long-float
 247 (defun complex-long-reg-imag-tn (x)
 248   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
 249                   :offset (1+ (tn-offset x))))
 250
 251 ;;; X is source, Y is destination.
 252 (define-move-fun (load-complex-single 2) (vop x y)
 253   ((complex-single-stack) (complex-single-reg))
 254   (let ((real-tn (complex-single-reg-real-tn y)))
 255     (with-empty-tn@fp-top (real-tn)
 256       (inst fld (ea-for-csf-real-stack x))))
 257   (let ((imag-tn (complex-single-reg-imag-tn y)))
 258     (with-empty-tn@fp-top (imag-tn)
 259       (inst fld (ea-for-csf-imag-stack x)))))
 260
 261 (define-move-fun (store-complex-single 2) (vop x y)
 262   ((complex-single-reg) (complex-single-stack))
 263   (let ((real-tn (complex-single-reg-real-tn x)))
 264     (cond ((zerop (tn-offset real-tn))
 265            (inst fst (ea-for-csf-real-stack y)))
 266           (t
 267            (inst fxch real-tn)
 268            (inst fst (ea-for-csf-real-stack y))
 269            (inst fxch real-tn))))
 270   (let ((imag-tn (complex-single-reg-imag-tn x)))
 271     (inst fxch imag-tn)
 272     (inst fst (ea-for-csf-imag-stack y))
 273     (inst fxch imag-tn)))
 274
 275 (define-move-fun (load-complex-double 2) (vop x y)
 276   ((complex-double-stack) (complex-double-reg))
 277   (let ((real-tn (complex-double-reg-real-tn y)))
 278     (with-empty-tn@fp-top(real-tn)
 279       (inst fldd (ea-for-cdf-real-stack x))))
 280   (let ((imag-tn (complex-double-reg-imag-tn y)))
 281     (with-empty-tn@fp-top(imag-tn)
 282       (inst fldd (ea-for-cdf-imag-stack x)))))
 283
 284 (define-move-fun (store-complex-double 2) (vop x y)
 285   ((complex-double-reg) (complex-double-stack))
 286   (let ((real-tn (complex-double-reg-real-tn x)))
 287     (cond ((zerop (tn-offset real-tn))
 288            (inst fstd (ea-for-cdf-real-stack y)))
 289           (t
 290            (inst fxch real-tn)
 291            (inst fstd (ea-for-cdf-real-stack y))
 292            (inst fxch real-tn))))
 293   (let ((imag-tn (complex-double-reg-imag-tn x)))
 294     (inst fxch imag-tn)
 295     (inst fstd (ea-for-cdf-imag-stack y))
 296     (inst fxch imag-tn)))
 297
 298 #!+long-float
 299 (define-move-fun (load-complex-long 2) (vop x y)
 300   ((complex-long-stack) (complex-long-reg))
 301   (let ((real-tn (complex-long-reg-real-tn y)))
 302     (with-empty-tn@fp-top(real-tn)
 303       (inst fldl (ea-for-clf-real-stack x))))
 304   (let ((imag-tn (complex-long-reg-imag-tn y)))
 305     (with-empty-tn@fp-top(imag-tn)
 306       (inst fldl (ea-for-clf-imag-stack x)))))
 307
 308 #!+long-float
 309 (define-move-fun (store-complex-long 2) (vop x y)
 310   ((complex-long-reg) (complex-long-stack))
 311   (let ((real-tn (complex-long-reg-real-tn x)))
 312     (cond ((zerop (tn-offset real-tn))
 313            (store-long-float (ea-for-clf-real-stack y)))
 314           (t
 315            (inst fxch real-tn)
 316            (store-long-float (ea-for-clf-real-stack y))
 317            (inst fxch real-tn))))
 318   (let ((imag-tn (complex-long-reg-imag-tn x)))
 319     (inst fxch imag-tn)
 320     (store-long-float (ea-for-clf-imag-stack y))
 321     (inst fxch imag-tn)))
 322
 323 \f
 324 ;;;; move VOPs
 325
 326 ;;; float register to register moves
 327 (define-vop (float-move)
 328   (:args (x))
 329   (:results (y))
 330   (:note "float move")
 331   (:generator 0
 332      (unless (location= x y)
 333         (cond ((zerop (tn-offset y))
 334                (copy-fp-reg-to-fr0 x))
 335               ((zerop (tn-offset x))
 336                (inst fstd y))
 337               (t
 338                (inst fxch x)
 339                (inst fstd y)
 340                (inst fxch x))))))
 341
 342 (define-vop (single-move float-move)
 343   (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
 344   (:results (y :scs (single-reg) :load-if (not (location= x y)))))
 345 (define-move-vop single-move :move (single-reg) (single-reg))
 346
 347 (define-vop (double-move float-move)
 348   (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
 349   (:results (y :scs (double-reg) :load-if (not (location= x y)))))
 350 (define-move-vop double-move :move (double-reg) (double-reg))
 351
 352 #!+long-float
 353 (define-vop (long-move float-move)
 354   (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
 355   (:results (y :scs (long-reg) :load-if (not (location= x y)))))
 356 #!+long-float
 357 (define-move-vop long-move :move (long-reg) (long-reg))
 358
 359 ;;; complex float register to register moves
 360 (define-vop (complex-float-move)
 361   (:args (x :target y :load-if (not (location= x y))))
 362   (:results (y :load-if (not (location= x y))))
 363   (:note "complex float move")
 364   (:generator 0
 365      (unless (location= x y)
 366        ;; Note the complex-float-regs are aligned to every second
 367        ;; float register so there is not need to worry about overlap.
 368        (let ((x-real (complex-double-reg-real-tn x))
 369              (y-real (complex-double-reg-real-tn y)))
 370          (cond ((zerop (tn-offset y-real))
 371                 (copy-fp-reg-to-fr0 x-real))
 372                ((zerop (tn-offset x-real))
 373                 (inst fstd y-real))
 374                (t
 375                 (inst fxch x-real)
 376                 (inst fstd y-real)
 377                 (inst fxch x-real))))
 378        (let ((x-imag (complex-double-reg-imag-tn x))
 379              (y-imag (complex-double-reg-imag-tn y)))
 380          (inst fxch x-imag)
 381          (inst fstd y-imag)
 382          (inst fxch x-imag)))))
 383
 384 (define-vop (complex-single-move complex-float-move)
 385   (:args (x :scs (complex-single-reg) :target y
 386             :load-if (not (location= x y))))
 387   (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
 388 (define-move-vop complex-single-move :move
 389   (complex-single-reg) (complex-single-reg))
 390
 391 (define-vop (complex-double-move complex-float-move)
 392   (:args (x :scs (complex-double-reg)
 393             :target y :load-if (not (location= x y))))
 394   (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
 395 (define-move-vop complex-double-move :move
 396   (complex-double-reg) (complex-double-reg))
 397
 398 #!+long-float
 399 (define-vop (complex-long-move complex-float-move)
 400   (:args (x :scs (complex-long-reg)
 401             :target y :load-if (not (location= x y))))
 402   (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
 403 #!+long-float
 404 (define-move-vop complex-long-move :move
 405   (complex-long-reg) (complex-long-reg))
 406 \f
 407 ;;; Move from float to a descriptor reg. allocating a new float
 408 ;;; object in the process.
 409 (define-vop (move-from-single)
 410   (:args (x :scs (single-reg) :to :save))
 411   (:results (y :scs (descriptor-reg)))
 412   (:node-var node)
 413   (:note "float to pointer coercion")
 414   (:generator 13
 415      (with-fixed-allocation (y
 416                              single-float-widetag
 417                              single-float-size node)
 418        (with-tn@fp-top(x)
 419          (inst fst (ea-for-sf-desc y))))))
 420 (define-move-vop move-from-single :move
 421   (single-reg) (descriptor-reg))
 422
 423 (define-vop (move-from-double)
 424   (:args (x :scs (double-reg) :to :save))
 425   (:results (y :scs (descriptor-reg)))
 426   (:node-var node)
 427   (:note "float to pointer coercion")
 428   (:generator 13
 429      (with-fixed-allocation (y
 430                              double-float-widetag
 431                              double-float-size
 432                              node)
 433        (with-tn@fp-top(x)
 434          (inst fstd (ea-for-df-desc y))))))
 435 (define-move-vop move-from-double :move
 436   (double-reg) (descriptor-reg))
 437
 438 #!+long-float
 439 (define-vop (move-from-long)
 440   (:args (x :scs (long-reg) :to :save))
 441   (:results (y :scs (descriptor-reg)))
 442   (:node-var node)
 443   (:note "float to pointer coercion")
 444   (:generator 13
 445      (with-fixed-allocation (y
 446                              long-float-widetag
 447                              long-float-size
 448                              node)
 449        (with-tn@fp-top(x)
 450          (store-long-float (ea-for-lf-desc y))))))
 451 #!+long-float
 452 (define-move-vop move-from-long :move
 453   (long-reg) (descriptor-reg))
 454
 455 (define-vop (move-from-fp-constant)
 456   (:args (x :scs (fp-constant)))
 457   (:results (y :scs (descriptor-reg)))
 458   (:generator 2
 459      (ecase (sb!c::constant-value (sb!c::tn-leaf x))
 460        (0f0 (load-symbol-value y *fp-constant-0f0*))
 461        (1f0 (load-symbol-value y *fp-constant-1f0*))
 462        (0d0 (load-symbol-value y *fp-constant-0d0*))
 463        (1d0 (load-symbol-value y *fp-constant-1d0*))
 464        #!+long-float
 465        (0l0 (load-symbol-value y *fp-constant-0l0*))
 466        #!+long-float
 467        (1l0 (load-symbol-value y *fp-constant-1l0*))
 468        #!+long-float
 469        (#.pi (load-symbol-value y *fp-constant-pi*))
 470        #!+long-float
 471        (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
 472        #!+long-float
 473        (#.(log 2.718281828459045235360287471352662L0 2l0)
 474           (load-symbol-value y *fp-constant-l2e*))
 475        #!+long-float
 476        (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
 477        #!+long-float
 478        (#.(log 2l0 2.718281828459045235360287471352662L0)
 479           (load-symbol-value y *fp-constant-ln2*)))))
 480 (define-move-vop move-from-fp-constant :move
 481   (fp-constant) (descriptor-reg))
 482
 483 ;;; Move from a descriptor to a float register.
 484 (define-vop (move-to-single)
 485   (:args (x :scs (descriptor-reg)))
 486   (:results (y :scs (single-reg)))
 487   (:note "pointer to float coercion")
 488   (:generator 2
 489      (with-empty-tn@fp-top(y)
 490        (inst fld (ea-for-sf-desc x)))))
 491 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
 492
 493 (define-vop (move-to-double)
 494   (:args (x :scs (descriptor-reg)))
 495   (:results (y :scs (double-reg)))
 496   (:note "pointer to float coercion")
 497   (:generator 2
 498      (with-empty-tn@fp-top(y)
 499        (inst fldd (ea-for-df-desc x)))))
 500 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
 501
 502 #!+long-float
 503 (define-vop (move-to-long)
 504   (:args (x :scs (descriptor-reg)))
 505   (:results (y :scs (long-reg)))
 506   (:note "pointer to float coercion")
 507   (:generator 2
 508      (with-empty-tn@fp-top(y)
 509        (inst fldl (ea-for-lf-desc x)))))
 510 #!+long-float
 511 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
 512 \f
 513 ;;; Move from complex float to a descriptor reg. allocating a new
 514 ;;; complex float object in the process.
 515 (define-vop (move-from-complex-single)
 516   (:args (x :scs (complex-single-reg) :to :save))
 517   (:results (y :scs (descriptor-reg)))
 518   (:node-var node)
 519   (:note "complex float to pointer coercion")
 520   (:generator 13
 521     (with-fixed-allocation (y
 522                             complex-single-float-widetag
 523                             complex-single-float-size
 524                             node)
 525       (let ((real-tn (complex-single-reg-real-tn x)))
 526         (with-tn@fp-top(real-tn)
 527           (inst fst (ea-for-csf-real-desc y))))
 528       (let ((imag-tn (complex-single-reg-imag-tn x)))
 529         (with-tn@fp-top(imag-tn)
 530           (inst fst (ea-for-csf-imag-desc y)))))))
 531 (define-move-vop move-from-complex-single :move
 532   (complex-single-reg) (descriptor-reg))
 533
 534 (define-vop (move-from-complex-double)
 535   (:args (x :scs (complex-double-reg) :to :save))
 536   (:results (y :scs (descriptor-reg)))
 537   (:node-var node)
 538   (:note "complex float to pointer coercion")
 539   (:generator 13
 540      (with-fixed-allocation (y
 541                              complex-double-float-widetag
 542                              complex-double-float-size
 543                              node)
 544        (let ((real-tn (complex-double-reg-real-tn x)))
 545          (with-tn@fp-top(real-tn)
 546            (inst fstd (ea-for-cdf-real-desc y))))
 547        (let ((imag-tn (complex-double-reg-imag-tn x)))
 548          (with-tn@fp-top(imag-tn)
 549            (inst fstd (ea-for-cdf-imag-desc y)))))))
 550 (define-move-vop move-from-complex-double :move
 551   (complex-double-reg) (descriptor-reg))
 552
 553 #!+long-float
 554 (define-vop (move-from-complex-long)
 555   (:args (x :scs (complex-long-reg) :to :save))
 556   (:results (y :scs (descriptor-reg)))
 557   (:node-var node)
 558   (:note "complex float to pointer coercion")
 559   (:generator 13
 560      (with-fixed-allocation (y
 561                              complex-long-float-widetag
 562                              complex-long-float-size
 563                              node)
 564        (let ((real-tn (complex-long-reg-real-tn x)))
 565          (with-tn@fp-top(real-tn)
 566            (store-long-float (ea-for-clf-real-desc y))))
 567        (let ((imag-tn (complex-long-reg-imag-tn x)))
 568          (with-tn@fp-top(imag-tn)
 569            (store-long-float (ea-for-clf-imag-desc y)))))))
 570 #!+long-float
 571 (define-move-vop move-from-complex-long :move
 572   (complex-long-reg) (descriptor-reg))
 573
 574 ;;; Move from a descriptor to a complex float register.
 575 (macrolet ((frob (name sc format)
 576              `(progn
 577                 (define-vop (,name)
 578                   (:args (x :scs (descriptor-reg)))
 579                   (:results (y :scs (,sc)))
 580                   (:note "pointer to complex float coercion")
 581                   (:generator 2
 582                     (let ((real-tn (complex-double-reg-real-tn y)))
 583                       (with-empty-tn@fp-top(real-tn)
 584                         ,@(ecase format
 585                            (:single '((inst fld (ea-for-csf-real-desc x))))
 586                            (:double '((inst fldd (ea-for-cdf-real-desc x))))
 587                            #!+long-float
 588                            (:long '((inst fldl (ea-for-clf-real-desc x)))))))
 589                     (let ((imag-tn (complex-double-reg-imag-tn y)))
 590                       (with-empty-tn@fp-top(imag-tn)
 591                         ,@(ecase format
 592                            (:single '((inst fld (ea-for-csf-imag-desc x))))
 593                            (:double '((inst fldd (ea-for-cdf-imag-desc x))))
 594                            #!+long-float
 595                            (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
 596                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 597           (frob move-to-complex-single complex-single-reg :single)
 598           (frob move-to-complex-double complex-double-reg :double)
 599           #!+long-float
 600           (frob move-to-complex-double complex-long-reg :long))
 601 \f
 602 ;;;; the move argument vops
 603 ;;;;
 604 ;;;; Note these are also used to stuff fp numbers onto the c-call
 605 ;;;; stack so the order is different than the lisp-stack.
 606
 607 ;;; the general MOVE-ARG VOP
 608 (macrolet ((frob (name sc stack-sc format)
 609              `(progn
 610                 (define-vop (,name)
 611                   (:args (x :scs (,sc) :target y)
 612                          (fp :scs (any-reg)
 613                              :load-if (not (sc-is y ,sc))))
 614                   (:results (y))
 615                   (:note "float argument move")
 616                   (:generator ,(case format (:single 2) (:double 3) (:long 4))
 617                     (sc-case y
 618                       (,sc
 619                        (unless (location= x y)
 620                           (cond ((zerop (tn-offset y))
 621                                  (copy-fp-reg-to-fr0 x))
 622                                 ((zerop (tn-offset x))
 623                                  (inst fstd y))
 624                                 (t
 625                                  (inst fxch x)
 626                                  (inst fstd y)
 627                                  (inst fxch x)))))
 628                       (,stack-sc
 629                        (if (= (tn-offset fp) esp-offset)
 630                            ;; C-call
 631                            (let* ((offset (* (tn-offset y) n-word-bytes))
 632                                   (ea (make-ea :dword :base fp :disp offset)))
 633                              (with-tn@fp-top(x)
 634                                 ,@(ecase format
 635                                          (:single '((inst fst ea)))
 636                                          (:double '((inst fstd ea)))
 637                                          #!+long-float
 638                                          (:long '((store-long-float ea))))))
 639                            ;; Lisp stack
 640                            (let ((ea (make-ea
 641                                       :dword :base fp
 642                                       :disp (frame-byte-offset
 643                                              (+ (tn-offset y)
 644                                                 ,(case format
 645                                                        (:single 0)
 646                                                        (:double 1)
 647                                                        (:long 2)))))))
 648                              (with-tn@fp-top(x)
 649                                ,@(ecase format
 650                                     (:single '((inst fst  ea)))
 651                                     (:double '((inst fstd ea)))
 652                                     #!+long-float
 653                                     (:long '((store-long-float ea)))))))))))
 654                 (define-move-vop ,name :move-arg
 655                   (,sc descriptor-reg) (,sc)))))
 656   (frob move-single-float-arg single-reg single-stack :single)
 657   (frob move-double-float-arg double-reg double-stack :double)
 658   #!+long-float
 659   (frob move-long-float-arg long-reg long-stack :long))
 660
 661 ;;;; complex float MOVE-ARG VOP
 662 (macrolet ((frob (name sc stack-sc format)
 663              `(progn
 664                 (define-vop (,name)
 665                   (:args (x :scs (,sc) :target y)
 666                          (fp :scs (any-reg)
 667                              :load-if (not (sc-is y ,sc))))
 668                   (:results (y))
 669                   (:note "complex float argument move")
 670                   (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
 671                     (sc-case y
 672                       (,sc
 673                        (unless (location= x y)
 674                          (let ((x-real (complex-double-reg-real-tn x))
 675                                (y-real (complex-double-reg-real-tn y)))
 676                            (cond ((zerop (tn-offset y-real))
 677                                   (copy-fp-reg-to-fr0 x-real))
 678                                  ((zerop (tn-offset x-real))
 679                                   (inst fstd y-real))
 680                                  (t
 681                                   (inst fxch x-real)
 682                                   (inst fstd y-real)
 683                                   (inst fxch x-real))))
 684                          (let ((x-imag (complex-double-reg-imag-tn x))
 685                                (y-imag (complex-double-reg-imag-tn y)))
 686                            (inst fxch x-imag)
 687                            (inst fstd y-imag)
 688                            (inst fxch x-imag))))
 689                       (,stack-sc
 690                        (let ((real-tn (complex-double-reg-real-tn x)))
 691                          (cond ((zerop (tn-offset real-tn))
 692                                 ,@(ecase format
 693                                     (:single
 694                                      '((inst fst
 695                                         (ea-for-csf-real-stack y fp))))
 696                                     (:double
 697                                      '((inst fstd
 698                                         (ea-for-cdf-real-stack y fp))))
 699                                     #!+long-float
 700                                     (:long
 701                                      '((store-long-float
 702                                         (ea-for-clf-real-stack y fp))))))
 703                                (t
 704                                 (inst fxch real-tn)
 705                                 ,@(ecase format
 706                                     (:single
 707                                      '((inst fst
 708                                         (ea-for-csf-real-stack y fp))))
 709                                     (:double
 710                                      '((inst fstd
 711                                         (ea-for-cdf-real-stack y fp))))
 712                                     #!+long-float
 713                                     (:long
 714                                      '((store-long-float
 715                                         (ea-for-clf-real-stack y fp)))))
 716                                 (inst fxch real-tn))))
 717                        (let ((imag-tn (complex-double-reg-imag-tn x)))
 718                          (inst fxch imag-tn)
 719                          ,@(ecase format
 720                              (:single
 721                               '((inst fst (ea-for-csf-imag-stack y fp))))
 722                              (:double
 723                               '((inst fstd (ea-for-cdf-imag-stack y fp))))
 724                              #!+long-float
 725                              (:long
 726                               '((store-long-float
 727                                  (ea-for-clf-imag-stack y fp)))))
 728                          (inst fxch imag-tn))))))
 729                 (define-move-vop ,name :move-arg
 730                   (,sc descriptor-reg) (,sc)))))
 731   (frob move-complex-single-float-arg
 732         complex-single-reg complex-single-stack :single)
 733   (frob move-complex-double-float-arg
 734         complex-double-reg complex-double-stack :double)
 735   #!+long-float
 736   (frob move-complex-long-float-arg
 737         complex-long-reg complex-long-stack :long))
 738
 739 (define-move-vop move-arg :move-arg
 740   (single-reg double-reg #!+long-float long-reg
 741    complex-single-reg complex-double-reg #!+long-float complex-long-reg)
 742   (descriptor-reg))
 743
 744 \f
 745 ;;;; arithmetic VOPs
 746
 747 ;;; dtc: the floating point arithmetic vops
 748 ;;;
 749 ;;; Note: Although these can accept x and y on the stack or pointed to
 750 ;;; from a descriptor register, they will work with register loading
 751 ;;; without these. Same deal with the result - it need only be a
 752 ;;; register. When load-tns are needed they will probably be in ST0
 753 ;;; and the code below should be able to correctly handle all cases.
 754 ;;;
 755 ;;; However it seems to produce better code if all arg. and result
 756 ;;; options are used; on the P86 there is no extra cost in using a
 757 ;;; memory operand to the FP instructions - not so on the PPro.
 758 ;;;
 759 ;;; It may also be useful to handle constant args?
 760 ;;;
 761 ;;; 22-Jul-97: descriptor args lose in some simple cases when
 762 ;;; a function result computed in a loop. Then Python insists
 763 ;;; on consing the intermediate values! For example
 764 ;;;
 765 ;;; (defun test(a n)
 766 ;;;   (declare (type (simple-array double-float (*)) a)
 767 ;;;        (fixnum n))
 768 ;;;   (let ((sum 0d0))
 769 ;;;     (declare (type double-float sum))
 770 ;;;   (dotimes (i n)
 771 ;;;     (incf sum (* (aref a i)(aref a i))))
 772 ;;;     sum))
 773 ;;;
 774 ;;; So, disabling descriptor args until this can be fixed elsewhere.
 775 (macrolet
 776     ((frob (op fop-sti fopr-sti
 777                fop fopr sname scost
 778                fopd foprd dname dcost
 779                lname lcost)
 780        #!-long-float (declare (ignore lcost lname))
 781        `(progn
 782          (define-vop (,sname)
 783            (:translate ,op)
 784            (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
 785                      :to :eval)
 786                   (y :scs (single-reg single-stack #+nil descriptor-reg)
 787                      :to :eval))
 788            (:temporary (:sc single-reg :offset fr0-offset
 789                             :from :eval :to :result) fr0)
 790            (:results (r :scs (single-reg single-stack)))
 791            (:arg-types single-float single-float)
 792            (:result-types single-float)
 793            (:policy :fast-safe)
 794            (:note "inline float arithmetic")
 795            (:vop-var vop)
 796            (:save-p :compute-only)
 797            (:node-var node)
 798            (:generator ,scost
 799              ;; Handle a few special cases
 800              (cond
 801               ;; x, y, and r are the same register.
 802               ((and (sc-is x single-reg) (location= x r) (location= y r))
 803                (cond ((zerop (tn-offset r))
 804                       (inst ,fop fr0))
 805                      (t
 806                       (inst fxch r)
 807                       (inst ,fop fr0)
 808                       ;; XX the source register will not be valid.
 809                       (note-next-instruction vop :internal-error)
 810                       (inst fxch r))))
 811
 812               ;; x and r are the same register.
 813               ((and (sc-is x single-reg) (location= x r))
 814                (cond ((zerop (tn-offset r))
 815                       (sc-case y
 816                          (single-reg
 817                           ;; ST(0) = ST(0) op ST(y)
 818                           (inst ,fop y))
 819                          (single-stack
 820                           ;; ST(0) = ST(0) op Mem
 821                           (inst ,fop (ea-for-sf-stack y)))
 822                          (descriptor-reg
 823                           (inst ,fop (ea-for-sf-desc y)))))
 824                      (t
 825                       ;; y to ST0
 826                       (sc-case y
 827                          (single-reg
 828                           (unless (zerop (tn-offset y))
 829                                   (copy-fp-reg-to-fr0 y)))
 830                          ((single-stack descriptor-reg)
 831                           (inst fstp fr0)
 832                           (if (sc-is y single-stack)
 833                               (inst fld (ea-for-sf-stack y))
 834                             (inst fld (ea-for-sf-desc y)))))
 835                       ;; ST(i) = ST(i) op ST0
 836                       (inst ,fop-sti r)))
 837                (maybe-fp-wait node vop))
 838               ;; y and r are the same register.
 839               ((and (sc-is y single-reg) (location= y r))
 840                (cond ((zerop (tn-offset r))
 841                       (sc-case x
 842                          (single-reg
 843                           ;; ST(0) = ST(x) op ST(0)
 844                           (inst ,fopr x))
 845                          (single-stack
 846                           ;; ST(0) = Mem op ST(0)
 847                           (inst ,fopr (ea-for-sf-stack x)))
 848                          (descriptor-reg
 849                           (inst ,fopr (ea-for-sf-desc x)))))
 850                      (t
 851                       ;; x to ST0
 852                       (sc-case x
 853                         (single-reg
 854                          (unless (zerop (tn-offset x))
 855                                  (copy-fp-reg-to-fr0 x)))
 856                         ((single-stack descriptor-reg)
 857                          (inst fstp fr0)
 858                          (if (sc-is x single-stack)
 859                              (inst fld (ea-for-sf-stack x))
 860                            (inst fld (ea-for-sf-desc x)))))
 861                       ;; ST(i) = ST(0) op ST(i)
 862                       (inst ,fopr-sti r)))
 863                (maybe-fp-wait node vop))
 864               ;; the default case
 865               (t
 866                ;; Get the result to ST0.
 867
 868                ;; Special handling is needed if x or y are in ST0, and
 869                ;; simpler code is generated.
 870                (cond
 871                 ;; x is in ST0
 872                 ((and (sc-is x single-reg) (zerop (tn-offset x)))
 873                  ;; ST0 = ST0 op y
 874                  (sc-case y
 875                    (single-reg
 876                     (inst ,fop y))
 877                    (single-stack
 878                     (inst ,fop (ea-for-sf-stack y)))
 879                    (descriptor-reg
 880                     (inst ,fop (ea-for-sf-desc y)))))
 881                 ;; y is in ST0
 882                 ((and (sc-is y single-reg) (zerop (tn-offset y)))
 883                  ;; ST0 = x op ST0
 884                  (sc-case x
 885                    (single-reg
 886                     (inst ,fopr x))
 887                    (single-stack
 888                     (inst ,fopr (ea-for-sf-stack x)))
 889                    (descriptor-reg
 890                     (inst ,fopr (ea-for-sf-desc x)))))
 891                 (t
 892                  ;; x to ST0
 893                  (sc-case x
 894                    (single-reg
 895                     (copy-fp-reg-to-fr0 x))
 896                    (single-stack
 897                     (inst fstp fr0)
 898                     (inst fld (ea-for-sf-stack x)))
 899                    (descriptor-reg
 900                     (inst fstp fr0)
 901                     (inst fld (ea-for-sf-desc x))))
 902                  ;; ST0 = ST0 op y
 903                  (sc-case y
 904                    (single-reg
 905                     (inst ,fop y))
 906                    (single-stack
 907                     (inst ,fop (ea-for-sf-stack y)))
 908                    (descriptor-reg
 909                     (inst ,fop (ea-for-sf-desc y))))))
 910
 911                (note-next-instruction vop :internal-error)
 912
 913                ;; Finally save the result.
 914                (sc-case r
 915                  (single-reg
 916                   (cond ((zerop (tn-offset r))
 917                          (maybe-fp-wait node))
 918                         (t
 919                          (inst fst r))))
 920                  (single-stack
 921                   (inst fst (ea-for-sf-stack r))))))))
 922
 923          (define-vop (,dname)
 924            (:translate ,op)
 925            (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
 926                      :to :eval)
 927                   (y :scs (double-reg double-stack #+nil descriptor-reg)
 928                      :to :eval))
 929            (:temporary (:sc double-reg :offset fr0-offset
 930                             :from :eval :to :result) fr0)
 931            (:results (r :scs (double-reg double-stack)))
 932            (:arg-types double-float double-float)
 933            (:result-types double-float)
 934            (:policy :fast-safe)
 935            (:note "inline float arithmetic")
 936            (:vop-var vop)
 937            (:save-p :compute-only)
 938            (:node-var node)
 939            (:generator ,dcost
 940              ;; Handle a few special cases.
 941              (cond
 942               ;; x, y, and r are the same register.
 943               ((and (sc-is x double-reg) (location= x r) (location= y r))
 944                (cond ((zerop (tn-offset r))
 945                       (inst ,fop fr0))
 946                      (t
 947                       (inst fxch x)
 948                       (inst ,fopd fr0)
 949                       ;; XX the source register will not be valid.
 950                       (note-next-instruction vop :internal-error)
 951                       (inst fxch r))))
 952
 953               ;; x and r are the same register.
 954               ((and (sc-is x double-reg) (location= x r))
 955                (cond ((zerop (tn-offset r))
 956                       (sc-case y
 957                          (double-reg
 958                           ;; ST(0) = ST(0) op ST(y)
 959                           (inst ,fopd y))
 960                          (double-stack
 961                           ;; ST(0) = ST(0) op Mem
 962                           (inst ,fopd (ea-for-df-stack y)))
 963                          (descriptor-reg
 964                           (inst ,fopd (ea-for-df-desc y)))))
 965                      (t
 966                       ;; y to ST0
 967                       (sc-case y
 968                          (double-reg
 969                           (unless (zerop (tn-offset y))
 970                                   (copy-fp-reg-to-fr0 y)))
 971                          ((double-stack descriptor-reg)
 972                           (inst fstp fr0)
 973                           (if (sc-is y double-stack)
 974                               (inst fldd (ea-for-df-stack y))
 975                             (inst fldd (ea-for-df-desc y)))))
 976                       ;; ST(i) = ST(i) op ST0
 977                       (inst ,fop-sti r)))
 978                (maybe-fp-wait node vop))
 979               ;; y and r are the same register.
 980               ((and (sc-is y double-reg) (location= y r))
 981                (cond ((zerop (tn-offset r))
 982                       (sc-case x
 983                          (double-reg
 984                           ;; ST(0) = ST(x) op ST(0)
 985                           (inst ,foprd x))
 986                          (double-stack
 987                           ;; ST(0) = Mem op ST(0)
 988                           (inst ,foprd (ea-for-df-stack x)))
 989                          (descriptor-reg
 990                           (inst ,foprd (ea-for-df-desc x)))))
 991                      (t
 992                       ;; x to ST0
 993                       (sc-case x
 994                          (double-reg
 995                           (unless (zerop (tn-offset x))
 996                                   (copy-fp-reg-to-fr0 x)))
 997                          ((double-stack descriptor-reg)
 998                           (inst fstp fr0)
 999                           (if (sc-is x double-stack)
1000                               (inst fldd (ea-for-df-stack x))
1001                             (inst fldd (ea-for-df-desc x)))))
1002                       ;; ST(i) = ST(0) op ST(i)
1003                       (inst ,fopr-sti r)))
1004                (maybe-fp-wait node vop))
1005               ;; the default case
1006               (t
1007                ;; Get the result to ST0.
1008
1009                ;; Special handling is needed if x or y are in ST0, and
1010                ;; simpler code is generated.
1011                (cond
1012                 ;; x is in ST0
1013                 ((and (sc-is x double-reg) (zerop (tn-offset x)))
1014                  ;; ST0 = ST0 op y
1015                  (sc-case y
1016                    (double-reg
1017                     (inst ,fopd y))
1018                    (double-stack
1019                     (inst ,fopd (ea-for-df-stack y)))
1020                    (descriptor-reg
1021                     (inst ,fopd (ea-for-df-desc y)))))
1022                 ;; y is in ST0
1023                 ((and (sc-is y double-reg) (zerop (tn-offset y)))
1024                  ;; ST0 = x op ST0
1025                  (sc-case x
1026                    (double-reg
1027                     (inst ,foprd x))
1028                    (double-stack
1029                     (inst ,foprd (ea-for-df-stack x)))
1030                    (descriptor-reg
1031                     (inst ,foprd (ea-for-df-desc x)))))
1032                 (t
1033                  ;; x to ST0
1034                  (sc-case x
1035                    (double-reg
1036                     (copy-fp-reg-to-fr0 x))
1037                    (double-stack
1038                     (inst fstp fr0)
1039                     (inst fldd (ea-for-df-stack x)))
1040                    (descriptor-reg
1041                     (inst fstp fr0)
1042                     (inst fldd (ea-for-df-desc x))))
1043                  ;; ST0 = ST0 op y
1044                  (sc-case y
1045                    (double-reg
1046                     (inst ,fopd y))
1047                    (double-stack
1048                     (inst ,fopd (ea-for-df-stack y)))
1049                    (descriptor-reg
1050                     (inst ,fopd (ea-for-df-desc y))))))
1051
1052                (note-next-instruction vop :internal-error)
1053
1054                ;; Finally save the result.
1055                (sc-case r
1056                  (double-reg
1057                   (cond ((zerop (tn-offset r))
1058                          (maybe-fp-wait node))
1059                         (t
1060                          (inst fst r))))
1061                  (double-stack
1062                   (inst fstd (ea-for-df-stack r))))))))
1063
1064          #!+long-float
1065          (define-vop (,lname)
1066            (:translate ,op)
1067            (:args (x :scs (long-reg) :to :eval)
1068                   (y :scs (long-reg) :to :eval))
1069            (:temporary (:sc long-reg :offset fr0-offset
1070                             :from :eval :to :result) fr0)
1071            (:results (r :scs (long-reg)))
1072            (:arg-types long-float long-float)
1073            (:result-types long-float)
1074            (:policy :fast-safe)
1075            (:note "inline float arithmetic")
1076            (:vop-var vop)
1077            (:save-p :compute-only)
1078            (:node-var node)
1079            (:generator ,lcost
1080              ;; Handle a few special cases.
1081              (cond
1082               ;; x, y, and r are the same register.
1083               ((and (location= x r) (location= y r))
1084                (cond ((zerop (tn-offset r))
1085                       (inst ,fop fr0))
1086                      (t
1087                       (inst fxch x)
1088                       (inst ,fopd fr0)
1089                       ;; XX the source register will not be valid.
1090                       (note-next-instruction vop :internal-error)
1091                       (inst fxch r))))
1092
1093               ;; x and r are the same register.
1094               ((location= x r)
1095                (cond ((zerop (tn-offset r))
1096                       ;; ST(0) = ST(0) op ST(y)
1097                       (inst ,fopd y))
1098                      (t
1099                       ;; y to ST0
1100                       (unless (zerop (tn-offset y))
1101                         (copy-fp-reg-to-fr0 y))
1102                       ;; ST(i) = ST(i) op ST0
1103                       (inst ,fop-sti r)))
1104                (maybe-fp-wait node vop))
1105               ;; y and r are the same register.
1106               ((location= y r)
1107                (cond ((zerop (tn-offset r))
1108                       ;; ST(0) = ST(x) op ST(0)
1109                       (inst ,foprd x))
1110                      (t
1111                       ;; x to ST0
1112                       (unless (zerop (tn-offset x))
1113                         (copy-fp-reg-to-fr0 x))
1114                       ;; ST(i) = ST(0) op ST(i)
1115                       (inst ,fopr-sti r)))
1116                (maybe-fp-wait node vop))
1117               ;; the default case
1118               (t
1119                ;; Get the result to ST0.
1120
1121                ;; Special handling is needed if x or y are in ST0, and
1122                ;; simpler code is generated.
1123                (cond
1124                 ;; x is in ST0.
1125                 ((zerop (tn-offset x))
1126                  ;; ST0 = ST0 op y
1127                  (inst ,fopd y))
1128                 ;; y is in ST0
1129                 ((zerop (tn-offset y))
1130                  ;; ST0 = x op ST0
1131                  (inst ,foprd x))
1132                 (t
1133                  ;; x to ST0
1134                  (copy-fp-reg-to-fr0 x)
1135                  ;; ST0 = ST0 op y
1136                  (inst ,fopd y)))
1137
1138                (note-next-instruction vop :internal-error)
1139
1140                ;; Finally save the result.
1141                (cond ((zerop (tn-offset r))
1142                       (maybe-fp-wait node))
1143                      (t
1144                       (inst fst r))))))))))
1145
1146     (frob + fadd-sti fadd-sti
1147           fadd fadd +/single-float 2
1148           faddd faddd +/double-float 2
1149           +/long-float 2)
1150     (frob - fsub-sti fsubr-sti
1151           fsub fsubr -/single-float 2
1152           fsubd fsubrd -/double-float 2
1153           -/long-float 2)
1154     (frob * fmul-sti fmul-sti
1155           fmul fmul */single-float 3
1156           fmuld fmuld */double-float 3
1157           */long-float 3)
1158     (frob / fdiv-sti fdivr-sti
1159           fdiv fdivr //single-float 12
1160           fdivd fdivrd //double-float 12
1161           //long-float 12))
1162 \f
1163 (macrolet ((frob (name inst translate sc type)
1164              `(define-vop (,name)
1165                (:args (x :scs (,sc) :target fr0))
1166                (:results (y :scs (,sc)))
1167                (:translate ,translate)
1168                (:policy :fast-safe)
1169                (:arg-types ,type)
1170                (:result-types ,type)
1171                (:temporary (:sc double-reg :offset fr0-offset
1172                                 :from :argument :to :result) fr0)
1173                (:ignore fr0)
1174                (:note "inline float arithmetic")
1175                (:vop-var vop)
1176                (:save-p :compute-only)
1177                (:generator 1
1178                 (note-this-location vop :internal-error)
1179                 (unless (zerop (tn-offset x))
1180                   (inst fxch x)         ; x to top of stack
1181                   (unless (location= x y)
1182                     (inst fst x)))      ; Maybe save it.
1183                 (inst ,inst)            ; Clobber st0.
1184                 (unless (zerop (tn-offset y))
1185                   (inst fst y))))))
1186
1187   (frob abs/single-float fabs abs single-reg single-float)
1188   (frob abs/double-float fabs abs double-reg double-float)
1189   #!+long-float
1190   (frob abs/long-float fabs abs long-reg long-float)
1191   (frob %negate/single-float fchs %negate single-reg single-float)
1192   (frob %negate/double-float fchs %negate double-reg double-float)
1193   #!+long-float
1194   (frob %negate/long-float fchs %negate long-reg long-float))
1195 \f
1196 ;;;; comparison
1197
1198 (define-vop (=/float)
1199   (:args (x) (y))
1200   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1201   (:conditional :e)
1202   (:policy :fast-safe)
1203   (:vop-var vop)
1204   (:save-p :compute-only)
1205   (:note "inline float comparison")
1206   (:ignore temp)
1207   (:generator 3
1208      (note-this-location vop :internal-error)
1209      (cond
1210       ;; x is in ST0; y is in any reg.
1211       ((zerop (tn-offset x))
1212        (inst fucom y))
1213       ;; y is in ST0; x is in another reg.
1214       ((zerop (tn-offset y))
1215        (inst fucom x))
1216       ;; x and y are the same register, not ST0
1217       ((location= x y)
1218        (inst fxch x)
1219        (inst fucom fr0-tn)
1220        (inst fxch x))
1221       ;; x and y are different registers, neither ST0.
1222       (t
1223        (inst fxch x)
1224        (inst fucom y)
1225        (inst fxch x)))
1226      (inst fnstsw)                      ; status word to ax
1227      (inst and ah-tn #x45)              ; C3 C2 C0
1228      (inst cmp ah-tn #x40)))
1229
1230 (define-vop (=/single-float =/float)
1231   (:translate =)
1232   (:args (x :scs (single-reg))
1233          (y :scs (single-reg)))
1234   (:arg-types single-float single-float))
1235
1236 (define-vop (=/double-float =/float)
1237   (:translate =)
1238   (:args (x :scs (double-reg))
1239          (y :scs (double-reg)))
1240   (:arg-types double-float double-float))
1241
1242 #!+long-float
1243 (define-vop (=/long-float =/float)
1244   (:translate =)
1245   (:args (x :scs (long-reg))
1246          (y :scs (long-reg)))
1247   (:arg-types long-float long-float))
1248
1249 (define-vop (<single-float)
1250   (:translate <)
1251   (:args (x :scs (single-reg single-stack descriptor-reg))
1252          (y :scs (single-reg single-stack descriptor-reg)))
1253   (:arg-types single-float single-float)
1254   (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1255   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1256   (:conditional :e)
1257   (:policy :fast-safe)
1258   (:note "inline float comparison")
1259   (:ignore temp)
1260   (:generator 3
1261     ;; Handle a few special cases.
1262     (cond
1263      ;; y is ST0.
1264      ((and (sc-is y single-reg) (zerop (tn-offset y)))
1265       (sc-case x
1266         (single-reg
1267          (inst fcom x))
1268         ((single-stack descriptor-reg)
1269          (if (sc-is x single-stack)
1270              (inst fcom (ea-for-sf-stack x))
1271            (inst fcom (ea-for-sf-desc x)))))
1272       (inst fnstsw)                     ; status word to ax
1273       (inst and ah-tn #x45))
1274
1275      ;; general case when y is not in ST0
1276      (t
1277       ;; x to ST0
1278       (sc-case x
1279          (single-reg
1280           (unless (zerop (tn-offset x))
1281                   (copy-fp-reg-to-fr0 x)))
1282          ((single-stack descriptor-reg)
1283           (inst fstp fr0)
1284           (if (sc-is x single-stack)
1285               (inst fld (ea-for-sf-stack x))
1286             (inst fld (ea-for-sf-desc x)))))
1287       (sc-case y
1288         (single-reg
1289          (inst fcom y))
1290         ((single-stack descriptor-reg)
1291          (if (sc-is y single-stack)
1292              (inst fcom (ea-for-sf-stack y))
1293            (inst fcom (ea-for-sf-desc y)))))
1294       (inst fnstsw)                     ; status word to ax
1295       (inst and ah-tn #x45)             ; C3 C2 C0
1296       (inst cmp ah-tn #x01)))))
1297
1298 (define-vop (<double-float)
1299   (:translate <)
1300   (:args (x :scs (double-reg double-stack descriptor-reg))
1301          (y :scs (double-reg double-stack descriptor-reg)))
1302   (:arg-types double-float double-float)
1303   (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1304   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1305   (:conditional :e)
1306   (:policy :fast-safe)
1307   (:note "inline float comparison")
1308   (:ignore temp)
1309   (:generator 3
1310     ;; Handle a few special cases
1311     (cond
1312      ;; y is ST0.
1313      ((and (sc-is y double-reg) (zerop (tn-offset y)))
1314       (sc-case x
1315         (double-reg
1316          (inst fcomd x))
1317         ((double-stack descriptor-reg)
1318          (if (sc-is x double-stack)
1319              (inst fcomd (ea-for-df-stack x))
1320            (inst fcomd (ea-for-df-desc x)))))
1321       (inst fnstsw)                     ; status word to ax
1322       (inst and ah-tn #x45))
1323
1324      ;; General case when y is not in ST0.
1325      (t
1326       ;; x to ST0
1327       (sc-case x
1328          (double-reg
1329           (unless (zerop (tn-offset x))
1330                   (copy-fp-reg-to-fr0 x)))
1331          ((double-stack descriptor-reg)
1332           (inst fstp fr0)
1333           (if (sc-is x double-stack)
1334               (inst fldd (ea-for-df-stack x))
1335             (inst fldd (ea-for-df-desc x)))))
1336       (sc-case y
1337         (double-reg
1338          (inst fcomd y))
1339         ((double-stack descriptor-reg)
1340          (if (sc-is y double-stack)
1341              (inst fcomd (ea-for-df-stack y))
1342            (inst fcomd (ea-for-df-desc y)))))
1343       (inst fnstsw)                     ; status word to ax
1344       (inst and ah-tn #x45)             ; C3 C2 C0
1345       (inst cmp ah-tn #x01)))))
1346
1347 #!+long-float
1348 (define-vop (<long-float)
1349   (:translate <)
1350   (:args (x :scs (long-reg))
1351          (y :scs (long-reg)))
1352   (:arg-types long-float long-float)
1353   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1354   (:conditional :e)
1355   (:policy :fast-safe)
1356   (:note "inline float comparison")
1357   (:ignore temp)
1358   (:generator 3
1359     (cond
1360       ;; x is in ST0; y is in any reg.
1361       ((zerop (tn-offset x))
1362        (inst fcomd y)
1363        (inst fnstsw)                    ; status word to ax
1364        (inst and ah-tn #x45)            ; C3 C2 C0
1365        (inst cmp ah-tn #x01))
1366       ;; y is in ST0; x is in another reg.
1367       ((zerop (tn-offset y))
1368        (inst fcomd x)
1369        (inst fnstsw)                    ; status word to ax
1370        (inst and ah-tn #x45))
1371       ;; x and y are the same register, not ST0
1372       ;; x and y are different registers, neither ST0.
1373       (t
1374        (inst fxch y)
1375        (inst fcomd x)
1376        (inst fxch y)
1377        (inst fnstsw)                    ; status word to ax
1378        (inst and ah-tn #x45)))))        ; C3 C2 C0
1379
1380
1381 (define-vop (>single-float)
1382   (:translate >)
1383   (:args (x :scs (single-reg single-stack descriptor-reg))
1384          (y :scs (single-reg single-stack descriptor-reg)))
1385   (:arg-types single-float single-float)
1386   (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1387   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1388   (:conditional :e)
1389   (:policy :fast-safe)
1390   (:note "inline float comparison")
1391   (:ignore temp)
1392   (:generator 3
1393     ;; Handle a few special cases.
1394     (cond
1395      ;; y is ST0.
1396      ((and (sc-is y single-reg) (zerop (tn-offset y)))
1397       (sc-case x
1398         (single-reg
1399          (inst fcom x))
1400         ((single-stack descriptor-reg)
1401          (if (sc-is x single-stack)
1402              (inst fcom (ea-for-sf-stack x))
1403            (inst fcom (ea-for-sf-desc x)))))
1404       (inst fnstsw)                     ; status word to ax
1405       (inst and ah-tn #x45)
1406       (inst cmp ah-tn #x01))
1407
1408      ;; general case when y is not in ST0
1409      (t
1410       ;; x to ST0
1411       (sc-case x
1412          (single-reg
1413           (unless (zerop (tn-offset x))
1414                   (copy-fp-reg-to-fr0 x)))
1415          ((single-stack descriptor-reg)
1416           (inst fstp fr0)
1417           (if (sc-is x single-stack)
1418               (inst fld (ea-for-sf-stack x))
1419             (inst fld (ea-for-sf-desc x)))))
1420       (sc-case y
1421         (single-reg
1422          (inst fcom y))
1423         ((single-stack descriptor-reg)
1424          (if (sc-is y single-stack)
1425              (inst fcom (ea-for-sf-stack y))
1426            (inst fcom (ea-for-sf-desc y)))))
1427       (inst fnstsw)                     ; status word to ax
1428       (inst and ah-tn #x45)))))
1429
1430 (define-vop (>double-float)
1431   (:translate >)
1432   (:args (x :scs (double-reg double-stack descriptor-reg))
1433          (y :scs (double-reg double-stack descriptor-reg)))
1434   (:arg-types double-float double-float)
1435   (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1436   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1437   (:conditional :e)
1438   (:policy :fast-safe)
1439   (:note "inline float comparison")
1440   (:ignore temp)
1441   (:generator 3
1442     ;; Handle a few special cases.
1443     (cond
1444      ;; y is ST0.
1445      ((and (sc-is y double-reg) (zerop (tn-offset y)))
1446       (sc-case x
1447         (double-reg
1448          (inst fcomd x))
1449         ((double-stack descriptor-reg)
1450          (if (sc-is x double-stack)
1451              (inst fcomd (ea-for-df-stack x))
1452            (inst fcomd (ea-for-df-desc x)))))
1453       (inst fnstsw)                     ; status word to ax
1454       (inst and ah-tn #x45)
1455       (inst cmp ah-tn #x01))
1456
1457      ;; general case when y is not in ST0
1458      (t
1459       ;; x to ST0
1460       (sc-case x
1461          (double-reg
1462           (unless (zerop (tn-offset x))
1463                   (copy-fp-reg-to-fr0 x)))
1464          ((double-stack descriptor-reg)
1465           (inst fstp fr0)
1466           (if (sc-is x double-stack)
1467               (inst fldd (ea-for-df-stack x))
1468             (inst fldd (ea-for-df-desc x)))))
1469       (sc-case y
1470         (double-reg
1471          (inst fcomd y))
1472         ((double-stack descriptor-reg)
1473          (if (sc-is y double-stack)
1474              (inst fcomd (ea-for-df-stack y))
1475            (inst fcomd (ea-for-df-desc y)))))
1476       (inst fnstsw)                     ; status word to ax
1477       (inst and ah-tn #x45)))))
1478
1479 #!+long-float
1480 (define-vop (>long-float)
1481   (:translate >)
1482   (:args (x :scs (long-reg))
1483          (y :scs (long-reg)))
1484   (:arg-types long-float long-float)
1485   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1486   (:conditional :e)
1487   (:policy :fast-safe)
1488   (:note "inline float comparison")
1489   (:ignore temp)
1490   (:generator 3
1491     (cond
1492       ;; y is in ST0; x is in any reg.
1493       ((zerop (tn-offset y))
1494        (inst fcomd x)
1495        (inst fnstsw)                    ; status word to ax
1496        (inst and ah-tn #x45)
1497        (inst cmp ah-tn #x01))
1498       ;; x is in ST0; y is in another reg.
1499       ((zerop (tn-offset x))
1500        (inst fcomd y)
1501        (inst fnstsw)                    ; status word to ax
1502        (inst and ah-tn #x45))
1503       ;; y and x are the same register, not ST0
1504       ;; y and x are different registers, neither ST0.
1505       (t
1506        (inst fxch x)
1507        (inst fcomd y)
1508        (inst fxch x)
1509        (inst fnstsw)                    ; status word to ax
1510        (inst and ah-tn #x45)))))
1511
1512 ;;; Comparisons with 0 can use the FTST instruction.
1513
1514 (define-vop (float-test)
1515   (:args (x))
1516   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1517   (:conditional :e)
1518   (:info y)
1519   (:variant-vars code)
1520   (:policy :fast-safe)
1521   (:vop-var vop)
1522   (:save-p :compute-only)
1523   (:note "inline float comparison")
1524   (:ignore temp y)
1525   (:generator 2
1526      (note-this-location vop :internal-error)
1527      (cond
1528       ;; x is in ST0
1529       ((zerop (tn-offset x))
1530        (inst ftst))
1531       ;; x not ST0
1532       (t
1533        (inst fxch x)
1534        (inst ftst)
1535        (inst fxch x)))
1536      (inst fnstsw)                      ; status word to ax
1537      (inst and ah-tn #x45)              ; C3 C2 C0
1538      (unless (zerop code)
1539         (inst cmp ah-tn code))))
1540
1541 (define-vop (=0/single-float float-test)
1542   (:translate =)
1543   (:args (x :scs (single-reg)))
1544   (:arg-types single-float (:constant (single-float 0f0 0f0)))
1545   (:variant #x40))
1546 (define-vop (=0/double-float float-test)
1547   (:translate =)
1548   (:args (x :scs (double-reg)))
1549   (:arg-types double-float (:constant (double-float 0d0 0d0)))
1550   (:variant #x40))
1551 #!+long-float
1552 (define-vop (=0/long-float float-test)
1553   (:translate =)
1554   (:args (x :scs (long-reg)))
1555   (:arg-types long-float (:constant (long-float 0l0 0l0)))
1556   (:variant #x40))
1557
1558 (define-vop (<0/single-float float-test)
1559   (:translate <)
1560   (:args (x :scs (single-reg)))
1561   (:arg-types single-float (:constant (single-float 0f0 0f0)))
1562   (:variant #x01))
1563 (define-vop (<0/double-float float-test)
1564   (:translate <)
1565   (:args (x :scs (double-reg)))
1566   (:arg-types double-float (:constant (double-float 0d0 0d0)))
1567   (:variant #x01))
1568 #!+long-float
1569 (define-vop (<0/long-float float-test)
1570   (:translate <)
1571   (:args (x :scs (long-reg)))
1572   (:arg-types long-float (:constant (long-float 0l0 0l0)))
1573   (:variant #x01))
1574
1575 (define-vop (>0/single-float float-test)
1576   (:translate >)
1577   (:args (x :scs (single-reg)))
1578   (:arg-types single-float (:constant (single-float 0f0 0f0)))
1579   (:variant #x00))
1580 (define-vop (>0/double-float float-test)
1581   (:translate >)
1582   (:args (x :scs (double-reg)))
1583   (:arg-types double-float (:constant (double-float 0d0 0d0)))
1584   (:variant #x00))
1585 #!+long-float
1586 (define-vop (>0/long-float float-test)
1587   (:translate >)
1588   (:args (x :scs (long-reg)))
1589   (:arg-types long-float (:constant (long-float 0l0 0l0)))
1590   (:variant #x00))
1591
1592 #!+long-float
1593 (deftransform eql ((x y) (long-float long-float))
1594   `(and (= (long-float-low-bits x) (long-float-low-bits y))
1595         (= (long-float-high-bits x) (long-float-high-bits y))
1596         (= (long-float-exp-bits x) (long-float-exp-bits y))))
1597 \f
1598 ;;;; conversion
1599
1600 (macrolet ((frob (name translate to-sc to-type)
1601              `(define-vop (,name)
1602                 (:args (x :scs (signed-stack signed-reg) :target temp))
1603                 (:temporary (:sc signed-stack) temp)
1604                 (:results (y :scs (,to-sc)))
1605                 (:arg-types signed-num)
1606                 (:result-types ,to-type)
1607                 (:policy :fast-safe)
1608                 (:note "inline float coercion")
1609                 (:translate ,translate)
1610                 (:vop-var vop)
1611                 (:save-p :compute-only)
1612                 (:generator 5
1613                   (sc-case x
1614                     (signed-reg
1615                      (inst mov temp x)
1616                      (with-empty-tn@fp-top(y)
1617                        (note-this-location vop :internal-error)
1618                        (inst fild temp)))
1619                     (signed-stack
1620                      (with-empty-tn@fp-top(y)
1621                        (note-this-location vop :internal-error)
1622                        (inst fild x))))))))
1623   (frob %single-float/signed %single-float single-reg single-float)
1624   (frob %double-float/signed %double-float double-reg double-float)
1625   #!+long-float
1626   (frob %long-float/signed %long-float long-reg long-float))
1627
1628 (macrolet ((frob (name translate to-sc to-type)
1629              `(define-vop (,name)
1630                 (:args (x :scs (unsigned-reg)))
1631                 (:results (y :scs (,to-sc)))
1632                 (:arg-types unsigned-num)
1633                 (:result-types ,to-type)
1634                 (:policy :fast-safe)
1635                 (:note "inline float coercion")
1636                 (:translate ,translate)
1637                 (:vop-var vop)
1638                 (:save-p :compute-only)
1639                 (:generator 6
1640                  (inst push 0)
1641                  (inst push x)
1642                  (with-empty-tn@fp-top(y)
1643                    (note-this-location vop :internal-error)
1644                    (inst fildl (make-ea :dword :base esp-tn)))
1645                  (inst add esp-tn 8)))))
1646   (frob %single-float/unsigned %single-float single-reg single-float)
1647   (frob %double-float/unsigned %double-float double-reg double-float)
1648   #!+long-float
1649   (frob %long-float/unsigned %long-float long-reg long-float))
1650
1651 ;;; These should be no-ops but the compiler might want to move some
1652 ;;; things around.
1653 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1654              `(define-vop (,name)
1655                (:args (x :scs (,from-sc) :target y))
1656                (:results (y :scs (,to-sc)))
1657                (:arg-types ,from-type)
1658                (:result-types ,to-type)
1659                (:policy :fast-safe)
1660                (:note "inline float coercion")
1661                (:translate ,translate)
1662                (:vop-var vop)
1663                (:save-p :compute-only)
1664                (:generator 2
1665                 (note-this-location vop :internal-error)
1666                 (unless (location= x y)
1667                   (cond
1668                    ((zerop (tn-offset x))
1669                     ;; x is in ST0, y is in another reg. not ST0
1670                     (inst fst  y))
1671                    ((zerop (tn-offset y))
1672                     ;; y is in ST0, x is in another reg. not ST0
1673                     (copy-fp-reg-to-fr0 x))
1674                    (t
1675                     ;; Neither x or y are in ST0, and they are not in
1676                     ;; the same reg.
1677                     (inst fxch x)
1678                     (inst fst  y)
1679                     (inst fxch x))))))))
1680
1681   (frob %single-float/double-float %single-float double-reg
1682         double-float single-reg single-float)
1683   #!+long-float
1684   (frob %single-float/long-float %single-float long-reg
1685         long-float single-reg single-float)
1686   (frob %double-float/single-float %double-float single-reg single-float
1687         double-reg double-float)
1688   #!+long-float
1689   (frob %double-float/long-float %double-float long-reg long-float
1690         double-reg double-float)
1691   #!+long-float
1692   (frob %long-float/single-float %long-float single-reg single-float
1693         long-reg long-float)
1694   #!+long-float
1695   (frob %long-float/double-float %long-float double-reg double-float
1696         long-reg long-float))
1697
1698 (macrolet ((frob (trans from-sc from-type round-p)
1699              `(define-vop (,(symbolicate trans "/" from-type))
1700                (:args (x :scs (,from-sc)))
1701                (:temporary (:sc signed-stack) stack-temp)
1702                ,@(unless round-p
1703                        '((:temporary (:sc unsigned-stack) scw)
1704                          (:temporary (:sc any-reg) rcw)))
1705                (:results (y :scs (signed-reg)))
1706                (:arg-types ,from-type)
1707                (:result-types signed-num)
1708                (:translate ,trans)
1709                (:policy :fast-safe)
1710                (:note "inline float truncate")
1711                (:vop-var vop)
1712                (:save-p :compute-only)
1713                (:generator 5
1714                 ,@(unless round-p
1715                    '((note-this-location vop :internal-error)
1716                      ;; Catch any pending FPE exceptions.
1717                      (inst wait)))
1718                 (,(if round-p 'progn 'pseudo-atomic)
1719                  ;; Normal mode (for now) is "round to best".
1720                  (with-tn@fp-top (x)
1721                    ,@(unless round-p
1722                      '((inst fnstcw scw) ; save current control word
1723                        (move rcw scw)   ; into 16-bit register
1724                        (inst or rcw (ash #b11 10)) ; CHOP
1725                        (move stack-temp rcw)
1726                        (inst fldcw stack-temp)))
1727                    (sc-case y
1728                      (signed-stack
1729                       (inst fist y))
1730                      (signed-reg
1731                       (inst fist stack-temp)
1732                       (inst mov y stack-temp)))
1733                    ,@(unless round-p
1734                       '((inst fldcw scw)))))))))
1735   (frob %unary-truncate/single-float single-reg single-float nil)
1736   (frob %unary-truncate/double-float double-reg double-float nil)
1737   #!+long-float
1738   (frob %unary-truncate/long-float long-reg long-float nil)
1739   (frob %unary-round single-reg single-float t)
1740   (frob %unary-round double-reg double-float t)
1741   #!+long-float
1742   (frob %unary-round long-reg long-float t))
1743
1744 (macrolet ((frob (trans from-sc from-type round-p)
1745              `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1746                (:args (x :scs (,from-sc) :target fr0))
1747                (:temporary (:sc double-reg :offset fr0-offset
1748                             :from :argument :to :result) fr0)
1749                ,@(unless round-p
1750                   '((:temporary (:sc unsigned-stack) stack-temp)
1751                     (:temporary (:sc unsigned-stack) scw)
1752                     (:temporary (:sc any-reg) rcw)))
1753                (:results (y :scs (unsigned-reg)))
1754                (:arg-types ,from-type)
1755                (:result-types unsigned-num)
1756                (:translate ,trans)
1757                (:policy :fast-safe)
1758                (:note "inline float truncate")
1759                (:vop-var vop)
1760                (:save-p :compute-only)
1761                (:generator 5
1762                 ,@(unless round-p
1763                    '((note-this-location vop :internal-error)
1764                      ;; Catch any pending FPE exceptions.
1765                      (inst wait)))
1766                 ;; Normal mode (for now) is "round to best".
1767                 (unless (zerop (tn-offset x))
1768                   (copy-fp-reg-to-fr0 x))
1769                 ,@(unless round-p
1770                    '((inst fnstcw scw)  ; save current control word
1771                      (move rcw scw)     ; into 16-bit register
1772                      (inst or rcw (ash #b11 10)) ; CHOP
1773                      (move stack-temp rcw)
1774                      (inst fldcw stack-temp)))
1775                 (inst sub esp-tn 8)
1776                 (inst fistpl (make-ea :dword :base esp-tn))
1777                 (inst pop y)
1778                 (inst fld fr0) ; copy fr0 to at least restore stack.
1779                 (inst add esp-tn 4)
1780                 ,@(unless round-p
1781                    '((inst fldcw scw)))))))
1782   (frob %unary-truncate/single-float single-reg single-float nil)
1783   (frob %unary-truncate/double-float double-reg double-float nil)
1784   #!+long-float
1785   (frob %unary-truncate/long-float long-reg long-float nil)
1786   (frob %unary-round single-reg single-float t)
1787   (frob %unary-round double-reg double-float t)
1788   #!+long-float
1789   (frob %unary-round long-reg long-float t))
1790
1791 (define-vop (make-single-float)
1792   (:args (bits :scs (signed-reg) :target res
1793                :load-if (not (or (and (sc-is bits signed-stack)
1794                                       (sc-is res single-reg))
1795                                  (and (sc-is bits signed-stack)
1796                                       (sc-is res single-stack)
1797                                       (location= bits res))))))
1798   (:results (res :scs (single-reg single-stack)))
1799   (:temporary (:sc signed-stack) stack-temp)
1800   (:arg-types signed-num)
1801   (:result-types single-float)
1802   (:translate make-single-float)
1803   (:policy :fast-safe)
1804   (:vop-var vop)
1805   (:generator 4
1806     (sc-case res
1807        (single-stack
1808         (sc-case bits
1809           (signed-reg
1810            (inst mov res bits))
1811           (signed-stack
1812            (aver (location= bits res)))))
1813        (single-reg
1814         (sc-case bits
1815           (signed-reg
1816            ;; source must be in memory
1817            (inst mov stack-temp bits)
1818            (with-empty-tn@fp-top(res)
1819               (inst fld stack-temp)))
1820           (signed-stack
1821            (with-empty-tn@fp-top(res)
1822               (inst fld bits))))))))
1823
1824 (define-vop (make-double-float)
1825   (:args (hi-bits :scs (signed-reg))
1826          (lo-bits :scs (unsigned-reg)))
1827   (:results (res :scs (double-reg)))
1828   (:temporary (:sc double-stack) temp)
1829   (:arg-types signed-num unsigned-num)
1830   (:result-types double-float)
1831   (:translate make-double-float)
1832   (:policy :fast-safe)
1833   (:vop-var vop)
1834   (:generator 2
1835     (let ((offset (tn-offset temp)))
1836       (storew hi-bits ebp-tn (frame-word-offset offset))
1837       (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
1838       (with-empty-tn@fp-top(res)
1839         (inst fldd (make-ea :dword :base ebp-tn
1840                             :disp (frame-byte-offset (1+ offset))))))))
1841
1842 #!+long-float
1843 (define-vop (make-long-float)
1844   (:args (exp-bits :scs (signed-reg))
1845          (hi-bits :scs (unsigned-reg))
1846          (lo-bits :scs (unsigned-reg)))
1847   (:results (res :scs (long-reg)))
1848   (:temporary (:sc long-stack) temp)
1849   (:arg-types signed-num unsigned-num unsigned-num)
1850   (:result-types long-float)
1851   (:translate make-long-float)
1852   (:policy :fast-safe)
1853   (:vop-var vop)
1854   (:generator 3
1855     (let ((offset (tn-offset temp)))
1856       (storew exp-bits ebp-tn (frame-word-offset offset))
1857       (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
1858       (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
1859       (with-empty-tn@fp-top(res)
1860         (inst fldl (make-ea :dword :base ebp-tn
1861                             :disp (frame-byte-offset (+ offset 2))))))))
1862
1863 (define-vop (single-float-bits)
1864   (:args (float :scs (single-reg descriptor-reg)
1865                 :load-if (not (sc-is float single-stack))))
1866   (:results (bits :scs (signed-reg)))
1867   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1868   (:arg-types single-float)
1869   (:result-types signed-num)
1870   (:translate single-float-bits)
1871   (:policy :fast-safe)
1872   (:vop-var vop)
1873   (:generator 4
1874     (sc-case bits
1875       (signed-reg
1876        (sc-case float
1877          (single-reg
1878           (with-tn@fp-top(float)
1879             (inst fst stack-temp)
1880             (inst mov bits stack-temp)))
1881          (single-stack
1882           (inst mov bits float))
1883          (descriptor-reg
1884           (loadw
1885            bits float single-float-value-slot
1886            other-pointer-lowtag))))
1887       (signed-stack
1888        (sc-case float
1889          (single-reg
1890           (with-tn@fp-top(float)
1891             (inst fst bits))))))))
1892
1893 (define-vop (double-float-high-bits)
1894   (:args (float :scs (double-reg descriptor-reg)
1895                 :load-if (not (sc-is float double-stack))))
1896   (:results (hi-bits :scs (signed-reg)))
1897   (:temporary (:sc double-stack) temp)
1898   (:arg-types double-float)
1899   (:result-types signed-num)
1900   (:translate double-float-high-bits)
1901   (:policy :fast-safe)
1902   (:vop-var vop)
1903   (:generator 5
1904      (sc-case float
1905        (double-reg
1906         (with-tn@fp-top(float)
1907           (let ((where (make-ea :dword :base ebp-tn
1908                                 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1909             (inst fstd where)))
1910         (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
1911        (double-stack
1912         (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
1913        (descriptor-reg
1914         (loadw hi-bits float (1+ double-float-value-slot)
1915                other-pointer-lowtag)))))
1916
1917 (define-vop (double-float-low-bits)
1918   (:args (float :scs (double-reg descriptor-reg)
1919                 :load-if (not (sc-is float double-stack))))
1920   (:results (lo-bits :scs (unsigned-reg)))
1921   (:temporary (:sc double-stack) temp)
1922   (:arg-types double-float)
1923   (:result-types unsigned-num)
1924   (:translate double-float-low-bits)
1925   (:policy :fast-safe)
1926   (:vop-var vop)
1927   (:generator 5
1928      (sc-case float
1929        (double-reg
1930         (with-tn@fp-top(float)
1931           (let ((where (make-ea :dword :base ebp-tn
1932                                 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1933             (inst fstd where)))
1934         (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1935        (double-stack
1936         (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
1937        (descriptor-reg
1938         (loadw lo-bits float double-float-value-slot
1939                other-pointer-lowtag)))))
1940
1941 #!+long-float
1942 (define-vop (long-float-exp-bits)
1943   (:args (float :scs (long-reg descriptor-reg)
1944                 :load-if (not (sc-is float long-stack))))
1945   (:results (exp-bits :scs (signed-reg)))
1946   (:temporary (:sc long-stack) temp)
1947   (:arg-types long-float)
1948   (:result-types signed-num)
1949   (:translate long-float-exp-bits)
1950   (:policy :fast-safe)
1951   (:vop-var vop)
1952   (:generator 5
1953      (sc-case float
1954        (long-reg
1955         (with-tn@fp-top(float)
1956           (let ((where (make-ea :dword :base ebp-tn
1957                                 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
1958             (store-long-float where)))
1959         (inst movsx exp-bits
1960               (make-ea :word :base ebp-tn
1961                        :disp (frame-byte-offset (tn-offset temp)))))
1962        (long-stack
1963         (inst movsx exp-bits
1964               (make-ea :word :base ebp-tn
1965                        :disp (frame-byte-offset (tn-offset temp)))))
1966        (descriptor-reg
1967         (inst movsx exp-bits
1968               (make-ea-for-object-slot float (+ 2 long-float-value-slot)
1969                                        other-pointer-lowtag :word))))))
1970
1971 #!+long-float
1972 (define-vop (long-float-high-bits)
1973   (:args (float :scs (long-reg descriptor-reg)
1974                 :load-if (not (sc-is float long-stack))))
1975   (:results (hi-bits :scs (unsigned-reg)))
1976   (:temporary (:sc long-stack) temp)
1977   (:arg-types long-float)
1978   (:result-types unsigned-num)
1979   (:translate long-float-high-bits)
1980   (:policy :fast-safe)
1981   (:vop-var vop)
1982   (:generator 5
1983      (sc-case float
1984        (long-reg
1985         (with-tn@fp-top(float)
1986           (let ((where (make-ea :dword :base ebp-tn
1987                                 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
1988             (store-long-float where)))
1989         (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1990        (long-stack
1991         (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1992        (descriptor-reg
1993         (loadw hi-bits float (1+ long-float-value-slot)
1994                other-pointer-lowtag)))))
1995
1996 #!+long-float
1997 (define-vop (long-float-low-bits)
1998   (:args (float :scs (long-reg descriptor-reg)
1999                 :load-if (not (sc-is float long-stack))))
2000   (:results (lo-bits :scs (unsigned-reg)))
2001   (:temporary (:sc long-stack) temp)
2002   (:arg-types long-float)
2003   (:result-types unsigned-num)
2004   (:translate long-float-low-bits)
2005   (:policy :fast-safe)
2006   (:vop-var vop)
2007   (:generator 5
2008      (sc-case float
2009        (long-reg
2010         (with-tn@fp-top(float)
2011           (let ((where (make-ea :dword :base ebp-tn
2012                                 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2013             (store-long-float where)))
2014         (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
2015        (long-stack
2016         (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
2017        (descriptor-reg
2018         (loadw lo-bits float long-float-value-slot
2019                other-pointer-lowtag)))))
2020 \f
2021 ;;;; float mode hackery
2022
2023 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2024 (defknown floating-point-modes () float-modes (flushable))
2025 (defknown ((setf floating-point-modes)) (float-modes)
2026   float-modes)
2027
2028 (def!constant npx-env-size (* 7 n-word-bytes))
2029 (def!constant npx-cw-offset 0)
2030 (def!constant npx-sw-offset 4)
2031
2032 (define-vop (floating-point-modes)
2033   (:results (res :scs (unsigned-reg)))
2034   (:result-types unsigned-num)
2035   (:translate floating-point-modes)
2036   (:policy :fast-safe)
2037   (:temporary (:sc unsigned-reg :offset eax-offset :target res
2038                    :to :result) eax)
2039   (:generator 8
2040    (inst sub esp-tn npx-env-size)       ; Make space on stack.
2041    (inst wait)                          ; Catch any pending FPE exceptions
2042    (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2043    (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2044    ;; Move current status to high word.
2045    (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2046    ;; Move exception mask to low word.
2047    (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2048    (inst add esp-tn npx-env-size)       ; Pop stack.
2049    (inst xor eax #x3f)            ; Flip exception mask to trap enable bits.
2050    (move res eax)))
2051
2052 (define-vop (set-floating-point-modes)
2053   (:args (new :scs (unsigned-reg) :to :result :target res))
2054   (:results (res :scs (unsigned-reg)))
2055   (:arg-types unsigned-num)
2056   (:result-types unsigned-num)
2057   (:translate (setf floating-point-modes))
2058   (:policy :fast-safe)
2059   (:temporary (:sc unsigned-reg :offset eax-offset
2060                    :from :eval :to :result) eax)
2061   (:generator 3
2062    (inst sub esp-tn npx-env-size)       ; Make space on stack.
2063    (inst wait)                          ; Catch any pending FPE exceptions.
2064    (inst fstenv (make-ea :dword :base esp-tn))
2065    (inst mov eax new)
2066    (inst xor eax #x3f)            ; Turn trap enable bits into exception mask.
2067    (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2068    (inst shr eax 16)                    ; position status word
2069    (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2070    (inst fldenv (make-ea :dword :base esp-tn))
2071    (inst add esp-tn npx-env-size)       ; Pop stack.
2072    (move res new)))
2073 \f
2074 #!-long-float
2075 (progn
2076
2077 ;;; Let's use some of the 80387 special functions.
2078 ;;;
2079 ;;; These defs will not take effect unless code/irrat.lisp is modified
2080 ;;; to remove the inlined alien routine def.
2081
2082 (macrolet ((frob (func trans op)
2083              `(define-vop (,func)
2084                (:args (x :scs (double-reg) :target fr0))
2085                (:temporary (:sc double-reg :offset fr0-offset
2086                                 :from :argument :to :result) fr0)
2087                (:ignore fr0)
2088                (:results (y :scs (double-reg)))
2089                (:arg-types double-float)
2090                (:result-types double-float)
2091                (:translate ,trans)
2092                (:policy :fast-safe)
2093                (:note "inline NPX function")
2094                (:vop-var vop)
2095                (:save-p :compute-only)
2096                (:node-var node)
2097                (:generator 5
2098                 (note-this-location vop :internal-error)
2099                 (unless (zerop (tn-offset x))
2100                   (inst fxch x)         ; x to top of stack
2101                   (unless (location= x y)
2102                     (inst fst x)))      ; maybe save it
2103                 (inst ,op)              ; clobber st0
2104                 (cond ((zerop (tn-offset y))
2105                        (maybe-fp-wait node))
2106                       (t
2107                        (inst fst y)))))))
2108
2109   ;; Quick versions of fsin and fcos that require the argument to be
2110   ;; within range 2^63.
2111   (frob fsin-quick %sin-quick fsin)
2112   (frob fcos-quick %cos-quick fcos)
2113   (frob fsqrt %sqrt fsqrt))
2114
2115 ;;; Quick version of ftan that requires the argument to be within
2116 ;;; range 2^63.
2117 (define-vop (ftan-quick)
2118   (:translate %tan-quick)
2119   (:args (x :scs (double-reg) :target fr0))
2120   (:temporary (:sc double-reg :offset fr0-offset
2121                    :from :argument :to :result) fr0)
2122   (:temporary (:sc double-reg :offset fr1-offset
2123                    :from :argument :to :result) fr1)
2124   (:results (y :scs (double-reg)))
2125   (:arg-types double-float)
2126   (:result-types double-float)
2127   (:policy :fast-safe)
2128   (:note "inline tan function")
2129   (:vop-var vop)
2130   (:save-p :compute-only)
2131   (:generator 5
2132     (note-this-location vop :internal-error)
2133     (case (tn-offset x)
2134        (0
2135         (inst fstp fr1))
2136        (1
2137         (inst fstp fr0))
2138        (t
2139         (inst fstp fr0)
2140         (inst fstp fr0)
2141         (inst fldd (make-random-tn :kind :normal
2142                                    :sc (sc-or-lose 'double-reg)
2143                                    :offset (- (tn-offset x) 2)))))
2144     (inst fptan)
2145     ;; Result is in fr1
2146     (case (tn-offset y)
2147        (0
2148         (inst fxch fr1))
2149        (1)
2150        (t
2151         (inst fxch fr1)
2152         (inst fstd y)))))
2153
2154 ;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
2155 ;;; result if the argument is out of range 2^63 and would thus be
2156 ;;; hopelessly inaccurate.
2157 (macrolet ((frob (func trans op)
2158              `(define-vop (,func)
2159                 (:translate ,trans)
2160                 (:args (x :scs (double-reg) :target fr0))
2161                 (:temporary (:sc double-reg :offset fr0-offset
2162                                  :from :argument :to :result) fr0)
2163                 ;; FIXME: make that an arbitrary location and
2164                 ;; FXCH only when range reduction needed
2165                 (:temporary (:sc double-reg :offset fr1-offset
2166                                  :from :argument :to :result) fr1)
2167                 (:temporary (:sc unsigned-reg :offset eax-offset
2168                              :from :argument :to :result) eax)
2169                 (:results (y :scs (double-reg)))
2170                 (:arg-types double-float)
2171                 (:result-types double-float)
2172                 (:policy :fast-safe)
2173                 (:note "inline sin/cos function")
2174                 (:vop-var vop)
2175                 (:save-p :compute-only)
2176                 (:ignore eax)
2177                 (:generator 5
2178                   (let ((DONE (gen-label))
2179                         (REDUCE (gen-label))
2180                         (REDUCE-LOOP (gen-label)))
2181                     (note-this-location vop :internal-error)
2182                     (unless (zerop (tn-offset x))
2183                       (inst fxch x)          ; x to top of stack
2184                       (unless (location= x y)
2185                         (inst fst x))) ; maybe save it
2186                     (inst ,op)
2187                     (inst fnstsw)                  ; status word to ax
2188                     (inst and ah-tn #x04)          ; C2
2189                     (inst jmp :nz REDUCE)
2190                     (emit-label DONE)
2191                     (unless (zerop (tn-offset y))
2192                       (inst fstd y))
2193                     (assemble (*elsewhere*)
2194                       (emit-label REDUCE)
2195                       ;; Else x was out of range so reduce it; ST0 is unchanged.
2196                       (with-empty-tn@fp-top (fr1)
2197                         (inst fldpi)
2198                         (inst fadd fr0))
2199                       (emit-label REDUCE-LOOP)
2200                       (inst fprem1)
2201                       (inst fnstsw)
2202                       (inst and ah-tn #x04)
2203                       (inst jmp :nz REDUCE-LOOP)
2204                       (inst ,op)
2205                       (inst jmp DONE)))))))
2206           (frob fsin  %sin fsin)
2207           (frob fcos  %cos fcos))
2208
2209 (define-vop (ftan)
2210   (:translate %tan)
2211   (:args (x :scs (double-reg) :target fr0))
2212   (:temporary (:sc double-reg :offset fr0-offset
2213                    :from :argument :to :result) fr0)
2214   (:temporary (:sc double-reg :offset fr1-offset
2215                    :from :argument :to :result) fr1)
2216   (:temporary (:sc unsigned-reg :offset eax-offset
2217                    :from :argument :to :result) eax)
2218   (:results (y :scs (double-reg)))
2219   (:arg-types double-float)
2220   (:result-types double-float)
2221   (:ignore eax)
2222   (:policy :fast-safe)
2223   (:note "inline tan function")
2224   (:vop-var vop)
2225   (:save-p :compute-only)
2226   (:ignore eax)
2227   (:generator 5
2228     (note-this-location vop :internal-error)
2229     (case (tn-offset x)
2230        (0
2231         (inst fstp fr1))
2232        (1
2233         (inst fstp fr0))
2234        (t
2235         (inst fstp fr0)
2236         (inst fstp fr0)
2237         (inst fldd (make-random-tn :kind :normal
2238                                    :sc (sc-or-lose 'double-reg)
2239                                    :offset (- (tn-offset x) 2)))))
2240     (inst fptan)
2241     (let ((REDUCE (gen-label))
2242           (REDUCE-LOOP (gen-label)))
2243       (inst fnstsw)                        ; status word to ax
2244       (inst and ah-tn #x04)                ; C2
2245       (inst jmp :nz REDUCE)
2246       (assemble (*elsewhere*)
2247         (emit-label REDUCE)
2248         ;; Else x was out of range so reduce it; ST0 is unchanged.
2249         (with-empty-tn@fp-top (fr1)
2250           (inst fldpi)
2251           (inst fadd fr0))
2252         (emit-label REDUCE-LOOP)
2253         (inst fprem1)
2254         (inst fnstsw)
2255         (inst and ah-tn #x04)
2256         (inst jmp :nz REDUCE-LOOP)
2257         (inst fptan)
2258         (inst jmp DONE)))
2259     DONE
2260     ;; Result is in fr1
2261     (case (tn-offset y)
2262        (0
2263         (inst fxch fr1))
2264        (1)
2265        (t
2266         (inst fxch fr1)
2267         (inst fstd y)))))
2268
2269 ;;; %exp that handles the following special cases: exp(+Inf) is +Inf;
2270 ;;; exp(-Inf) is 0; exp(NaN) is NaN.
2271 (define-vop (fexp)
2272   (:translate %exp)
2273   (:args (x :scs (double-reg) :target fr0))
2274   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2275   (:temporary (:sc double-reg :offset fr0-offset
2276                    :from :argument :to :result) fr0)
2277   (:temporary (:sc double-reg :offset fr1-offset
2278                    :from :argument :to :result) fr1)
2279   (:temporary (:sc double-reg :offset fr2-offset
2280                    :from :argument :to :result) fr2)
2281   (:results (y :scs (double-reg)))
2282   (:arg-types double-float)
2283   (:result-types double-float)
2284   (:policy :fast-safe)
2285   (:note "inline exp function")
2286   (:vop-var vop)
2287   (:save-p :compute-only)
2288   (:ignore temp)
2289   (:generator 5
2290      (note-this-location vop :internal-error)
2291      (unless (zerop (tn-offset x))
2292        (inst fxch x)            ; x to top of stack
2293        (unless (location= x y)
2294          (inst fst x))) ; maybe save it
2295      ;; Check for Inf or NaN
2296      (inst fxam)
2297      (inst fnstsw)
2298      (inst sahf)
2299      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
2300      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
2301      (inst and ah-tn #x02)            ; Test sign of Inf.
2302      (inst jmp :z DONE)          ; +Inf gives +Inf.
2303      (inst fstp fr0)                ; -Inf gives 0
2304      (inst fldz)
2305      (inst jmp-short DONE)
2306      NOINFNAN
2307      (inst fstp fr1)
2308      (inst fldl2e)
2309      (inst fmul fr1)
2310      ;; Now fr0=x log2(e)
2311      (inst fst fr1)
2312      (inst frndint)
2313      (inst fst fr2)
2314      (inst fsubp-sti fr1)
2315      (inst f2xm1)
2316      (inst fld1)
2317      (inst faddp-sti fr1)
2318      (inst fscale)
2319      (inst fld fr0)
2320      DONE
2321      (unless (zerop (tn-offset y))
2322              (inst fstd y))))
2323
2324 ;;; Expm1 = exp(x) - 1.
2325 ;;; Handles the following special cases:
2326 ;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2327 (define-vop (fexpm1)
2328   (:translate %expm1)
2329   (:args (x :scs (double-reg) :target fr0))
2330   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2331   (:temporary (:sc double-reg :offset fr0-offset
2332                    :from :argument :to :result) fr0)
2333   (:temporary (:sc double-reg :offset fr1-offset
2334                    :from :argument :to :result) fr1)
2335   (:temporary (:sc double-reg :offset fr2-offset
2336                    :from :argument :to :result) fr2)
2337   (:results (y :scs (double-reg)))
2338   (:arg-types double-float)
2339   (:result-types double-float)
2340   (:policy :fast-safe)
2341   (:note "inline expm1 function")
2342   (:vop-var vop)
2343   (:save-p :compute-only)
2344   (:ignore temp)
2345   (:generator 5
2346      (note-this-location vop :internal-error)
2347      (unless (zerop (tn-offset x))
2348        (inst fxch x)            ; x to top of stack
2349        (unless (location= x y)
2350          (inst fst x))) ; maybe save it
2351      ;; Check for Inf or NaN
2352      (inst fxam)
2353      (inst fnstsw)
2354      (inst sahf)
2355      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
2356      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
2357      (inst and ah-tn #x02)            ; Test sign of Inf.
2358      (inst jmp :z DONE)          ; +Inf gives +Inf.
2359      (inst fstp fr0)                ; -Inf gives -1.0
2360      (inst fld1)
2361      (inst fchs)
2362      (inst jmp-short DONE)
2363      NOINFNAN
2364      ;; Free two stack slots leaving the argument on top.
2365      (inst fstp fr2)
2366      (inst fstp fr0)
2367      (inst fldl2e)
2368      (inst fmul fr1)    ; Now fr0 = x log2(e)
2369      (inst fst fr1)
2370      (inst frndint)
2371      (inst fsub-sti fr1)
2372      (inst fxch fr1)
2373      (inst f2xm1)
2374      (inst fscale)
2375      (inst fxch fr1)
2376      (inst fld1)
2377      (inst fscale)
2378      (inst fstp fr1)
2379      (inst fld1)
2380      (inst fsub fr1)
2381      (inst fsubr fr2)
2382      DONE
2383      (unless (zerop (tn-offset y))
2384        (inst fstd y))))
2385
2386 (define-vop (flog)
2387   (:translate %log)
2388   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2389   (:temporary (:sc double-reg :offset fr0-offset
2390                    :from :argument :to :result) fr0)
2391   (:temporary (:sc double-reg :offset fr1-offset
2392                    :from :argument :to :result) fr1)
2393   (:results (y :scs (double-reg)))
2394   (:arg-types double-float)
2395   (:result-types double-float)
2396   (:policy :fast-safe)
2397   (:note "inline log function")
2398   (:vop-var vop)
2399   (:save-p :compute-only)
2400   (:generator 5
2401      (note-this-location vop :internal-error)
2402      (sc-case x
2403         (double-reg
2404          (case (tn-offset x)
2405             (0
2406              ;; x is in fr0
2407              (inst fstp fr1)
2408              (inst fldln2)
2409              (inst fxch fr1))
2410             (1
2411              ;; x is in fr1
2412              (inst fstp fr0)
2413              (inst fldln2)
2414              (inst fxch fr1))
2415             (t
2416              ;; x is in a FP reg, not fr0 or fr1
2417              (inst fstp fr0)
2418              (inst fstp fr0)
2419              (inst fldln2)
2420              (inst fldd (make-random-tn :kind :normal
2421                                         :sc (sc-or-lose 'double-reg)
2422                                         :offset (1- (tn-offset x))))))
2423          (inst fyl2x))
2424         ((double-stack descriptor-reg)
2425          (inst fstp fr0)
2426          (inst fstp fr0)
2427          (inst fldln2)
2428          (if (sc-is x double-stack)
2429              (inst fldd (ea-for-df-stack x))
2430              (inst fldd (ea-for-df-desc x)))
2431          (inst fyl2x)))
2432      (inst fld fr0)
2433      (case (tn-offset y)
2434        ((0 1))
2435        (t (inst fstd y)))))
2436
2437 (define-vop (flog10)
2438   (:translate %log10)
2439   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2440   (:temporary (:sc double-reg :offset fr0-offset
2441                    :from :argument :to :result) fr0)
2442   (:temporary (:sc double-reg :offset fr1-offset
2443                    :from :argument :to :result) fr1)
2444   (:results (y :scs (double-reg)))
2445   (:arg-types double-float)
2446   (:result-types double-float)
2447   (:policy :fast-safe)
2448   (:note "inline log10 function")
2449   (:vop-var vop)
2450   (:save-p :compute-only)
2451   (:generator 5
2452      (note-this-location vop :internal-error)
2453      (sc-case x
2454         (double-reg
2455          (case (tn-offset x)
2456             (0
2457              ;; x is in fr0
2458              (inst fstp fr1)
2459              (inst fldlg2)
2460              (inst fxch fr1))
2461             (1
2462              ;; x is in fr1
2463              (inst fstp fr0)
2464              (inst fldlg2)
2465              (inst fxch fr1))
2466             (t
2467              ;; x is in a FP reg, not fr0 or fr1
2468              (inst fstp fr0)
2469              (inst fstp fr0)
2470              (inst fldlg2)
2471              (inst fldd (make-random-tn :kind :normal
2472                                         :sc (sc-or-lose 'double-reg)
2473                                         :offset (1- (tn-offset x))))))
2474          (inst fyl2x))
2475         ((double-stack descriptor-reg)
2476          (inst fstp fr0)
2477          (inst fstp fr0)
2478          (inst fldlg2)
2479          (if (sc-is x double-stack)
2480              (inst fldd (ea-for-df-stack x))
2481              (inst fldd (ea-for-df-desc x)))
2482          (inst fyl2x)))
2483      (inst fld fr0)
2484      (case (tn-offset y)
2485        ((0 1))
2486        (t (inst fstd y)))))
2487
2488 (define-vop (fpow)
2489   (:translate %pow)
2490   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2491          (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2492   (:temporary (:sc double-reg :offset fr0-offset
2493                    :from (:argument 0) :to :result) fr0)
2494   (:temporary (:sc double-reg :offset fr1-offset
2495                    :from (:argument 1) :to :result) fr1)
2496   (:temporary (:sc double-reg :offset fr2-offset
2497                    :from :load :to :result) fr2)
2498   (:results (r :scs (double-reg)))
2499   (:arg-types double-float double-float)
2500   (:result-types double-float)
2501   (:policy :fast-safe)
2502   (:note "inline pow function")
2503   (:vop-var vop)
2504   (:save-p :compute-only)
2505   (:generator 5
2506      (note-this-location vop :internal-error)
2507      ;; Setup x in fr0 and y in fr1
2508      (cond
2509       ;; x in fr0; y in fr1
2510       ((and (sc-is x double-reg) (zerop (tn-offset x))
2511             (sc-is y double-reg) (= 1 (tn-offset y))))
2512       ;; y in fr1; x not in fr0
2513       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2514        ;; Load x to fr0
2515        (sc-case x
2516           (double-reg
2517            (copy-fp-reg-to-fr0 x))
2518           (double-stack
2519            (inst fstp fr0)
2520            (inst fldd (ea-for-df-stack x)))
2521           (descriptor-reg
2522            (inst fstp fr0)
2523            (inst fldd (ea-for-df-desc x)))))
2524       ;; x in fr0; y not in fr1
2525       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2526        (inst fxch fr1)
2527        ;; Now load y to fr0
2528        (sc-case y
2529           (double-reg
2530            (copy-fp-reg-to-fr0 y))
2531           (double-stack
2532            (inst fstp fr0)
2533            (inst fldd (ea-for-df-stack y)))
2534           (descriptor-reg
2535            (inst fstp fr0)
2536            (inst fldd (ea-for-df-desc y))))
2537        (inst fxch fr1))
2538       ;; x in fr1; y not in fr1
2539       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2540        ;; Load y to fr0
2541        (sc-case y
2542           (double-reg
2543            (copy-fp-reg-to-fr0 y))
2544           (double-stack
2545            (inst fstp fr0)
2546            (inst fldd (ea-for-df-stack y)))
2547           (descriptor-reg
2548            (inst fstp fr0)
2549            (inst fldd (ea-for-df-desc y))))
2550        (inst fxch fr1))
2551       ;; y in fr0;
2552       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2553        (inst fxch fr1)
2554        ;; Now load x to fr0
2555        (sc-case x
2556           (double-reg
2557            (copy-fp-reg-to-fr0 x))
2558           (double-stack
2559            (inst fstp fr0)
2560            (inst fldd (ea-for-df-stack x)))
2561           (descriptor-reg
2562            (inst fstp fr0)
2563            (inst fldd (ea-for-df-desc x)))))
2564       ;; Neither x or y are in either fr0 or fr1
2565       (t
2566        ;; Load y then x
2567        (inst fstp fr0)
2568        (inst fstp fr0)
2569        (sc-case y
2570           (double-reg
2571            (inst fldd (make-random-tn :kind :normal
2572                                       :sc (sc-or-lose 'double-reg)
2573                                       :offset (- (tn-offset y) 2))))
2574           (double-stack
2575            (inst fldd (ea-for-df-stack y)))
2576           (descriptor-reg
2577            (inst fldd (ea-for-df-desc y))))
2578        ;; Load x to fr0
2579        (sc-case x
2580           (double-reg
2581            (inst fldd (make-random-tn :kind :normal
2582                                       :sc (sc-or-lose 'double-reg)
2583                                       :offset (1- (tn-offset x)))))
2584           (double-stack
2585            (inst fldd (ea-for-df-stack x)))
2586           (descriptor-reg
2587            (inst fldd (ea-for-df-desc x))))))
2588
2589      ;; Now have x at fr0; and y at fr1
2590      (inst fyl2x)
2591      ;; Now fr0=y log2(x)
2592      (inst fld fr0)
2593      (inst frndint)
2594      (inst fst fr2)
2595      (inst fsubp-sti fr1)
2596      (inst f2xm1)
2597      (inst fld1)
2598      (inst faddp-sti fr1)
2599      (inst fscale)
2600      (inst fld fr0)
2601      (case (tn-offset r)
2602        ((0 1))
2603        (t (inst fstd r)))))
2604
2605 (define-vop (fscalen)
2606   (:translate %scalbn)
2607   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2608          (y :scs (signed-stack signed-reg) :target temp))
2609   (:temporary (:sc double-reg :offset fr0-offset
2610                    :from (:argument 0) :to :result) fr0)
2611   (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2612   (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2613   (:results (r :scs (double-reg)))
2614   (:arg-types double-float signed-num)
2615   (:result-types double-float)
2616   (:policy :fast-safe)
2617   (:note "inline scalbn function")
2618   (:generator 5
2619      ;; Setup x in fr0 and y in fr1
2620      (sc-case x
2621        (double-reg
2622         (case (tn-offset x)
2623           (0
2624            (inst fstp fr1)
2625            (sc-case y
2626              (signed-reg
2627               (inst mov temp y)
2628               (inst fild temp))
2629              (signed-stack
2630               (inst fild y)))
2631            (inst fxch fr1))
2632           (1
2633            (inst fstp fr0)
2634            (sc-case y
2635              (signed-reg
2636               (inst mov temp y)
2637               (inst fild temp))
2638              (signed-stack
2639               (inst fild y)))
2640            (inst fxch fr1))
2641           (t
2642            (inst fstp fr0)
2643            (inst fstp fr0)
2644            (sc-case y
2645              (signed-reg
2646               (inst mov temp y)
2647               (inst fild temp))
2648              (signed-stack
2649               (inst fild y)))
2650            (inst fld (make-random-tn :kind :normal
2651                                      :sc (sc-or-lose 'double-reg)
2652                                      :offset (1- (tn-offset x)))))))
2653        ((double-stack descriptor-reg)
2654         (inst fstp fr0)
2655         (inst fstp fr0)
2656         (sc-case y
2657           (signed-reg
2658            (inst mov temp y)
2659            (inst fild temp))
2660           (signed-stack
2661            (inst fild y)))
2662         (if (sc-is x double-stack)
2663             (inst fldd (ea-for-df-stack x))
2664             (inst fldd (ea-for-df-desc x)))))
2665      (inst fscale)
2666      (unless (zerop (tn-offset r))
2667        (inst fstd r))))
2668
2669 (define-vop (fscale)
2670   (:translate %scalb)
2671   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2672          (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2673   (:temporary (:sc double-reg :offset fr0-offset
2674                    :from (:argument 0) :to :result) fr0)
2675   (:temporary (:sc double-reg :offset fr1-offset
2676                    :from (:argument 1) :to :result) fr1)
2677   (:results (r :scs (double-reg)))
2678   (:arg-types double-float double-float)
2679   (:result-types double-float)
2680   (:policy :fast-safe)
2681   (:note "inline scalb function")
2682   (:vop-var vop)
2683   (:save-p :compute-only)
2684   (:generator 5
2685      (note-this-location vop :internal-error)
2686      ;; Setup x in fr0 and y in fr1
2687      (cond
2688       ;; x in fr0; y in fr1
2689       ((and (sc-is x double-reg) (zerop (tn-offset x))
2690             (sc-is y double-reg) (= 1 (tn-offset y))))
2691       ;; y in fr1; x not in fr0
2692       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2693        ;; Load x to fr0
2694        (sc-case x
2695           (double-reg
2696            (copy-fp-reg-to-fr0 x))
2697           (double-stack
2698            (inst fstp fr0)
2699            (inst fldd (ea-for-df-stack x)))
2700           (descriptor-reg
2701            (inst fstp fr0)
2702            (inst fldd (ea-for-df-desc x)))))
2703       ;; x in fr0; y not in fr1
2704       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2705        (inst fxch fr1)
2706        ;; Now load y to fr0
2707        (sc-case y
2708           (double-reg
2709            (copy-fp-reg-to-fr0 y))
2710           (double-stack
2711            (inst fstp fr0)
2712            (inst fldd (ea-for-df-stack y)))
2713           (descriptor-reg
2714            (inst fstp fr0)
2715            (inst fldd (ea-for-df-desc y))))
2716        (inst fxch fr1))
2717       ;; x in fr1; y not in fr1
2718       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2719        ;; Load y to fr0
2720        (sc-case y
2721           (double-reg
2722            (copy-fp-reg-to-fr0 y))
2723           (double-stack
2724            (inst fstp fr0)
2725            (inst fldd (ea-for-df-stack y)))
2726           (descriptor-reg
2727            (inst fstp fr0)
2728            (inst fldd (ea-for-df-desc y))))
2729        (inst fxch fr1))
2730       ;; y in fr0;
2731       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2732        (inst fxch fr1)
2733        ;; Now load x to fr0
2734        (sc-case x
2735           (double-reg
2736            (copy-fp-reg-to-fr0 x))
2737           (double-stack
2738            (inst fstp fr0)
2739            (inst fldd (ea-for-df-stack x)))
2740           (descriptor-reg
2741            (inst fstp fr0)
2742            (inst fldd (ea-for-df-desc x)))))
2743       ;; Neither x or y are in either fr0 or fr1
2744       (t
2745        ;; Load y then x
2746        (inst fstp fr0)
2747        (inst fstp fr0)
2748        (sc-case y
2749           (double-reg
2750            (inst fldd (make-random-tn :kind :normal
2751                                       :sc (sc-or-lose 'double-reg)
2752                                       :offset (- (tn-offset y) 2))))
2753           (double-stack
2754            (inst fldd (ea-for-df-stack y)))
2755           (descriptor-reg
2756            (inst fldd (ea-for-df-desc y))))
2757        ;; Load x to fr0
2758        (sc-case x
2759           (double-reg
2760            (inst fldd (make-random-tn :kind :normal
2761                                       :sc (sc-or-lose 'double-reg)
2762                                       :offset (1- (tn-offset x)))))
2763           (double-stack
2764            (inst fldd (ea-for-df-stack x)))
2765           (descriptor-reg
2766            (inst fldd (ea-for-df-desc x))))))
2767
2768      ;; Now have x at fr0; and y at fr1
2769      (inst fscale)
2770      (unless (zerop (tn-offset r))
2771              (inst fstd r))))
2772
2773 (define-vop (flog1p)
2774   (:translate %log1p)
2775   (:args (x :scs (double-reg) :to :result))
2776   (:temporary (:sc double-reg :offset fr0-offset
2777                    :from :argument :to :result) fr0)
2778   (:temporary (:sc double-reg :offset fr1-offset
2779                    :from :argument :to :result) fr1)
2780   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2781   (:results (y :scs (double-reg)))
2782   (:arg-types double-float)
2783   (:result-types double-float)
2784   (:policy :fast-safe)
2785   (:note "inline log1p function")
2786   (:ignore temp)
2787   (:generator 5
2788      ;; x is in a FP reg, not fr0, fr1.
2789      (inst fstp fr0)
2790      (inst fstp fr0)
2791      (inst fldd (make-random-tn :kind :normal
2792                                 :sc (sc-or-lose 'double-reg)
2793                                 :offset (- (tn-offset x) 2)))
2794      ;; Check the range
2795      (inst push #x3e947ae1)     ; Constant 0.29
2796      (inst fabs)
2797      (inst fld (make-ea :dword :base esp-tn))
2798      (inst fcompp)
2799      (inst add esp-tn 4)
2800      (inst fnstsw)                      ; status word to ax
2801      (inst and ah-tn #x45)
2802      (inst jmp :z WITHIN-RANGE)
2803      ;; Out of range for fyl2xp1.
2804      (inst fld1)
2805      (inst faddd (make-random-tn :kind :normal
2806                                  :sc (sc-or-lose 'double-reg)
2807                                  :offset (- (tn-offset x) 1)))
2808      (inst fldln2)
2809      (inst fxch fr1)
2810      (inst fyl2x)
2811      (inst jmp DONE)
2812
2813      WITHIN-RANGE
2814      (inst fldln2)
2815      (inst fldd (make-random-tn :kind :normal
2816                                 :sc (sc-or-lose 'double-reg)
2817                                 :offset (- (tn-offset x) 1)))
2818      (inst fyl2xp1)
2819      DONE
2820      (inst fld fr0)
2821      (case (tn-offset y)
2822        ((0 1))
2823        (t (inst fstd y)))))
2824
2825 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2826 ;;; instruction and a range check can be avoided.
2827 (define-vop (flog1p-pentium)
2828   (:translate %log1p)
2829   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2830   (:temporary (:sc double-reg :offset fr0-offset
2831                    :from :argument :to :result) fr0)
2832   (:temporary (:sc double-reg :offset fr1-offset
2833                    :from :argument :to :result) fr1)
2834   (:results (y :scs (double-reg)))
2835   (:arg-types double-float)
2836   (:result-types double-float)
2837   (:policy :fast-safe)
2838   (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2839   (:note "inline log1p with limited x range function")
2840   (:vop-var vop)
2841   (:save-p :compute-only)
2842   (:generator 4
2843      (note-this-location vop :internal-error)
2844      (sc-case x
2845         (double-reg
2846          (case (tn-offset x)
2847             (0
2848              ;; x is in fr0
2849              (inst fstp fr1)
2850              (inst fldln2)
2851              (inst fxch fr1))
2852             (1
2853              ;; x is in fr1
2854              (inst fstp fr0)
2855              (inst fldln2)
2856              (inst fxch fr1))
2857             (t
2858              ;; x is in a FP reg, not fr0 or fr1
2859              (inst fstp fr0)
2860              (inst fstp fr0)
2861              (inst fldln2)
2862              (inst fldd (make-random-tn :kind :normal
2863                                         :sc (sc-or-lose 'double-reg)
2864                                         :offset (1- (tn-offset x)))))))
2865         ((double-stack descriptor-reg)
2866          (inst fstp fr0)
2867          (inst fstp fr0)
2868          (inst fldln2)
2869          (if (sc-is x double-stack)
2870              (inst fldd (ea-for-df-stack x))
2871            (inst fldd (ea-for-df-desc x)))))
2872      (inst fyl2xp1)
2873      (inst fld fr0)
2874      (case (tn-offset y)
2875        ((0 1))
2876        (t (inst fstd y)))))
2877
2878 (define-vop (flogb)
2879   (:translate %logb)
2880   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2881   (:temporary (:sc double-reg :offset fr0-offset
2882                    :from :argument :to :result) fr0)
2883   (:temporary (:sc double-reg :offset fr1-offset
2884                    :from :argument :to :result) fr1)
2885   (:results (y :scs (double-reg)))
2886   (:arg-types double-float)
2887   (:result-types double-float)
2888   (:policy :fast-safe)
2889   (:note "inline logb function")
2890   (:vop-var vop)
2891   (:save-p :compute-only)
2892   (:generator 5
2893      (note-this-location vop :internal-error)
2894      (sc-case x
2895         (double-reg
2896          (case (tn-offset x)
2897             (0
2898              ;; x is in fr0
2899              (inst fstp fr1))
2900             (1
2901              ;; x is in fr1
2902              (inst fstp fr0))
2903             (t
2904              ;; x is in a FP reg, not fr0 or fr1
2905              (inst fstp fr0)
2906              (inst fstp fr0)
2907              (inst fldd (make-random-tn :kind :normal
2908                                         :sc (sc-or-lose 'double-reg)
2909                                         :offset (- (tn-offset x) 2))))))
2910         ((double-stack descriptor-reg)
2911          (inst fstp fr0)
2912          (inst fstp fr0)
2913          (if (sc-is x double-stack)
2914              (inst fldd (ea-for-df-stack x))
2915            (inst fldd (ea-for-df-desc x)))))
2916      (inst fxtract)
2917      (case (tn-offset y)
2918        (0
2919         (inst fxch fr1))
2920        (1)
2921        (t (inst fxch fr1)
2922           (inst fstd y)))))
2923
2924 (define-vop (fatan)
2925   (:translate %atan)
2926   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2927   (:temporary (:sc double-reg :offset fr0-offset
2928                    :from (:argument 0) :to :result) fr0)
2929   (:temporary (:sc double-reg :offset fr1-offset
2930                    :from (:argument 0) :to :result) fr1)
2931   (:results (r :scs (double-reg)))
2932   (:arg-types double-float)
2933   (:result-types double-float)
2934   (:policy :fast-safe)
2935   (:note "inline atan function")
2936   (:vop-var vop)
2937   (:save-p :compute-only)
2938   (:generator 5
2939      (note-this-location vop :internal-error)
2940      ;; Setup x in fr1 and 1.0 in fr0
2941      (cond
2942       ;; x in fr0
2943       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2944        (inst fstp fr1))
2945       ;; x in fr1
2946       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2947        (inst fstp fr0))
2948       ;; x not in fr0 or fr1
2949       (t
2950        ;; Load x then 1.0
2951        (inst fstp fr0)
2952        (inst fstp fr0)
2953        (sc-case x
2954           (double-reg
2955            (inst fldd (make-random-tn :kind :normal
2956                                       :sc (sc-or-lose 'double-reg)
2957                                       :offset (- (tn-offset x) 2))))
2958           (double-stack
2959            (inst fldd (ea-for-df-stack x)))
2960           (descriptor-reg
2961            (inst fldd (ea-for-df-desc x))))))
2962      (inst fld1)
2963      ;; Now have x at fr1; and 1.0 at fr0
2964      (inst fpatan)
2965      (inst fld fr0)
2966      (case (tn-offset r)
2967        ((0 1))
2968        (t (inst fstd r)))))
2969
2970 (define-vop (fatan2)
2971   (:translate %atan2)
2972   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
2973          (y :scs (double-reg double-stack descriptor-reg) :target fr0))
2974   (:temporary (:sc double-reg :offset fr0-offset
2975                    :from (:argument 1) :to :result) fr0)
2976   (:temporary (:sc double-reg :offset fr1-offset
2977                    :from (:argument 0) :to :result) fr1)
2978   (:results (r :scs (double-reg)))
2979   (:arg-types double-float double-float)
2980   (:result-types double-float)
2981   (:policy :fast-safe)
2982   (:note "inline atan2 function")
2983   (:vop-var vop)
2984   (:save-p :compute-only)
2985   (:generator 5
2986      (note-this-location vop :internal-error)
2987      ;; Setup x in fr1 and y in fr0
2988      (cond
2989       ;; y in fr0; x in fr1
2990       ((and (sc-is y double-reg) (zerop (tn-offset y))
2991             (sc-is x double-reg) (= 1 (tn-offset x))))
2992       ;; x in fr1; y not in fr0
2993       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2994        ;; Load y to fr0
2995        (sc-case y
2996           (double-reg
2997            (copy-fp-reg-to-fr0 y))
2998           (double-stack
2999            (inst fstp fr0)
3000            (inst fldd (ea-for-df-stack y)))
3001           (descriptor-reg
3002            (inst fstp fr0)
3003            (inst fldd (ea-for-df-desc y)))))
3004       ((and (sc-is x double-reg) (zerop (tn-offset x))
3005             (sc-is y double-reg) (zerop (tn-offset x)))
3006        ;; copy x to fr1
3007        (inst fst fr1))
3008       ;; y in fr0; x not in fr1
3009       ((and (sc-is y double-reg) (zerop (tn-offset y)))
3010        (inst fxch fr1)
3011        ;; Now load x to fr0
3012        (sc-case x
3013           (double-reg
3014            (copy-fp-reg-to-fr0 x))
3015           (double-stack
3016            (inst fstp fr0)
3017            (inst fldd (ea-for-df-stack x)))
3018           (descriptor-reg
3019            (inst fstp fr0)
3020            (inst fldd (ea-for-df-desc x))))
3021        (inst fxch fr1))
3022       ;; y in fr1; x not in fr1
3023       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3024        ;; Load x to fr0
3025        (sc-case x
3026           (double-reg
3027            (copy-fp-reg-to-fr0 x))
3028           (double-stack
3029            (inst fstp fr0)
3030            (inst fldd (ea-for-df-stack x)))
3031           (descriptor-reg
3032            (inst fstp fr0)
3033            (inst fldd (ea-for-df-desc x))))
3034        (inst fxch fr1))
3035       ;; x in fr0;
3036       ((and (sc-is x double-reg) (zerop (tn-offset x)))
3037        (inst fxch fr1)
3038        ;; Now load y to fr0
3039        (sc-case y
3040           (double-reg
3041            (copy-fp-reg-to-fr0 y))
3042           (double-stack
3043            (inst fstp fr0)
3044            (inst fldd (ea-for-df-stack y)))
3045           (descriptor-reg
3046            (inst fstp fr0)
3047            (inst fldd (ea-for-df-desc y)))))
3048       ;; Neither y or x are in either fr0 or fr1
3049       (t
3050        ;; Load x then y
3051        (inst fstp fr0)
3052        (inst fstp fr0)
3053        (sc-case x
3054           (double-reg
3055            (inst fldd (make-random-tn :kind :normal
3056                                       :sc (sc-or-lose 'double-reg)
3057                                       :offset (- (tn-offset x) 2))))
3058           (double-stack
3059            (inst fldd (ea-for-df-stack x)))
3060           (descriptor-reg
3061            (inst fldd (ea-for-df-desc x))))
3062        ;; Load y to fr0
3063        (sc-case y
3064           (double-reg
3065            (inst fldd (make-random-tn :kind :normal
3066                                       :sc (sc-or-lose 'double-reg)
3067                                       :offset (1- (tn-offset y)))))
3068           (double-stack
3069            (inst fldd (ea-for-df-stack y)))
3070           (descriptor-reg
3071            (inst fldd (ea-for-df-desc y))))))
3072
3073      ;; Now have y at fr0; and x at fr1
3074      (inst fpatan)
3075      (inst fld fr0)
3076      (case (tn-offset r)
3077        ((0 1))
3078        (t (inst fstd r)))))
3079 ) ; PROGN #!-LONG-FLOAT
3080 \f
3081 #!+long-float
3082 (progn
3083
3084 ;;; Lets use some of the 80387 special functions.
3085 ;;;
3086 ;;; These defs will not take effect unless code/irrat.lisp is modified
3087 ;;; to remove the inlined alien routine def.
3088
3089 (macrolet ((frob (func trans op)
3090              `(define-vop (,func)
3091                (:args (x :scs (long-reg) :target fr0))
3092                (:temporary (:sc long-reg :offset fr0-offset
3093                                 :from :argument :to :result) fr0)
3094                (:ignore fr0)
3095                (:results (y :scs (long-reg)))
3096                (:arg-types long-float)
3097                (:result-types long-float)
3098                (:translate ,trans)
3099                (:policy :fast-safe)
3100                (:note "inline NPX function")
3101                (:vop-var vop)
3102                (:save-p :compute-only)
3103                (:node-var node)
3104                (:generator 5
3105                 (note-this-location vop :internal-error)
3106                 (unless (zerop (tn-offset x))
3107                   (inst fxch x)         ; x to top of stack
3108                   (unless (location= x y)
3109                     (inst fst x)))      ; maybe save it
3110                 (inst ,op)              ; clobber st0
3111                 (cond ((zerop (tn-offset y))
3112                        (maybe-fp-wait node))
3113                       (t
3114                        (inst fst y)))))))
3115
3116   ;; Quick versions of FSIN and FCOS that require the argument to be
3117   ;; within range 2^63.
3118   (frob fsin-quick %sin-quick fsin)
3119   (frob fcos-quick %cos-quick fcos)
3120   (frob fsqrt %sqrt fsqrt))
3121
3122 ;;; Quick version of ftan that requires the argument to be within
3123 ;;; range 2^63.
3124 (define-vop (ftan-quick)
3125   (:translate %tan-quick)
3126   (:args (x :scs (long-reg) :target fr0))
3127   (:temporary (:sc long-reg :offset fr0-offset
3128                    :from :argument :to :result) fr0)
3129   (:temporary (:sc long-reg :offset fr1-offset
3130                    :from :argument :to :result) fr1)
3131   (:results (y :scs (long-reg)))
3132   (:arg-types long-float)
3133   (:result-types long-float)
3134   (:policy :fast-safe)
3135   (:note "inline tan function")
3136   (:vop-var vop)
3137   (:save-p :compute-only)
3138   (:generator 5
3139     (note-this-location vop :internal-error)
3140     (case (tn-offset x)
3141        (0
3142         (inst fstp fr1))
3143        (1
3144         (inst fstp fr0))
3145        (t
3146         (inst fstp fr0)
3147         (inst fstp fr0)
3148         (inst fldd (make-random-tn :kind :normal
3149                                    :sc (sc-or-lose 'double-reg)
3150                                    :offset (- (tn-offset x) 2)))))
3151     (inst fptan)
3152     ;; Result is in fr1
3153     (case (tn-offset y)
3154        (0
3155         (inst fxch fr1))
3156        (1)
3157        (t
3158         (inst fxch fr1)
3159         (inst fstd y)))))
3160
3161 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3162 ;;; the argument is out of range 2^63 and would thus be hopelessly
3163 ;;; inaccurate.
3164 (macrolet ((frob (func trans op)
3165              `(define-vop (,func)
3166                 (:translate ,trans)
3167                 (:args (x :scs (long-reg) :target fr0))
3168                 (:temporary (:sc long-reg :offset fr0-offset
3169                                  :from :argument :to :result) fr0)
3170                 (:temporary (:sc unsigned-reg :offset eax-offset
3171                              :from :argument :to :result) eax)
3172                 (:results (y :scs (long-reg)))
3173                 (:arg-types long-float)
3174                 (:result-types long-float)
3175                 (:policy :fast-safe)
3176                 (:note "inline sin/cos function")
3177                 (:vop-var vop)
3178                 (:save-p :compute-only)
3179                 (:ignore eax)
3180                 (:generator 5
3181                   (note-this-location vop :internal-error)
3182                   (unless (zerop (tn-offset x))
3183                           (inst fxch x)          ; x to top of stack
3184                           (unless (location= x y)
3185                                   (inst fst x))) ; maybe save it
3186                   (inst ,op)
3187                   (inst fnstsw)                  ; status word to ax
3188                   (inst and ah-tn #x04)          ; C2
3189                   (inst jmp :z DONE)
3190                   ;; Else x was out of range so reduce it; ST0 is unchanged.
3191                   (inst fstp fr0)               ; Load 0.0
3192                   (inst fldz)
3193                   DONE
3194                   (unless (zerop (tn-offset y))
3195                           (inst fstd y))))))
3196           (frob fsin  %sin fsin)
3197           (frob fcos  %cos fcos))
3198
3199 (define-vop (ftan)
3200   (:translate %tan)
3201   (:args (x :scs (long-reg) :target fr0))
3202   (:temporary (:sc long-reg :offset fr0-offset
3203                    :from :argument :to :result) fr0)
3204   (:temporary (:sc long-reg :offset fr1-offset
3205                    :from :argument :to :result) fr1)
3206   (:temporary (:sc unsigned-reg :offset eax-offset
3207                    :from :argument :to :result) eax)
3208   (:results (y :scs (long-reg)))
3209   (:arg-types long-float)
3210   (:result-types long-float)
3211   (:ignore eax)
3212   (:policy :fast-safe)
3213   (:note "inline tan function")
3214   (:vop-var vop)
3215   (:save-p :compute-only)
3216   (:ignore eax)
3217   (:generator 5
3218     (note-this-location vop :internal-error)
3219     (case (tn-offset x)
3220        (0
3221         (inst fstp fr1))
3222        (1
3223         (inst fstp fr0))
3224        (t
3225         (inst fstp fr0)
3226         (inst fstp fr0)
3227         (inst fldd (make-random-tn :kind :normal
3228                                    :sc (sc-or-lose 'double-reg)
3229                                    :offset (- (tn-offset x) 2)))))
3230     (inst fptan)
3231     (inst fnstsw)                        ; status word to ax
3232     (inst and ah-tn #x04)                ; C2
3233     (inst jmp :z DONE)
3234     ;; Else x was out of range so reduce it; ST0 is unchanged.
3235     (inst fldz)                  ; Load 0.0
3236     (inst fxch fr1)
3237     DONE
3238     ;; Result is in fr1
3239     (case (tn-offset y)
3240        (0
3241         (inst fxch fr1))
3242        (1)
3243        (t
3244         (inst fxch fr1)
3245         (inst fstd y)))))
3246
3247 ;;; Modified exp that handles the following special cases:
3248 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3249 (define-vop (fexp)
3250   (:translate %exp)
3251   (:args (x :scs (long-reg) :target fr0))
3252   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3253   (:temporary (:sc long-reg :offset fr0-offset
3254                    :from :argument :to :result) fr0)
3255   (:temporary (:sc long-reg :offset fr1-offset
3256                    :from :argument :to :result) fr1)
3257   (:temporary (:sc long-reg :offset fr2-offset
3258                    :from :argument :to :result) fr2)
3259   (:results (y :scs (long-reg)))
3260   (:arg-types long-float)
3261   (:result-types long-float)
3262   (:policy :fast-safe)
3263   (:note "inline exp function")
3264   (:vop-var vop)
3265   (:save-p :compute-only)
3266   (:ignore temp)
3267   (:generator 5
3268      (note-this-location vop :internal-error)
3269      (unless (zerop (tn-offset x))
3270              (inst fxch x)              ; x to top of stack
3271              (unless (location= x y)
3272                      (inst fst x)))     ; maybe save it
3273      ;; Check for Inf or NaN
3274      (inst fxam)
3275      (inst fnstsw)
3276      (inst sahf)
3277      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3278      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3279      (inst and ah-tn #x02)            ; Test sign of Inf.
3280      (inst jmp :z DONE)          ; +Inf gives +Inf.
3281      (inst fstp fr0)                ; -Inf gives 0
3282      (inst fldz)
3283      (inst jmp-short DONE)
3284      NOINFNAN
3285      (inst fstp fr1)
3286      (inst fldl2e)
3287      (inst fmul fr1)
3288      ;; Now fr0=x log2(e)
3289      (inst fst fr1)
3290      (inst frndint)
3291      (inst fst fr2)
3292      (inst fsubp-sti fr1)
3293      (inst f2xm1)
3294      (inst fld1)
3295      (inst faddp-sti fr1)
3296      (inst fscale)
3297      (inst fld fr0)
3298      DONE
3299      (unless (zerop (tn-offset y))
3300              (inst fstd y))))
3301
3302 ;;; Expm1 = exp(x) - 1.
3303 ;;; Handles the following special cases:
3304 ;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3305 (define-vop (fexpm1)
3306   (:translate %expm1)
3307   (:args (x :scs (long-reg) :target fr0))
3308   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3309   (:temporary (:sc long-reg :offset fr0-offset
3310                    :from :argument :to :result) fr0)
3311   (:temporary (:sc long-reg :offset fr1-offset
3312                    :from :argument :to :result) fr1)
3313   (:temporary (:sc long-reg :offset fr2-offset
3314                    :from :argument :to :result) fr2)
3315   (:results (y :scs (long-reg)))
3316   (:arg-types long-float)
3317   (:result-types long-float)
3318   (:policy :fast-safe)
3319   (:note "inline expm1 function")
3320   (:vop-var vop)
3321   (:save-p :compute-only)
3322   (:ignore temp)
3323   (:generator 5
3324      (note-this-location vop :internal-error)
3325      (unless (zerop (tn-offset x))
3326        (inst fxch x)            ; x to top of stack
3327        (unless (location= x y)
3328          (inst fst x))) ; maybe save it
3329      ;; Check for Inf or NaN
3330      (inst fxam)
3331      (inst fnstsw)
3332      (inst sahf)
3333      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3334      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3335      (inst and ah-tn #x02)            ; Test sign of Inf.
3336      (inst jmp :z DONE)          ; +Inf gives +Inf.
3337      (inst fstp fr0)                ; -Inf gives -1.0
3338      (inst fld1)
3339      (inst fchs)
3340      (inst jmp-short DONE)
3341      NOINFNAN
3342      ;; Free two stack slots leaving the argument on top.
3343      (inst fstp fr2)
3344      (inst fstp fr0)
3345      (inst fldl2e)
3346      (inst fmul fr1)    ; Now fr0 = x log2(e)
3347      (inst fst fr1)
3348      (inst frndint)
3349      (inst fsub-sti fr1)
3350      (inst fxch fr1)
3351      (inst f2xm1)
3352      (inst fscale)
3353      (inst fxch fr1)
3354      (inst fld1)
3355      (inst fscale)
3356      (inst fstp fr1)
3357      (inst fld1)
3358      (inst fsub fr1)
3359      (inst fsubr fr2)
3360      DONE
3361      (unless (zerop (tn-offset y))
3362        (inst fstd y))))
3363
3364 (define-vop (flog)
3365   (:translate %log)
3366   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3367   (:temporary (:sc long-reg :offset fr0-offset
3368                    :from :argument :to :result) fr0)
3369   (:temporary (:sc long-reg :offset fr1-offset
3370                    :from :argument :to :result) fr1)
3371   (:results (y :scs (long-reg)))
3372   (:arg-types long-float)
3373   (:result-types long-float)
3374   (:policy :fast-safe)
3375   (:note "inline log function")
3376   (:vop-var vop)
3377   (:save-p :compute-only)
3378   (:generator 5
3379      (note-this-location vop :internal-error)
3380      (sc-case x
3381         (long-reg
3382          (case (tn-offset x)
3383             (0
3384              ;; x is in fr0
3385              (inst fstp fr1)
3386              (inst fldln2)
3387              (inst fxch fr1))
3388             (1
3389              ;; x is in fr1
3390              (inst fstp fr0)
3391              (inst fldln2)
3392              (inst fxch fr1))
3393             (t
3394              ;; x is in a FP reg, not fr0 or fr1
3395              (inst fstp fr0)
3396              (inst fstp fr0)
3397              (inst fldln2)
3398              (inst fldd (make-random-tn :kind :normal
3399                                         :sc (sc-or-lose 'double-reg)
3400                                         :offset (1- (tn-offset x))))))
3401          (inst fyl2x))
3402         ((long-stack descriptor-reg)
3403          (inst fstp fr0)
3404          (inst fstp fr0)
3405          (inst fldln2)
3406          (if (sc-is x long-stack)
3407              (inst fldl (ea-for-lf-stack x))
3408              (inst fldl (ea-for-lf-desc x)))
3409          (inst fyl2x)))
3410      (inst fld fr0)
3411      (case (tn-offset y)
3412        ((0 1))
3413        (t (inst fstd y)))))
3414
3415 (define-vop (flog10)
3416   (:translate %log10)
3417   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3418   (:temporary (:sc long-reg :offset fr0-offset
3419                    :from :argument :to :result) fr0)
3420   (:temporary (:sc long-reg :offset fr1-offset
3421                    :from :argument :to :result) fr1)
3422   (:results (y :scs (long-reg)))
3423   (:arg-types long-float)
3424   (:result-types long-float)
3425   (:policy :fast-safe)
3426   (:note "inline log10 function")
3427   (:vop-var vop)
3428   (:save-p :compute-only)
3429   (:generator 5
3430      (note-this-location vop :internal-error)
3431      (sc-case x
3432         (long-reg
3433          (case (tn-offset x)
3434             (0
3435              ;; x is in fr0
3436              (inst fstp fr1)
3437              (inst fldlg2)
3438              (inst fxch fr1))
3439             (1
3440              ;; x is in fr1
3441              (inst fstp fr0)
3442              (inst fldlg2)
3443              (inst fxch fr1))
3444             (t
3445              ;; x is in a FP reg, not fr0 or fr1
3446              (inst fstp fr0)
3447              (inst fstp fr0)
3448              (inst fldlg2)
3449              (inst fldd (make-random-tn :kind :normal
3450                                         :sc (sc-or-lose 'double-reg)
3451                                         :offset (1- (tn-offset x))))))
3452          (inst fyl2x))
3453         ((long-stack descriptor-reg)
3454          (inst fstp fr0)
3455          (inst fstp fr0)
3456          (inst fldlg2)
3457          (if (sc-is x long-stack)
3458              (inst fldl (ea-for-lf-stack x))
3459              (inst fldl (ea-for-lf-desc x)))
3460          (inst fyl2x)))
3461      (inst fld fr0)
3462      (case (tn-offset y)
3463        ((0 1))
3464        (t (inst fstd y)))))
3465
3466 (define-vop (fpow)
3467   (:translate %pow)
3468   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3469          (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3470   (:temporary (:sc long-reg :offset fr0-offset
3471                    :from (:argument 0) :to :result) fr0)
3472   (:temporary (:sc long-reg :offset fr1-offset
3473                    :from (:argument 1) :to :result) fr1)
3474   (:temporary (:sc long-reg :offset fr2-offset
3475                    :from :load :to :result) fr2)
3476   (:results (r :scs (long-reg)))
3477   (:arg-types long-float long-float)
3478   (:result-types long-float)
3479   (:policy :fast-safe)
3480   (:note "inline pow function")
3481   (:vop-var vop)
3482   (:save-p :compute-only)
3483   (:generator 5
3484      (note-this-location vop :internal-error)
3485      ;; Setup x in fr0 and y in fr1
3486      (cond
3487       ;; x in fr0; y in fr1
3488       ((and (sc-is x long-reg) (zerop (tn-offset x))
3489             (sc-is y long-reg) (= 1 (tn-offset y))))
3490       ;; y in fr1; x not in fr0
3491       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3492        ;; Load x to fr0
3493        (sc-case x
3494           (long-reg
3495            (copy-fp-reg-to-fr0 x))
3496           (long-stack
3497            (inst fstp fr0)
3498            (inst fldl (ea-for-lf-stack x)))
3499           (descriptor-reg
3500            (inst fstp fr0)
3501            (inst fldl (ea-for-lf-desc x)))))
3502       ;; x in fr0; y not in fr1
3503       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3504        (inst fxch fr1)
3505        ;; Now load y to fr0
3506        (sc-case y
3507           (long-reg
3508            (copy-fp-reg-to-fr0 y))
3509           (long-stack
3510            (inst fstp fr0)
3511            (inst fldl (ea-for-lf-stack y)))
3512           (descriptor-reg
3513            (inst fstp fr0)
3514            (inst fldl (ea-for-lf-desc y))))
3515        (inst fxch fr1))
3516       ;; x in fr1; y not in fr1
3517       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3518        ;; Load y to fr0
3519        (sc-case y
3520           (long-reg
3521            (copy-fp-reg-to-fr0 y))
3522           (long-stack
3523            (inst fstp fr0)
3524            (inst fldl (ea-for-lf-stack y)))
3525           (descriptor-reg
3526            (inst fstp fr0)
3527            (inst fldl (ea-for-lf-desc y))))
3528        (inst fxch fr1))
3529       ;; y in fr0;
3530       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3531        (inst fxch fr1)
3532        ;; Now load x to fr0
3533        (sc-case x
3534           (long-reg
3535            (copy-fp-reg-to-fr0 x))
3536           (long-stack
3537            (inst fstp fr0)
3538            (inst fldl (ea-for-lf-stack x)))
3539           (descriptor-reg
3540            (inst fstp fr0)
3541            (inst fldl (ea-for-lf-desc x)))))
3542       ;; Neither x or y are in either fr0 or fr1
3543       (t
3544        ;; Load y then x
3545        (inst fstp fr0)
3546        (inst fstp fr0)
3547        (sc-case y
3548           (long-reg
3549            (inst fldd (make-random-tn :kind :normal
3550                                       :sc (sc-or-lose 'double-reg)
3551                                       :offset (- (tn-offset y) 2))))
3552           (long-stack
3553            (inst fldl (ea-for-lf-stack y)))
3554           (descriptor-reg
3555            (inst fldl (ea-for-lf-desc y))))
3556        ;; Load x to fr0
3557        (sc-case x
3558           (long-reg
3559            (inst fldd (make-random-tn :kind :normal
3560                                       :sc (sc-or-lose 'double-reg)
3561                                       :offset (1- (tn-offset x)))))
3562           (long-stack
3563            (inst fldl (ea-for-lf-stack x)))
3564           (descriptor-reg
3565            (inst fldl (ea-for-lf-desc x))))))
3566
3567      ;; Now have x at fr0; and y at fr1
3568      (inst fyl2x)
3569      ;; Now fr0=y log2(x)
3570      (inst fld fr0)
3571      (inst frndint)
3572      (inst fst fr2)
3573      (inst fsubp-sti fr1)
3574      (inst f2xm1)
3575      (inst fld1)
3576      (inst faddp-sti fr1)
3577      (inst fscale)
3578      (inst fld fr0)
3579      (case (tn-offset r)
3580        ((0 1))
3581        (t (inst fstd r)))))
3582
3583 (define-vop (fscalen)
3584   (:translate %scalbn)
3585   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3586          (y :scs (signed-stack signed-reg) :target temp))
3587   (:temporary (:sc long-reg :offset fr0-offset
3588                    :from (:argument 0) :to :result) fr0)
3589   (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3590   (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3591   (:results (r :scs (long-reg)))
3592   (:arg-types long-float signed-num)
3593   (:result-types long-float)
3594   (:policy :fast-safe)
3595   (:note "inline scalbn function")
3596   (:generator 5
3597      ;; Setup x in fr0 and y in fr1
3598      (sc-case x
3599        (long-reg
3600         (case (tn-offset x)
3601           (0
3602            (inst fstp fr1)
3603            (sc-case y
3604              (signed-reg
3605               (inst mov temp y)
3606               (inst fild temp))
3607              (signed-stack
3608               (inst fild y)))
3609            (inst fxch fr1))
3610           (1
3611            (inst fstp fr0)
3612            (sc-case y
3613              (signed-reg
3614               (inst mov temp y)
3615               (inst fild temp))
3616              (signed-stack
3617               (inst fild y)))
3618            (inst fxch fr1))
3619           (t
3620            (inst fstp fr0)
3621            (inst fstp fr0)
3622            (sc-case y
3623              (signed-reg
3624               (inst mov temp y)
3625               (inst fild temp))
3626              (signed-stack
3627               (inst fild y)))
3628            (inst fld (make-random-tn :kind :normal
3629                                      :sc (sc-or-lose 'double-reg)
3630                                      :offset (1- (tn-offset x)))))))
3631        ((long-stack descriptor-reg)
3632         (inst fstp fr0)
3633         (inst fstp fr0)
3634         (sc-case y
3635           (signed-reg
3636            (inst mov temp y)
3637            (inst fild temp))
3638           (signed-stack
3639            (inst fild y)))
3640         (if (sc-is x long-stack)
3641             (inst fldl (ea-for-lf-stack x))
3642             (inst fldl (ea-for-lf-desc x)))))
3643      (inst fscale)
3644      (unless (zerop (tn-offset r))
3645        (inst fstd r))))
3646
3647 (define-vop (fscale)
3648   (:translate %scalb)
3649   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3650          (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3651   (:temporary (:sc long-reg :offset fr0-offset
3652                    :from (:argument 0) :to :result) fr0)
3653   (:temporary (:sc long-reg :offset fr1-offset
3654                    :from (:argument 1) :to :result) fr1)
3655   (:results (r :scs (long-reg)))
3656   (:arg-types long-float long-float)
3657   (:result-types long-float)
3658   (:policy :fast-safe)
3659   (:note "inline scalb function")
3660   (:vop-var vop)
3661   (:save-p :compute-only)
3662   (:generator 5
3663      (note-this-location vop :internal-error)
3664      ;; Setup x in fr0 and y in fr1
3665      (cond
3666       ;; x in fr0; y in fr1
3667       ((and (sc-is x long-reg) (zerop (tn-offset x))
3668             (sc-is y long-reg) (= 1 (tn-offset y))))
3669       ;; y in fr1; x not in fr0
3670       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3671        ;; Load x to fr0
3672        (sc-case x
3673           (long-reg
3674            (copy-fp-reg-to-fr0 x))
3675           (long-stack
3676            (inst fstp fr0)
3677            (inst fldl (ea-for-lf-stack x)))
3678           (descriptor-reg
3679            (inst fstp fr0)
3680            (inst fldl (ea-for-lf-desc x)))))
3681       ;; x in fr0; y not in fr1
3682       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3683        (inst fxch fr1)
3684        ;; Now load y to fr0
3685        (sc-case y
3686           (long-reg
3687            (copy-fp-reg-to-fr0 y))
3688           (long-stack
3689            (inst fstp fr0)
3690            (inst fldl (ea-for-lf-stack y)))
3691           (descriptor-reg
3692            (inst fstp fr0)
3693            (inst fldl (ea-for-lf-desc y))))
3694        (inst fxch fr1))
3695       ;; x in fr1; y not in fr1
3696       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3697        ;; Load y to fr0
3698        (sc-case y
3699           (long-reg
3700            (copy-fp-reg-to-fr0 y))
3701           (long-stack
3702            (inst fstp fr0)
3703            (inst fldl (ea-for-lf-stack y)))
3704           (descriptor-reg
3705            (inst fstp fr0)
3706            (inst fldl (ea-for-lf-desc y))))
3707        (inst fxch fr1))
3708       ;; y in fr0;
3709       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3710        (inst fxch fr1)
3711        ;; Now load x to fr0
3712        (sc-case x
3713           (long-reg
3714            (copy-fp-reg-to-fr0 x))
3715           (long-stack
3716            (inst fstp fr0)
3717            (inst fldl (ea-for-lf-stack x)))
3718           (descriptor-reg
3719            (inst fstp fr0)
3720            (inst fldl (ea-for-lf-desc x)))))
3721       ;; Neither x or y are in either fr0 or fr1
3722       (t
3723        ;; Load y then x
3724        (inst fstp fr0)
3725        (inst fstp fr0)
3726        (sc-case y
3727           (long-reg
3728            (inst fldd (make-random-tn :kind :normal
3729                                       :sc (sc-or-lose 'double-reg)
3730                                       :offset (- (tn-offset y) 2))))
3731           (long-stack
3732            (inst fldl (ea-for-lf-stack y)))
3733           (descriptor-reg
3734            (inst fldl (ea-for-lf-desc y))))
3735        ;; Load x to fr0
3736        (sc-case x
3737           (long-reg
3738            (inst fldd (make-random-tn :kind :normal
3739                                       :sc (sc-or-lose 'double-reg)
3740                                       :offset (1- (tn-offset x)))))
3741           (long-stack
3742            (inst fldl (ea-for-lf-stack x)))
3743           (descriptor-reg
3744            (inst fldl (ea-for-lf-desc x))))))
3745
3746      ;; Now have x at fr0; and y at fr1
3747      (inst fscale)
3748      (unless (zerop (tn-offset r))
3749              (inst fstd r))))
3750
3751 (define-vop (flog1p)
3752   (:translate %log1p)
3753   (:args (x :scs (long-reg) :to :result))
3754   (:temporary (:sc long-reg :offset fr0-offset
3755                    :from :argument :to :result) fr0)
3756   (:temporary (:sc long-reg :offset fr1-offset
3757                    :from :argument :to :result) fr1)
3758   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3759   (:results (y :scs (long-reg)))
3760   (:arg-types long-float)
3761   (:result-types long-float)
3762   (:policy :fast-safe)
3763   ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3764   ;;   Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3765   ;;   an enormous PROGN above. Still, it would be probably be good to
3766   ;;   add some code to warn about redefining VOPs.
3767   (:note "inline log1p function")
3768   (:ignore temp)
3769   (:generator 5
3770      ;; x is in a FP reg, not fr0, fr1.
3771      (inst fstp fr0)
3772      (inst fstp fr0)
3773      (inst fldd (make-random-tn :kind :normal
3774                                 :sc (sc-or-lose 'double-reg)
3775                                 :offset (- (tn-offset x) 2)))
3776      ;; Check the range
3777      (inst push #x3e947ae1)     ; Constant 0.29
3778      (inst fabs)
3779      (inst fld (make-ea :dword :base esp-tn))
3780      (inst fcompp)
3781      (inst add esp-tn 4)
3782      (inst fnstsw)                      ; status word to ax
3783      (inst and ah-tn #x45)
3784      (inst jmp :z WITHIN-RANGE)
3785      ;; Out of range for fyl2xp1.
3786      (inst fld1)
3787      (inst faddd (make-random-tn :kind :normal
3788                                  :sc (sc-or-lose 'double-reg)
3789                                  :offset (- (tn-offset x) 1)))
3790      (inst fldln2)
3791      (inst fxch fr1)
3792      (inst fyl2x)
3793      (inst jmp DONE)
3794
3795      WITHIN-RANGE
3796      (inst fldln2)
3797      (inst fldd (make-random-tn :kind :normal
3798                                 :sc (sc-or-lose 'double-reg)
3799                                 :offset (- (tn-offset x) 1)))
3800      (inst fyl2xp1)
3801      DONE
3802      (inst fld fr0)
3803      (case (tn-offset y)
3804        ((0 1))
3805        (t (inst fstd y)))))
3806
3807 ;;; The Pentium has a less restricted implementation of the fyl2xp1
3808 ;;; instruction and a range check can be avoided.
3809 (define-vop (flog1p-pentium)
3810   (:translate %log1p)
3811   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3812   (:temporary (:sc long-reg :offset fr0-offset
3813                    :from :argument :to :result) fr0)
3814   (:temporary (:sc long-reg :offset fr1-offset
3815                    :from :argument :to :result) fr1)
3816   (:results (y :scs (long-reg)))
3817   (:arg-types long-float)
3818   (:result-types long-float)
3819   (:policy :fast-safe)
3820   (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
3821   (:note "inline log1p function")
3822   (:generator 5
3823      (sc-case x
3824         (long-reg
3825          (case (tn-offset x)
3826             (0
3827              ;; x is in fr0
3828              (inst fstp fr1)
3829              (inst fldln2)
3830              (inst fxch fr1))
3831             (1
3832              ;; x is in fr1
3833              (inst fstp fr0)
3834              (inst fldln2)
3835              (inst fxch fr1))
3836             (t
3837              ;; x is in a FP reg, not fr0 or fr1
3838              (inst fstp fr0)
3839              (inst fstp fr0)
3840              (inst fldln2)
3841              (inst fldd (make-random-tn :kind :normal
3842                                         :sc (sc-or-lose 'double-reg)
3843                                         :offset (1- (tn-offset x)))))))
3844         ((long-stack descriptor-reg)
3845          (inst fstp fr0)
3846          (inst fstp fr0)
3847          (inst fldln2)
3848          (if (sc-is x long-stack)
3849              (inst fldl (ea-for-lf-stack x))
3850            (inst fldl (ea-for-lf-desc x)))))
3851      (inst fyl2xp1)
3852      (inst fld fr0)
3853      (case (tn-offset y)
3854        ((0 1))
3855        (t (inst fstd y)))))
3856
3857 (define-vop (flogb)
3858   (:translate %logb)
3859   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3860   (:temporary (:sc long-reg :offset fr0-offset
3861                    :from :argument :to :result) fr0)
3862   (:temporary (:sc long-reg :offset fr1-offset
3863                    :from :argument :to :result) fr1)
3864   (:results (y :scs (long-reg)))
3865   (:arg-types long-float)
3866   (:result-types long-float)
3867   (:policy :fast-safe)
3868   (:note "inline logb function")
3869   (:vop-var vop)
3870   (:save-p :compute-only)
3871   (:generator 5
3872      (note-this-location vop :internal-error)
3873      (sc-case x
3874         (long-reg
3875          (case (tn-offset x)
3876             (0
3877              ;; x is in fr0
3878              (inst fstp fr1))
3879             (1
3880              ;; x is in fr1
3881              (inst fstp fr0))
3882             (t
3883              ;; x is in a FP reg, not fr0 or fr1
3884              (inst fstp fr0)
3885              (inst fstp fr0)
3886              (inst fldd (make-random-tn :kind :normal
3887                                         :sc (sc-or-lose 'double-reg)
3888                                         :offset (- (tn-offset x) 2))))))
3889         ((long-stack descriptor-reg)
3890          (inst fstp fr0)
3891          (inst fstp fr0)
3892          (if (sc-is x long-stack)
3893              (inst fldl (ea-for-lf-stack x))
3894            (inst fldl (ea-for-lf-desc x)))))
3895      (inst fxtract)
3896      (case (tn-offset y)
3897        (0
3898         (inst fxch fr1))
3899        (1)
3900        (t (inst fxch fr1)
3901           (inst fstd y)))))
3902
3903 (define-vop (fatan)
3904   (:translate %atan)
3905   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3906   (:temporary (:sc long-reg :offset fr0-offset
3907                    :from (:argument 0) :to :result) fr0)
3908   (:temporary (:sc long-reg :offset fr1-offset
3909                    :from (:argument 0) :to :result) fr1)
3910   (:results (r :scs (long-reg)))
3911   (:arg-types long-float)
3912   (:result-types long-float)
3913   (:policy :fast-safe)
3914   (:note "inline atan function")
3915   (:vop-var vop)
3916   (:save-p :compute-only)
3917   (:generator 5
3918      (note-this-location vop :internal-error)
3919      ;; Setup x in fr1 and 1.0 in fr0
3920      (cond
3921       ;; x in fr0
3922       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3923        (inst fstp fr1))
3924       ;; x in fr1
3925       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3926        (inst fstp fr0))
3927       ;; x not in fr0 or fr1
3928       (t
3929        ;; Load x then 1.0
3930        (inst fstp fr0)
3931        (inst fstp fr0)
3932        (sc-case x
3933           (long-reg
3934            (inst fldd (make-random-tn :kind :normal
3935                                       :sc (sc-or-lose 'double-reg)
3936                                       :offset (- (tn-offset x) 2))))
3937           (long-stack
3938            (inst fldl (ea-for-lf-stack x)))
3939           (descriptor-reg
3940            (inst fldl (ea-for-lf-desc x))))))
3941      (inst fld1)
3942      ;; Now have x at fr1; and 1.0 at fr0
3943      (inst fpatan)
3944      (inst fld fr0)
3945      (case (tn-offset r)
3946        ((0 1))
3947        (t (inst fstd r)))))
3948
3949 (define-vop (fatan2)
3950   (:translate %atan2)
3951   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
3952          (y :scs (long-reg long-stack descriptor-reg) :target fr0))
3953   (:temporary (:sc long-reg :offset fr0-offset
3954                    :from (:argument 1) :to :result) fr0)
3955   (:temporary (:sc long-reg :offset fr1-offset
3956                    :from (:argument 0) :to :result) fr1)
3957   (:results (r :scs (long-reg)))
3958   (:arg-types long-float long-float)
3959   (:result-types long-float)
3960   (:policy :fast-safe)
3961   (:note "inline atan2 function")
3962   (:vop-var vop)
3963   (:save-p :compute-only)
3964   (:generator 5
3965      (note-this-location vop :internal-error)
3966      ;; Setup x in fr1 and y in fr0
3967      (cond
3968       ;; y in fr0; x in fr1
3969       ((and (sc-is y long-reg) (zerop (tn-offset y))
3970             (sc-is x long-reg) (= 1 (tn-offset x))))
3971       ;; x in fr1; y not in fr0
3972       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3973        ;; Load y to fr0
3974        (sc-case y
3975           (long-reg
3976            (copy-fp-reg-to-fr0 y))
3977           (long-stack
3978            (inst fstp fr0)
3979            (inst fldl (ea-for-lf-stack y)))
3980           (descriptor-reg
3981            (inst fstp fr0)
3982            (inst fldl (ea-for-lf-desc y)))))
3983       ;; y in fr0; x not in fr1
3984       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3985        (inst fxch fr1)
3986        ;; Now load x to fr0
3987        (sc-case x
3988           (long-reg
3989            (copy-fp-reg-to-fr0 x))
3990           (long-stack
3991            (inst fstp fr0)
3992            (inst fldl (ea-for-lf-stack x)))
3993           (descriptor-reg
3994            (inst fstp fr0)
3995            (inst fldl (ea-for-lf-desc x))))
3996        (inst fxch fr1))
3997       ;; y in fr1; x not in fr1
3998       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3999        ;; Load x to fr0
4000        (sc-case x
4001           (long-reg
4002            (copy-fp-reg-to-fr0 x))
4003           (long-stack
4004            (inst fstp fr0)
4005            (inst fldl (ea-for-lf-stack x)))
4006           (descriptor-reg
4007            (inst fstp fr0)
4008            (inst fldl (ea-for-lf-desc x))))
4009        (inst fxch fr1))
4010       ;; x in fr0;
4011       ((and (sc-is x long-reg) (zerop (tn-offset x)))
4012        (inst fxch fr1)
4013        ;; Now load y to fr0
4014        (sc-case y
4015           (long-reg
4016            (copy-fp-reg-to-fr0 y))
4017           (long-stack
4018            (inst fstp fr0)
4019            (inst fldl (ea-for-lf-stack y)))
4020           (descriptor-reg
4021            (inst fstp fr0)
4022            (inst fldl (ea-for-lf-desc y)))))
4023       ;; Neither y or x are in either fr0 or fr1
4024       (t
4025        ;; Load x then y
4026        (inst fstp fr0)
4027        (inst fstp fr0)
4028        (sc-case x
4029           (long-reg
4030            (inst fldd (make-random-tn :kind :normal
4031                                       :sc (sc-or-lose 'double-reg)
4032                                       :offset (- (tn-offset x) 2))))
4033           (long-stack
4034            (inst fldl (ea-for-lf-stack x)))
4035           (descriptor-reg
4036            (inst fldl (ea-for-lf-desc x))))
4037        ;; Load y to fr0
4038        (sc-case y
4039           (long-reg
4040            (inst fldd (make-random-tn :kind :normal
4041                                       :sc (sc-or-lose 'double-reg)
4042                                       :offset (1- (tn-offset y)))))
4043           (long-stack
4044            (inst fldl (ea-for-lf-stack y)))
4045           (descriptor-reg
4046            (inst fldl (ea-for-lf-desc y))))))
4047
4048      ;; Now have y at fr0; and x at fr1
4049      (inst fpatan)
4050      (inst fld fr0)
4051      (case (tn-offset r)
4052        ((0 1))
4053        (t (inst fstd r)))))
4054
4055 ) ; PROGN #!+LONG-FLOAT
4056 \f
4057 ;;;; complex float VOPs
4058
4059 (define-vop (make-complex-single-float)
4060   (:translate complex)
4061   (:args (real :scs (single-reg) :to :result :target r
4062                :load-if (not (location= real r)))
4063          (imag :scs (single-reg) :to :save))
4064   (:arg-types single-float single-float)
4065   (:results (r :scs (complex-single-reg) :from (:argument 0)
4066                :load-if (not (sc-is r complex-single-stack))))
4067   (:result-types complex-single-float)
4068   (:note "inline complex single-float creation")
4069   (:policy :fast-safe)
4070   (:generator 5
4071     (sc-case r
4072       (complex-single-reg
4073        (let ((r-real (complex-double-reg-real-tn r)))
4074          (unless (location= real r-real)
4075            (cond ((zerop (tn-offset r-real))
4076                   (copy-fp-reg-to-fr0 real))
4077                  ((zerop (tn-offset real))
4078                   (inst fstd r-real))
4079                  (t
4080                   (inst fxch real)
4081                   (inst fstd r-real)
4082                   (inst fxch real)))))
4083        (let ((r-imag (complex-double-reg-imag-tn r)))
4084          (unless (location= imag r-imag)
4085            (cond ((zerop (tn-offset imag))
4086                   (inst fstd r-imag))
4087                  (t
4088                   (inst fxch imag)
4089                   (inst fstd r-imag)
4090                   (inst fxch imag))))))
4091       (complex-single-stack
4092        (unless (location= real r)
4093          (cond ((zerop (tn-offset real))
4094                 (inst fst (ea-for-csf-real-stack r)))
4095                (t
4096                 (inst fxch real)
4097                 (inst fst (ea-for-csf-real-stack r))
4098                 (inst fxch real))))
4099        (inst fxch imag)
4100        (inst fst (ea-for-csf-imag-stack r))
4101        (inst fxch imag)))))
4102
4103 (define-vop (make-complex-double-float)
4104   (:translate complex)
4105   (:args (real :scs (double-reg) :target r
4106                :load-if (not (location= real r)))
4107          (imag :scs (double-reg) :to :save))
4108   (:arg-types double-float double-float)
4109   (:results (r :scs (complex-double-reg) :from (:argument 0)
4110                :load-if (not (sc-is r complex-double-stack))))
4111   (:result-types complex-double-float)
4112   (:note "inline complex double-float creation")
4113   (:policy :fast-safe)
4114   (:generator 5
4115     (sc-case r
4116       (complex-double-reg
4117        (let ((r-real (complex-double-reg-real-tn r)))
4118          (unless (location= real r-real)
4119            (cond ((zerop (tn-offset r-real))
4120                   (copy-fp-reg-to-fr0 real))
4121                  ((zerop (tn-offset real))
4122                   (inst fstd r-real))
4123                  (t
4124                   (inst fxch real)
4125                   (inst fstd r-real)
4126                   (inst fxch real)))))
4127        (let ((r-imag (complex-double-reg-imag-tn r)))
4128          (unless (location= imag r-imag)
4129            (cond ((zerop (tn-offset imag))
4130                   (inst fstd r-imag))
4131                  (t
4132                   (inst fxch imag)
4133                   (inst fstd r-imag)
4134                   (inst fxch imag))))))
4135       (complex-double-stack
4136        (unless (location= real r)
4137          (cond ((zerop (tn-offset real))
4138                 (inst fstd (ea-for-cdf-real-stack r)))
4139                (t
4140                 (inst fxch real)
4141                 (inst fstd (ea-for-cdf-real-stack r))
4142                 (inst fxch real))))
4143        (inst fxch imag)
4144        (inst fstd (ea-for-cdf-imag-stack r))
4145        (inst fxch imag)))))
4146
4147 #!+long-float
4148 (define-vop (make-complex-long-float)
4149   (:translate complex)
4150   (:args (real :scs (long-reg) :target r
4151                :load-if (not (location= real r)))
4152          (imag :scs (long-reg) :to :save))
4153   (:arg-types long-float long-float)
4154   (:results (r :scs (complex-long-reg) :from (:argument 0)
4155                :load-if (not (sc-is r complex-long-stack))))
4156   (:result-types complex-long-float)
4157   (:note "inline complex long-float creation")
4158   (:policy :fast-safe)
4159   (:generator 5
4160     (sc-case r
4161       (complex-long-reg
4162        (let ((r-real (complex-double-reg-real-tn r)))
4163          (unless (location= real r-real)
4164            (cond ((zerop (tn-offset r-real))
4165                   (copy-fp-reg-to-fr0 real))
4166                  ((zerop (tn-offset real))
4167                   (inst fstd r-real))
4168                  (t
4169                   (inst fxch real)
4170                   (inst fstd r-real)
4171                   (inst fxch real)))))
4172        (let ((r-imag (complex-double-reg-imag-tn r)))
4173          (unless (location= imag r-imag)
4174            (cond ((zerop (tn-offset imag))
4175                   (inst fstd r-imag))
4176                  (t
4177                   (inst fxch imag)
4178                   (inst fstd r-imag)
4179                   (inst fxch imag))))))
4180       (complex-long-stack
4181        (unless (location= real r)
4182          (cond ((zerop (tn-offset real))
4183                 (store-long-float (ea-for-clf-real-stack r)))
4184                (t
4185                 (inst fxch real)
4186                 (store-long-float (ea-for-clf-real-stack r))
4187                 (inst fxch real))))
4188        (inst fxch imag)
4189        (store-long-float (ea-for-clf-imag-stack r))
4190        (inst fxch imag)))))
4191
4192
4193 (define-vop (complex-float-value)
4194   (:args (x :target r))
4195   (:results (r))
4196   (:variant-vars offset)
4197   (:policy :fast-safe)
4198   (:generator 3
4199     (cond ((sc-is x complex-single-reg complex-double-reg
4200                   #!+long-float complex-long-reg)
4201            (let ((value-tn
4202                   (make-random-tn :kind :normal
4203                                   :sc (sc-or-lose 'double-reg)
4204                                   :offset (+ offset (tn-offset x)))))
4205              (unless (location= value-tn r)
4206                (cond ((zerop (tn-offset r))
4207                       (copy-fp-reg-to-fr0 value-tn))
4208                      ((zerop (tn-offset value-tn))
4209                       (inst fstd r))
4210                      (t
4211                       (inst fxch value-tn)
4212                       (inst fstd r)
4213                       (inst fxch value-tn))))))
4214           ((sc-is r single-reg)
4215            (let ((ea (sc-case x
4216                        (complex-single-stack
4217                         (ecase offset
4218                           (0 (ea-for-csf-real-stack x))
4219                           (1 (ea-for-csf-imag-stack x))))
4220                        (descriptor-reg
4221                         (ecase offset
4222                           (0 (ea-for-csf-real-desc x))
4223                           (1 (ea-for-csf-imag-desc x)))))))
4224              (with-empty-tn@fp-top(r)
4225                (inst fld ea))))
4226           ((sc-is r double-reg)
4227            (let ((ea (sc-case x
4228                        (complex-double-stack
4229                         (ecase offset
4230                           (0 (ea-for-cdf-real-stack x))
4231                           (1 (ea-for-cdf-imag-stack x))))
4232                        (descriptor-reg
4233                         (ecase offset
4234                           (0 (ea-for-cdf-real-desc x))
4235                           (1 (ea-for-cdf-imag-desc x)))))))
4236              (with-empty-tn@fp-top(r)
4237                (inst fldd ea))))
4238           #!+long-float
4239           ((sc-is r long-reg)
4240            (let ((ea (sc-case x
4241                        (complex-long-stack
4242                         (ecase offset
4243                           (0 (ea-for-clf-real-stack x))
4244                           (1 (ea-for-clf-imag-stack x))))
4245                        (descriptor-reg
4246                         (ecase offset
4247                           (0 (ea-for-clf-real-desc x))
4248                           (1 (ea-for-clf-imag-desc x)))))))
4249              (with-empty-tn@fp-top(r)
4250                (inst fldl ea))))
4251           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4252
4253 (define-vop (realpart/complex-single-float complex-float-value)
4254   (:translate realpart)
4255   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4256             :target r))
4257   (:arg-types complex-single-float)
4258   (:results (r :scs (single-reg)))
4259   (:result-types single-float)
4260   (:note "complex float realpart")
4261   (:variant 0))
4262
4263 (define-vop (realpart/complex-double-float complex-float-value)
4264   (:translate realpart)
4265   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4266             :target r))
4267   (:arg-types complex-double-float)
4268   (:results (r :scs (double-reg)))
4269   (:result-types double-float)
4270   (:note "complex float realpart")
4271   (:variant 0))
4272
4273 #!+long-float
4274 (define-vop (realpart/complex-long-float complex-float-value)
4275   (:translate realpart)
4276   (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4277             :target r))
4278   (:arg-types complex-long-float)
4279   (:results (r :scs (long-reg)))
4280   (:result-types long-float)
4281   (:note "complex float realpart")
4282   (:variant 0))
4283
4284 (define-vop (imagpart/complex-single-float complex-float-value)
4285   (:translate imagpart)
4286   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4287             :target r))
4288   (:arg-types complex-single-float)
4289   (:results (r :scs (single-reg)))
4290   (:result-types single-float)
4291   (:note "complex float imagpart")
4292   (:variant 1))
4293
4294 (define-vop (imagpart/complex-double-float complex-float-value)
4295   (:translate imagpart)
4296   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4297             :target r))
4298   (:arg-types complex-double-float)
4299   (:results (r :scs (double-reg)))
4300   (:result-types double-float)
4301   (:note "complex float imagpart")
4302   (:variant 1))
4303
4304 #!+long-float
4305 (define-vop (imagpart/complex-long-float complex-float-value)
4306   (:translate imagpart)
4307   (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4308             :target r))
4309   (:arg-types complex-long-float)
4310   (:results (r :scs (long-reg)))
4311   (:result-types long-float)
4312   (:note "complex float imagpart")
4313   (:variant 1))
4314 \f
4315 ;;; hack dummy VOPs to bias the representation selection of their
4316 ;;; arguments towards a FP register, which can help avoid consing at
4317 ;;; inappropriate locations
4318 (defknown double-float-reg-bias (double-float) (values))
4319 (define-vop (double-float-reg-bias)
4320   (:translate double-float-reg-bias)
4321   (:args (x :scs (double-reg double-stack) :load-if nil))
4322   (:arg-types double-float)
4323   (:policy :fast-safe)
4324   (:note "inline dummy FP register bias")
4325   (:ignore x)
4326   (:generator 0))
4327 (defknown single-float-reg-bias (single-float) (values))
4328 (define-vop (single-float-reg-bias)
4329   (:translate single-float-reg-bias)
4330   (:args (x :scs (single-reg single-stack) :load-if nil))
4331   (:arg-types single-float)
4332   (:policy :fast-safe)
4333   (:note "inline dummy FP register bias")
4334   (:ignore x)
4335   (:generator 0))