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