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