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-single-float-c)
1825   (:results (res :scs (single-reg single-stack)))
1826   (:arg-types (:constant (signed-byte 32)))
1827   (:result-types single-float)
1828   (:info bits)
1829   (:translate make-single-float)
1830   (:policy :fast-safe)
1831   (:vop-var vop)
1832   (:generator 2
1833     (sc-case res
1834       (single-stack
1835        (inst mov res bits))
1836       (single-reg
1837        (with-empty-tn@fp-top (res)
1838          (inst fld (register-inline-constant :dword bits)))))))
1839
1840 (define-vop (make-double-float)
1841   (:args (hi-bits :scs (signed-reg))
1842          (lo-bits :scs (unsigned-reg)))
1843   (:results (res :scs (double-reg)))
1844   (:temporary (:sc double-stack) temp)
1845   (:arg-types signed-num unsigned-num)
1846   (:result-types double-float)
1847   (:translate make-double-float)
1848   (:policy :fast-safe)
1849   (:vop-var vop)
1850   (:generator 2
1851     (let ((offset (tn-offset temp)))
1852       (storew hi-bits ebp-tn (frame-word-offset offset))
1853       (storew lo-bits ebp-tn (frame-word-offset (1+ offset)))
1854       (with-empty-tn@fp-top(res)
1855         (inst fldd (make-ea :dword :base ebp-tn
1856                             :disp (frame-byte-offset (1+ offset))))))))
1857
1858 (define-vop (make-double-float-c)
1859   (:results (res :scs (double-reg)))
1860   (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32)))
1861   (:result-types double-float)
1862   (:info hi lo)
1863   (:translate make-double-float)
1864   (:policy :fast-safe)
1865   (:vop-var vop)
1866   (:generator 1
1867     (with-empty-tn@fp-top(res)
1868       (inst fldd (register-inline-constant
1869                   :double-float-bits (logior (ash hi 32) lo))))))
1870
1871 #!+long-float
1872 (define-vop (make-long-float)
1873   (:args (exp-bits :scs (signed-reg))
1874          (hi-bits :scs (unsigned-reg))
1875          (lo-bits :scs (unsigned-reg)))
1876   (:results (res :scs (long-reg)))
1877   (:temporary (:sc long-stack) temp)
1878   (:arg-types signed-num unsigned-num unsigned-num)
1879   (:result-types long-float)
1880   (:translate make-long-float)
1881   (:policy :fast-safe)
1882   (:vop-var vop)
1883   (:generator 3
1884     (let ((offset (tn-offset temp)))
1885       (storew exp-bits ebp-tn (frame-word-offset offset))
1886       (storew hi-bits ebp-tn (frame-word-offset (1+ offset)))
1887       (storew lo-bits ebp-tn (frame-word-offset (+ offset 2)))
1888       (with-empty-tn@fp-top(res)
1889         (inst fldl (make-ea :dword :base ebp-tn
1890                             :disp (frame-byte-offset (+ offset 2))))))))
1891
1892 (define-vop (single-float-bits)
1893   (:args (float :scs (single-reg descriptor-reg)
1894                 :load-if (not (sc-is float single-stack))))
1895   (:results (bits :scs (signed-reg)))
1896   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1897   (:arg-types single-float)
1898   (:result-types signed-num)
1899   (:translate single-float-bits)
1900   (:policy :fast-safe)
1901   (:vop-var vop)
1902   (:generator 4
1903     (sc-case bits
1904       (signed-reg
1905        (sc-case float
1906          (single-reg
1907           (with-tn@fp-top(float)
1908             (inst fst stack-temp)
1909             (inst mov bits stack-temp)))
1910          (single-stack
1911           (inst mov bits float))
1912          (descriptor-reg
1913           (loadw
1914            bits float single-float-value-slot
1915            other-pointer-lowtag))))
1916       (signed-stack
1917        (sc-case float
1918          (single-reg
1919           (with-tn@fp-top(float)
1920             (inst fst bits))))))))
1921
1922 (define-vop (double-float-high-bits)
1923   (:args (float :scs (double-reg descriptor-reg)
1924                 :load-if (not (sc-is float double-stack))))
1925   (:results (hi-bits :scs (signed-reg)))
1926   (:temporary (:sc double-stack) temp)
1927   (:arg-types double-float)
1928   (:result-types signed-num)
1929   (:translate double-float-high-bits)
1930   (:policy :fast-safe)
1931   (:vop-var vop)
1932   (:generator 5
1933      (sc-case float
1934        (double-reg
1935         (with-tn@fp-top(float)
1936           (let ((where (make-ea :dword :base ebp-tn
1937                                 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1938             (inst fstd where)))
1939         (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp))))
1940        (double-stack
1941         (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
1942        (descriptor-reg
1943         (loadw hi-bits float (1+ double-float-value-slot)
1944                other-pointer-lowtag)))))
1945
1946 (define-vop (double-float-low-bits)
1947   (:args (float :scs (double-reg descriptor-reg)
1948                 :load-if (not (sc-is float double-stack))))
1949   (:results (lo-bits :scs (unsigned-reg)))
1950   (:temporary (:sc double-stack) temp)
1951   (:arg-types double-float)
1952   (:result-types unsigned-num)
1953   (:translate double-float-low-bits)
1954   (:policy :fast-safe)
1955   (:vop-var vop)
1956   (:generator 5
1957      (sc-case float
1958        (double-reg
1959         (with-tn@fp-top(float)
1960           (let ((where (make-ea :dword :base ebp-tn
1961                                 :disp (frame-byte-offset (1+ (tn-offset temp))))))
1962             (inst fstd where)))
1963         (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
1964        (double-stack
1965         (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float)))))
1966        (descriptor-reg
1967         (loadw lo-bits float double-float-value-slot
1968                other-pointer-lowtag)))))
1969
1970 #!+long-float
1971 (define-vop (long-float-exp-bits)
1972   (:args (float :scs (long-reg descriptor-reg)
1973                 :load-if (not (sc-is float long-stack))))
1974   (:results (exp-bits :scs (signed-reg)))
1975   (:temporary (:sc long-stack) temp)
1976   (:arg-types long-float)
1977   (:result-types signed-num)
1978   (:translate long-float-exp-bits)
1979   (:policy :fast-safe)
1980   (:vop-var vop)
1981   (:generator 5
1982      (sc-case float
1983        (long-reg
1984         (with-tn@fp-top(float)
1985           (let ((where (make-ea :dword :base ebp-tn
1986                                 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
1987             (store-long-float where)))
1988         (inst movsx exp-bits
1989               (make-ea :word :base ebp-tn
1990                        :disp (frame-byte-offset (tn-offset temp)))))
1991        (long-stack
1992         (inst movsx exp-bits
1993               (make-ea :word :base ebp-tn
1994                        :disp (frame-byte-offset (tn-offset temp)))))
1995        (descriptor-reg
1996         (inst movsx exp-bits
1997               (make-ea-for-object-slot float (+ 2 long-float-value-slot)
1998                                        other-pointer-lowtag :word))))))
1999
2000 #!+long-float
2001 (define-vop (long-float-high-bits)
2002   (:args (float :scs (long-reg descriptor-reg)
2003                 :load-if (not (sc-is float long-stack))))
2004   (:results (hi-bits :scs (unsigned-reg)))
2005   (:temporary (:sc long-stack) temp)
2006   (:arg-types long-float)
2007   (:result-types unsigned-num)
2008   (:translate long-float-high-bits)
2009   (:policy :fast-safe)
2010   (:vop-var vop)
2011   (:generator 5
2012      (sc-case float
2013        (long-reg
2014         (with-tn@fp-top(float)
2015           (let ((where (make-ea :dword :base ebp-tn
2016                                 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2017             (store-long-float where)))
2018         (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
2019        (long-stack
2020         (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp)))))
2021        (descriptor-reg
2022         (loadw hi-bits float (1+ long-float-value-slot)
2023                other-pointer-lowtag)))))
2024
2025 #!+long-float
2026 (define-vop (long-float-low-bits)
2027   (:args (float :scs (long-reg descriptor-reg)
2028                 :load-if (not (sc-is float long-stack))))
2029   (:results (lo-bits :scs (unsigned-reg)))
2030   (:temporary (:sc long-stack) temp)
2031   (:arg-types long-float)
2032   (:result-types unsigned-num)
2033   (:translate long-float-low-bits)
2034   (:policy :fast-safe)
2035   (:vop-var vop)
2036   (:generator 5
2037      (sc-case float
2038        (long-reg
2039         (with-tn@fp-top(float)
2040           (let ((where (make-ea :dword :base ebp-tn
2041                                 :disp (frame-byte-offset (+ 2 (tn-offset temp))))))
2042             (store-long-float where)))
2043         (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2))))
2044        (long-stack
2045         (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2))))
2046        (descriptor-reg
2047         (loadw lo-bits float long-float-value-slot
2048                other-pointer-lowtag)))))
2049 \f
2050 ;;;; float mode hackery
2051
2052 (sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
2053 (defknown floating-point-modes () float-modes (flushable))
2054 (defknown ((setf floating-point-modes)) (float-modes)
2055   float-modes)
2056
2057 (def!constant npx-env-size (* 7 n-word-bytes))
2058 (def!constant npx-cw-offset 0)
2059 (def!constant npx-sw-offset 4)
2060
2061 (define-vop (floating-point-modes)
2062   (:results (res :scs (unsigned-reg)))
2063   (:result-types unsigned-num)
2064   (:translate floating-point-modes)
2065   (:policy :fast-safe)
2066   (:temporary (:sc unsigned-reg :offset eax-offset :target res
2067                    :to :result) eax)
2068   (:generator 8
2069    (inst sub esp-tn npx-env-size)       ; Make space on stack.
2070    (inst wait)                          ; Catch any pending FPE exceptions
2071    (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2072    (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
2073    ;; Move current status to high word.
2074    (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2075    ;; Move exception mask to low word.
2076    (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2077    (inst add esp-tn npx-env-size)       ; Pop stack.
2078    (inst xor eax #x3f)            ; Flip exception mask to trap enable bits.
2079    (move res eax)))
2080
2081 (define-vop (set-floating-point-modes)
2082   (:args (new :scs (unsigned-reg) :to :result :target res))
2083   (:results (res :scs (unsigned-reg)))
2084   (:arg-types unsigned-num)
2085   (:result-types unsigned-num)
2086   (:translate (setf floating-point-modes))
2087   (:policy :fast-safe)
2088   (:temporary (:sc unsigned-reg :offset eax-offset
2089                    :from :eval :to :result) eax)
2090   (:generator 3
2091    (inst sub esp-tn npx-env-size)       ; Make space on stack.
2092    (inst wait)                          ; Catch any pending FPE exceptions.
2093    (inst fstenv (make-ea :dword :base esp-tn))
2094    (inst mov eax new)
2095    (inst xor eax #x3f)            ; Turn trap enable bits into exception mask.
2096    (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2097    (inst shr eax 16)                    ; position status word
2098    (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2099    (inst fldenv (make-ea :dword :base esp-tn))
2100    (inst add esp-tn npx-env-size)       ; Pop stack.
2101    (move res new)))
2102 \f
2103 #!-long-float
2104 (progn
2105
2106 ;;; Let's use some of the 80387 special functions.
2107 ;;;
2108 ;;; These defs will not take effect unless code/irrat.lisp is modified
2109 ;;; to remove the inlined alien routine def.
2110
2111 (macrolet ((frob (func trans op)
2112              `(define-vop (,func)
2113                (:args (x :scs (double-reg) :target fr0))
2114                (:temporary (:sc double-reg :offset fr0-offset
2115                                 :from :argument :to :result) fr0)
2116                (:ignore fr0)
2117                (:results (y :scs (double-reg)))
2118                (:arg-types double-float)
2119                (:result-types double-float)
2120                (:translate ,trans)
2121                (:policy :fast-safe)
2122                (:note "inline NPX function")
2123                (:vop-var vop)
2124                (:save-p :compute-only)
2125                (:node-var node)
2126                (:generator 5
2127                 (note-this-location vop :internal-error)
2128                 (unless (zerop (tn-offset x))
2129                   (inst fxch x)         ; x to top of stack
2130                   (unless (location= x y)
2131                     (inst fst x)))      ; maybe save it
2132                 (inst ,op)              ; clobber st0
2133                 (cond ((zerop (tn-offset y))
2134                        (maybe-fp-wait node))
2135                       (t
2136                        (inst fst y)))))))
2137
2138   ;; Quick versions of fsin and fcos that require the argument to be
2139   ;; within range 2^63.
2140   (frob fsin-quick %sin-quick fsin)
2141   (frob fcos-quick %cos-quick fcos)
2142   (frob fsqrt %sqrt fsqrt))
2143
2144 ;;; Quick version of ftan that requires the argument to be within
2145 ;;; range 2^63.
2146 (define-vop (ftan-quick)
2147   (:translate %tan-quick)
2148   (:args (x :scs (double-reg) :target fr0))
2149   (:temporary (:sc double-reg :offset fr0-offset
2150                    :from :argument :to :result) fr0)
2151   (:temporary (:sc double-reg :offset fr1-offset
2152                    :from :argument :to :result) fr1)
2153   (:results (y :scs (double-reg)))
2154   (:arg-types double-float)
2155   (:result-types double-float)
2156   (:policy :fast-safe)
2157   (:note "inline tan function")
2158   (:vop-var vop)
2159   (:save-p :compute-only)
2160   (:generator 5
2161     (note-this-location vop :internal-error)
2162     (case (tn-offset x)
2163        (0
2164         (inst fstp fr1))
2165        (1
2166         (inst fstp fr0))
2167        (t
2168         (inst fstp fr0)
2169         (inst fstp fr0)
2170         (inst fldd (make-random-tn :kind :normal
2171                                    :sc (sc-or-lose 'double-reg)
2172                                    :offset (- (tn-offset x) 2)))))
2173     (inst fptan)
2174     ;; Result is in fr1
2175     (case (tn-offset y)
2176        (0
2177         (inst fxch fr1))
2178        (1)
2179        (t
2180         (inst fxch fr1)
2181         (inst fstd y)))))
2182
2183 ;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
2184 ;;; result if the argument is out of range 2^63 and would thus be
2185 ;;; hopelessly inaccurate.
2186 (macrolet ((frob (func trans op)
2187              `(define-vop (,func)
2188                 (:translate ,trans)
2189                 (:args (x :scs (double-reg) :target fr0))
2190                 (:temporary (:sc double-reg :offset fr0-offset
2191                                  :from :argument :to :result) fr0)
2192                 ;; FIXME: make that an arbitrary location and
2193                 ;; FXCH only when range reduction needed
2194                 (:temporary (:sc double-reg :offset fr1-offset
2195                                  :from :argument :to :result) fr1)
2196                 (:temporary (:sc unsigned-reg :offset eax-offset
2197                              :from :argument :to :result) eax)
2198                 (:results (y :scs (double-reg)))
2199                 (:arg-types double-float)
2200                 (:result-types double-float)
2201                 (:policy :fast-safe)
2202                 (:note "inline sin/cos function")
2203                 (:vop-var vop)
2204                 (:save-p :compute-only)
2205                 (:ignore eax)
2206                 (:generator 5
2207                   (let ((DONE (gen-label))
2208                         (REDUCE (gen-label))
2209                         (REDUCE-LOOP (gen-label)))
2210                     (note-this-location vop :internal-error)
2211                     (unless (zerop (tn-offset x))
2212                       (inst fxch x)          ; x to top of stack
2213                       (unless (location= x y)
2214                         (inst fst x))) ; maybe save it
2215                     (inst ,op)
2216                     (inst fnstsw)                  ; status word to ax
2217                     (inst and ah-tn #x04)          ; C2
2218                     (inst jmp :nz REDUCE)
2219                     (emit-label DONE)
2220                     (unless (zerop (tn-offset y))
2221                       (inst fstd y))
2222                     (assemble (*elsewhere*)
2223                       (emit-label REDUCE)
2224                       ;; Else x was out of range so reduce it; ST0 is unchanged.
2225                       (with-empty-tn@fp-top (fr1)
2226                         (inst fldpi)
2227                         (inst fadd fr0))
2228                       (emit-label REDUCE-LOOP)
2229                       (inst fprem1)
2230                       (inst fnstsw)
2231                       (inst and ah-tn #x04)
2232                       (inst jmp :nz REDUCE-LOOP)
2233                       (inst ,op)
2234                       (inst jmp DONE)))))))
2235           (frob fsin  %sin fsin)
2236           (frob fcos  %cos fcos))
2237
2238 (define-vop (ftan)
2239   (:translate %tan)
2240   (:args (x :scs (double-reg) :target fr0))
2241   (:temporary (:sc double-reg :offset fr0-offset
2242                    :from :argument :to :result) fr0)
2243   (:temporary (:sc double-reg :offset fr1-offset
2244                    :from :argument :to :result) fr1)
2245   (:temporary (:sc unsigned-reg :offset eax-offset
2246                    :from :argument :to :result) eax)
2247   (:results (y :scs (double-reg)))
2248   (:arg-types double-float)
2249   (:result-types double-float)
2250   (:ignore eax)
2251   (:policy :fast-safe)
2252   (:note "inline tan function")
2253   (:vop-var vop)
2254   (:save-p :compute-only)
2255   (:ignore eax)
2256   (:generator 5
2257     (note-this-location vop :internal-error)
2258     (case (tn-offset x)
2259        (0
2260         (inst fstp fr1))
2261        (1
2262         (inst fstp fr0))
2263        (t
2264         (inst fstp fr0)
2265         (inst fstp fr0)
2266         (inst fldd (make-random-tn :kind :normal
2267                                    :sc (sc-or-lose 'double-reg)
2268                                    :offset (- (tn-offset x) 2)))))
2269     (inst fptan)
2270     (let ((REDUCE (gen-label))
2271           (REDUCE-LOOP (gen-label)))
2272       (inst fnstsw)                        ; status word to ax
2273       (inst and ah-tn #x04)                ; C2
2274       (inst jmp :nz REDUCE)
2275       (assemble (*elsewhere*)
2276         (emit-label REDUCE)
2277         ;; Else x was out of range so reduce it; ST0 is unchanged.
2278         (with-empty-tn@fp-top (fr1)
2279           (inst fldpi)
2280           (inst fadd fr0))
2281         (emit-label REDUCE-LOOP)
2282         (inst fprem1)
2283         (inst fnstsw)
2284         (inst and ah-tn #x04)
2285         (inst jmp :nz REDUCE-LOOP)
2286         (inst fptan)
2287         (inst jmp DONE)))
2288     DONE
2289     ;; Result is in fr1
2290     (case (tn-offset y)
2291        (0
2292         (inst fxch fr1))
2293        (1)
2294        (t
2295         (inst fxch fr1)
2296         (inst fstd y)))))
2297
2298 ;;; %exp that handles the following special cases: exp(+Inf) is +Inf;
2299 ;;; exp(-Inf) is 0; exp(NaN) is NaN.
2300 (define-vop (fexp)
2301   (:translate %exp)
2302   (:args (x :scs (double-reg) :target fr0))
2303   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2304   (:temporary (:sc double-reg :offset fr0-offset
2305                    :from :argument :to :result) fr0)
2306   (:temporary (:sc double-reg :offset fr1-offset
2307                    :from :argument :to :result) fr1)
2308   (:temporary (:sc double-reg :offset fr2-offset
2309                    :from :argument :to :result) fr2)
2310   (:results (y :scs (double-reg)))
2311   (:arg-types double-float)
2312   (:result-types double-float)
2313   (:policy :fast-safe)
2314   (:note "inline exp function")
2315   (:vop-var vop)
2316   (:save-p :compute-only)
2317   (:ignore temp)
2318   (:generator 5
2319      (note-this-location vop :internal-error)
2320      (unless (zerop (tn-offset x))
2321        (inst fxch x)            ; x to top of stack
2322        (unless (location= x y)
2323          (inst fst x))) ; maybe save it
2324      ;; Check for Inf or NaN
2325      (inst fxam)
2326      (inst fnstsw)
2327      (inst sahf)
2328      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
2329      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
2330      (inst and ah-tn #x02)            ; Test sign of Inf.
2331      (inst jmp :z DONE)          ; +Inf gives +Inf.
2332      (inst fstp fr0)                ; -Inf gives 0
2333      (inst fldz)
2334      (inst jmp-short DONE)
2335      NOINFNAN
2336      (inst fstp fr1)
2337      (inst fldl2e)
2338      (inst fmul fr1)
2339      ;; Now fr0=x log2(e)
2340      (inst fst fr1)
2341      (inst frndint)
2342      (inst fst fr2)
2343      (inst fsubp-sti fr1)
2344      (inst f2xm1)
2345      (inst fld1)
2346      (inst faddp-sti fr1)
2347      (inst fscale)
2348      (inst fld fr0)
2349      DONE
2350      (unless (zerop (tn-offset y))
2351              (inst fstd y))))
2352
2353 ;;; Expm1 = exp(x) - 1.
2354 ;;; Handles the following special cases:
2355 ;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
2356 (define-vop (fexpm1)
2357   (:translate %expm1)
2358   (:args (x :scs (double-reg) :target fr0))
2359   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
2360   (:temporary (:sc double-reg :offset fr0-offset
2361                    :from :argument :to :result) fr0)
2362   (:temporary (:sc double-reg :offset fr1-offset
2363                    :from :argument :to :result) fr1)
2364   (:temporary (:sc double-reg :offset fr2-offset
2365                    :from :argument :to :result) fr2)
2366   (:results (y :scs (double-reg)))
2367   (:arg-types double-float)
2368   (:result-types double-float)
2369   (:policy :fast-safe)
2370   (:note "inline expm1 function")
2371   (:vop-var vop)
2372   (:save-p :compute-only)
2373   (:ignore temp)
2374   (:generator 5
2375      (note-this-location vop :internal-error)
2376      (unless (zerop (tn-offset x))
2377        (inst fxch x)            ; x to top of stack
2378        (unless (location= x y)
2379          (inst fst x))) ; maybe save it
2380      ;; Check for Inf or NaN
2381      (inst fxam)
2382      (inst fnstsw)
2383      (inst sahf)
2384      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
2385      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
2386      (inst and ah-tn #x02)            ; Test sign of Inf.
2387      (inst jmp :z DONE)          ; +Inf gives +Inf.
2388      (inst fstp fr0)                ; -Inf gives -1.0
2389      (inst fld1)
2390      (inst fchs)
2391      (inst jmp-short DONE)
2392      NOINFNAN
2393      ;; Free two stack slots leaving the argument on top.
2394      (inst fstp fr2)
2395      (inst fstp fr0)
2396      (inst fldl2e)
2397      (inst fmul fr1)    ; Now fr0 = x log2(e)
2398      (inst fst fr1)
2399      (inst frndint)
2400      (inst fsub-sti fr1)
2401      (inst fxch fr1)
2402      (inst f2xm1)
2403      (inst fscale)
2404      (inst fxch fr1)
2405      (inst fld1)
2406      (inst fscale)
2407      (inst fstp fr1)
2408      (inst fld1)
2409      (inst fsub fr1)
2410      (inst fsubr fr2)
2411      DONE
2412      (unless (zerop (tn-offset y))
2413        (inst fstd y))))
2414
2415 (define-vop (flog)
2416   (:translate %log)
2417   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2418   (:temporary (:sc double-reg :offset fr0-offset
2419                    :from :argument :to :result) fr0)
2420   (:temporary (:sc double-reg :offset fr1-offset
2421                    :from :argument :to :result) fr1)
2422   (:results (y :scs (double-reg)))
2423   (:arg-types double-float)
2424   (:result-types double-float)
2425   (:policy :fast-safe)
2426   (:note "inline log function")
2427   (:vop-var vop)
2428   (:save-p :compute-only)
2429   (:generator 5
2430      (note-this-location vop :internal-error)
2431      (sc-case x
2432         (double-reg
2433          (case (tn-offset x)
2434             (0
2435              ;; x is in fr0
2436              (inst fstp fr1)
2437              (inst fldln2)
2438              (inst fxch fr1))
2439             (1
2440              ;; x is in fr1
2441              (inst fstp fr0)
2442              (inst fldln2)
2443              (inst fxch fr1))
2444             (t
2445              ;; x is in a FP reg, not fr0 or fr1
2446              (inst fstp fr0)
2447              (inst fstp fr0)
2448              (inst fldln2)
2449              (inst fldd (make-random-tn :kind :normal
2450                                         :sc (sc-or-lose 'double-reg)
2451                                         :offset (1- (tn-offset x))))))
2452          (inst fyl2x))
2453         ((double-stack descriptor-reg)
2454          (inst fstp fr0)
2455          (inst fstp fr0)
2456          (inst fldln2)
2457          (if (sc-is x double-stack)
2458              (inst fldd (ea-for-df-stack x))
2459              (inst fldd (ea-for-df-desc x)))
2460          (inst fyl2x)))
2461      (inst fld fr0)
2462      (case (tn-offset y)
2463        ((0 1))
2464        (t (inst fstd y)))))
2465
2466 (define-vop (flog10)
2467   (:translate %log10)
2468   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2469   (:temporary (:sc double-reg :offset fr0-offset
2470                    :from :argument :to :result) fr0)
2471   (:temporary (:sc double-reg :offset fr1-offset
2472                    :from :argument :to :result) fr1)
2473   (:results (y :scs (double-reg)))
2474   (:arg-types double-float)
2475   (:result-types double-float)
2476   (:policy :fast-safe)
2477   (:note "inline log10 function")
2478   (:vop-var vop)
2479   (:save-p :compute-only)
2480   (:generator 5
2481      (note-this-location vop :internal-error)
2482      (sc-case x
2483         (double-reg
2484          (case (tn-offset x)
2485             (0
2486              ;; x is in fr0
2487              (inst fstp fr1)
2488              (inst fldlg2)
2489              (inst fxch fr1))
2490             (1
2491              ;; x is in fr1
2492              (inst fstp fr0)
2493              (inst fldlg2)
2494              (inst fxch fr1))
2495             (t
2496              ;; x is in a FP reg, not fr0 or fr1
2497              (inst fstp fr0)
2498              (inst fstp fr0)
2499              (inst fldlg2)
2500              (inst fldd (make-random-tn :kind :normal
2501                                         :sc (sc-or-lose 'double-reg)
2502                                         :offset (1- (tn-offset x))))))
2503          (inst fyl2x))
2504         ((double-stack descriptor-reg)
2505          (inst fstp fr0)
2506          (inst fstp fr0)
2507          (inst fldlg2)
2508          (if (sc-is x double-stack)
2509              (inst fldd (ea-for-df-stack x))
2510              (inst fldd (ea-for-df-desc x)))
2511          (inst fyl2x)))
2512      (inst fld fr0)
2513      (case (tn-offset y)
2514        ((0 1))
2515        (t (inst fstd y)))))
2516
2517 (define-vop (fpow)
2518   (:translate %pow)
2519   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2520          (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2521   (:temporary (:sc double-reg :offset fr0-offset
2522                    :from (:argument 0) :to :result) fr0)
2523   (:temporary (:sc double-reg :offset fr1-offset
2524                    :from (:argument 1) :to :result) fr1)
2525   (:temporary (:sc double-reg :offset fr2-offset
2526                    :from :load :to :result) fr2)
2527   (:results (r :scs (double-reg)))
2528   (:arg-types double-float double-float)
2529   (:result-types double-float)
2530   (:policy :fast-safe)
2531   (:note "inline pow function")
2532   (:vop-var vop)
2533   (:save-p :compute-only)
2534   (:generator 5
2535      (note-this-location vop :internal-error)
2536      ;; Setup x in fr0 and y in fr1
2537      (cond
2538       ;; x in fr0; y in fr1
2539       ((and (sc-is x double-reg) (zerop (tn-offset x))
2540             (sc-is y double-reg) (= 1 (tn-offset y))))
2541       ;; y in fr1; x not in fr0
2542       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2543        ;; Load x to fr0
2544        (sc-case x
2545           (double-reg
2546            (copy-fp-reg-to-fr0 x))
2547           (double-stack
2548            (inst fstp fr0)
2549            (inst fldd (ea-for-df-stack x)))
2550           (descriptor-reg
2551            (inst fstp fr0)
2552            (inst fldd (ea-for-df-desc x)))))
2553       ;; x in fr0; y not in fr1
2554       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2555        (inst fxch fr1)
2556        ;; Now load y to fr0
2557        (sc-case y
2558           (double-reg
2559            (copy-fp-reg-to-fr0 y))
2560           (double-stack
2561            (inst fstp fr0)
2562            (inst fldd (ea-for-df-stack y)))
2563           (descriptor-reg
2564            (inst fstp fr0)
2565            (inst fldd (ea-for-df-desc y))))
2566        (inst fxch fr1))
2567       ;; x in fr1; y not in fr1
2568       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2569        ;; Load y to fr0
2570        (sc-case y
2571           (double-reg
2572            (copy-fp-reg-to-fr0 y))
2573           (double-stack
2574            (inst fstp fr0)
2575            (inst fldd (ea-for-df-stack y)))
2576           (descriptor-reg
2577            (inst fstp fr0)
2578            (inst fldd (ea-for-df-desc y))))
2579        (inst fxch fr1))
2580       ;; y in fr0;
2581       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2582        (inst fxch fr1)
2583        ;; Now load x to fr0
2584        (sc-case x
2585           (double-reg
2586            (copy-fp-reg-to-fr0 x))
2587           (double-stack
2588            (inst fstp fr0)
2589            (inst fldd (ea-for-df-stack x)))
2590           (descriptor-reg
2591            (inst fstp fr0)
2592            (inst fldd (ea-for-df-desc x)))))
2593       ;; Neither x or y are in either fr0 or fr1
2594       (t
2595        ;; Load y then x
2596        (inst fstp fr0)
2597        (inst fstp fr0)
2598        (sc-case y
2599           (double-reg
2600            (inst fldd (make-random-tn :kind :normal
2601                                       :sc (sc-or-lose 'double-reg)
2602                                       :offset (- (tn-offset y) 2))))
2603           (double-stack
2604            (inst fldd (ea-for-df-stack y)))
2605           (descriptor-reg
2606            (inst fldd (ea-for-df-desc y))))
2607        ;; Load x to fr0
2608        (sc-case x
2609           (double-reg
2610            (inst fldd (make-random-tn :kind :normal
2611                                       :sc (sc-or-lose 'double-reg)
2612                                       :offset (1- (tn-offset x)))))
2613           (double-stack
2614            (inst fldd (ea-for-df-stack x)))
2615           (descriptor-reg
2616            (inst fldd (ea-for-df-desc x))))))
2617
2618      ;; Now have x at fr0; and y at fr1
2619      (inst fyl2x)
2620      ;; Now fr0=y log2(x)
2621      (inst fld fr0)
2622      (inst frndint)
2623      (inst fst fr2)
2624      (inst fsubp-sti fr1)
2625      (inst f2xm1)
2626      (inst fld1)
2627      (inst faddp-sti fr1)
2628      (inst fscale)
2629      (inst fld fr0)
2630      (case (tn-offset r)
2631        ((0 1))
2632        (t (inst fstd r)))))
2633
2634 (define-vop (fscalen)
2635   (:translate %scalbn)
2636   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2637          (y :scs (signed-stack signed-reg) :target temp))
2638   (:temporary (:sc double-reg :offset fr0-offset
2639                    :from (:argument 0) :to :result) fr0)
2640   (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2641   (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2642   (:results (r :scs (double-reg)))
2643   (:arg-types double-float signed-num)
2644   (:result-types double-float)
2645   (:policy :fast-safe)
2646   (:note "inline scalbn function")
2647   (:generator 5
2648      ;; Setup x in fr0 and y in fr1
2649      (sc-case x
2650        (double-reg
2651         (case (tn-offset x)
2652           (0
2653            (inst fstp fr1)
2654            (sc-case y
2655              (signed-reg
2656               (inst mov temp y)
2657               (inst fild temp))
2658              (signed-stack
2659               (inst fild y)))
2660            (inst fxch fr1))
2661           (1
2662            (inst fstp fr0)
2663            (sc-case y
2664              (signed-reg
2665               (inst mov temp y)
2666               (inst fild temp))
2667              (signed-stack
2668               (inst fild y)))
2669            (inst fxch fr1))
2670           (t
2671            (inst fstp fr0)
2672            (inst fstp fr0)
2673            (sc-case y
2674              (signed-reg
2675               (inst mov temp y)
2676               (inst fild temp))
2677              (signed-stack
2678               (inst fild y)))
2679            (inst fld (make-random-tn :kind :normal
2680                                      :sc (sc-or-lose 'double-reg)
2681                                      :offset (1- (tn-offset x)))))))
2682        ((double-stack descriptor-reg)
2683         (inst fstp fr0)
2684         (inst fstp fr0)
2685         (sc-case y
2686           (signed-reg
2687            (inst mov temp y)
2688            (inst fild temp))
2689           (signed-stack
2690            (inst fild y)))
2691         (if (sc-is x double-stack)
2692             (inst fldd (ea-for-df-stack x))
2693             (inst fldd (ea-for-df-desc x)))))
2694      (inst fscale)
2695      (unless (zerop (tn-offset r))
2696        (inst fstd r))))
2697
2698 (define-vop (fscale)
2699   (:translate %scalb)
2700   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2701          (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2702   (:temporary (:sc double-reg :offset fr0-offset
2703                    :from (:argument 0) :to :result) fr0)
2704   (:temporary (:sc double-reg :offset fr1-offset
2705                    :from (:argument 1) :to :result) fr1)
2706   (:results (r :scs (double-reg)))
2707   (:arg-types double-float double-float)
2708   (:result-types double-float)
2709   (:policy :fast-safe)
2710   (:note "inline scalb function")
2711   (:vop-var vop)
2712   (:save-p :compute-only)
2713   (:generator 5
2714      (note-this-location vop :internal-error)
2715      ;; Setup x in fr0 and y in fr1
2716      (cond
2717       ;; x in fr0; y in fr1
2718       ((and (sc-is x double-reg) (zerop (tn-offset x))
2719             (sc-is y double-reg) (= 1 (tn-offset y))))
2720       ;; y in fr1; x not in fr0
2721       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2722        ;; Load x to fr0
2723        (sc-case x
2724           (double-reg
2725            (copy-fp-reg-to-fr0 x))
2726           (double-stack
2727            (inst fstp fr0)
2728            (inst fldd (ea-for-df-stack x)))
2729           (descriptor-reg
2730            (inst fstp fr0)
2731            (inst fldd (ea-for-df-desc x)))))
2732       ;; x in fr0; y not in fr1
2733       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2734        (inst fxch fr1)
2735        ;; Now load y to fr0
2736        (sc-case y
2737           (double-reg
2738            (copy-fp-reg-to-fr0 y))
2739           (double-stack
2740            (inst fstp fr0)
2741            (inst fldd (ea-for-df-stack y)))
2742           (descriptor-reg
2743            (inst fstp fr0)
2744            (inst fldd (ea-for-df-desc y))))
2745        (inst fxch fr1))
2746       ;; x in fr1; y not in fr1
2747       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2748        ;; Load y to fr0
2749        (sc-case y
2750           (double-reg
2751            (copy-fp-reg-to-fr0 y))
2752           (double-stack
2753            (inst fstp fr0)
2754            (inst fldd (ea-for-df-stack y)))
2755           (descriptor-reg
2756            (inst fstp fr0)
2757            (inst fldd (ea-for-df-desc y))))
2758        (inst fxch fr1))
2759       ;; y in fr0;
2760       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2761        (inst fxch fr1)
2762        ;; Now load x to fr0
2763        (sc-case x
2764           (double-reg
2765            (copy-fp-reg-to-fr0 x))
2766           (double-stack
2767            (inst fstp fr0)
2768            (inst fldd (ea-for-df-stack x)))
2769           (descriptor-reg
2770            (inst fstp fr0)
2771            (inst fldd (ea-for-df-desc x)))))
2772       ;; Neither x or y are in either fr0 or fr1
2773       (t
2774        ;; Load y then x
2775        (inst fstp fr0)
2776        (inst fstp fr0)
2777        (sc-case y
2778           (double-reg
2779            (inst fldd (make-random-tn :kind :normal
2780                                       :sc (sc-or-lose 'double-reg)
2781                                       :offset (- (tn-offset y) 2))))
2782           (double-stack
2783            (inst fldd (ea-for-df-stack y)))
2784           (descriptor-reg
2785            (inst fldd (ea-for-df-desc y))))
2786        ;; Load x to fr0
2787        (sc-case x
2788           (double-reg
2789            (inst fldd (make-random-tn :kind :normal
2790                                       :sc (sc-or-lose 'double-reg)
2791                                       :offset (1- (tn-offset x)))))
2792           (double-stack
2793            (inst fldd (ea-for-df-stack x)))
2794           (descriptor-reg
2795            (inst fldd (ea-for-df-desc x))))))
2796
2797      ;; Now have x at fr0; and y at fr1
2798      (inst fscale)
2799      (unless (zerop (tn-offset r))
2800              (inst fstd r))))
2801
2802 (define-vop (flog1p)
2803   (:translate %log1p)
2804   (:args (x :scs (double-reg) :to :result))
2805   (:temporary (:sc double-reg :offset fr0-offset
2806                    :from :argument :to :result) fr0)
2807   (:temporary (:sc double-reg :offset fr1-offset
2808                    :from :argument :to :result) fr1)
2809   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2810   (:results (y :scs (double-reg)))
2811   (:arg-types double-float)
2812   (:result-types double-float)
2813   (:policy :fast-safe)
2814   (:note "inline log1p function")
2815   (:ignore temp)
2816   (:generator 5
2817      ;; x is in a FP reg, not fr0, fr1.
2818      (inst fstp fr0)
2819      (inst fstp fr0)
2820      (inst fldd (make-random-tn :kind :normal
2821                                 :sc (sc-or-lose 'double-reg)
2822                                 :offset (- (tn-offset x) 2)))
2823      ;; Check the range
2824      (inst push #x3e947ae1)     ; Constant 0.29
2825      (inst fabs)
2826      (inst fld (make-ea :dword :base esp-tn))
2827      (inst fcompp)
2828      (inst add esp-tn 4)
2829      (inst fnstsw)                      ; status word to ax
2830      (inst and ah-tn #x45)
2831      (inst jmp :z WITHIN-RANGE)
2832      ;; Out of range for fyl2xp1.
2833      (inst fld1)
2834      (inst faddd (make-random-tn :kind :normal
2835                                  :sc (sc-or-lose 'double-reg)
2836                                  :offset (- (tn-offset x) 1)))
2837      (inst fldln2)
2838      (inst fxch fr1)
2839      (inst fyl2x)
2840      (inst jmp DONE)
2841
2842      WITHIN-RANGE
2843      (inst fldln2)
2844      (inst fldd (make-random-tn :kind :normal
2845                                 :sc (sc-or-lose 'double-reg)
2846                                 :offset (- (tn-offset x) 1)))
2847      (inst fyl2xp1)
2848      DONE
2849      (inst fld fr0)
2850      (case (tn-offset y)
2851        ((0 1))
2852        (t (inst fstd y)))))
2853
2854 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2855 ;;; instruction and a range check can be avoided.
2856 (define-vop (flog1p-pentium)
2857   (:translate %log1p)
2858   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2859   (:temporary (:sc double-reg :offset fr0-offset
2860                    :from :argument :to :result) fr0)
2861   (:temporary (:sc double-reg :offset fr1-offset
2862                    :from :argument :to :result) fr1)
2863   (:results (y :scs (double-reg)))
2864   (:arg-types double-float)
2865   (:result-types double-float)
2866   (:policy :fast-safe)
2867   (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2868   (:note "inline log1p with limited x range function")
2869   (:vop-var vop)
2870   (:save-p :compute-only)
2871   (:generator 4
2872      (note-this-location vop :internal-error)
2873      (sc-case x
2874         (double-reg
2875          (case (tn-offset x)
2876             (0
2877              ;; x is in fr0
2878              (inst fstp fr1)
2879              (inst fldln2)
2880              (inst fxch fr1))
2881             (1
2882              ;; x is in fr1
2883              (inst fstp fr0)
2884              (inst fldln2)
2885              (inst fxch fr1))
2886             (t
2887              ;; x is in a FP reg, not fr0 or fr1
2888              (inst fstp fr0)
2889              (inst fstp fr0)
2890              (inst fldln2)
2891              (inst fldd (make-random-tn :kind :normal
2892                                         :sc (sc-or-lose 'double-reg)
2893                                         :offset (1- (tn-offset x)))))))
2894         ((double-stack descriptor-reg)
2895          (inst fstp fr0)
2896          (inst fstp fr0)
2897          (inst fldln2)
2898          (if (sc-is x double-stack)
2899              (inst fldd (ea-for-df-stack x))
2900            (inst fldd (ea-for-df-desc x)))))
2901      (inst fyl2xp1)
2902      (inst fld fr0)
2903      (case (tn-offset y)
2904        ((0 1))
2905        (t (inst fstd y)))))
2906
2907 (define-vop (flogb)
2908   (:translate %logb)
2909   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2910   (:temporary (:sc double-reg :offset fr0-offset
2911                    :from :argument :to :result) fr0)
2912   (:temporary (:sc double-reg :offset fr1-offset
2913                    :from :argument :to :result) fr1)
2914   (:results (y :scs (double-reg)))
2915   (:arg-types double-float)
2916   (:result-types double-float)
2917   (:policy :fast-safe)
2918   (:note "inline logb function")
2919   (:vop-var vop)
2920   (:save-p :compute-only)
2921   (:generator 5
2922      (note-this-location vop :internal-error)
2923      (sc-case x
2924         (double-reg
2925          (case (tn-offset x)
2926             (0
2927              ;; x is in fr0
2928              (inst fstp fr1))
2929             (1
2930              ;; x is in fr1
2931              (inst fstp fr0))
2932             (t
2933              ;; x is in a FP reg, not fr0 or fr1
2934              (inst fstp fr0)
2935              (inst fstp fr0)
2936              (inst fldd (make-random-tn :kind :normal
2937                                         :sc (sc-or-lose 'double-reg)
2938                                         :offset (- (tn-offset x) 2))))))
2939         ((double-stack descriptor-reg)
2940          (inst fstp fr0)
2941          (inst fstp fr0)
2942          (if (sc-is x double-stack)
2943              (inst fldd (ea-for-df-stack x))
2944            (inst fldd (ea-for-df-desc x)))))
2945      (inst fxtract)
2946      (case (tn-offset y)
2947        (0
2948         (inst fxch fr1))
2949        (1)
2950        (t (inst fxch fr1)
2951           (inst fstd y)))))
2952
2953 (define-vop (fatan)
2954   (:translate %atan)
2955   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2956   (:temporary (:sc double-reg :offset fr0-offset
2957                    :from (:argument 0) :to :result) fr0)
2958   (:temporary (:sc double-reg :offset fr1-offset
2959                    :from (:argument 0) :to :result) fr1)
2960   (:results (r :scs (double-reg)))
2961   (:arg-types double-float)
2962   (:result-types double-float)
2963   (:policy :fast-safe)
2964   (:note "inline atan function")
2965   (:vop-var vop)
2966   (:save-p :compute-only)
2967   (:generator 5
2968      (note-this-location vop :internal-error)
2969      ;; Setup x in fr1 and 1.0 in fr0
2970      (cond
2971       ;; x in fr0
2972       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2973        (inst fstp fr1))
2974       ;; x in fr1
2975       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2976        (inst fstp fr0))
2977       ;; x not in fr0 or fr1
2978       (t
2979        ;; Load x then 1.0
2980        (inst fstp fr0)
2981        (inst fstp fr0)
2982        (sc-case x
2983           (double-reg
2984            (inst fldd (make-random-tn :kind :normal
2985                                       :sc (sc-or-lose 'double-reg)
2986                                       :offset (- (tn-offset x) 2))))
2987           (double-stack
2988            (inst fldd (ea-for-df-stack x)))
2989           (descriptor-reg
2990            (inst fldd (ea-for-df-desc x))))))
2991      (inst fld1)
2992      ;; Now have x at fr1; and 1.0 at fr0
2993      (inst fpatan)
2994      (inst fld fr0)
2995      (case (tn-offset r)
2996        ((0 1))
2997        (t (inst fstd r)))))
2998
2999 (define-vop (fatan2)
3000   (:translate %atan2)
3001   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
3002          (y :scs (double-reg double-stack descriptor-reg) :target fr0))
3003   (:temporary (:sc double-reg :offset fr0-offset
3004                    :from (:argument 1) :to :result) fr0)
3005   (:temporary (:sc double-reg :offset fr1-offset
3006                    :from (:argument 0) :to :result) fr1)
3007   (:results (r :scs (double-reg)))
3008   (:arg-types double-float double-float)
3009   (:result-types double-float)
3010   (:policy :fast-safe)
3011   (:note "inline atan2 function")
3012   (:vop-var vop)
3013   (:save-p :compute-only)
3014   (:generator 5
3015      (note-this-location vop :internal-error)
3016      ;; Setup x in fr1 and y in fr0
3017      (cond
3018       ;; y in fr0; x in fr1
3019       ((and (sc-is y double-reg) (zerop (tn-offset y))
3020             (sc-is x double-reg) (= 1 (tn-offset x))))
3021       ;; x in fr1; y not in fr0
3022       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
3023        ;; Load y to fr0
3024        (sc-case y
3025           (double-reg
3026            (copy-fp-reg-to-fr0 y))
3027           (double-stack
3028            (inst fstp fr0)
3029            (inst fldd (ea-for-df-stack y)))
3030           (descriptor-reg
3031            (inst fstp fr0)
3032            (inst fldd (ea-for-df-desc y)))))
3033       ((and (sc-is x double-reg) (zerop (tn-offset x))
3034             (sc-is y double-reg) (zerop (tn-offset x)))
3035        ;; copy x to fr1
3036        (inst fst fr1))
3037       ;; y in fr0; x not in fr1
3038       ((and (sc-is y double-reg) (zerop (tn-offset y)))
3039        (inst fxch fr1)
3040        ;; Now load x to fr0
3041        (sc-case x
3042           (double-reg
3043            (copy-fp-reg-to-fr0 x))
3044           (double-stack
3045            (inst fstp fr0)
3046            (inst fldd (ea-for-df-stack x)))
3047           (descriptor-reg
3048            (inst fstp fr0)
3049            (inst fldd (ea-for-df-desc x))))
3050        (inst fxch fr1))
3051       ;; y in fr1; x not in fr1
3052       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3053        ;; Load x to fr0
3054        (sc-case x
3055           (double-reg
3056            (copy-fp-reg-to-fr0 x))
3057           (double-stack
3058            (inst fstp fr0)
3059            (inst fldd (ea-for-df-stack x)))
3060           (descriptor-reg
3061            (inst fstp fr0)
3062            (inst fldd (ea-for-df-desc x))))
3063        (inst fxch fr1))
3064       ;; x in fr0;
3065       ((and (sc-is x double-reg) (zerop (tn-offset x)))
3066        (inst fxch fr1)
3067        ;; Now load y to fr0
3068        (sc-case y
3069           (double-reg
3070            (copy-fp-reg-to-fr0 y))
3071           (double-stack
3072            (inst fstp fr0)
3073            (inst fldd (ea-for-df-stack y)))
3074           (descriptor-reg
3075            (inst fstp fr0)
3076            (inst fldd (ea-for-df-desc y)))))
3077       ;; Neither y or x are in either fr0 or fr1
3078       (t
3079        ;; Load x then y
3080        (inst fstp fr0)
3081        (inst fstp fr0)
3082        (sc-case x
3083           (double-reg
3084            (inst fldd (make-random-tn :kind :normal
3085                                       :sc (sc-or-lose 'double-reg)
3086                                       :offset (- (tn-offset x) 2))))
3087           (double-stack
3088            (inst fldd (ea-for-df-stack x)))
3089           (descriptor-reg
3090            (inst fldd (ea-for-df-desc x))))
3091        ;; Load y to fr0
3092        (sc-case y
3093           (double-reg
3094            (inst fldd (make-random-tn :kind :normal
3095                                       :sc (sc-or-lose 'double-reg)
3096                                       :offset (1- (tn-offset y)))))
3097           (double-stack
3098            (inst fldd (ea-for-df-stack y)))
3099           (descriptor-reg
3100            (inst fldd (ea-for-df-desc y))))))
3101
3102      ;; Now have y at fr0; and x at fr1
3103      (inst fpatan)
3104      (inst fld fr0)
3105      (case (tn-offset r)
3106        ((0 1))
3107        (t (inst fstd r)))))
3108 ) ; PROGN #!-LONG-FLOAT
3109 \f
3110 #!+long-float
3111 (progn
3112
3113 ;;; Lets use some of the 80387 special functions.
3114 ;;;
3115 ;;; These defs will not take effect unless code/irrat.lisp is modified
3116 ;;; to remove the inlined alien routine def.
3117
3118 (macrolet ((frob (func trans op)
3119              `(define-vop (,func)
3120                (:args (x :scs (long-reg) :target fr0))
3121                (:temporary (:sc long-reg :offset fr0-offset
3122                                 :from :argument :to :result) fr0)
3123                (:ignore fr0)
3124                (:results (y :scs (long-reg)))
3125                (:arg-types long-float)
3126                (:result-types long-float)
3127                (:translate ,trans)
3128                (:policy :fast-safe)
3129                (:note "inline NPX function")
3130                (:vop-var vop)
3131                (:save-p :compute-only)
3132                (:node-var node)
3133                (:generator 5
3134                 (note-this-location vop :internal-error)
3135                 (unless (zerop (tn-offset x))
3136                   (inst fxch x)         ; x to top of stack
3137                   (unless (location= x y)
3138                     (inst fst x)))      ; maybe save it
3139                 (inst ,op)              ; clobber st0
3140                 (cond ((zerop (tn-offset y))
3141                        (maybe-fp-wait node))
3142                       (t
3143                        (inst fst y)))))))
3144
3145   ;; Quick versions of FSIN and FCOS that require the argument to be
3146   ;; within range 2^63.
3147   (frob fsin-quick %sin-quick fsin)
3148   (frob fcos-quick %cos-quick fcos)
3149   (frob fsqrt %sqrt fsqrt))
3150
3151 ;;; Quick version of ftan that requires the argument to be within
3152 ;;; range 2^63.
3153 (define-vop (ftan-quick)
3154   (:translate %tan-quick)
3155   (:args (x :scs (long-reg) :target fr0))
3156   (:temporary (:sc long-reg :offset fr0-offset
3157                    :from :argument :to :result) fr0)
3158   (:temporary (:sc long-reg :offset fr1-offset
3159                    :from :argument :to :result) fr1)
3160   (:results (y :scs (long-reg)))
3161   (:arg-types long-float)
3162   (:result-types long-float)
3163   (:policy :fast-safe)
3164   (:note "inline tan function")
3165   (:vop-var vop)
3166   (:save-p :compute-only)
3167   (:generator 5
3168     (note-this-location vop :internal-error)
3169     (case (tn-offset x)
3170        (0
3171         (inst fstp fr1))
3172        (1
3173         (inst fstp fr0))
3174        (t
3175         (inst fstp fr0)
3176         (inst fstp fr0)
3177         (inst fldd (make-random-tn :kind :normal
3178                                    :sc (sc-or-lose 'double-reg)
3179                                    :offset (- (tn-offset x) 2)))))
3180     (inst fptan)
3181     ;; Result is in fr1
3182     (case (tn-offset y)
3183        (0
3184         (inst fxch fr1))
3185        (1)
3186        (t
3187         (inst fxch fr1)
3188         (inst fstd y)))))
3189
3190 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3191 ;;; the argument is out of range 2^63 and would thus be hopelessly
3192 ;;; inaccurate.
3193 (macrolet ((frob (func trans op)
3194              `(define-vop (,func)
3195                 (:translate ,trans)
3196                 (:args (x :scs (long-reg) :target fr0))
3197                 (:temporary (:sc long-reg :offset fr0-offset
3198                                  :from :argument :to :result) fr0)
3199                 (:temporary (:sc unsigned-reg :offset eax-offset
3200                              :from :argument :to :result) eax)
3201                 (:results (y :scs (long-reg)))
3202                 (:arg-types long-float)
3203                 (:result-types long-float)
3204                 (:policy :fast-safe)
3205                 (:note "inline sin/cos function")
3206                 (:vop-var vop)
3207                 (:save-p :compute-only)
3208                 (:ignore eax)
3209                 (:generator 5
3210                   (note-this-location vop :internal-error)
3211                   (unless (zerop (tn-offset x))
3212                           (inst fxch x)          ; x to top of stack
3213                           (unless (location= x y)
3214                                   (inst fst x))) ; maybe save it
3215                   (inst ,op)
3216                   (inst fnstsw)                  ; status word to ax
3217                   (inst and ah-tn #x04)          ; C2
3218                   (inst jmp :z DONE)
3219                   ;; Else x was out of range so reduce it; ST0 is unchanged.
3220                   (inst fstp fr0)               ; Load 0.0
3221                   (inst fldz)
3222                   DONE
3223                   (unless (zerop (tn-offset y))
3224                           (inst fstd y))))))
3225           (frob fsin  %sin fsin)
3226           (frob fcos  %cos fcos))
3227
3228 (define-vop (ftan)
3229   (:translate %tan)
3230   (:args (x :scs (long-reg) :target fr0))
3231   (:temporary (:sc long-reg :offset fr0-offset
3232                    :from :argument :to :result) fr0)
3233   (:temporary (:sc long-reg :offset fr1-offset
3234                    :from :argument :to :result) fr1)
3235   (:temporary (:sc unsigned-reg :offset eax-offset
3236                    :from :argument :to :result) eax)
3237   (:results (y :scs (long-reg)))
3238   (:arg-types long-float)
3239   (:result-types long-float)
3240   (:ignore eax)
3241   (:policy :fast-safe)
3242   (:note "inline tan function")
3243   (:vop-var vop)
3244   (:save-p :compute-only)
3245   (:ignore eax)
3246   (:generator 5
3247     (note-this-location vop :internal-error)
3248     (case (tn-offset x)
3249        (0
3250         (inst fstp fr1))
3251        (1
3252         (inst fstp fr0))
3253        (t
3254         (inst fstp fr0)
3255         (inst fstp fr0)
3256         (inst fldd (make-random-tn :kind :normal
3257                                    :sc (sc-or-lose 'double-reg)
3258                                    :offset (- (tn-offset x) 2)))))
3259     (inst fptan)
3260     (inst fnstsw)                        ; status word to ax
3261     (inst and ah-tn #x04)                ; C2
3262     (inst jmp :z DONE)
3263     ;; Else x was out of range so reduce it; ST0 is unchanged.
3264     (inst fldz)                  ; Load 0.0
3265     (inst fxch fr1)
3266     DONE
3267     ;; Result is in fr1
3268     (case (tn-offset y)
3269        (0
3270         (inst fxch fr1))
3271        (1)
3272        (t
3273         (inst fxch fr1)
3274         (inst fstd y)))))
3275
3276 ;;; Modified exp that handles the following special cases:
3277 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3278 (define-vop (fexp)
3279   (:translate %exp)
3280   (:args (x :scs (long-reg) :target fr0))
3281   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3282   (:temporary (:sc long-reg :offset fr0-offset
3283                    :from :argument :to :result) fr0)
3284   (:temporary (:sc long-reg :offset fr1-offset
3285                    :from :argument :to :result) fr1)
3286   (:temporary (:sc long-reg :offset fr2-offset
3287                    :from :argument :to :result) fr2)
3288   (:results (y :scs (long-reg)))
3289   (:arg-types long-float)
3290   (:result-types long-float)
3291   (:policy :fast-safe)
3292   (:note "inline exp function")
3293   (:vop-var vop)
3294   (:save-p :compute-only)
3295   (:ignore temp)
3296   (:generator 5
3297      (note-this-location vop :internal-error)
3298      (unless (zerop (tn-offset x))
3299              (inst fxch x)              ; x to top of stack
3300              (unless (location= x y)
3301                      (inst fst x)))     ; maybe save it
3302      ;; Check for Inf or NaN
3303      (inst fxam)
3304      (inst fnstsw)
3305      (inst sahf)
3306      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3307      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3308      (inst and ah-tn #x02)            ; Test sign of Inf.
3309      (inst jmp :z DONE)          ; +Inf gives +Inf.
3310      (inst fstp fr0)                ; -Inf gives 0
3311      (inst fldz)
3312      (inst jmp-short DONE)
3313      NOINFNAN
3314      (inst fstp fr1)
3315      (inst fldl2e)
3316      (inst fmul fr1)
3317      ;; Now fr0=x log2(e)
3318      (inst fst fr1)
3319      (inst frndint)
3320      (inst fst fr2)
3321      (inst fsubp-sti fr1)
3322      (inst f2xm1)
3323      (inst fld1)
3324      (inst faddp-sti fr1)
3325      (inst fscale)
3326      (inst fld fr0)
3327      DONE
3328      (unless (zerop (tn-offset y))
3329              (inst fstd y))))
3330
3331 ;;; Expm1 = exp(x) - 1.
3332 ;;; Handles the following special cases:
3333 ;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3334 (define-vop (fexpm1)
3335   (:translate %expm1)
3336   (:args (x :scs (long-reg) :target fr0))
3337   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3338   (:temporary (:sc long-reg :offset fr0-offset
3339                    :from :argument :to :result) fr0)
3340   (:temporary (:sc long-reg :offset fr1-offset
3341                    :from :argument :to :result) fr1)
3342   (:temporary (:sc long-reg :offset fr2-offset
3343                    :from :argument :to :result) fr2)
3344   (:results (y :scs (long-reg)))
3345   (:arg-types long-float)
3346   (:result-types long-float)
3347   (:policy :fast-safe)
3348   (:note "inline expm1 function")
3349   (:vop-var vop)
3350   (:save-p :compute-only)
3351   (:ignore temp)
3352   (:generator 5
3353      (note-this-location vop :internal-error)
3354      (unless (zerop (tn-offset x))
3355        (inst fxch x)            ; x to top of stack
3356        (unless (location= x y)
3357          (inst fst x))) ; maybe save it
3358      ;; Check for Inf or NaN
3359      (inst fxam)
3360      (inst fnstsw)
3361      (inst sahf)
3362      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3363      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3364      (inst and ah-tn #x02)            ; Test sign of Inf.
3365      (inst jmp :z DONE)          ; +Inf gives +Inf.
3366      (inst fstp fr0)                ; -Inf gives -1.0
3367      (inst fld1)
3368      (inst fchs)
3369      (inst jmp-short DONE)
3370      NOINFNAN
3371      ;; Free two stack slots leaving the argument on top.
3372      (inst fstp fr2)
3373      (inst fstp fr0)
3374      (inst fldl2e)
3375      (inst fmul fr1)    ; Now fr0 = x log2(e)
3376      (inst fst fr1)
3377      (inst frndint)
3378      (inst fsub-sti fr1)
3379      (inst fxch fr1)
3380      (inst f2xm1)
3381      (inst fscale)
3382      (inst fxch fr1)
3383      (inst fld1)
3384      (inst fscale)
3385      (inst fstp fr1)
3386      (inst fld1)
3387      (inst fsub fr1)
3388      (inst fsubr fr2)
3389      DONE
3390      (unless (zerop (tn-offset y))
3391        (inst fstd y))))
3392
3393 (define-vop (flog)
3394   (:translate %log)
3395   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3396   (:temporary (:sc long-reg :offset fr0-offset
3397                    :from :argument :to :result) fr0)
3398   (:temporary (:sc long-reg :offset fr1-offset
3399                    :from :argument :to :result) fr1)
3400   (:results (y :scs (long-reg)))
3401   (:arg-types long-float)
3402   (:result-types long-float)
3403   (:policy :fast-safe)
3404   (:note "inline log function")
3405   (:vop-var vop)
3406   (:save-p :compute-only)
3407   (:generator 5
3408      (note-this-location vop :internal-error)
3409      (sc-case x
3410         (long-reg
3411          (case (tn-offset x)
3412             (0
3413              ;; x is in fr0
3414              (inst fstp fr1)
3415              (inst fldln2)
3416              (inst fxch fr1))
3417             (1
3418              ;; x is in fr1
3419              (inst fstp fr0)
3420              (inst fldln2)
3421              (inst fxch fr1))
3422             (t
3423              ;; x is in a FP reg, not fr0 or fr1
3424              (inst fstp fr0)
3425              (inst fstp fr0)
3426              (inst fldln2)
3427              (inst fldd (make-random-tn :kind :normal
3428                                         :sc (sc-or-lose 'double-reg)
3429                                         :offset (1- (tn-offset x))))))
3430          (inst fyl2x))
3431         ((long-stack descriptor-reg)
3432          (inst fstp fr0)
3433          (inst fstp fr0)
3434          (inst fldln2)
3435          (if (sc-is x long-stack)
3436              (inst fldl (ea-for-lf-stack x))
3437              (inst fldl (ea-for-lf-desc x)))
3438          (inst fyl2x)))
3439      (inst fld fr0)
3440      (case (tn-offset y)
3441        ((0 1))
3442        (t (inst fstd y)))))
3443
3444 (define-vop (flog10)
3445   (:translate %log10)
3446   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3447   (:temporary (:sc long-reg :offset fr0-offset
3448                    :from :argument :to :result) fr0)
3449   (:temporary (:sc long-reg :offset fr1-offset
3450                    :from :argument :to :result) fr1)
3451   (:results (y :scs (long-reg)))
3452   (:arg-types long-float)
3453   (:result-types long-float)
3454   (:policy :fast-safe)
3455   (:note "inline log10 function")
3456   (:vop-var vop)
3457   (:save-p :compute-only)
3458   (:generator 5
3459      (note-this-location vop :internal-error)
3460      (sc-case x
3461         (long-reg
3462          (case (tn-offset x)
3463             (0
3464              ;; x is in fr0
3465              (inst fstp fr1)
3466              (inst fldlg2)
3467              (inst fxch fr1))
3468             (1
3469              ;; x is in fr1
3470              (inst fstp fr0)
3471              (inst fldlg2)
3472              (inst fxch fr1))
3473             (t
3474              ;; x is in a FP reg, not fr0 or fr1
3475              (inst fstp fr0)
3476              (inst fstp fr0)
3477              (inst fldlg2)
3478              (inst fldd (make-random-tn :kind :normal
3479                                         :sc (sc-or-lose 'double-reg)
3480                                         :offset (1- (tn-offset x))))))
3481          (inst fyl2x))
3482         ((long-stack descriptor-reg)
3483          (inst fstp fr0)
3484          (inst fstp fr0)
3485          (inst fldlg2)
3486          (if (sc-is x long-stack)
3487              (inst fldl (ea-for-lf-stack x))
3488              (inst fldl (ea-for-lf-desc x)))
3489          (inst fyl2x)))
3490      (inst fld fr0)
3491      (case (tn-offset y)
3492        ((0 1))
3493        (t (inst fstd y)))))
3494
3495 (define-vop (fpow)
3496   (:translate %pow)
3497   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3498          (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3499   (:temporary (:sc long-reg :offset fr0-offset
3500                    :from (:argument 0) :to :result) fr0)
3501   (:temporary (:sc long-reg :offset fr1-offset
3502                    :from (:argument 1) :to :result) fr1)
3503   (:temporary (:sc long-reg :offset fr2-offset
3504                    :from :load :to :result) fr2)
3505   (:results (r :scs (long-reg)))
3506   (:arg-types long-float long-float)
3507   (:result-types long-float)
3508   (:policy :fast-safe)
3509   (:note "inline pow function")
3510   (:vop-var vop)
3511   (:save-p :compute-only)
3512   (:generator 5
3513      (note-this-location vop :internal-error)
3514      ;; Setup x in fr0 and y in fr1
3515      (cond
3516       ;; x in fr0; y in fr1
3517       ((and (sc-is x long-reg) (zerop (tn-offset x))
3518             (sc-is y long-reg) (= 1 (tn-offset y))))
3519       ;; y in fr1; x not in fr0
3520       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3521        ;; Load x to fr0
3522        (sc-case x
3523           (long-reg
3524            (copy-fp-reg-to-fr0 x))
3525           (long-stack
3526            (inst fstp fr0)
3527            (inst fldl (ea-for-lf-stack x)))
3528           (descriptor-reg
3529            (inst fstp fr0)
3530            (inst fldl (ea-for-lf-desc x)))))
3531       ;; x in fr0; y not in fr1
3532       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3533        (inst fxch fr1)
3534        ;; Now load y to fr0
3535        (sc-case y
3536           (long-reg
3537            (copy-fp-reg-to-fr0 y))
3538           (long-stack
3539            (inst fstp fr0)
3540            (inst fldl (ea-for-lf-stack y)))
3541           (descriptor-reg
3542            (inst fstp fr0)
3543            (inst fldl (ea-for-lf-desc y))))
3544        (inst fxch fr1))
3545       ;; x in fr1; y not in fr1
3546       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3547        ;; Load y to fr0
3548        (sc-case y
3549           (long-reg
3550            (copy-fp-reg-to-fr0 y))
3551           (long-stack
3552            (inst fstp fr0)
3553            (inst fldl (ea-for-lf-stack y)))
3554           (descriptor-reg
3555            (inst fstp fr0)
3556            (inst fldl (ea-for-lf-desc y))))
3557        (inst fxch fr1))
3558       ;; y in fr0;
3559       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3560        (inst fxch fr1)
3561        ;; Now load x to fr0
3562        (sc-case x
3563           (long-reg
3564            (copy-fp-reg-to-fr0 x))
3565           (long-stack
3566            (inst fstp fr0)
3567            (inst fldl (ea-for-lf-stack x)))
3568           (descriptor-reg
3569            (inst fstp fr0)
3570            (inst fldl (ea-for-lf-desc x)))))
3571       ;; Neither x or y are in either fr0 or fr1
3572       (t
3573        ;; Load y then x
3574        (inst fstp fr0)
3575        (inst fstp fr0)
3576        (sc-case y
3577           (long-reg
3578            (inst fldd (make-random-tn :kind :normal
3579                                       :sc (sc-or-lose 'double-reg)
3580                                       :offset (- (tn-offset y) 2))))
3581           (long-stack
3582            (inst fldl (ea-for-lf-stack y)))
3583           (descriptor-reg
3584            (inst fldl (ea-for-lf-desc y))))
3585        ;; Load x to fr0
3586        (sc-case x
3587           (long-reg
3588            (inst fldd (make-random-tn :kind :normal
3589                                       :sc (sc-or-lose 'double-reg)
3590                                       :offset (1- (tn-offset x)))))
3591           (long-stack
3592            (inst fldl (ea-for-lf-stack x)))
3593           (descriptor-reg
3594            (inst fldl (ea-for-lf-desc x))))))
3595
3596      ;; Now have x at fr0; and y at fr1
3597      (inst fyl2x)
3598      ;; Now fr0=y log2(x)
3599      (inst fld fr0)
3600      (inst frndint)
3601      (inst fst fr2)
3602      (inst fsubp-sti fr1)
3603      (inst f2xm1)
3604      (inst fld1)
3605      (inst faddp-sti fr1)
3606      (inst fscale)
3607      (inst fld fr0)
3608      (case (tn-offset r)
3609        ((0 1))
3610        (t (inst fstd r)))))
3611
3612 (define-vop (fscalen)
3613   (:translate %scalbn)
3614   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3615          (y :scs (signed-stack signed-reg) :target temp))
3616   (:temporary (:sc long-reg :offset fr0-offset
3617                    :from (:argument 0) :to :result) fr0)
3618   (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3619   (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3620   (:results (r :scs (long-reg)))
3621   (:arg-types long-float signed-num)
3622   (:result-types long-float)
3623   (:policy :fast-safe)
3624   (:note "inline scalbn function")
3625   (:generator 5
3626      ;; Setup x in fr0 and y in fr1
3627      (sc-case x
3628        (long-reg
3629         (case (tn-offset x)
3630           (0
3631            (inst fstp fr1)
3632            (sc-case y
3633              (signed-reg
3634               (inst mov temp y)
3635               (inst fild temp))
3636              (signed-stack
3637               (inst fild y)))
3638            (inst fxch fr1))
3639           (1
3640            (inst fstp fr0)
3641            (sc-case y
3642              (signed-reg
3643               (inst mov temp y)
3644               (inst fild temp))
3645              (signed-stack
3646               (inst fild y)))
3647            (inst fxch fr1))
3648           (t
3649            (inst fstp fr0)
3650            (inst fstp fr0)
3651            (sc-case y
3652              (signed-reg
3653               (inst mov temp y)
3654               (inst fild temp))
3655              (signed-stack
3656               (inst fild y)))
3657            (inst fld (make-random-tn :kind :normal
3658                                      :sc (sc-or-lose 'double-reg)
3659                                      :offset (1- (tn-offset x)))))))
3660        ((long-stack descriptor-reg)
3661         (inst fstp fr0)
3662         (inst fstp fr0)
3663         (sc-case y
3664           (signed-reg
3665            (inst mov temp y)
3666            (inst fild temp))
3667           (signed-stack
3668            (inst fild y)))
3669         (if (sc-is x long-stack)
3670             (inst fldl (ea-for-lf-stack x))
3671             (inst fldl (ea-for-lf-desc x)))))
3672      (inst fscale)
3673      (unless (zerop (tn-offset r))
3674        (inst fstd r))))
3675
3676 (define-vop (fscale)
3677   (:translate %scalb)
3678   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3679          (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3680   (:temporary (:sc long-reg :offset fr0-offset
3681                    :from (:argument 0) :to :result) fr0)
3682   (:temporary (:sc long-reg :offset fr1-offset
3683                    :from (:argument 1) :to :result) fr1)
3684   (:results (r :scs (long-reg)))
3685   (:arg-types long-float long-float)
3686   (:result-types long-float)
3687   (:policy :fast-safe)
3688   (:note "inline scalb function")
3689   (:vop-var vop)
3690   (:save-p :compute-only)
3691   (:generator 5
3692      (note-this-location vop :internal-error)
3693      ;; Setup x in fr0 and y in fr1
3694      (cond
3695       ;; x in fr0; y in fr1
3696       ((and (sc-is x long-reg) (zerop (tn-offset x))
3697             (sc-is y long-reg) (= 1 (tn-offset y))))
3698       ;; y in fr1; x not in fr0
3699       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3700        ;; Load x to fr0
3701        (sc-case x
3702           (long-reg
3703            (copy-fp-reg-to-fr0 x))
3704           (long-stack
3705            (inst fstp fr0)
3706            (inst fldl (ea-for-lf-stack x)))
3707           (descriptor-reg
3708            (inst fstp fr0)
3709            (inst fldl (ea-for-lf-desc x)))))
3710       ;; x in fr0; y not in fr1
3711       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3712        (inst fxch fr1)
3713        ;; Now load y to fr0
3714        (sc-case y
3715           (long-reg
3716            (copy-fp-reg-to-fr0 y))
3717           (long-stack
3718            (inst fstp fr0)
3719            (inst fldl (ea-for-lf-stack y)))
3720           (descriptor-reg
3721            (inst fstp fr0)
3722            (inst fldl (ea-for-lf-desc y))))
3723        (inst fxch fr1))
3724       ;; x in fr1; y not in fr1
3725       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3726        ;; Load y to fr0
3727        (sc-case y
3728           (long-reg
3729            (copy-fp-reg-to-fr0 y))
3730           (long-stack
3731            (inst fstp fr0)
3732            (inst fldl (ea-for-lf-stack y)))
3733           (descriptor-reg
3734            (inst fstp fr0)
3735            (inst fldl (ea-for-lf-desc y))))
3736        (inst fxch fr1))
3737       ;; y in fr0;
3738       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3739        (inst fxch fr1)
3740        ;; Now load x to fr0
3741        (sc-case x
3742           (long-reg
3743            (copy-fp-reg-to-fr0 x))
3744           (long-stack
3745            (inst fstp fr0)
3746            (inst fldl (ea-for-lf-stack x)))
3747           (descriptor-reg
3748            (inst fstp fr0)
3749            (inst fldl (ea-for-lf-desc x)))))
3750       ;; Neither x or y are in either fr0 or fr1
3751       (t
3752        ;; Load y then x
3753        (inst fstp fr0)
3754        (inst fstp fr0)
3755        (sc-case y
3756           (long-reg
3757            (inst fldd (make-random-tn :kind :normal
3758                                       :sc (sc-or-lose 'double-reg)
3759                                       :offset (- (tn-offset y) 2))))
3760           (long-stack
3761            (inst fldl (ea-for-lf-stack y)))
3762           (descriptor-reg
3763            (inst fldl (ea-for-lf-desc y))))
3764        ;; Load x to fr0
3765        (sc-case x
3766           (long-reg
3767            (inst fldd (make-random-tn :kind :normal
3768                                       :sc (sc-or-lose 'double-reg)
3769                                       :offset (1- (tn-offset x)))))
3770           (long-stack
3771            (inst fldl (ea-for-lf-stack x)))
3772           (descriptor-reg
3773            (inst fldl (ea-for-lf-desc x))))))
3774
3775      ;; Now have x at fr0; and y at fr1
3776      (inst fscale)
3777      (unless (zerop (tn-offset r))
3778              (inst fstd r))))
3779
3780 (define-vop (flog1p)
3781   (:translate %log1p)
3782   (:args (x :scs (long-reg) :to :result))
3783   (:temporary (:sc long-reg :offset fr0-offset
3784                    :from :argument :to :result) fr0)
3785   (:temporary (:sc long-reg :offset fr1-offset
3786                    :from :argument :to :result) fr1)
3787   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3788   (:results (y :scs (long-reg)))
3789   (:arg-types long-float)
3790   (:result-types long-float)
3791   (:policy :fast-safe)
3792   ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3793   ;;   Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3794   ;;   an enormous PROGN above. Still, it would be probably be good to
3795   ;;   add some code to warn about redefining VOPs.
3796   (:note "inline log1p function")
3797   (:ignore temp)
3798   (:generator 5
3799      ;; x is in a FP reg, not fr0, fr1.
3800      (inst fstp fr0)
3801      (inst fstp fr0)
3802      (inst fldd (make-random-tn :kind :normal
3803                                 :sc (sc-or-lose 'double-reg)
3804                                 :offset (- (tn-offset x) 2)))
3805      ;; Check the range
3806      (inst push #x3e947ae1)     ; Constant 0.29
3807      (inst fabs)
3808      (inst fld (make-ea :dword :base esp-tn))
3809      (inst fcompp)
3810      (inst add esp-tn 4)
3811      (inst fnstsw)                      ; status word to ax
3812      (inst and ah-tn #x45)
3813      (inst jmp :z WITHIN-RANGE)
3814      ;; Out of range for fyl2xp1.
3815      (inst fld1)
3816      (inst faddd (make-random-tn :kind :normal
3817                                  :sc (sc-or-lose 'double-reg)
3818                                  :offset (- (tn-offset x) 1)))
3819      (inst fldln2)
3820      (inst fxch fr1)
3821      (inst fyl2x)
3822      (inst jmp DONE)
3823
3824      WITHIN-RANGE
3825      (inst fldln2)
3826      (inst fldd (make-random-tn :kind :normal
3827                                 :sc (sc-or-lose 'double-reg)
3828                                 :offset (- (tn-offset x) 1)))
3829      (inst fyl2xp1)
3830      DONE
3831      (inst fld fr0)
3832      (case (tn-offset y)
3833        ((0 1))
3834        (t (inst fstd y)))))
3835
3836 ;;; The Pentium has a less restricted implementation of the fyl2xp1
3837 ;;; instruction and a range check can be avoided.
3838 (define-vop (flog1p-pentium)
3839   (:translate %log1p)
3840   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3841   (:temporary (:sc long-reg :offset fr0-offset
3842                    :from :argument :to :result) fr0)
3843   (:temporary (:sc long-reg :offset fr1-offset
3844                    :from :argument :to :result) fr1)
3845   (:results (y :scs (long-reg)))
3846   (:arg-types long-float)
3847   (:result-types long-float)
3848   (:policy :fast-safe)
3849   (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
3850   (:note "inline log1p function")
3851   (:generator 5
3852      (sc-case x
3853         (long-reg
3854          (case (tn-offset x)
3855             (0
3856              ;; x is in fr0
3857              (inst fstp fr1)
3858              (inst fldln2)
3859              (inst fxch fr1))
3860             (1
3861              ;; x is in fr1
3862              (inst fstp fr0)
3863              (inst fldln2)
3864              (inst fxch fr1))
3865             (t
3866              ;; x is in a FP reg, not fr0 or fr1
3867              (inst fstp fr0)
3868              (inst fstp fr0)
3869              (inst fldln2)
3870              (inst fldd (make-random-tn :kind :normal
3871                                         :sc (sc-or-lose 'double-reg)
3872                                         :offset (1- (tn-offset x)))))))
3873         ((long-stack descriptor-reg)
3874          (inst fstp fr0)
3875          (inst fstp fr0)
3876          (inst fldln2)
3877          (if (sc-is x long-stack)
3878              (inst fldl (ea-for-lf-stack x))
3879            (inst fldl (ea-for-lf-desc x)))))
3880      (inst fyl2xp1)
3881      (inst fld fr0)
3882      (case (tn-offset y)
3883        ((0 1))
3884        (t (inst fstd y)))))
3885
3886 (define-vop (flogb)
3887   (:translate %logb)
3888   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3889   (:temporary (:sc long-reg :offset fr0-offset
3890                    :from :argument :to :result) fr0)
3891   (:temporary (:sc long-reg :offset fr1-offset
3892                    :from :argument :to :result) fr1)
3893   (:results (y :scs (long-reg)))
3894   (:arg-types long-float)
3895   (:result-types long-float)
3896   (:policy :fast-safe)
3897   (:note "inline logb function")
3898   (:vop-var vop)
3899   (:save-p :compute-only)
3900   (:generator 5
3901      (note-this-location vop :internal-error)
3902      (sc-case x
3903         (long-reg
3904          (case (tn-offset x)
3905             (0
3906              ;; x is in fr0
3907              (inst fstp fr1))
3908             (1
3909              ;; x is in fr1
3910              (inst fstp fr0))
3911             (t
3912              ;; x is in a FP reg, not fr0 or fr1
3913              (inst fstp fr0)
3914              (inst fstp fr0)
3915              (inst fldd (make-random-tn :kind :normal
3916                                         :sc (sc-or-lose 'double-reg)
3917                                         :offset (- (tn-offset x) 2))))))
3918         ((long-stack descriptor-reg)
3919          (inst fstp fr0)
3920          (inst fstp fr0)
3921          (if (sc-is x long-stack)
3922              (inst fldl (ea-for-lf-stack x))
3923            (inst fldl (ea-for-lf-desc x)))))
3924      (inst fxtract)
3925      (case (tn-offset y)
3926        (0
3927         (inst fxch fr1))
3928        (1)
3929        (t (inst fxch fr1)
3930           (inst fstd y)))))
3931
3932 (define-vop (fatan)
3933   (:translate %atan)
3934   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3935   (:temporary (:sc long-reg :offset fr0-offset
3936                    :from (:argument 0) :to :result) fr0)
3937   (:temporary (:sc long-reg :offset fr1-offset
3938                    :from (:argument 0) :to :result) fr1)
3939   (:results (r :scs (long-reg)))
3940   (:arg-types long-float)
3941   (:result-types long-float)
3942   (:policy :fast-safe)
3943   (:note "inline atan function")
3944   (:vop-var vop)
3945   (:save-p :compute-only)
3946   (:generator 5
3947      (note-this-location vop :internal-error)
3948      ;; Setup x in fr1 and 1.0 in fr0
3949      (cond
3950       ;; x in fr0
3951       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3952        (inst fstp fr1))
3953       ;; x in fr1
3954       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3955        (inst fstp fr0))
3956       ;; x not in fr0 or fr1
3957       (t
3958        ;; Load x then 1.0
3959        (inst fstp fr0)
3960        (inst fstp fr0)
3961        (sc-case x
3962           (long-reg
3963            (inst fldd (make-random-tn :kind :normal
3964                                       :sc (sc-or-lose 'double-reg)
3965                                       :offset (- (tn-offset x) 2))))
3966           (long-stack
3967            (inst fldl (ea-for-lf-stack x)))
3968           (descriptor-reg
3969            (inst fldl (ea-for-lf-desc x))))))
3970      (inst fld1)
3971      ;; Now have x at fr1; and 1.0 at fr0
3972      (inst fpatan)
3973      (inst fld fr0)
3974      (case (tn-offset r)
3975        ((0 1))
3976        (t (inst fstd r)))))
3977
3978 (define-vop (fatan2)
3979   (:translate %atan2)
3980   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
3981          (y :scs (long-reg long-stack descriptor-reg) :target fr0))
3982   (:temporary (:sc long-reg :offset fr0-offset
3983                    :from (:argument 1) :to :result) fr0)
3984   (:temporary (:sc long-reg :offset fr1-offset
3985                    :from (:argument 0) :to :result) fr1)
3986   (:results (r :scs (long-reg)))
3987   (:arg-types long-float long-float)
3988   (:result-types long-float)
3989   (:policy :fast-safe)
3990   (:note "inline atan2 function")
3991   (:vop-var vop)
3992   (:save-p :compute-only)
3993   (:generator 5
3994      (note-this-location vop :internal-error)
3995      ;; Setup x in fr1 and y in fr0
3996      (cond
3997       ;; y in fr0; x in fr1
3998       ((and (sc-is y long-reg) (zerop (tn-offset y))
3999             (sc-is x long-reg) (= 1 (tn-offset x))))
4000       ;; x in fr1; y not in fr0
4001       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4002        ;; Load y to fr0
4003        (sc-case y
4004           (long-reg
4005            (copy-fp-reg-to-fr0 y))
4006           (long-stack
4007            (inst fstp fr0)
4008            (inst fldl (ea-for-lf-stack y)))
4009           (descriptor-reg
4010            (inst fstp fr0)
4011            (inst fldl (ea-for-lf-desc y)))))
4012       ;; y in fr0; x not in fr1
4013       ((and (sc-is y long-reg) (zerop (tn-offset y)))
4014        (inst fxch fr1)
4015        ;; Now load x to fr0
4016        (sc-case x
4017           (long-reg
4018            (copy-fp-reg-to-fr0 x))
4019           (long-stack
4020            (inst fstp fr0)
4021            (inst fldl (ea-for-lf-stack x)))
4022           (descriptor-reg
4023            (inst fstp fr0)
4024            (inst fldl (ea-for-lf-desc x))))
4025        (inst fxch fr1))
4026       ;; y in fr1; x not in fr1
4027       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4028        ;; Load x to fr0
4029        (sc-case x
4030           (long-reg
4031            (copy-fp-reg-to-fr0 x))
4032           (long-stack
4033            (inst fstp fr0)
4034            (inst fldl (ea-for-lf-stack x)))
4035           (descriptor-reg
4036            (inst fstp fr0)
4037            (inst fldl (ea-for-lf-desc x))))
4038        (inst fxch fr1))
4039       ;; x in fr0;
4040       ((and (sc-is x long-reg) (zerop (tn-offset x)))
4041        (inst fxch fr1)
4042        ;; Now load y to fr0
4043        (sc-case y
4044           (long-reg
4045            (copy-fp-reg-to-fr0 y))
4046           (long-stack
4047            (inst fstp fr0)
4048            (inst fldl (ea-for-lf-stack y)))
4049           (descriptor-reg
4050            (inst fstp fr0)
4051            (inst fldl (ea-for-lf-desc y)))))
4052       ;; Neither y or x are in either fr0 or fr1
4053       (t
4054        ;; Load x then y
4055        (inst fstp fr0)
4056        (inst fstp fr0)
4057        (sc-case x
4058           (long-reg
4059            (inst fldd (make-random-tn :kind :normal
4060                                       :sc (sc-or-lose 'double-reg)
4061                                       :offset (- (tn-offset x) 2))))
4062           (long-stack
4063            (inst fldl (ea-for-lf-stack x)))
4064           (descriptor-reg
4065            (inst fldl (ea-for-lf-desc x))))
4066        ;; Load y to fr0
4067        (sc-case y
4068           (long-reg
4069            (inst fldd (make-random-tn :kind :normal
4070                                       :sc (sc-or-lose 'double-reg)
4071                                       :offset (1- (tn-offset y)))))
4072           (long-stack
4073            (inst fldl (ea-for-lf-stack y)))
4074           (descriptor-reg
4075            (inst fldl (ea-for-lf-desc y))))))
4076
4077      ;; Now have y at fr0; and x at fr1
4078      (inst fpatan)
4079      (inst fld fr0)
4080      (case (tn-offset r)
4081        ((0 1))
4082        (t (inst fstd r)))))
4083
4084 ) ; PROGN #!+LONG-FLOAT
4085 \f
4086 ;;;; complex float VOPs
4087
4088 (define-vop (make-complex-single-float)
4089   (:translate complex)
4090   (:args (real :scs (single-reg) :to :result :target r
4091                :load-if (not (location= real r)))
4092          (imag :scs (single-reg) :to :save))
4093   (:arg-types single-float single-float)
4094   (:results (r :scs (complex-single-reg) :from (:argument 0)
4095                :load-if (not (sc-is r complex-single-stack))))
4096   (:result-types complex-single-float)
4097   (:note "inline complex single-float creation")
4098   (:policy :fast-safe)
4099   (:generator 5
4100     (sc-case r
4101       (complex-single-reg
4102        (let ((r-real (complex-double-reg-real-tn r)))
4103          (unless (location= real r-real)
4104            (cond ((zerop (tn-offset r-real))
4105                   (copy-fp-reg-to-fr0 real))
4106                  ((zerop (tn-offset real))
4107                   (inst fstd r-real))
4108                  (t
4109                   (inst fxch real)
4110                   (inst fstd r-real)
4111                   (inst fxch real)))))
4112        (let ((r-imag (complex-double-reg-imag-tn r)))
4113          (unless (location= imag r-imag)
4114            (cond ((zerop (tn-offset imag))
4115                   (inst fstd r-imag))
4116                  (t
4117                   (inst fxch imag)
4118                   (inst fstd r-imag)
4119                   (inst fxch imag))))))
4120       (complex-single-stack
4121        (unless (location= real r)
4122          (cond ((zerop (tn-offset real))
4123                 (inst fst (ea-for-csf-real-stack r)))
4124                (t
4125                 (inst fxch real)
4126                 (inst fst (ea-for-csf-real-stack r))
4127                 (inst fxch real))))
4128        (inst fxch imag)
4129        (inst fst (ea-for-csf-imag-stack r))
4130        (inst fxch imag)))))
4131
4132 (define-vop (make-complex-double-float)
4133   (:translate complex)
4134   (:args (real :scs (double-reg) :target r
4135                :load-if (not (location= real r)))
4136          (imag :scs (double-reg) :to :save))
4137   (:arg-types double-float double-float)
4138   (:results (r :scs (complex-double-reg) :from (:argument 0)
4139                :load-if (not (sc-is r complex-double-stack))))
4140   (:result-types complex-double-float)
4141   (:note "inline complex double-float creation")
4142   (:policy :fast-safe)
4143   (:generator 5
4144     (sc-case r
4145       (complex-double-reg
4146        (let ((r-real (complex-double-reg-real-tn r)))
4147          (unless (location= real r-real)
4148            (cond ((zerop (tn-offset r-real))
4149                   (copy-fp-reg-to-fr0 real))
4150                  ((zerop (tn-offset real))
4151                   (inst fstd r-real))
4152                  (t
4153                   (inst fxch real)
4154                   (inst fstd r-real)
4155                   (inst fxch real)))))
4156        (let ((r-imag (complex-double-reg-imag-tn r)))
4157          (unless (location= imag r-imag)
4158            (cond ((zerop (tn-offset imag))
4159                   (inst fstd r-imag))
4160                  (t
4161                   (inst fxch imag)
4162                   (inst fstd r-imag)
4163                   (inst fxch imag))))))
4164       (complex-double-stack
4165        (unless (location= real r)
4166          (cond ((zerop (tn-offset real))
4167                 (inst fstd (ea-for-cdf-real-stack r)))
4168                (t
4169                 (inst fxch real)
4170                 (inst fstd (ea-for-cdf-real-stack r))
4171                 (inst fxch real))))
4172        (inst fxch imag)
4173        (inst fstd (ea-for-cdf-imag-stack r))
4174        (inst fxch imag)))))
4175
4176 #!+long-float
4177 (define-vop (make-complex-long-float)
4178   (:translate complex)
4179   (:args (real :scs (long-reg) :target r
4180                :load-if (not (location= real r)))
4181          (imag :scs (long-reg) :to :save))
4182   (:arg-types long-float long-float)
4183   (:results (r :scs (complex-long-reg) :from (:argument 0)
4184                :load-if (not (sc-is r complex-long-stack))))
4185   (:result-types complex-long-float)
4186   (:note "inline complex long-float creation")
4187   (:policy :fast-safe)
4188   (:generator 5
4189     (sc-case r
4190       (complex-long-reg
4191        (let ((r-real (complex-double-reg-real-tn r)))
4192          (unless (location= real r-real)
4193            (cond ((zerop (tn-offset r-real))
4194                   (copy-fp-reg-to-fr0 real))
4195                  ((zerop (tn-offset real))
4196                   (inst fstd r-real))
4197                  (t
4198                   (inst fxch real)
4199                   (inst fstd r-real)
4200                   (inst fxch real)))))
4201        (let ((r-imag (complex-double-reg-imag-tn r)))
4202          (unless (location= imag r-imag)
4203            (cond ((zerop (tn-offset imag))
4204                   (inst fstd r-imag))
4205                  (t
4206                   (inst fxch imag)
4207                   (inst fstd r-imag)
4208                   (inst fxch imag))))))
4209       (complex-long-stack
4210        (unless (location= real r)
4211          (cond ((zerop (tn-offset real))
4212                 (store-long-float (ea-for-clf-real-stack r)))
4213                (t
4214                 (inst fxch real)
4215                 (store-long-float (ea-for-clf-real-stack r))
4216                 (inst fxch real))))
4217        (inst fxch imag)
4218        (store-long-float (ea-for-clf-imag-stack r))
4219        (inst fxch imag)))))
4220
4221
4222 (define-vop (complex-float-value)
4223   (:args (x :target r))
4224   (:results (r))
4225   (:variant-vars offset)
4226   (:policy :fast-safe)
4227   (:generator 3
4228     (cond ((sc-is x complex-single-reg complex-double-reg
4229                   #!+long-float complex-long-reg)
4230            (let ((value-tn
4231                   (make-random-tn :kind :normal
4232                                   :sc (sc-or-lose 'double-reg)
4233                                   :offset (+ offset (tn-offset x)))))
4234              (unless (location= value-tn r)
4235                (cond ((zerop (tn-offset r))
4236                       (copy-fp-reg-to-fr0 value-tn))
4237                      ((zerop (tn-offset value-tn))
4238                       (inst fstd r))
4239                      (t
4240                       (inst fxch value-tn)
4241                       (inst fstd r)
4242                       (inst fxch value-tn))))))
4243           ((sc-is r single-reg)
4244            (let ((ea (sc-case x
4245                        (complex-single-stack
4246                         (ecase offset
4247                           (0 (ea-for-csf-real-stack x))
4248                           (1 (ea-for-csf-imag-stack x))))
4249                        (descriptor-reg
4250                         (ecase offset
4251                           (0 (ea-for-csf-real-desc x))
4252                           (1 (ea-for-csf-imag-desc x)))))))
4253              (with-empty-tn@fp-top(r)
4254                (inst fld ea))))
4255           ((sc-is r double-reg)
4256            (let ((ea (sc-case x
4257                        (complex-double-stack
4258                         (ecase offset
4259                           (0 (ea-for-cdf-real-stack x))
4260                           (1 (ea-for-cdf-imag-stack x))))
4261                        (descriptor-reg
4262                         (ecase offset
4263                           (0 (ea-for-cdf-real-desc x))
4264                           (1 (ea-for-cdf-imag-desc x)))))))
4265              (with-empty-tn@fp-top(r)
4266                (inst fldd ea))))
4267           #!+long-float
4268           ((sc-is r long-reg)
4269            (let ((ea (sc-case x
4270                        (complex-long-stack
4271                         (ecase offset
4272                           (0 (ea-for-clf-real-stack x))
4273                           (1 (ea-for-clf-imag-stack x))))
4274                        (descriptor-reg
4275                         (ecase offset
4276                           (0 (ea-for-clf-real-desc x))
4277                           (1 (ea-for-clf-imag-desc x)))))))
4278              (with-empty-tn@fp-top(r)
4279                (inst fldl ea))))
4280           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4281
4282 (define-vop (realpart/complex-single-float complex-float-value)
4283   (:translate realpart)
4284   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4285             :target r))
4286   (:arg-types complex-single-float)
4287   (:results (r :scs (single-reg)))
4288   (:result-types single-float)
4289   (:note "complex float realpart")
4290   (:variant 0))
4291
4292 (define-vop (realpart/complex-double-float complex-float-value)
4293   (:translate realpart)
4294   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4295             :target r))
4296   (:arg-types complex-double-float)
4297   (:results (r :scs (double-reg)))
4298   (:result-types double-float)
4299   (:note "complex float realpart")
4300   (:variant 0))
4301
4302 #!+long-float
4303 (define-vop (realpart/complex-long-float complex-float-value)
4304   (:translate realpart)
4305   (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4306             :target r))
4307   (:arg-types complex-long-float)
4308   (:results (r :scs (long-reg)))
4309   (:result-types long-float)
4310   (:note "complex float realpart")
4311   (:variant 0))
4312
4313 (define-vop (imagpart/complex-single-float complex-float-value)
4314   (:translate imagpart)
4315   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4316             :target r))
4317   (:arg-types complex-single-float)
4318   (:results (r :scs (single-reg)))
4319   (:result-types single-float)
4320   (:note "complex float imagpart")
4321   (:variant 1))
4322
4323 (define-vop (imagpart/complex-double-float complex-float-value)
4324   (:translate imagpart)
4325   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4326             :target r))
4327   (:arg-types complex-double-float)
4328   (:results (r :scs (double-reg)))
4329   (:result-types double-float)
4330   (:note "complex float imagpart")
4331   (:variant 1))
4332
4333 #!+long-float
4334 (define-vop (imagpart/complex-long-float complex-float-value)
4335   (:translate imagpart)
4336   (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4337             :target r))
4338   (:arg-types complex-long-float)
4339   (:results (r :scs (long-reg)))
4340   (:result-types long-float)
4341   (:note "complex float imagpart")
4342   (:variant 1))
4343 \f
4344 ;;; hack dummy VOPs to bias the representation selection of their
4345 ;;; arguments towards a FP register, which can help avoid consing at
4346 ;;; inappropriate locations
4347 (defknown double-float-reg-bias (double-float) (values))
4348 (define-vop (double-float-reg-bias)
4349   (:translate double-float-reg-bias)
4350   (:args (x :scs (double-reg double-stack) :load-if nil))
4351   (:arg-types double-float)
4352   (:policy :fast-safe)
4353   (:note "inline dummy FP register bias")
4354   (:ignore x)
4355   (:generator 0))
4356 (defknown single-float-reg-bias (single-float) (values))
4357 (define-vop (single-float-reg-bias)
4358   (:translate single-float-reg-bias)
4359   (:args (x :scs (single-reg single-stack) :load-if nil))
4360   (:arg-types single-float)
4361   (:policy :fast-safe)
4362   (:note "inline dummy FP register bias")
4363   (:ignore x)
4364   (:generator 0))