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