src/compiler/x86/float.lisp

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