src/compiler/x86/float.lisp

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