src/compiler/x86/float.lisp

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