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