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