src/compiler/x86/float.lisp

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