src/compiler/x86/float.lisp

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