src/compiler/x86/float.lisp

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