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