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       ((and (sc-is x double-reg) (zerop (tn-offset x))
3130             (sc-is y double-reg) (zerop (tn-offset x)))
3131        ;; copy x to fr1
3132        (inst fst fr1))
3133       ;; y in fr0; x not in fr1
3134       ((and (sc-is y double-reg) (zerop (tn-offset y)))
3135        (inst fxch fr1)
3136        ;; Now load x to fr0
3137        (sc-case x
3138           (double-reg
3139            (copy-fp-reg-to-fr0 x))
3140           (double-stack
3141            (inst fstp fr0)
3142            (inst fldd (ea-for-df-stack x)))
3143           (descriptor-reg
3144            (inst fstp fr0)
3145            (inst fldd (ea-for-df-desc x))))
3146        (inst fxch fr1))
3147       ;; y in fr1; x not in fr1
3148       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
3149        ;; Load x to fr0
3150        (sc-case x
3151           (double-reg
3152            (copy-fp-reg-to-fr0 x))
3153           (double-stack
3154            (inst fstp fr0)
3155            (inst fldd (ea-for-df-stack x)))
3156           (descriptor-reg
3157            (inst fstp fr0)
3158            (inst fldd (ea-for-df-desc x))))
3159        (inst fxch fr1))
3160       ;; x in fr0;
3161       ((and (sc-is x double-reg) (zerop (tn-offset x)))
3162        (inst fxch fr1)
3163        ;; Now load y to fr0
3164        (sc-case y
3165           (double-reg
3166            (copy-fp-reg-to-fr0 y))
3167           (double-stack
3168            (inst fstp fr0)
3169            (inst fldd (ea-for-df-stack y)))
3170           (descriptor-reg
3171            (inst fstp fr0)
3172            (inst fldd (ea-for-df-desc y)))))
3173       ;; Neither y or x are in either fr0 or fr1
3174       (t
3175        ;; Load x then y
3176        (inst fstp fr0)
3177        (inst fstp fr0)
3178        (sc-case x
3179           (double-reg
3180            (inst fldd (make-random-tn :kind :normal
3181                                       :sc (sc-or-lose 'double-reg)
3182                                       :offset (- (tn-offset x) 2))))
3183           (double-stack
3184            (inst fldd (ea-for-df-stack x)))
3185           (descriptor-reg
3186            (inst fldd (ea-for-df-desc x))))
3187        ;; Load y to fr0
3188        (sc-case y
3189           (double-reg
3190            (inst fldd (make-random-tn :kind :normal
3191                                       :sc (sc-or-lose 'double-reg)
3192                                       :offset (1- (tn-offset y)))))
3193           (double-stack
3194            (inst fldd (ea-for-df-stack y)))
3195           (descriptor-reg
3196            (inst fldd (ea-for-df-desc y))))))
3197
3198      ;; Now have y at fr0; and x at fr1
3199      (inst fpatan)
3200      (inst fld fr0)
3201      (case (tn-offset r)
3202        ((0 1))
3203        (t (inst fstd r)))))
3204 ) ; PROGN #!-LONG-FLOAT
3205 \f
3206 #!+long-float
3207 (progn
3208
3209 ;;; Lets use some of the 80387 special functions.
3210 ;;;
3211 ;;; These defs will not take effect unless code/irrat.lisp is modified
3212 ;;; to remove the inlined alien routine def.
3213
3214 (macrolet ((frob (func trans op)
3215              `(define-vop (,func)
3216                (:args (x :scs (long-reg) :target fr0))
3217                (:temporary (:sc long-reg :offset fr0-offset
3218                                 :from :argument :to :result) fr0)
3219                (:ignore fr0)
3220                (:results (y :scs (long-reg)))
3221                (:arg-types long-float)
3222                (:result-types long-float)
3223                (:translate ,trans)
3224                (:policy :fast-safe)
3225                (:note "inline NPX function")
3226                (:vop-var vop)
3227                (:save-p :compute-only)
3228                (:node-var node)
3229                (:generator 5
3230                 (note-this-location vop :internal-error)
3231                 (unless (zerop (tn-offset x))
3232                   (inst fxch x)         ; x to top of stack
3233                   (unless (location= x y)
3234                     (inst fst x)))      ; maybe save it
3235                 (inst ,op)              ; clobber st0
3236                 (cond ((zerop (tn-offset y))
3237                        (maybe-fp-wait node))
3238                       (t
3239                        (inst fst y)))))))
3240
3241   ;; Quick versions of FSIN and FCOS that require the argument to be
3242   ;; within range 2^63.
3243   (frob fsin-quick %sin-quick fsin)
3244   (frob fcos-quick %cos-quick fcos)
3245   (frob fsqrt %sqrt fsqrt))
3246
3247 ;;; Quick version of ftan that requires the argument to be within
3248 ;;; range 2^63.
3249 (define-vop (ftan-quick)
3250   (:translate %tan-quick)
3251   (:args (x :scs (long-reg) :target fr0))
3252   (:temporary (:sc long-reg :offset fr0-offset
3253                    :from :argument :to :result) fr0)
3254   (:temporary (:sc long-reg :offset fr1-offset
3255                    :from :argument :to :result) fr1)
3256   (:results (y :scs (long-reg)))
3257   (:arg-types long-float)
3258   (:result-types long-float)
3259   (:policy :fast-safe)
3260   (:note "inline tan function")
3261   (:vop-var vop)
3262   (:save-p :compute-only)
3263   (:generator 5
3264     (note-this-location vop :internal-error)
3265     (case (tn-offset x)
3266        (0
3267         (inst fstp fr1))
3268        (1
3269         (inst fstp fr0))
3270        (t
3271         (inst fstp fr0)
3272         (inst fstp fr0)
3273         (inst fldd (make-random-tn :kind :normal
3274                                    :sc (sc-or-lose 'double-reg)
3275                                    :offset (- (tn-offset x) 2)))))
3276     (inst fptan)
3277     ;; Result is in fr1
3278     (case (tn-offset y)
3279        (0
3280         (inst fxch fr1))
3281        (1)
3282        (t
3283         (inst fxch fr1)
3284         (inst fstd y)))))
3285
3286 ;;; These versions of fsin, fcos, and ftan try to use argument
3287 ;;; reduction but to do this accurately requires greater precision and
3288 ;;; it is hopelessly inaccurate.
3289 #+nil
3290 (macrolet ((frob (func trans op)
3291              `(define-vop (,func)
3292                 (:translate ,trans)
3293                 (:args (x :scs (long-reg) :target fr0))
3294                 (:temporary (:sc unsigned-reg :offset eax-offset
3295                                  :from :eval :to :result) eax)
3296                 (:temporary (:sc long-reg :offset fr0-offset
3297                                  :from :argument :to :result) fr0)
3298                 (:temporary (:sc long-reg :offset fr1-offset
3299                                  :from :argument :to :result) fr1)
3300                 (:results (y :scs (long-reg)))
3301                 (:arg-types long-float)
3302                 (:result-types long-float)
3303                 (:policy :fast-safe)
3304                 (:note "inline sin/cos function")
3305                 (:vop-var vop)
3306                 (:save-p :compute-only)
3307                 (:ignore eax)
3308                 (:generator 5
3309                   (note-this-location vop :internal-error)
3310                   (unless (zerop (tn-offset x))
3311                           (inst fxch x)          ; x to top of stack
3312                           (unless (location= x y)
3313                                   (inst fst x))) ; maybe save it
3314                   (inst ,op)
3315                   (inst fnstsw)                  ; status word to ax
3316                   (inst and ah-tn #x04)          ; C2
3317                   (inst jmp :z DONE)
3318                   ;; Else x was out of range so reduce it; ST0 is unchanged.
3319                   (inst fstp fr1)               ; Load 2*PI
3320                   (inst fldpi)
3321                   (inst fadd fr0)
3322                   (inst fxch fr1)
3323                   LOOP
3324                   (inst fprem1)
3325                   (inst fnstsw)         ; status word to ax
3326                   (inst and ah-tn #x04) ; C2
3327                   (inst jmp :nz LOOP)
3328                   (inst ,op)
3329                   DONE
3330                   (unless (zerop (tn-offset y))
3331                           (inst fstd y))))))
3332           (frob fsin  %sin fsin)
3333           (frob fcos  %cos fcos))
3334
3335 #+nil
3336 (define-vop (ftan)
3337   (:translate %tan)
3338   (:args (x :scs (long-reg) :target fr0))
3339   (:temporary (:sc unsigned-reg :offset eax-offset
3340                    :from :argument :to :result) eax)
3341   (:temporary (:sc long-reg :offset fr0-offset
3342                    :from :argument :to :result) fr0)
3343   (:temporary (:sc long-reg :offset fr1-offset
3344                    :from :argument :to :result) fr1)
3345   (:results (y :scs (long-reg)))
3346   (:arg-types long-float)
3347   (:result-types long-float)
3348   (:policy :fast-safe)
3349   (:note "inline tan function")
3350   (:vop-var vop)
3351   (:save-p :compute-only)
3352   (:ignore eax)
3353   (:generator 5
3354     (note-this-location vop :internal-error)
3355     (case (tn-offset x)
3356        (0
3357         (inst fstp fr1))
3358        (1
3359         (inst fstp fr0))
3360        (t
3361         (inst fstp fr0)
3362         (inst fstp fr0)
3363         (inst fldd (make-random-tn :kind :normal
3364                                    :sc (sc-or-lose 'double-reg)
3365                                    :offset (- (tn-offset x) 2)))))
3366     (inst fptan)
3367     (inst fnstsw)                        ; status word to ax
3368     (inst and ah-tn #x04)                ; C2
3369     (inst jmp :z DONE)
3370     ;; Else x was out of range so reduce it; ST0 is unchanged.
3371     (inst fldpi)                         ; Load 2*PI
3372     (inst fadd fr0)
3373     (inst fxch fr1)
3374     LOOP
3375     (inst fprem1)
3376     (inst fnstsw)                        ; status word to ax
3377     (inst and ah-tn #x04)                ; C2
3378     (inst jmp :nz LOOP)
3379     (inst fstp fr1)
3380     (inst fptan)
3381     DONE
3382     ;; Result is in fr1
3383     (case (tn-offset y)
3384        (0
3385         (inst fxch fr1))
3386        (1)
3387        (t
3388         (inst fxch fr1)
3389         (inst fstd y)))))
3390
3391 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
3392 ;;; the argument is out of range 2^63 and would thus be hopelessly
3393 ;;; inaccurate.
3394 (macrolet ((frob (func trans op)
3395              `(define-vop (,func)
3396                 (:translate ,trans)
3397                 (:args (x :scs (long-reg) :target fr0))
3398                 (:temporary (:sc long-reg :offset fr0-offset
3399                                  :from :argument :to :result) fr0)
3400                 (:temporary (:sc unsigned-reg :offset eax-offset
3401                              :from :argument :to :result) eax)
3402                 (:results (y :scs (long-reg)))
3403                 (:arg-types long-float)
3404                 (:result-types long-float)
3405                 (:policy :fast-safe)
3406                 (:note "inline sin/cos function")
3407                 (:vop-var vop)
3408                 (:save-p :compute-only)
3409                 (:ignore eax)
3410                 (:generator 5
3411                   (note-this-location vop :internal-error)
3412                   (unless (zerop (tn-offset x))
3413                           (inst fxch x)          ; x to top of stack
3414                           (unless (location= x y)
3415                                   (inst fst x))) ; maybe save it
3416                   (inst ,op)
3417                   (inst fnstsw)                  ; status word to ax
3418                   (inst and ah-tn #x04)          ; C2
3419                   (inst jmp :z DONE)
3420                   ;; Else x was out of range so reduce it; ST0 is unchanged.
3421                   (inst fstp fr0)               ; Load 0.0
3422                   (inst fldz)
3423                   DONE
3424                   (unless (zerop (tn-offset y))
3425                           (inst fstd y))))))
3426           (frob fsin  %sin fsin)
3427           (frob fcos  %cos fcos))
3428
3429 (define-vop (ftan)
3430   (:translate %tan)
3431   (:args (x :scs (long-reg) :target fr0))
3432   (:temporary (:sc long-reg :offset fr0-offset
3433                    :from :argument :to :result) fr0)
3434   (:temporary (:sc long-reg :offset fr1-offset
3435                    :from :argument :to :result) fr1)
3436   (:temporary (:sc unsigned-reg :offset eax-offset
3437                    :from :argument :to :result) eax)
3438   (:results (y :scs (long-reg)))
3439   (:arg-types long-float)
3440   (:result-types long-float)
3441   (:ignore eax)
3442   (:policy :fast-safe)
3443   (:note "inline tan function")
3444   (:vop-var vop)
3445   (:save-p :compute-only)
3446   (:ignore eax)
3447   (:generator 5
3448     (note-this-location vop :internal-error)
3449     (case (tn-offset x)
3450        (0
3451         (inst fstp fr1))
3452        (1
3453         (inst fstp fr0))
3454        (t
3455         (inst fstp fr0)
3456         (inst fstp fr0)
3457         (inst fldd (make-random-tn :kind :normal
3458                                    :sc (sc-or-lose 'double-reg)
3459                                    :offset (- (tn-offset x) 2)))))
3460     (inst fptan)
3461     (inst fnstsw)                        ; status word to ax
3462     (inst and ah-tn #x04)                ; C2
3463     (inst jmp :z DONE)
3464     ;; Else x was out of range so reduce it; ST0 is unchanged.
3465     (inst fldz)                  ; Load 0.0
3466     (inst fxch fr1)
3467     DONE
3468     ;; Result is in fr1
3469     (case (tn-offset y)
3470        (0
3471         (inst fxch fr1))
3472        (1)
3473        (t
3474         (inst fxch fr1)
3475         (inst fstd y)))))
3476
3477 ;;; Modified exp that handles the following special cases:
3478 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
3479 (define-vop (fexp)
3480   (:translate %exp)
3481   (:args (x :scs (long-reg) :target fr0))
3482   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3483   (:temporary (:sc long-reg :offset fr0-offset
3484                    :from :argument :to :result) fr0)
3485   (:temporary (:sc long-reg :offset fr1-offset
3486                    :from :argument :to :result) fr1)
3487   (:temporary (:sc long-reg :offset fr2-offset
3488                    :from :argument :to :result) fr2)
3489   (:results (y :scs (long-reg)))
3490   (:arg-types long-float)
3491   (:result-types long-float)
3492   (:policy :fast-safe)
3493   (:note "inline exp function")
3494   (:vop-var vop)
3495   (:save-p :compute-only)
3496   (:ignore temp)
3497   (:generator 5
3498      (note-this-location vop :internal-error)
3499      (unless (zerop (tn-offset x))
3500              (inst fxch x)              ; x to top of stack
3501              (unless (location= x y)
3502                      (inst fst x)))     ; maybe save it
3503      ;; Check for Inf or NaN
3504      (inst fxam)
3505      (inst fnstsw)
3506      (inst sahf)
3507      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3508      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3509      (inst and ah-tn #x02)            ; Test sign of Inf.
3510      (inst jmp :z DONE)          ; +Inf gives +Inf.
3511      (inst fstp fr0)                ; -Inf gives 0
3512      (inst fldz)
3513      (inst jmp-short DONE)
3514      NOINFNAN
3515      (inst fstp fr1)
3516      (inst fldl2e)
3517      (inst fmul fr1)
3518      ;; Now fr0=x log2(e)
3519      (inst fst fr1)
3520      (inst frndint)
3521      (inst fst fr2)
3522      (inst fsubp-sti fr1)
3523      (inst f2xm1)
3524      (inst fld1)
3525      (inst faddp-sti fr1)
3526      (inst fscale)
3527      (inst fld fr0)
3528      DONE
3529      (unless (zerop (tn-offset y))
3530              (inst fstd y))))
3531
3532 ;;; Expm1 = exp(x) - 1.
3533 ;;; Handles the following special cases:
3534 ;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
3535 (define-vop (fexpm1)
3536   (:translate %expm1)
3537   (:args (x :scs (long-reg) :target fr0))
3538   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
3539   (:temporary (:sc long-reg :offset fr0-offset
3540                    :from :argument :to :result) fr0)
3541   (:temporary (:sc long-reg :offset fr1-offset
3542                    :from :argument :to :result) fr1)
3543   (:temporary (:sc long-reg :offset fr2-offset
3544                    :from :argument :to :result) fr2)
3545   (:results (y :scs (long-reg)))
3546   (:arg-types long-float)
3547   (:result-types long-float)
3548   (:policy :fast-safe)
3549   (:note "inline expm1 function")
3550   (:vop-var vop)
3551   (:save-p :compute-only)
3552   (:ignore temp)
3553   (:generator 5
3554      (note-this-location vop :internal-error)
3555      (unless (zerop (tn-offset x))
3556        (inst fxch x)            ; x to top of stack
3557        (unless (location= x y)
3558          (inst fst x))) ; maybe save it
3559      ;; Check for Inf or NaN
3560      (inst fxam)
3561      (inst fnstsw)
3562      (inst sahf)
3563      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
3564      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
3565      (inst and ah-tn #x02)            ; Test sign of Inf.
3566      (inst jmp :z DONE)          ; +Inf gives +Inf.
3567      (inst fstp fr0)                ; -Inf gives -1.0
3568      (inst fld1)
3569      (inst fchs)
3570      (inst jmp-short DONE)
3571      NOINFNAN
3572      ;; Free two stack slots leaving the argument on top.
3573      (inst fstp fr2)
3574      (inst fstp fr0)
3575      (inst fldl2e)
3576      (inst fmul fr1)    ; Now fr0 = x log2(e)
3577      (inst fst fr1)
3578      (inst frndint)
3579      (inst fsub-sti fr1)
3580      (inst fxch fr1)
3581      (inst f2xm1)
3582      (inst fscale)
3583      (inst fxch fr1)
3584      (inst fld1)
3585      (inst fscale)
3586      (inst fstp fr1)
3587      (inst fld1)
3588      (inst fsub fr1)
3589      (inst fsubr fr2)
3590      DONE
3591      (unless (zerop (tn-offset y))
3592        (inst fstd y))))
3593
3594 (define-vop (flog)
3595   (:translate %log)
3596   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3597   (:temporary (:sc long-reg :offset fr0-offset
3598                    :from :argument :to :result) fr0)
3599   (:temporary (:sc long-reg :offset fr1-offset
3600                    :from :argument :to :result) fr1)
3601   (:results (y :scs (long-reg)))
3602   (:arg-types long-float)
3603   (:result-types long-float)
3604   (:policy :fast-safe)
3605   (:note "inline log function")
3606   (:vop-var vop)
3607   (:save-p :compute-only)
3608   (:generator 5
3609      (note-this-location vop :internal-error)
3610      (sc-case x
3611         (long-reg
3612          (case (tn-offset x)
3613             (0
3614              ;; x is in fr0
3615              (inst fstp fr1)
3616              (inst fldln2)
3617              (inst fxch fr1))
3618             (1
3619              ;; x is in fr1
3620              (inst fstp fr0)
3621              (inst fldln2)
3622              (inst fxch fr1))
3623             (t
3624              ;; x is in a FP reg, not fr0 or fr1
3625              (inst fstp fr0)
3626              (inst fstp fr0)
3627              (inst fldln2)
3628              (inst fldd (make-random-tn :kind :normal
3629                                         :sc (sc-or-lose 'double-reg)
3630                                         :offset (1- (tn-offset x))))))
3631          (inst fyl2x))
3632         ((long-stack descriptor-reg)
3633          (inst fstp fr0)
3634          (inst fstp fr0)
3635          (inst fldln2)
3636          (if (sc-is x long-stack)
3637              (inst fldl (ea-for-lf-stack x))
3638              (inst fldl (ea-for-lf-desc x)))
3639          (inst fyl2x)))
3640      (inst fld fr0)
3641      (case (tn-offset y)
3642        ((0 1))
3643        (t (inst fstd y)))))
3644
3645 (define-vop (flog10)
3646   (:translate %log10)
3647   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
3648   (:temporary (:sc long-reg :offset fr0-offset
3649                    :from :argument :to :result) fr0)
3650   (:temporary (:sc long-reg :offset fr1-offset
3651                    :from :argument :to :result) fr1)
3652   (:results (y :scs (long-reg)))
3653   (:arg-types long-float)
3654   (:result-types long-float)
3655   (:policy :fast-safe)
3656   (:note "inline log10 function")
3657   (:vop-var vop)
3658   (:save-p :compute-only)
3659   (:generator 5
3660      (note-this-location vop :internal-error)
3661      (sc-case x
3662         (long-reg
3663          (case (tn-offset x)
3664             (0
3665              ;; x is in fr0
3666              (inst fstp fr1)
3667              (inst fldlg2)
3668              (inst fxch fr1))
3669             (1
3670              ;; x is in fr1
3671              (inst fstp fr0)
3672              (inst fldlg2)
3673              (inst fxch fr1))
3674             (t
3675              ;; x is in a FP reg, not fr0 or fr1
3676              (inst fstp fr0)
3677              (inst fstp fr0)
3678              (inst fldlg2)
3679              (inst fldd (make-random-tn :kind :normal
3680                                         :sc (sc-or-lose 'double-reg)
3681                                         :offset (1- (tn-offset x))))))
3682          (inst fyl2x))
3683         ((long-stack descriptor-reg)
3684          (inst fstp fr0)
3685          (inst fstp fr0)
3686          (inst fldlg2)
3687          (if (sc-is x long-stack)
3688              (inst fldl (ea-for-lf-stack x))
3689              (inst fldl (ea-for-lf-desc x)))
3690          (inst fyl2x)))
3691      (inst fld fr0)
3692      (case (tn-offset y)
3693        ((0 1))
3694        (t (inst fstd y)))))
3695
3696 (define-vop (fpow)
3697   (:translate %pow)
3698   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3699          (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3700   (:temporary (:sc long-reg :offset fr0-offset
3701                    :from (:argument 0) :to :result) fr0)
3702   (:temporary (:sc long-reg :offset fr1-offset
3703                    :from (:argument 1) :to :result) fr1)
3704   (:temporary (:sc long-reg :offset fr2-offset
3705                    :from :load :to :result) fr2)
3706   (:results (r :scs (long-reg)))
3707   (:arg-types long-float long-float)
3708   (:result-types long-float)
3709   (:policy :fast-safe)
3710   (:note "inline pow function")
3711   (:vop-var vop)
3712   (:save-p :compute-only)
3713   (:generator 5
3714      (note-this-location vop :internal-error)
3715      ;; Setup x in fr0 and y in fr1
3716      (cond
3717       ;; x in fr0; y in fr1
3718       ((and (sc-is x long-reg) (zerop (tn-offset x))
3719             (sc-is y long-reg) (= 1 (tn-offset y))))
3720       ;; y in fr1; x not in fr0
3721       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3722        ;; Load x to fr0
3723        (sc-case x
3724           (long-reg
3725            (copy-fp-reg-to-fr0 x))
3726           (long-stack
3727            (inst fstp fr0)
3728            (inst fldl (ea-for-lf-stack x)))
3729           (descriptor-reg
3730            (inst fstp fr0)
3731            (inst fldl (ea-for-lf-desc x)))))
3732       ;; x in fr0; y not in fr1
3733       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3734        (inst fxch fr1)
3735        ;; Now load y to fr0
3736        (sc-case y
3737           (long-reg
3738            (copy-fp-reg-to-fr0 y))
3739           (long-stack
3740            (inst fstp fr0)
3741            (inst fldl (ea-for-lf-stack y)))
3742           (descriptor-reg
3743            (inst fstp fr0)
3744            (inst fldl (ea-for-lf-desc y))))
3745        (inst fxch fr1))
3746       ;; x in fr1; y not in fr1
3747       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3748        ;; Load y to fr0
3749        (sc-case y
3750           (long-reg
3751            (copy-fp-reg-to-fr0 y))
3752           (long-stack
3753            (inst fstp fr0)
3754            (inst fldl (ea-for-lf-stack y)))
3755           (descriptor-reg
3756            (inst fstp fr0)
3757            (inst fldl (ea-for-lf-desc y))))
3758        (inst fxch fr1))
3759       ;; y in fr0;
3760       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3761        (inst fxch fr1)
3762        ;; Now load x to fr0
3763        (sc-case x
3764           (long-reg
3765            (copy-fp-reg-to-fr0 x))
3766           (long-stack
3767            (inst fstp fr0)
3768            (inst fldl (ea-for-lf-stack x)))
3769           (descriptor-reg
3770            (inst fstp fr0)
3771            (inst fldl (ea-for-lf-desc x)))))
3772       ;; Neither x or y are in either fr0 or fr1
3773       (t
3774        ;; Load y then x
3775        (inst fstp fr0)
3776        (inst fstp fr0)
3777        (sc-case y
3778           (long-reg
3779            (inst fldd (make-random-tn :kind :normal
3780                                       :sc (sc-or-lose 'double-reg)
3781                                       :offset (- (tn-offset y) 2))))
3782           (long-stack
3783            (inst fldl (ea-for-lf-stack y)))
3784           (descriptor-reg
3785            (inst fldl (ea-for-lf-desc y))))
3786        ;; Load x to fr0
3787        (sc-case x
3788           (long-reg
3789            (inst fldd (make-random-tn :kind :normal
3790                                       :sc (sc-or-lose 'double-reg)
3791                                       :offset (1- (tn-offset x)))))
3792           (long-stack
3793            (inst fldl (ea-for-lf-stack x)))
3794           (descriptor-reg
3795            (inst fldl (ea-for-lf-desc x))))))
3796
3797      ;; Now have x at fr0; and y at fr1
3798      (inst fyl2x)
3799      ;; Now fr0=y log2(x)
3800      (inst fld fr0)
3801      (inst frndint)
3802      (inst fst fr2)
3803      (inst fsubp-sti fr1)
3804      (inst f2xm1)
3805      (inst fld1)
3806      (inst faddp-sti fr1)
3807      (inst fscale)
3808      (inst fld fr0)
3809      (case (tn-offset r)
3810        ((0 1))
3811        (t (inst fstd r)))))
3812
3813 (define-vop (fscalen)
3814   (:translate %scalbn)
3815   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3816          (y :scs (signed-stack signed-reg) :target temp))
3817   (:temporary (:sc long-reg :offset fr0-offset
3818                    :from (:argument 0) :to :result) fr0)
3819   (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
3820   (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
3821   (:results (r :scs (long-reg)))
3822   (:arg-types long-float signed-num)
3823   (:result-types long-float)
3824   (:policy :fast-safe)
3825   (:note "inline scalbn function")
3826   (:generator 5
3827      ;; Setup x in fr0 and y in fr1
3828      (sc-case x
3829        (long-reg
3830         (case (tn-offset x)
3831           (0
3832            (inst fstp fr1)
3833            (sc-case y
3834              (signed-reg
3835               (inst mov temp y)
3836               (inst fild temp))
3837              (signed-stack
3838               (inst fild y)))
3839            (inst fxch fr1))
3840           (1
3841            (inst fstp fr0)
3842            (sc-case y
3843              (signed-reg
3844               (inst mov temp y)
3845               (inst fild temp))
3846              (signed-stack
3847               (inst fild y)))
3848            (inst fxch fr1))
3849           (t
3850            (inst fstp fr0)
3851            (inst fstp fr0)
3852            (sc-case y
3853              (signed-reg
3854               (inst mov temp y)
3855               (inst fild temp))
3856              (signed-stack
3857               (inst fild y)))
3858            (inst fld (make-random-tn :kind :normal
3859                                      :sc (sc-or-lose 'double-reg)
3860                                      :offset (1- (tn-offset x)))))))
3861        ((long-stack descriptor-reg)
3862         (inst fstp fr0)
3863         (inst fstp fr0)
3864         (sc-case y
3865           (signed-reg
3866            (inst mov temp y)
3867            (inst fild temp))
3868           (signed-stack
3869            (inst fild y)))
3870         (if (sc-is x long-stack)
3871             (inst fldl (ea-for-lf-stack x))
3872             (inst fldl (ea-for-lf-desc x)))))
3873      (inst fscale)
3874      (unless (zerop (tn-offset r))
3875        (inst fstd r))))
3876
3877 (define-vop (fscale)
3878   (:translate %scalb)
3879   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
3880          (y :scs (long-reg long-stack descriptor-reg) :target fr1))
3881   (:temporary (:sc long-reg :offset fr0-offset
3882                    :from (:argument 0) :to :result) fr0)
3883   (:temporary (:sc long-reg :offset fr1-offset
3884                    :from (:argument 1) :to :result) fr1)
3885   (:results (r :scs (long-reg)))
3886   (:arg-types long-float long-float)
3887   (:result-types long-float)
3888   (:policy :fast-safe)
3889   (:note "inline scalb function")
3890   (:vop-var vop)
3891   (:save-p :compute-only)
3892   (:generator 5
3893      (note-this-location vop :internal-error)
3894      ;; Setup x in fr0 and y in fr1
3895      (cond
3896       ;; x in fr0; y in fr1
3897       ((and (sc-is x long-reg) (zerop (tn-offset x))
3898             (sc-is y long-reg) (= 1 (tn-offset y))))
3899       ;; y in fr1; x not in fr0
3900       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
3901        ;; Load x to fr0
3902        (sc-case x
3903           (long-reg
3904            (copy-fp-reg-to-fr0 x))
3905           (long-stack
3906            (inst fstp fr0)
3907            (inst fldl (ea-for-lf-stack x)))
3908           (descriptor-reg
3909            (inst fstp fr0)
3910            (inst fldl (ea-for-lf-desc x)))))
3911       ;; x in fr0; y not in fr1
3912       ((and (sc-is x long-reg) (zerop (tn-offset x)))
3913        (inst fxch fr1)
3914        ;; Now load y to fr0
3915        (sc-case y
3916           (long-reg
3917            (copy-fp-reg-to-fr0 y))
3918           (long-stack
3919            (inst fstp fr0)
3920            (inst fldl (ea-for-lf-stack y)))
3921           (descriptor-reg
3922            (inst fstp fr0)
3923            (inst fldl (ea-for-lf-desc y))))
3924        (inst fxch fr1))
3925       ;; x in fr1; y not in fr1
3926       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
3927        ;; Load y to fr0
3928        (sc-case y
3929           (long-reg
3930            (copy-fp-reg-to-fr0 y))
3931           (long-stack
3932            (inst fstp fr0)
3933            (inst fldl (ea-for-lf-stack y)))
3934           (descriptor-reg
3935            (inst fstp fr0)
3936            (inst fldl (ea-for-lf-desc y))))
3937        (inst fxch fr1))
3938       ;; y in fr0;
3939       ((and (sc-is y long-reg) (zerop (tn-offset y)))
3940        (inst fxch fr1)
3941        ;; Now load x to fr0
3942        (sc-case x
3943           (long-reg
3944            (copy-fp-reg-to-fr0 x))
3945           (long-stack
3946            (inst fstp fr0)
3947            (inst fldl (ea-for-lf-stack x)))
3948           (descriptor-reg
3949            (inst fstp fr0)
3950            (inst fldl (ea-for-lf-desc x)))))
3951       ;; Neither x or y are in either fr0 or fr1
3952       (t
3953        ;; Load y then x
3954        (inst fstp fr0)
3955        (inst fstp fr0)
3956        (sc-case y
3957           (long-reg
3958            (inst fldd (make-random-tn :kind :normal
3959                                       :sc (sc-or-lose 'double-reg)
3960                                       :offset (- (tn-offset y) 2))))
3961           (long-stack
3962            (inst fldl (ea-for-lf-stack y)))
3963           (descriptor-reg
3964            (inst fldl (ea-for-lf-desc y))))
3965        ;; Load x to fr0
3966        (sc-case x
3967           (long-reg
3968            (inst fldd (make-random-tn :kind :normal
3969                                       :sc (sc-or-lose 'double-reg)
3970                                       :offset (1- (tn-offset x)))))
3971           (long-stack
3972            (inst fldl (ea-for-lf-stack x)))
3973           (descriptor-reg
3974            (inst fldl (ea-for-lf-desc x))))))
3975
3976      ;; Now have x at fr0; and y at fr1
3977      (inst fscale)
3978      (unless (zerop (tn-offset r))
3979              (inst fstd r))))
3980
3981 (define-vop (flog1p)
3982   (:translate %log1p)
3983   (:args (x :scs (long-reg) :to :result))
3984   (:temporary (:sc long-reg :offset fr0-offset
3985                    :from :argument :to :result) fr0)
3986   (:temporary (:sc long-reg :offset fr1-offset
3987                    :from :argument :to :result) fr1)
3988   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
3989   (:results (y :scs (long-reg)))
3990   (:arg-types long-float)
3991   (:result-types long-float)
3992   (:policy :fast-safe)
3993   ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
3994   ;;   Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
3995   ;;   an enormous PROGN above. Still, it would be probably be good to
3996   ;;   add some code to warn about redefining VOPs.
3997   (:note "inline log1p function")
3998   (:ignore temp)
3999   (:generator 5
4000      ;; x is in a FP reg, not fr0, fr1.
4001      (inst fstp fr0)
4002      (inst fstp fr0)
4003      (inst fldd (make-random-tn :kind :normal
4004                                 :sc (sc-or-lose 'double-reg)
4005                                 :offset (- (tn-offset x) 2)))
4006      ;; Check the range
4007      (inst push #x3e947ae1)     ; Constant 0.29
4008      (inst fabs)
4009      (inst fld (make-ea :dword :base esp-tn))
4010      (inst fcompp)
4011      (inst add esp-tn 4)
4012      (inst fnstsw)                      ; status word to ax
4013      (inst and ah-tn #x45)
4014      (inst jmp :z WITHIN-RANGE)
4015      ;; Out of range for fyl2xp1.
4016      (inst fld1)
4017      (inst faddd (make-random-tn :kind :normal
4018                                  :sc (sc-or-lose 'double-reg)
4019                                  :offset (- (tn-offset x) 1)))
4020      (inst fldln2)
4021      (inst fxch fr1)
4022      (inst fyl2x)
4023      (inst jmp DONE)
4024
4025      WITHIN-RANGE
4026      (inst fldln2)
4027      (inst fldd (make-random-tn :kind :normal
4028                                 :sc (sc-or-lose 'double-reg)
4029                                 :offset (- (tn-offset x) 1)))
4030      (inst fyl2xp1)
4031      DONE
4032      (inst fld fr0)
4033      (case (tn-offset y)
4034        ((0 1))
4035        (t (inst fstd y)))))
4036
4037 ;;; The Pentium has a less restricted implementation of the fyl2xp1
4038 ;;; instruction and a range check can be avoided.
4039 (define-vop (flog1p-pentium)
4040   (:translate %log1p)
4041   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4042   (:temporary (:sc long-reg :offset fr0-offset
4043                    :from :argument :to :result) fr0)
4044   (:temporary (:sc long-reg :offset fr1-offset
4045                    :from :argument :to :result) fr1)
4046   (:results (y :scs (long-reg)))
4047   (:arg-types long-float)
4048   (:result-types long-float)
4049   (:policy :fast-safe)
4050   (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
4051   (:note "inline log1p function")
4052   (:generator 5
4053      (sc-case x
4054         (long-reg
4055          (case (tn-offset x)
4056             (0
4057              ;; x is in fr0
4058              (inst fstp fr1)
4059              (inst fldln2)
4060              (inst fxch fr1))
4061             (1
4062              ;; x is in fr1
4063              (inst fstp fr0)
4064              (inst fldln2)
4065              (inst fxch fr1))
4066             (t
4067              ;; x is in a FP reg, not fr0 or fr1
4068              (inst fstp fr0)
4069              (inst fstp fr0)
4070              (inst fldln2)
4071              (inst fldd (make-random-tn :kind :normal
4072                                         :sc (sc-or-lose 'double-reg)
4073                                         :offset (1- (tn-offset x)))))))
4074         ((long-stack descriptor-reg)
4075          (inst fstp fr0)
4076          (inst fstp fr0)
4077          (inst fldln2)
4078          (if (sc-is x long-stack)
4079              (inst fldl (ea-for-lf-stack x))
4080            (inst fldl (ea-for-lf-desc x)))))
4081      (inst fyl2xp1)
4082      (inst fld fr0)
4083      (case (tn-offset y)
4084        ((0 1))
4085        (t (inst fstd y)))))
4086
4087 (define-vop (flogb)
4088   (:translate %logb)
4089   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4090   (:temporary (:sc long-reg :offset fr0-offset
4091                    :from :argument :to :result) fr0)
4092   (:temporary (:sc long-reg :offset fr1-offset
4093                    :from :argument :to :result) fr1)
4094   (:results (y :scs (long-reg)))
4095   (:arg-types long-float)
4096   (:result-types long-float)
4097   (:policy :fast-safe)
4098   (:note "inline logb function")
4099   (:vop-var vop)
4100   (:save-p :compute-only)
4101   (:generator 5
4102      (note-this-location vop :internal-error)
4103      (sc-case x
4104         (long-reg
4105          (case (tn-offset x)
4106             (0
4107              ;; x is in fr0
4108              (inst fstp fr1))
4109             (1
4110              ;; x is in fr1
4111              (inst fstp fr0))
4112             (t
4113              ;; x is in a FP reg, not fr0 or fr1
4114              (inst fstp fr0)
4115              (inst fstp fr0)
4116              (inst fldd (make-random-tn :kind :normal
4117                                         :sc (sc-or-lose 'double-reg)
4118                                         :offset (- (tn-offset x) 2))))))
4119         ((long-stack descriptor-reg)
4120          (inst fstp fr0)
4121          (inst fstp fr0)
4122          (if (sc-is x long-stack)
4123              (inst fldl (ea-for-lf-stack x))
4124            (inst fldl (ea-for-lf-desc x)))))
4125      (inst fxtract)
4126      (case (tn-offset y)
4127        (0
4128         (inst fxch fr1))
4129        (1)
4130        (t (inst fxch fr1)
4131           (inst fstd y)))))
4132
4133 (define-vop (fatan)
4134   (:translate %atan)
4135   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
4136   (:temporary (:sc long-reg :offset fr0-offset
4137                    :from (:argument 0) :to :result) fr0)
4138   (:temporary (:sc long-reg :offset fr1-offset
4139                    :from (:argument 0) :to :result) fr1)
4140   (:results (r :scs (long-reg)))
4141   (:arg-types long-float)
4142   (:result-types long-float)
4143   (:policy :fast-safe)
4144   (:note "inline atan function")
4145   (:vop-var vop)
4146   (:save-p :compute-only)
4147   (:generator 5
4148      (note-this-location vop :internal-error)
4149      ;; Setup x in fr1 and 1.0 in fr0
4150      (cond
4151       ;; x in fr0
4152       ((and (sc-is x long-reg) (zerop (tn-offset x)))
4153        (inst fstp fr1))
4154       ;; x in fr1
4155       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4156        (inst fstp fr0))
4157       ;; x not in fr0 or fr1
4158       (t
4159        ;; Load x then 1.0
4160        (inst fstp fr0)
4161        (inst fstp fr0)
4162        (sc-case x
4163           (long-reg
4164            (inst fldd (make-random-tn :kind :normal
4165                                       :sc (sc-or-lose 'double-reg)
4166                                       :offset (- (tn-offset x) 2))))
4167           (long-stack
4168            (inst fldl (ea-for-lf-stack x)))
4169           (descriptor-reg
4170            (inst fldl (ea-for-lf-desc x))))))
4171      (inst fld1)
4172      ;; Now have x at fr1; and 1.0 at fr0
4173      (inst fpatan)
4174      (inst fld fr0)
4175      (case (tn-offset r)
4176        ((0 1))
4177        (t (inst fstd r)))))
4178
4179 (define-vop (fatan2)
4180   (:translate %atan2)
4181   (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
4182          (y :scs (long-reg long-stack descriptor-reg) :target fr0))
4183   (:temporary (:sc long-reg :offset fr0-offset
4184                    :from (:argument 1) :to :result) fr0)
4185   (:temporary (:sc long-reg :offset fr1-offset
4186                    :from (:argument 0) :to :result) fr1)
4187   (:results (r :scs (long-reg)))
4188   (:arg-types long-float long-float)
4189   (:result-types long-float)
4190   (:policy :fast-safe)
4191   (:note "inline atan2 function")
4192   (:vop-var vop)
4193   (:save-p :compute-only)
4194   (:generator 5
4195      (note-this-location vop :internal-error)
4196      ;; Setup x in fr1 and y in fr0
4197      (cond
4198       ;; y in fr0; x in fr1
4199       ((and (sc-is y long-reg) (zerop (tn-offset y))
4200             (sc-is x long-reg) (= 1 (tn-offset x))))
4201       ;; x in fr1; y not in fr0
4202       ((and (sc-is x long-reg) (= 1 (tn-offset x)))
4203        ;; Load y to fr0
4204        (sc-case y
4205           (long-reg
4206            (copy-fp-reg-to-fr0 y))
4207           (long-stack
4208            (inst fstp fr0)
4209            (inst fldl (ea-for-lf-stack y)))
4210           (descriptor-reg
4211            (inst fstp fr0)
4212            (inst fldl (ea-for-lf-desc y)))))
4213       ;; y in fr0; x not in fr1
4214       ((and (sc-is y long-reg) (zerop (tn-offset y)))
4215        (inst fxch fr1)
4216        ;; Now load x to fr0
4217        (sc-case x
4218           (long-reg
4219            (copy-fp-reg-to-fr0 x))
4220           (long-stack
4221            (inst fstp fr0)
4222            (inst fldl (ea-for-lf-stack x)))
4223           (descriptor-reg
4224            (inst fstp fr0)
4225            (inst fldl (ea-for-lf-desc x))))
4226        (inst fxch fr1))
4227       ;; y in fr1; x not in fr1
4228       ((and (sc-is y long-reg) (= 1 (tn-offset y)))
4229        ;; Load x to fr0
4230        (sc-case x
4231           (long-reg
4232            (copy-fp-reg-to-fr0 x))
4233           (long-stack
4234            (inst fstp fr0)
4235            (inst fldl (ea-for-lf-stack x)))
4236           (descriptor-reg
4237            (inst fstp fr0)
4238            (inst fldl (ea-for-lf-desc x))))
4239        (inst fxch fr1))
4240       ;; x in fr0;
4241       ((and (sc-is x long-reg) (zerop (tn-offset x)))
4242        (inst fxch fr1)
4243        ;; Now load y to fr0
4244        (sc-case y
4245           (long-reg
4246            (copy-fp-reg-to-fr0 y))
4247           (long-stack
4248            (inst fstp fr0)
4249            (inst fldl (ea-for-lf-stack y)))
4250           (descriptor-reg
4251            (inst fstp fr0)
4252            (inst fldl (ea-for-lf-desc y)))))
4253       ;; Neither y or x are in either fr0 or fr1
4254       (t
4255        ;; Load x then y
4256        (inst fstp fr0)
4257        (inst fstp fr0)
4258        (sc-case x
4259           (long-reg
4260            (inst fldd (make-random-tn :kind :normal
4261                                       :sc (sc-or-lose 'double-reg)
4262                                       :offset (- (tn-offset x) 2))))
4263           (long-stack
4264            (inst fldl (ea-for-lf-stack x)))
4265           (descriptor-reg
4266            (inst fldl (ea-for-lf-desc x))))
4267        ;; Load y to fr0
4268        (sc-case y
4269           (long-reg
4270            (inst fldd (make-random-tn :kind :normal
4271                                       :sc (sc-or-lose 'double-reg)
4272                                       :offset (1- (tn-offset y)))))
4273           (long-stack
4274            (inst fldl (ea-for-lf-stack y)))
4275           (descriptor-reg
4276            (inst fldl (ea-for-lf-desc y))))))
4277
4278      ;; Now have y at fr0; and x at fr1
4279      (inst fpatan)
4280      (inst fld fr0)
4281      (case (tn-offset r)
4282        ((0 1))
4283        (t (inst fstd r)))))
4284
4285 ) ; PROGN #!+LONG-FLOAT
4286 \f
4287 ;;;; complex float VOPs
4288
4289 (define-vop (make-complex-single-float)
4290   (:translate complex)
4291   (:args (real :scs (single-reg) :to :result :target r
4292                :load-if (not (location= real r)))
4293          (imag :scs (single-reg) :to :save))
4294   (:arg-types single-float single-float)
4295   (:results (r :scs (complex-single-reg) :from (:argument 0)
4296                :load-if (not (sc-is r complex-single-stack))))
4297   (:result-types complex-single-float)
4298   (:note "inline complex single-float creation")
4299   (:policy :fast-safe)
4300   (:generator 5
4301     (sc-case r
4302       (complex-single-reg
4303        (let ((r-real (complex-double-reg-real-tn r)))
4304          (unless (location= real r-real)
4305            (cond ((zerop (tn-offset r-real))
4306                   (copy-fp-reg-to-fr0 real))
4307                  ((zerop (tn-offset real))
4308                   (inst fstd r-real))
4309                  (t
4310                   (inst fxch real)
4311                   (inst fstd r-real)
4312                   (inst fxch real)))))
4313        (let ((r-imag (complex-double-reg-imag-tn r)))
4314          (unless (location= imag r-imag)
4315            (cond ((zerop (tn-offset imag))
4316                   (inst fstd r-imag))
4317                  (t
4318                   (inst fxch imag)
4319                   (inst fstd r-imag)
4320                   (inst fxch imag))))))
4321       (complex-single-stack
4322        (unless (location= real r)
4323          (cond ((zerop (tn-offset real))
4324                 (inst fst (ea-for-csf-real-stack r)))
4325                (t
4326                 (inst fxch real)
4327                 (inst fst (ea-for-csf-real-stack r))
4328                 (inst fxch real))))
4329        (inst fxch imag)
4330        (inst fst (ea-for-csf-imag-stack r))
4331        (inst fxch imag)))))
4332
4333 (define-vop (make-complex-double-float)
4334   (:translate complex)
4335   (:args (real :scs (double-reg) :target r
4336                :load-if (not (location= real r)))
4337          (imag :scs (double-reg) :to :save))
4338   (:arg-types double-float double-float)
4339   (:results (r :scs (complex-double-reg) :from (:argument 0)
4340                :load-if (not (sc-is r complex-double-stack))))
4341   (:result-types complex-double-float)
4342   (:note "inline complex double-float creation")
4343   (:policy :fast-safe)
4344   (:generator 5
4345     (sc-case r
4346       (complex-double-reg
4347        (let ((r-real (complex-double-reg-real-tn r)))
4348          (unless (location= real r-real)
4349            (cond ((zerop (tn-offset r-real))
4350                   (copy-fp-reg-to-fr0 real))
4351                  ((zerop (tn-offset real))
4352                   (inst fstd r-real))
4353                  (t
4354                   (inst fxch real)
4355                   (inst fstd r-real)
4356                   (inst fxch real)))))
4357        (let ((r-imag (complex-double-reg-imag-tn r)))
4358          (unless (location= imag r-imag)
4359            (cond ((zerop (tn-offset imag))
4360                   (inst fstd r-imag))
4361                  (t
4362                   (inst fxch imag)
4363                   (inst fstd r-imag)
4364                   (inst fxch imag))))))
4365       (complex-double-stack
4366        (unless (location= real r)
4367          (cond ((zerop (tn-offset real))
4368                 (inst fstd (ea-for-cdf-real-stack r)))
4369                (t
4370                 (inst fxch real)
4371                 (inst fstd (ea-for-cdf-real-stack r))
4372                 (inst fxch real))))
4373        (inst fxch imag)
4374        (inst fstd (ea-for-cdf-imag-stack r))
4375        (inst fxch imag)))))
4376
4377 #!+long-float
4378 (define-vop (make-complex-long-float)
4379   (:translate complex)
4380   (:args (real :scs (long-reg) :target r
4381                :load-if (not (location= real r)))
4382          (imag :scs (long-reg) :to :save))
4383   (:arg-types long-float long-float)
4384   (:results (r :scs (complex-long-reg) :from (:argument 0)
4385                :load-if (not (sc-is r complex-long-stack))))
4386   (:result-types complex-long-float)
4387   (:note "inline complex long-float creation")
4388   (:policy :fast-safe)
4389   (:generator 5
4390     (sc-case r
4391       (complex-long-reg
4392        (let ((r-real (complex-double-reg-real-tn r)))
4393          (unless (location= real r-real)
4394            (cond ((zerop (tn-offset r-real))
4395                   (copy-fp-reg-to-fr0 real))
4396                  ((zerop (tn-offset real))
4397                   (inst fstd r-real))
4398                  (t
4399                   (inst fxch real)
4400                   (inst fstd r-real)
4401                   (inst fxch real)))))
4402        (let ((r-imag (complex-double-reg-imag-tn r)))
4403          (unless (location= imag r-imag)
4404            (cond ((zerop (tn-offset imag))
4405                   (inst fstd r-imag))
4406                  (t
4407                   (inst fxch imag)
4408                   (inst fstd r-imag)
4409                   (inst fxch imag))))))
4410       (complex-long-stack
4411        (unless (location= real r)
4412          (cond ((zerop (tn-offset real))
4413                 (store-long-float (ea-for-clf-real-stack r)))
4414                (t
4415                 (inst fxch real)
4416                 (store-long-float (ea-for-clf-real-stack r))
4417                 (inst fxch real))))
4418        (inst fxch imag)
4419        (store-long-float (ea-for-clf-imag-stack r))
4420        (inst fxch imag)))))
4421
4422
4423 (define-vop (complex-float-value)
4424   (:args (x :target r))
4425   (:results (r))
4426   (:variant-vars offset)
4427   (:policy :fast-safe)
4428   (:generator 3
4429     (cond ((sc-is x complex-single-reg complex-double-reg
4430                   #!+long-float complex-long-reg)
4431            (let ((value-tn
4432                   (make-random-tn :kind :normal
4433                                   :sc (sc-or-lose 'double-reg)
4434                                   :offset (+ offset (tn-offset x)))))
4435              (unless (location= value-tn r)
4436                (cond ((zerop (tn-offset r))
4437                       (copy-fp-reg-to-fr0 value-tn))
4438                      ((zerop (tn-offset value-tn))
4439                       (inst fstd r))
4440                      (t
4441                       (inst fxch value-tn)
4442                       (inst fstd r)
4443                       (inst fxch value-tn))))))
4444           ((sc-is r single-reg)
4445            (let ((ea (sc-case x
4446                        (complex-single-stack
4447                         (ecase offset
4448                           (0 (ea-for-csf-real-stack x))
4449                           (1 (ea-for-csf-imag-stack x))))
4450                        (descriptor-reg
4451                         (ecase offset
4452                           (0 (ea-for-csf-real-desc x))
4453                           (1 (ea-for-csf-imag-desc x)))))))
4454              (with-empty-tn@fp-top(r)
4455                (inst fld ea))))
4456           ((sc-is r double-reg)
4457            (let ((ea (sc-case x
4458                        (complex-double-stack
4459                         (ecase offset
4460                           (0 (ea-for-cdf-real-stack x))
4461                           (1 (ea-for-cdf-imag-stack x))))
4462                        (descriptor-reg
4463                         (ecase offset
4464                           (0 (ea-for-cdf-real-desc x))
4465                           (1 (ea-for-cdf-imag-desc x)))))))
4466              (with-empty-tn@fp-top(r)
4467                (inst fldd ea))))
4468           #!+long-float
4469           ((sc-is r long-reg)
4470            (let ((ea (sc-case x
4471                        (complex-long-stack
4472                         (ecase offset
4473                           (0 (ea-for-clf-real-stack x))
4474                           (1 (ea-for-clf-imag-stack x))))
4475                        (descriptor-reg
4476                         (ecase offset
4477                           (0 (ea-for-clf-real-desc x))
4478                           (1 (ea-for-clf-imag-desc x)))))))
4479              (with-empty-tn@fp-top(r)
4480                (inst fldl ea))))
4481           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
4482
4483 (define-vop (realpart/complex-single-float complex-float-value)
4484   (:translate realpart)
4485   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4486             :target r))
4487   (:arg-types complex-single-float)
4488   (:results (r :scs (single-reg)))
4489   (:result-types single-float)
4490   (:note "complex float realpart")
4491   (:variant 0))
4492
4493 (define-vop (realpart/complex-double-float complex-float-value)
4494   (:translate realpart)
4495   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4496             :target r))
4497   (:arg-types complex-double-float)
4498   (:results (r :scs (double-reg)))
4499   (:result-types double-float)
4500   (:note "complex float realpart")
4501   (:variant 0))
4502
4503 #!+long-float
4504 (define-vop (realpart/complex-long-float complex-float-value)
4505   (:translate realpart)
4506   (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4507             :target r))
4508   (:arg-types complex-long-float)
4509   (:results (r :scs (long-reg)))
4510   (:result-types long-float)
4511   (:note "complex float realpart")
4512   (:variant 0))
4513
4514 (define-vop (imagpart/complex-single-float complex-float-value)
4515   (:translate imagpart)
4516   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
4517             :target r))
4518   (:arg-types complex-single-float)
4519   (:results (r :scs (single-reg)))
4520   (:result-types single-float)
4521   (:note "complex float imagpart")
4522   (:variant 1))
4523
4524 (define-vop (imagpart/complex-double-float complex-float-value)
4525   (:translate imagpart)
4526   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
4527             :target r))
4528   (:arg-types complex-double-float)
4529   (:results (r :scs (double-reg)))
4530   (:result-types double-float)
4531   (:note "complex float imagpart")
4532   (:variant 1))
4533
4534 #!+long-float
4535 (define-vop (imagpart/complex-long-float complex-float-value)
4536   (:translate imagpart)
4537   (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
4538             :target r))
4539   (:arg-types complex-long-float)
4540   (:results (r :scs (long-reg)))
4541   (:result-types long-float)
4542   (:note "complex float imagpart")
4543   (:variant 1))
4544 \f
4545 ;;; hack dummy VOPs to bias the representation selection of their
4546 ;;; arguments towards a FP register, which can help avoid consing at
4547 ;;; inappropriate locations
4548 (defknown double-float-reg-bias (double-float) (values))
4549 (define-vop (double-float-reg-bias)
4550   (:translate double-float-reg-bias)
4551   (:args (x :scs (double-reg double-stack) :load-if nil))
4552   (:arg-types double-float)
4553   (:policy :fast-safe)
4554   (:note "inline dummy FP register bias")
4555   (:ignore x)
4556   (:generator 0))
4557 (defknown single-float-reg-bias (single-float) (values))
4558 (define-vop (single-float-reg-bias)
4559   (:translate single-float-reg-bias)
4560   (:args (x :scs (single-reg single-stack) :load-if nil))
4561   (:arg-types single-float)
4562   (:policy :fast-safe)
4563   (:note "inline dummy FP register bias")
4564   (:ignore x)
4565   (:generator 0))