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