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