src/compiler/x86/float.lisp

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