src/compiler/x86-64/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                :qword :base ,tn
  17                :disp (- (* ,slot n-word-bytes)
  18                         other-pointer-lowtag))))
  19   (defun ea-for-sf-desc (tn)
  20     (ea-for-xf-desc tn single-float-value-slot))
  21   (defun ea-for-df-desc (tn)
  22     (ea-for-xf-desc tn double-float-value-slot))
  23   ;; complex floats
  24   (defun ea-for-csf-real-desc (tn)
  25     (ea-for-xf-desc tn complex-single-float-real-slot))
  26   (defun ea-for-csf-imag-desc (tn)
  27     (ea-for-xf-desc tn complex-single-float-imag-slot))
  28   (defun ea-for-cdf-real-desc (tn)
  29     (ea-for-xf-desc tn complex-double-float-real-slot))
  30   (defun ea-for-cdf-imag-desc (tn)
  31     (ea-for-xf-desc tn complex-double-float-imag-slot)))
  32
  33 (macrolet ((ea-for-xf-stack (tn kind)
  34              `(make-ea
  35                :qword :base rbp-tn
  36                :disp (- (* (+ (tn-offset ,tn) 1)
  37                            n-word-bytes)))))
  38   (defun ea-for-sf-stack (tn)
  39     (ea-for-xf-stack tn :single))
  40   (defun ea-for-df-stack (tn)
  41     (ea-for-xf-stack tn :double)))
  42
  43 ;;; Telling the FPU to wait is required in order to make signals occur
  44 ;;; at the expected place, but naturally slows things down.
  45 ;;;
  46 ;;; NODE is the node whose compilation policy controls the decision
  47 ;;; whether to just blast through carelessly or carefully emit wait
  48 ;;; instructions and whatnot.
  49 ;;;
  50 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
  51 ;;; #'NOTE-NEXT-INSTRUCTION.
  52 (defun maybe-fp-wait (node &optional note-next-instruction)
  53   (when (policy node (or (= debug 3) (> safety speed))))
  54     (when note-next-instruction
  55       (note-next-instruction note-next-instruction :internal-error))
  56     #+nil
  57     (inst wait))
  58
  59 ;;; complex float stack EAs
  60 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
  61              (declare (ignore kind))
  62              `(make-ea
  63                :qword :base ,base
  64                :disp (- (* (+ (tn-offset ,tn)
  65                               (* 1 (ecase ,slot (:real 1) (:imag 2))))
  66                            n-word-bytes)))))
  67   (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
  68     (ea-for-cxf-stack tn :single :real base))
  69   (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
  70     (ea-for-cxf-stack tn :single :imag base))
  71   (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
  72     (ea-for-cxf-stack tn :double :real base))
  73   (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
  74     (ea-for-cxf-stack tn :double :imag base)))
  75
  76 \f
  77 ;;;; move functions
  78
  79 ;;; X is source, Y is destination.
  80 (define-move-fun (load-single 2) (vop x y)
  81   ((single-stack) (single-reg))
  82   (inst movss y (ea-for-sf-stack x)))
  83
  84 ;;; got this far 20040627
  85
  86 (define-move-fun (store-single 2) (vop x y)
  87   ((single-reg) (single-stack))
  88   (cond ((zerop (tn-offset x))
  89          (inst fst (ea-for-sf-stack y)))
  90         (t
  91          (inst fxch x)
  92          (inst fst (ea-for-sf-stack y))
  93          ;; This may not be necessary as ST0 is likely invalid now.
  94          (inst fxch x))))
  95
  96 (define-move-fun (load-double 2) (vop x y)
  97   ((double-stack) (double-reg))
  98   (with-empty-tn@fp-top(y)
  99      (inst fldd (ea-for-df-stack x))))
 100
 101 (define-move-fun (store-double 2) (vop x y)
 102   ((double-reg) (double-stack))
 103   (cond ((zerop (tn-offset x))
 104          (inst fstd (ea-for-df-stack y)))
 105         (t
 106          (inst fxch x)
 107          (inst fstd (ea-for-df-stack y))
 108          ;; This may not be necessary as ST0 is likely invalid now.
 109          (inst fxch x))))
 110
 111
 112
 113 ;;; The i387 has instructions to load some useful constants. This
 114 ;;; doesn't save much time but might cut down on memory access and
 115 ;;; reduce the size of the constant vector (CV). Intel claims they are
 116 ;;; stored in a more precise form on chip. Anyhow, might as well use
 117 ;;; the feature. It can be turned off by hacking the
 118 ;;; "immediate-constant-sc" in vm.lisp.
 119 (eval-when (:compile-toplevel :execute)
 120   (setf *read-default-float-format* 'double-float))
 121 (define-move-fun (load-fp-constant 2) (vop x y)
 122   ((fp-constant) (single-reg double-reg))
 123   (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
 124     (with-empty-tn@fp-top(y)
 125       (cond ((zerop value)
 126              (inst fldz))
 127             ((= value 1e0)
 128              (inst fld1))
 129             ((= value (coerce pi *read-default-float-format*))
 130              (inst fldpi))
 131             ((= value (log 10e0 2e0))
 132              (inst fldl2t))
 133             ((= value (log 2.718281828459045235360287471352662e0 2e0))
 134              (inst fldl2e))
 135             ((= value (log 2e0 10e0))
 136              (inst fldlg2))
 137             ((= value (log 2e0 2.718281828459045235360287471352662e0))
 138              (inst fldln2))
 139             (t (warn "ignoring bogus i387 constant ~A" value))))))
 140 (eval-when (:compile-toplevel :execute)
 141   (setf *read-default-float-format* 'single-float))
 142 \f
 143 ;;;; complex float move functions
 144
 145 (defun complex-single-reg-real-tn (x)
 146   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 147                   :offset (tn-offset x)))
 148 (defun complex-single-reg-imag-tn (x)
 149   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 150                   :offset (1+ (tn-offset x))))
 151
 152 (defun complex-double-reg-real-tn (x)
 153   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 154                   :offset (tn-offset x)))
 155 (defun complex-double-reg-imag-tn (x)
 156   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 157                   :offset (1+ (tn-offset x))))
 158
 159 ;;; X is source, Y is destination.
 160 (define-move-fun (load-complex-single 2) (vop x y)
 161   ((complex-single-stack) (complex-single-reg))
 162   (let ((real-tn (complex-single-reg-real-tn y)))
 163     (with-empty-tn@fp-top (real-tn)
 164       (inst fld (ea-for-csf-real-stack x))))
 165   (let ((imag-tn (complex-single-reg-imag-tn y)))
 166     (with-empty-tn@fp-top (imag-tn)
 167       (inst fld (ea-for-csf-imag-stack x)))))
 168
 169 (define-move-fun (store-complex-single 2) (vop x y)
 170   ((complex-single-reg) (complex-single-stack))
 171   (let ((real-tn (complex-single-reg-real-tn x)))
 172     (cond ((zerop (tn-offset real-tn))
 173            (inst fst (ea-for-csf-real-stack y)))
 174           (t
 175            (inst fxch real-tn)
 176            (inst fst (ea-for-csf-real-stack y))
 177            (inst fxch real-tn))))
 178   (let ((imag-tn (complex-single-reg-imag-tn x)))
 179     (inst fxch imag-tn)
 180     (inst fst (ea-for-csf-imag-stack y))
 181     (inst fxch imag-tn)))
 182
 183 (define-move-fun (load-complex-double 2) (vop x y)
 184   ((complex-double-stack) (complex-double-reg))
 185   (let ((real-tn (complex-double-reg-real-tn y)))
 186     (with-empty-tn@fp-top(real-tn)
 187       (inst fldd (ea-for-cdf-real-stack x))))
 188   (let ((imag-tn (complex-double-reg-imag-tn y)))
 189     (with-empty-tn@fp-top(imag-tn)
 190       (inst fldd (ea-for-cdf-imag-stack x)))))
 191
 192 (define-move-fun (store-complex-double 2) (vop x y)
 193   ((complex-double-reg) (complex-double-stack))
 194   (let ((real-tn (complex-double-reg-real-tn x)))
 195     (cond ((zerop (tn-offset real-tn))
 196            (inst fstd (ea-for-cdf-real-stack y)))
 197           (t
 198            (inst fxch real-tn)
 199            (inst fstd (ea-for-cdf-real-stack y))
 200            (inst fxch real-tn))))
 201   (let ((imag-tn (complex-double-reg-imag-tn x)))
 202     (inst fxch imag-tn)
 203     (inst fstd (ea-for-cdf-imag-stack y))
 204     (inst fxch imag-tn)))
 205
 206 \f
 207 ;;;; move VOPs
 208
 209 ;;; float register to register moves
 210 (define-vop (float-move)
 211   (:args (x))
 212   (:results (y))
 213   (:note "float move")
 214   (:generator 0
 215      (unless (location= x y)
 216         (cond ((zerop (tn-offset y))
 217                (copy-fp-reg-to-fr0 x))
 218               ((zerop (tn-offset x))
 219                (inst fstd y))
 220               (t
 221                (inst fxch x)
 222                (inst fstd y)
 223                (inst fxch x))))))
 224
 225 (define-vop (single-move float-move)
 226   (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
 227   (:results (y :scs (single-reg) :load-if (not (location= x y)))))
 228 (define-move-vop single-move :move (single-reg) (single-reg))
 229
 230 (define-vop (double-move float-move)
 231   (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
 232   (:results (y :scs (double-reg) :load-if (not (location= x y)))))
 233 (define-move-vop double-move :move (double-reg) (double-reg))
 234
 235 ;;; complex float register to register moves
 236 (define-vop (complex-float-move)
 237   (:args (x :target y :load-if (not (location= x y))))
 238   (:results (y :load-if (not (location= x y))))
 239   (:note "complex float move")
 240   (:generator 0
 241      (unless (location= x y)
 242        ;; Note the complex-float-regs are aligned to every second
 243        ;; float register so there is not need to worry about overlap.
 244        (let ((x-real (complex-double-reg-real-tn x))
 245              (y-real (complex-double-reg-real-tn y)))
 246          (cond ((zerop (tn-offset y-real))
 247                 (copy-fp-reg-to-fr0 x-real))
 248                ((zerop (tn-offset x-real))
 249                 (inst fstd y-real))
 250                (t
 251                 (inst fxch x-real)
 252                 (inst fstd y-real)
 253                 (inst fxch x-real))))
 254        (let ((x-imag (complex-double-reg-imag-tn x))
 255              (y-imag (complex-double-reg-imag-tn y)))
 256          (inst fxch x-imag)
 257          (inst fstd y-imag)
 258          (inst fxch x-imag)))))
 259
 260 (define-vop (complex-single-move complex-float-move)
 261   (:args (x :scs (complex-single-reg) :target y
 262             :load-if (not (location= x y))))
 263   (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
 264 (define-move-vop complex-single-move :move
 265   (complex-single-reg) (complex-single-reg))
 266
 267 (define-vop (complex-double-move complex-float-move)
 268   (:args (x :scs (complex-double-reg)
 269             :target y :load-if (not (location= x y))))
 270   (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
 271 (define-move-vop complex-double-move :move
 272   (complex-double-reg) (complex-double-reg))
 273
 274 \f
 275 ;;; Move from float to a descriptor reg. allocating a new float
 276 ;;; object in the process.
 277 (define-vop (move-from-single)
 278   (:args (x :scs (single-reg) :to :save))
 279   (:results (y :scs (descriptor-reg)))
 280   (:node-var node)
 281   (:note "float to pointer coercion")
 282   (:generator 13
 283      (with-fixed-allocation (y
 284                              single-float-widetag
 285                              single-float-size node)
 286        (with-tn@fp-top(x)
 287          (inst fst (ea-for-sf-desc y))))))
 288 (define-move-vop move-from-single :move
 289   (single-reg) (descriptor-reg))
 290
 291 (define-vop (move-from-double)
 292   (:args (x :scs (double-reg) :to :save))
 293   (:results (y :scs (descriptor-reg)))
 294   (:node-var node)
 295   (:note "float to pointer coercion")
 296   (:generator 13
 297      (with-fixed-allocation (y
 298                              double-float-widetag
 299                              double-float-size
 300                              node)
 301        (with-tn@fp-top(x)
 302          (inst fstd (ea-for-df-desc y))))))
 303 (define-move-vop move-from-double :move
 304   (double-reg) (descriptor-reg))
 305
 306 (define-vop (move-from-fp-constant)
 307   (:args (x :scs (fp-constant)))
 308   (:results (y :scs (descriptor-reg)))
 309   (:generator 2
 310      (ecase (sb!c::constant-value (sb!c::tn-leaf x))
 311        (0f0 (load-symbol-value y *fp-constant-0f0*))
 312        (1f0 (load-symbol-value y *fp-constant-1f0*))
 313        (0d0 (load-symbol-value y *fp-constant-0d0*))
 314        (1d0 (load-symbol-value y *fp-constant-1d0*)))))
 315 (define-move-vop move-from-fp-constant :move
 316   (fp-constant) (descriptor-reg))
 317
 318 ;;; Move from a descriptor to a float register.
 319 (define-vop (move-to-single)
 320   (:args (x :scs (descriptor-reg)))
 321   (:results (y :scs (single-reg)))
 322   (:note "pointer to float coercion")
 323   (:generator 2
 324      (with-empty-tn@fp-top(y)
 325        (inst fld (ea-for-sf-desc x)))))
 326 (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
 327
 328 (define-vop (move-to-double)
 329   (:args (x :scs (descriptor-reg)))
 330   (:results (y :scs (double-reg)))
 331   (:note "pointer to float coercion")
 332   (:generator 2
 333      (with-empty-tn@fp-top(y)
 334        (inst fldd (ea-for-df-desc x)))))
 335 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
 336
 337 \f
 338 ;;; Move from complex float to a descriptor reg. allocating a new
 339 ;;; complex float object in the process.
 340 (define-vop (move-from-complex-single)
 341   (:args (x :scs (complex-single-reg) :to :save))
 342   (:results (y :scs (descriptor-reg)))
 343   (:node-var node)
 344   (:note "complex float to pointer coercion")
 345   (:generator 13
 346      (with-fixed-allocation (y
 347                              complex-single-float-widetag
 348                              complex-single-float-size
 349                              node)
 350        (let ((real-tn (complex-single-reg-real-tn x)))
 351          (with-tn@fp-top(real-tn)
 352            (inst fst (ea-for-csf-real-desc y))))
 353        (let ((imag-tn (complex-single-reg-imag-tn x)))
 354          (with-tn@fp-top(imag-tn)
 355            (inst fst (ea-for-csf-imag-desc y)))))))
 356 (define-move-vop move-from-complex-single :move
 357   (complex-single-reg) (descriptor-reg))
 358
 359 (define-vop (move-from-complex-double)
 360   (:args (x :scs (complex-double-reg) :to :save))
 361   (:results (y :scs (descriptor-reg)))
 362   (:node-var node)
 363   (:note "complex float to pointer coercion")
 364   (:generator 13
 365      (with-fixed-allocation (y
 366                              complex-double-float-widetag
 367                              complex-double-float-size
 368                              node)
 369        (let ((real-tn (complex-double-reg-real-tn x)))
 370          (with-tn@fp-top(real-tn)
 371            (inst fstd (ea-for-cdf-real-desc y))))
 372        (let ((imag-tn (complex-double-reg-imag-tn x)))
 373          (with-tn@fp-top(imag-tn)
 374            (inst fstd (ea-for-cdf-imag-desc y)))))))
 375 (define-move-vop move-from-complex-double :move
 376   (complex-double-reg) (descriptor-reg))
 377
 378 ;;; Move from a descriptor to a complex float register.
 379 (macrolet ((frob (name sc format)
 380              `(progn
 381                 (define-vop (,name)
 382                   (:args (x :scs (descriptor-reg)))
 383                   (:results (y :scs (,sc)))
 384                   (:note "pointer to complex float coercion")
 385                   (:generator 2
 386                     (let ((real-tn (complex-double-reg-real-tn y)))
 387                       (with-empty-tn@fp-top(real-tn)
 388                         ,@(ecase format
 389                            (:single '((inst fld (ea-for-csf-real-desc x))))
 390                            (:double '((inst fldd (ea-for-cdf-real-desc x)))))))
 391                     (let ((imag-tn (complex-double-reg-imag-tn y)))
 392                       (with-empty-tn@fp-top(imag-tn)
 393                         ,@(ecase format
 394                            (:single '((inst fld (ea-for-csf-imag-desc x))))
 395                            (:double '((inst fldd (ea-for-cdf-imag-desc x)))))))))
 396                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 397           (frob move-to-complex-single complex-single-reg :single)
 398           (frob move-to-complex-double complex-double-reg :double))
 399 \f
 400 ;;;; the move argument vops
 401 ;;;;
 402 ;;;; Note these are also used to stuff fp numbers onto the c-call
 403 ;;;; stack so the order is different than the lisp-stack.
 404
 405 ;;; the general MOVE-ARG VOP
 406 (macrolet ((frob (name sc stack-sc format)
 407              `(progn
 408                 (define-vop (,name)
 409                   (:args (x :scs (,sc) :target y)
 410                          (fp :scs (any-reg)
 411                              :load-if (not (sc-is y ,sc))))
 412                   (:results (y))
 413                   (:note "float argument move")
 414                   (:generator ,(case format (:single 2) (:double 3) (:long 4))
 415                     (sc-case y
 416                       (,sc
 417                        (unless (location= x y)
 418                           (cond ((zerop (tn-offset y))
 419                                  (copy-fp-reg-to-fr0 x))
 420                                 ((zerop (tn-offset x))
 421                                  (inst fstd y))
 422                                 (t
 423                                  (inst fxch x)
 424                                  (inst fstd y)
 425                                  (inst fxch x)))))
 426                       (,stack-sc
 427                        (if (= (tn-offset fp) esp-offset)
 428                            (let* ((offset (* (tn-offset y) n-word-bytes))
 429                                   (ea (make-ea :dword :base fp :disp offset)))
 430                              (with-tn@fp-top(x)
 431                                 ,@(ecase format
 432                                          (:single '((inst fst ea)))
 433                                          (:double '((inst fstd ea))))))
 434                            (let ((ea (make-ea
 435                                       :dword :base fp
 436                                       :disp (- (* (+ (tn-offset y)
 437                                                      ,(case format
 438                                                             (:single 1)
 439                                                             (:double 2)
 440                                                             (:long 3)))
 441                                                   n-word-bytes)))))
 442                              (with-tn@fp-top(x)
 443                                ,@(ecase format
 444                                     (:single '((inst fst  ea)))
 445                                     (:double '((inst fstd ea)))))))))))
 446                 (define-move-vop ,name :move-arg
 447                   (,sc descriptor-reg) (,sc)))))
 448   (frob move-single-float-arg single-reg single-stack :single)
 449   (frob move-double-float-arg double-reg double-stack :double))
 450
 451 ;;;; complex float MOVE-ARG VOP
 452 (macrolet ((frob (name sc stack-sc format)
 453              `(progn
 454                 (define-vop (,name)
 455                   (:args (x :scs (,sc) :target y)
 456                          (fp :scs (any-reg)
 457                              :load-if (not (sc-is y ,sc))))
 458                   (:results (y))
 459                   (:note "complex float argument move")
 460                   (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
 461                     (sc-case y
 462                       (,sc
 463                        (unless (location= x y)
 464                          (let ((x-real (complex-double-reg-real-tn x))
 465                                (y-real (complex-double-reg-real-tn y)))
 466                            (cond ((zerop (tn-offset y-real))
 467                                   (copy-fp-reg-to-fr0 x-real))
 468                                  ((zerop (tn-offset x-real))
 469                                   (inst fstd y-real))
 470                                  (t
 471                                   (inst fxch x-real)
 472                                   (inst fstd y-real)
 473                                   (inst fxch x-real))))
 474                          (let ((x-imag (complex-double-reg-imag-tn x))
 475                                (y-imag (complex-double-reg-imag-tn y)))
 476                            (inst fxch x-imag)
 477                            (inst fstd y-imag)
 478                            (inst fxch x-imag))))
 479                       (,stack-sc
 480                        (let ((real-tn (complex-double-reg-real-tn x)))
 481                          (cond ((zerop (tn-offset real-tn))
 482                                 ,@(ecase format
 483                                     (:single
 484                                      '((inst fst
 485                                         (ea-for-csf-real-stack y fp))))
 486                                     (:double
 487                                      '((inst fstd
 488                                         (ea-for-cdf-real-stack y fp))))))
 489                                (t
 490                                 (inst fxch real-tn)
 491                                 ,@(ecase format
 492                                     (:single
 493                                      '((inst fst
 494                                         (ea-for-csf-real-stack y fp))))
 495                                     (:double
 496                                      '((inst fstd
 497                                         (ea-for-cdf-real-stack y fp)))))
 498                                 (inst fxch real-tn))))
 499                        (let ((imag-tn (complex-double-reg-imag-tn x)))
 500                          (inst fxch imag-tn)
 501                          ,@(ecase format
 502                              (:single
 503                               '((inst fst (ea-for-csf-imag-stack y fp))))
 504                              (:double
 505                               '((inst fstd (ea-for-cdf-imag-stack y fp)))))
 506                          (inst fxch imag-tn))))))
 507                 (define-move-vop ,name :move-arg
 508                   (,sc descriptor-reg) (,sc)))))
 509   (frob move-complex-single-float-arg
 510         complex-single-reg complex-single-stack :single)
 511   (frob move-complex-double-float-arg
 512         complex-double-reg complex-double-stack :double))
 513
 514 (define-move-vop move-arg :move-arg
 515   (single-reg double-reg
 516    complex-single-reg complex-double-reg)
 517   (descriptor-reg))
 518
 519 \f
 520 ;;;; arithmetic VOPs
 521
 522 ;;; dtc: the floating point arithmetic vops
 523 ;;;
 524 ;;; Note: Although these can accept x and y on the stack or pointed to
 525 ;;; from a descriptor register, they will work with register loading
 526 ;;; without these. Same deal with the result - it need only be a
 527 ;;; register. When load-tns are needed they will probably be in ST0
 528 ;;; and the code below should be able to correctly handle all cases.
 529 ;;;
 530 ;;; However it seems to produce better code if all arg. and result
 531 ;;; options are used; on the P86 there is no extra cost in using a
 532 ;;; memory operand to the FP instructions - not so on the PPro.
 533 ;;;
 534 ;;; It may also be useful to handle constant args?
 535 ;;;
 536 ;;; 22-Jul-97: descriptor args lose in some simple cases when
 537 ;;; a function result computed in a loop. Then Python insists
 538 ;;; on consing the intermediate values! For example
 539 #|
 540 (defun test(a n)
 541   (declare (type (simple-array double-float (*)) a)
 542            (fixnum n))
 543   (let ((sum 0d0))
 544     (declare (type double-float sum))
 545   (dotimes (i n)
 546     (incf sum (* (aref a i)(aref a i))))
 547     sum))
 548 |#
 549 ;;; So, disabling descriptor args until this can be fixed elsewhere.
 550 (macrolet
 551     ((frob (op fop-sti fopr-sti
 552                fop fopr sname scost
 553                fopd foprd dname dcost
 554                lname lcost)
 555        #!-long-float (declare (ignore lcost lname))
 556        `(progn
 557          (define-vop (,sname)
 558            (:translate ,op)
 559            (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
 560                      :to :eval)
 561                   (y :scs (single-reg single-stack #+nil descriptor-reg)
 562                      :to :eval))
 563            (:temporary (:sc single-reg :offset fr0-offset
 564                             :from :eval :to :result) fr0)
 565            (:results (r :scs (single-reg single-stack)))
 566            (:arg-types single-float single-float)
 567            (:result-types single-float)
 568            (:policy :fast-safe)
 569            (:note "inline float arithmetic")
 570            (:vop-var vop)
 571            (:save-p :compute-only)
 572            (:node-var node)
 573            (:generator ,scost
 574              ;; Handle a few special cases
 575              (cond
 576               ;; x, y, and r are the same register.
 577               ((and (sc-is x single-reg) (location= x r) (location= y r))
 578                (cond ((zerop (tn-offset r))
 579                       (inst ,fop fr0))
 580                      (t
 581                       (inst fxch r)
 582                       (inst ,fop fr0)
 583                       ;; XX the source register will not be valid.
 584                       (note-next-instruction vop :internal-error)
 585                       (inst fxch r))))
 586
 587               ;; x and r are the same register.
 588               ((and (sc-is x single-reg) (location= x r))
 589                (cond ((zerop (tn-offset r))
 590                       (sc-case y
 591                          (single-reg
 592                           ;; ST(0) = ST(0) op ST(y)
 593                           (inst ,fop y))
 594                          (single-stack
 595                           ;; ST(0) = ST(0) op Mem
 596                           (inst ,fop (ea-for-sf-stack y)))
 597                          (descriptor-reg
 598                           (inst ,fop (ea-for-sf-desc y)))))
 599                      (t
 600                       ;; y to ST0
 601                       (sc-case y
 602                          (single-reg
 603                           (unless (zerop (tn-offset y))
 604                                   (copy-fp-reg-to-fr0 y)))
 605                          ((single-stack descriptor-reg)
 606                           (inst fstp fr0)
 607                           (if (sc-is y single-stack)
 608                               (inst fld (ea-for-sf-stack y))
 609                             (inst fld (ea-for-sf-desc y)))))
 610                       ;; ST(i) = ST(i) op ST0
 611                       (inst ,fop-sti r)))
 612                (maybe-fp-wait node vop))
 613               ;; y and r are the same register.
 614               ((and (sc-is y single-reg) (location= y r))
 615                (cond ((zerop (tn-offset r))
 616                       (sc-case x
 617                          (single-reg
 618                           ;; ST(0) = ST(x) op ST(0)
 619                           (inst ,fopr x))
 620                          (single-stack
 621                           ;; ST(0) = Mem op ST(0)
 622                           (inst ,fopr (ea-for-sf-stack x)))
 623                          (descriptor-reg
 624                           (inst ,fopr (ea-for-sf-desc x)))))
 625                      (t
 626                       ;; x to ST0
 627                       (sc-case x
 628                         (single-reg
 629                          (unless (zerop (tn-offset x))
 630                                  (copy-fp-reg-to-fr0 x)))
 631                         ((single-stack descriptor-reg)
 632                          (inst fstp fr0)
 633                          (if (sc-is x single-stack)
 634                              (inst fld (ea-for-sf-stack x))
 635                            (inst fld (ea-for-sf-desc x)))))
 636                       ;; ST(i) = ST(0) op ST(i)
 637                       (inst ,fopr-sti r)))
 638                (maybe-fp-wait node vop))
 639               ;; the default case
 640               (t
 641                ;; Get the result to ST0.
 642
 643                ;; Special handling is needed if x or y are in ST0, and
 644                ;; simpler code is generated.
 645                (cond
 646                 ;; x is in ST0
 647                 ((and (sc-is x single-reg) (zerop (tn-offset x)))
 648                  ;; ST0 = ST0 op y
 649                  (sc-case y
 650                    (single-reg
 651                     (inst ,fop y))
 652                    (single-stack
 653                     (inst ,fop (ea-for-sf-stack y)))
 654                    (descriptor-reg
 655                     (inst ,fop (ea-for-sf-desc y)))))
 656                 ;; y is in ST0
 657                 ((and (sc-is y single-reg) (zerop (tn-offset y)))
 658                  ;; ST0 = x op ST0
 659                  (sc-case x
 660                    (single-reg
 661                     (inst ,fopr x))
 662                    (single-stack
 663                     (inst ,fopr (ea-for-sf-stack x)))
 664                    (descriptor-reg
 665                     (inst ,fopr (ea-for-sf-desc x)))))
 666                 (t
 667                  ;; x to ST0
 668                  (sc-case x
 669                    (single-reg
 670                     (copy-fp-reg-to-fr0 x))
 671                    (single-stack
 672                     (inst fstp fr0)
 673                     (inst fld (ea-for-sf-stack x)))
 674                    (descriptor-reg
 675                     (inst fstp fr0)
 676                     (inst fld (ea-for-sf-desc x))))
 677                  ;; ST0 = ST0 op y
 678                  (sc-case y
 679                    (single-reg
 680                     (inst ,fop y))
 681                    (single-stack
 682                     (inst ,fop (ea-for-sf-stack y)))
 683                    (descriptor-reg
 684                     (inst ,fop (ea-for-sf-desc y))))))
 685
 686                (note-next-instruction vop :internal-error)
 687
 688                ;; Finally save the result.
 689                (sc-case r
 690                  (single-reg
 691                   (cond ((zerop (tn-offset r))
 692                          (maybe-fp-wait node))
 693                         (t
 694                          (inst fst r))))
 695                  (single-stack
 696                   (inst fst (ea-for-sf-stack r))))))))
 697
 698          (define-vop (,dname)
 699            (:translate ,op)
 700            (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
 701                      :to :eval)
 702                   (y :scs (double-reg double-stack #+nil descriptor-reg)
 703                      :to :eval))
 704            (:temporary (:sc double-reg :offset fr0-offset
 705                             :from :eval :to :result) fr0)
 706            (:results (r :scs (double-reg double-stack)))
 707            (:arg-types double-float double-float)
 708            (:result-types double-float)
 709            (:policy :fast-safe)
 710            (:note "inline float arithmetic")
 711            (:vop-var vop)
 712            (:save-p :compute-only)
 713            (:node-var node)
 714            (:generator ,dcost
 715              ;; Handle a few special cases.
 716              (cond
 717               ;; x, y, and r are the same register.
 718               ((and (sc-is x double-reg) (location= x r) (location= y r))
 719                (cond ((zerop (tn-offset r))
 720                       (inst ,fop fr0))
 721                      (t
 722                       (inst fxch x)
 723                       (inst ,fopd fr0)
 724                       ;; XX the source register will not be valid.
 725                       (note-next-instruction vop :internal-error)
 726                       (inst fxch r))))
 727
 728               ;; x and r are the same register.
 729               ((and (sc-is x double-reg) (location= x r))
 730                (cond ((zerop (tn-offset r))
 731                       (sc-case y
 732                          (double-reg
 733                           ;; ST(0) = ST(0) op ST(y)
 734                           (inst ,fopd y))
 735                          (double-stack
 736                           ;; ST(0) = ST(0) op Mem
 737                           (inst ,fopd (ea-for-df-stack y)))
 738                          (descriptor-reg
 739                           (inst ,fopd (ea-for-df-desc y)))))
 740                      (t
 741                       ;; y to ST0
 742                       (sc-case y
 743                          (double-reg
 744                           (unless (zerop (tn-offset y))
 745                                   (copy-fp-reg-to-fr0 y)))
 746                          ((double-stack descriptor-reg)
 747                           (inst fstp fr0)
 748                           (if (sc-is y double-stack)
 749                               (inst fldd (ea-for-df-stack y))
 750                             (inst fldd (ea-for-df-desc y)))))
 751                       ;; ST(i) = ST(i) op ST0
 752                       (inst ,fop-sti r)))
 753                (maybe-fp-wait node vop))
 754               ;; y and r are the same register.
 755               ((and (sc-is y double-reg) (location= y r))
 756                (cond ((zerop (tn-offset r))
 757                       (sc-case x
 758                          (double-reg
 759                           ;; ST(0) = ST(x) op ST(0)
 760                           (inst ,foprd x))
 761                          (double-stack
 762                           ;; ST(0) = Mem op ST(0)
 763                           (inst ,foprd (ea-for-df-stack x)))
 764                          (descriptor-reg
 765                           (inst ,foprd (ea-for-df-desc x)))))
 766                      (t
 767                       ;; x to ST0
 768                       (sc-case x
 769                          (double-reg
 770                           (unless (zerop (tn-offset x))
 771                                   (copy-fp-reg-to-fr0 x)))
 772                          ((double-stack descriptor-reg)
 773                           (inst fstp fr0)
 774                           (if (sc-is x double-stack)
 775                               (inst fldd (ea-for-df-stack x))
 776                             (inst fldd (ea-for-df-desc x)))))
 777                       ;; ST(i) = ST(0) op ST(i)
 778                       (inst ,fopr-sti r)))
 779                (maybe-fp-wait node vop))
 780               ;; the default case
 781               (t
 782                ;; Get the result to ST0.
 783
 784                ;; Special handling is needed if x or y are in ST0, and
 785                ;; simpler code is generated.
 786                (cond
 787                 ;; x is in ST0
 788                 ((and (sc-is x double-reg) (zerop (tn-offset x)))
 789                  ;; ST0 = ST0 op y
 790                  (sc-case y
 791                    (double-reg
 792                     (inst ,fopd y))
 793                    (double-stack
 794                     (inst ,fopd (ea-for-df-stack y)))
 795                    (descriptor-reg
 796                     (inst ,fopd (ea-for-df-desc y)))))
 797                 ;; y is in ST0
 798                 ((and (sc-is y double-reg) (zerop (tn-offset y)))
 799                  ;; ST0 = x op ST0
 800                  (sc-case x
 801                    (double-reg
 802                     (inst ,foprd x))
 803                    (double-stack
 804                     (inst ,foprd (ea-for-df-stack x)))
 805                    (descriptor-reg
 806                     (inst ,foprd (ea-for-df-desc x)))))
 807                 (t
 808                  ;; x to ST0
 809                  (sc-case x
 810                    (double-reg
 811                     (copy-fp-reg-to-fr0 x))
 812                    (double-stack
 813                     (inst fstp fr0)
 814                     (inst fldd (ea-for-df-stack x)))
 815                    (descriptor-reg
 816                     (inst fstp fr0)
 817                     (inst fldd (ea-for-df-desc x))))
 818                  ;; ST0 = ST0 op y
 819                  (sc-case y
 820                    (double-reg
 821                     (inst ,fopd y))
 822                    (double-stack
 823                     (inst ,fopd (ea-for-df-stack y)))
 824                    (descriptor-reg
 825                     (inst ,fopd (ea-for-df-desc y))))))
 826
 827                (note-next-instruction vop :internal-error)
 828
 829                ;; Finally save the result.
 830                (sc-case r
 831                  (double-reg
 832                   (cond ((zerop (tn-offset r))
 833                          (maybe-fp-wait node))
 834                         (t
 835                          (inst fst r))))
 836                  (double-stack
 837                   (inst fstd (ea-for-df-stack r))))))))
 838          )))
 839
 840     (frob + fadd-sti fadd-sti
 841           fadd fadd +/single-float 2
 842           faddd faddd +/double-float 2
 843           +/long-float 2)
 844     (frob - fsub-sti fsubr-sti
 845           fsub fsubr -/single-float 2
 846           fsubd fsubrd -/double-float 2
 847           -/long-float 2)
 848     (frob * fmul-sti fmul-sti
 849           fmul fmul */single-float 3
 850           fmuld fmuld */double-float 3
 851           */long-float 3)
 852     (frob / fdiv-sti fdivr-sti
 853           fdiv fdivr //single-float 12
 854           fdivd fdivrd //double-float 12
 855           //long-float 12))
 856 \f
 857 (macrolet ((frob (name inst translate sc type)
 858              `(define-vop (,name)
 859                (:args (x :scs (,sc) :target fr0))
 860                (:results (y :scs (,sc)))
 861                (:translate ,translate)
 862                (:policy :fast-safe)
 863                (:arg-types ,type)
 864                (:result-types ,type)
 865                (:temporary (:sc double-reg :offset fr0-offset
 866                                 :from :argument :to :result) fr0)
 867                (:ignore fr0)
 868                (:note "inline float arithmetic")
 869                (:vop-var vop)
 870                (:save-p :compute-only)
 871                (:generator 1
 872                 (note-this-location vop :internal-error)
 873                 (unless (zerop (tn-offset x))
 874                   (inst fxch x)         ; x to top of stack
 875                   (unless (location= x y)
 876                     (inst fst x)))      ; Maybe save it.
 877                 (inst ,inst)            ; Clobber st0.
 878                 (unless (zerop (tn-offset y))
 879                   (inst fst y))))))
 880
 881   (frob abs/single-float fabs abs single-reg single-float)
 882   (frob abs/double-float fabs abs double-reg double-float)
 883
 884   (frob %negate/single-float fchs %negate single-reg single-float)
 885   (frob %negate/double-float fchs %negate double-reg double-float))
 886 \f
 887 ;;;; comparison
 888
 889 (define-vop (=/float)
 890   (:args (x) (y))
 891   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
 892   (:conditional)
 893   (:info target not-p)
 894   (:policy :fast-safe)
 895   (:vop-var vop)
 896   (:save-p :compute-only)
 897   (:note "inline float comparison")
 898   (:ignore temp)
 899   (:generator 3
 900      (note-this-location vop :internal-error)
 901      (cond
 902       ;; x is in ST0; y is in any reg.
 903       ((zerop (tn-offset x))
 904        (inst fucom y))
 905       ;; y is in ST0; x is in another reg.
 906       ((zerop (tn-offset y))
 907        (inst fucom x))
 908       ;; x and y are the same register, not ST0
 909       ((location= x y)
 910        (inst fxch x)
 911        (inst fucom fr0-tn)
 912        (inst fxch x))
 913       ;; x and y are different registers, neither ST0.
 914       (t
 915        (inst fxch x)
 916        (inst fucom y)
 917        (inst fxch x)))
 918      (inst fnstsw)                      ; status word to ax
 919      (inst and ah-tn #x45)              ; C3 C2 C0
 920      (inst cmp ah-tn #x40)
 921      (inst jmp (if not-p :ne :e) target)))
 922
 923 (define-vop (=/single-float =/float)
 924   (:translate =)
 925   (:args (x :scs (single-reg))
 926          (y :scs (single-reg)))
 927   (:arg-types single-float single-float))
 928
 929 (define-vop (=/double-float =/float)
 930   (:translate =)
 931   (:args (x :scs (double-reg))
 932          (y :scs (double-reg)))
 933   (:arg-types double-float double-float))
 934
 935 (define-vop (<single-float)
 936   (:translate <)
 937   (:args (x :scs (single-reg single-stack descriptor-reg))
 938          (y :scs (single-reg single-stack descriptor-reg)))
 939   (:arg-types single-float single-float)
 940   (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
 941   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
 942   (:conditional)
 943   (:info target not-p)
 944   (:policy :fast-safe)
 945   (:note "inline float comparison")
 946   (:ignore temp)
 947   (:generator 3
 948     ;; Handle a few special cases.
 949     (cond
 950      ;; y is ST0.
 951      ((and (sc-is y single-reg) (zerop (tn-offset y)))
 952       (sc-case x
 953         (single-reg
 954          (inst fcom x))
 955         ((single-stack descriptor-reg)
 956          (if (sc-is x single-stack)
 957              (inst fcom (ea-for-sf-stack x))
 958            (inst fcom (ea-for-sf-desc x)))))
 959       (inst fnstsw)                     ; status word to ax
 960       (inst and ah-tn #x45))
 961
 962      ;; general case when y is not in ST0
 963      (t
 964       ;; x to ST0
 965       (sc-case x
 966          (single-reg
 967           (unless (zerop (tn-offset x))
 968                   (copy-fp-reg-to-fr0 x)))
 969          ((single-stack descriptor-reg)
 970           (inst fstp fr0)
 971           (if (sc-is x single-stack)
 972               (inst fld (ea-for-sf-stack x))
 973             (inst fld (ea-for-sf-desc x)))))
 974       (sc-case y
 975         (single-reg
 976          (inst fcom y))
 977         ((single-stack descriptor-reg)
 978          (if (sc-is y single-stack)
 979              (inst fcom (ea-for-sf-stack y))
 980            (inst fcom (ea-for-sf-desc y)))))
 981       (inst fnstsw)                     ; status word to ax
 982       (inst and ah-tn #x45)             ; C3 C2 C0
 983       (inst cmp ah-tn #x01)))
 984     (inst jmp (if not-p :ne :e) target)))
 985
 986 (define-vop (<double-float)
 987   (:translate <)
 988   (:args (x :scs (double-reg double-stack descriptor-reg))
 989          (y :scs (double-reg double-stack descriptor-reg)))
 990   (:arg-types double-float double-float)
 991   (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
 992   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
 993   (:conditional)
 994   (:info target not-p)
 995   (:policy :fast-safe)
 996   (:note "inline float comparison")
 997   (:ignore temp)
 998   (:generator 3
 999     ;; Handle a few special cases
1000     (cond
1001      ;; y is ST0.
1002      ((and (sc-is y double-reg) (zerop (tn-offset y)))
1003       (sc-case x
1004         (double-reg
1005          (inst fcomd x))
1006         ((double-stack descriptor-reg)
1007          (if (sc-is x double-stack)
1008              (inst fcomd (ea-for-df-stack x))
1009            (inst fcomd (ea-for-df-desc x)))))
1010       (inst fnstsw)                     ; status word to ax
1011       (inst and ah-tn #x45))
1012
1013      ;; General case when y is not in ST0.
1014      (t
1015       ;; x to ST0
1016       (sc-case x
1017          (double-reg
1018           (unless (zerop (tn-offset x))
1019                   (copy-fp-reg-to-fr0 x)))
1020          ((double-stack descriptor-reg)
1021           (inst fstp fr0)
1022           (if (sc-is x double-stack)
1023               (inst fldd (ea-for-df-stack x))
1024             (inst fldd (ea-for-df-desc x)))))
1025       (sc-case y
1026         (double-reg
1027          (inst fcomd y))
1028         ((double-stack descriptor-reg)
1029          (if (sc-is y double-stack)
1030              (inst fcomd (ea-for-df-stack y))
1031            (inst fcomd (ea-for-df-desc y)))))
1032       (inst fnstsw)                     ; status word to ax
1033       (inst and ah-tn #x45)             ; C3 C2 C0
1034       (inst cmp ah-tn #x01)))
1035     (inst jmp (if not-p :ne :e) target)))
1036
1037 (define-vop (>single-float)
1038   (:translate >)
1039   (:args (x :scs (single-reg single-stack descriptor-reg))
1040          (y :scs (single-reg single-stack descriptor-reg)))
1041   (:arg-types single-float single-float)
1042   (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
1043   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1044   (:conditional)
1045   (:info target not-p)
1046   (:policy :fast-safe)
1047   (:note "inline float comparison")
1048   (:ignore temp)
1049   (:generator 3
1050     ;; Handle a few special cases.
1051     (cond
1052      ;; y is ST0.
1053      ((and (sc-is y single-reg) (zerop (tn-offset y)))
1054       (sc-case x
1055         (single-reg
1056          (inst fcom x))
1057         ((single-stack descriptor-reg)
1058          (if (sc-is x single-stack)
1059              (inst fcom (ea-for-sf-stack x))
1060            (inst fcom (ea-for-sf-desc x)))))
1061       (inst fnstsw)                     ; status word to ax
1062       (inst and ah-tn #x45)
1063       (inst cmp ah-tn #x01))
1064
1065      ;; general case when y is not in ST0
1066      (t
1067       ;; x to ST0
1068       (sc-case x
1069          (single-reg
1070           (unless (zerop (tn-offset x))
1071                   (copy-fp-reg-to-fr0 x)))
1072          ((single-stack descriptor-reg)
1073           (inst fstp fr0)
1074           (if (sc-is x single-stack)
1075               (inst fld (ea-for-sf-stack x))
1076             (inst fld (ea-for-sf-desc x)))))
1077       (sc-case y
1078         (single-reg
1079          (inst fcom y))
1080         ((single-stack descriptor-reg)
1081          (if (sc-is y single-stack)
1082              (inst fcom (ea-for-sf-stack y))
1083            (inst fcom (ea-for-sf-desc y)))))
1084       (inst fnstsw)                     ; status word to ax
1085       (inst and ah-tn #x45)))
1086     (inst jmp (if not-p :ne :e) target)))
1087
1088 (define-vop (>double-float)
1089   (:translate >)
1090   (:args (x :scs (double-reg double-stack descriptor-reg))
1091          (y :scs (double-reg double-stack descriptor-reg)))
1092   (:arg-types double-float double-float)
1093   (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
1094   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1095   (:conditional)
1096   (:info target not-p)
1097   (:policy :fast-safe)
1098   (:note "inline float comparison")
1099   (:ignore temp)
1100   (:generator 3
1101     ;; Handle a few special cases.
1102     (cond
1103      ;; y is ST0.
1104      ((and (sc-is y double-reg) (zerop (tn-offset y)))
1105       (sc-case x
1106         (double-reg
1107          (inst fcomd x))
1108         ((double-stack descriptor-reg)
1109          (if (sc-is x double-stack)
1110              (inst fcomd (ea-for-df-stack x))
1111            (inst fcomd (ea-for-df-desc x)))))
1112       (inst fnstsw)                     ; status word to ax
1113       (inst and ah-tn #x45)
1114       (inst cmp ah-tn #x01))
1115
1116      ;; general case when y is not in ST0
1117      (t
1118       ;; x to ST0
1119       (sc-case x
1120          (double-reg
1121           (unless (zerop (tn-offset x))
1122                   (copy-fp-reg-to-fr0 x)))
1123          ((double-stack descriptor-reg)
1124           (inst fstp fr0)
1125           (if (sc-is x double-stack)
1126               (inst fldd (ea-for-df-stack x))
1127             (inst fldd (ea-for-df-desc x)))))
1128       (sc-case y
1129         (double-reg
1130          (inst fcomd y))
1131         ((double-stack descriptor-reg)
1132          (if (sc-is y double-stack)
1133              (inst fcomd (ea-for-df-stack y))
1134            (inst fcomd (ea-for-df-desc y)))))
1135       (inst fnstsw)                     ; status word to ax
1136       (inst and ah-tn #x45)))
1137     (inst jmp (if not-p :ne :e) target)))
1138
1139 ;;; Comparisons with 0 can use the FTST instruction.
1140
1141 (define-vop (float-test)
1142   (:args (x))
1143   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
1144   (:conditional)
1145   (:info target not-p y)
1146   (:variant-vars code)
1147   (:policy :fast-safe)
1148   (:vop-var vop)
1149   (:save-p :compute-only)
1150   (:note "inline float comparison")
1151   (:ignore temp y)
1152   (:generator 2
1153      (note-this-location vop :internal-error)
1154      (cond
1155       ;; x is in ST0
1156       ((zerop (tn-offset x))
1157        (inst ftst))
1158       ;; x not ST0
1159       (t
1160        (inst fxch x)
1161        (inst ftst)
1162        (inst fxch x)))
1163      (inst fnstsw)                      ; status word to ax
1164      (inst and ah-tn #x45)              ; C3 C2 C0
1165      (unless (zerop code)
1166         (inst cmp ah-tn code))
1167      (inst jmp (if not-p :ne :e) target)))
1168
1169 (define-vop (=0/single-float float-test)
1170   (:translate =)
1171   (:args (x :scs (single-reg)))
1172   (:arg-types single-float (:constant (single-float 0f0 0f0)))
1173   (:variant #x40))
1174 (define-vop (=0/double-float float-test)
1175   (:translate =)
1176   (:args (x :scs (double-reg)))
1177   (:arg-types double-float (:constant (double-float 0d0 0d0)))
1178   (:variant #x40))
1179
1180 (define-vop (<0/single-float float-test)
1181   (:translate <)
1182   (:args (x :scs (single-reg)))
1183   (:arg-types single-float (:constant (single-float 0f0 0f0)))
1184   (:variant #x01))
1185 (define-vop (<0/double-float float-test)
1186   (:translate <)
1187   (:args (x :scs (double-reg)))
1188   (:arg-types double-float (:constant (double-float 0d0 0d0)))
1189   (:variant #x01))
1190
1191 (define-vop (>0/single-float float-test)
1192   (:translate >)
1193   (:args (x :scs (single-reg)))
1194   (:arg-types single-float (:constant (single-float 0f0 0f0)))
1195   (:variant #x00))
1196 (define-vop (>0/double-float float-test)
1197   (:translate >)
1198   (:args (x :scs (double-reg)))
1199   (:arg-types double-float (:constant (double-float 0d0 0d0)))
1200   (:variant #x00))
1201
1202 \f
1203 ;;;; conversion
1204
1205 (macrolet ((frob (name translate to-sc to-type)
1206              `(define-vop (,name)
1207                 (:args (x :scs (signed-stack signed-reg) :target temp))
1208                 (:temporary (:sc signed-stack) temp)
1209                 (:results (y :scs (,to-sc)))
1210                 (:arg-types signed-num)
1211                 (:result-types ,to-type)
1212                 (:policy :fast-safe)
1213                 (:note "inline float coercion")
1214                 (:translate ,translate)
1215                 (:vop-var vop)
1216                 (:save-p :compute-only)
1217                 (:generator 5
1218                   (sc-case x
1219                     (signed-reg
1220                      (inst mov temp x)
1221                      (with-empty-tn@fp-top(y)
1222                        (note-this-location vop :internal-error)
1223                        (inst fild temp)))
1224                     (signed-stack
1225                      (with-empty-tn@fp-top(y)
1226                        (note-this-location vop :internal-error)
1227                        (inst fild x))))))))
1228   (frob %single-float/signed %single-float single-reg single-float)
1229   (frob %double-float/signed %double-float double-reg double-float))
1230
1231 (macrolet ((frob (name translate to-sc to-type)
1232              `(define-vop (,name)
1233                 (:args (x :scs (unsigned-reg)))
1234                 (:results (y :scs (,to-sc)))
1235                 (:arg-types unsigned-num)
1236                 (:result-types ,to-type)
1237                 (:policy :fast-safe)
1238                 (:note "inline float coercion")
1239                 (:translate ,translate)
1240                 (:vop-var vop)
1241                 (:save-p :compute-only)
1242                 (:generator 6
1243                  (inst push 0)
1244                  (inst push x)
1245                  (with-empty-tn@fp-top(y)
1246                    (note-this-location vop :internal-error)
1247                    (inst fildl (make-ea :dword :base rsp-tn)))
1248                  (inst add rsp-tn 16)))))
1249   (frob %single-float/unsigned %single-float single-reg single-float)
1250   (frob %double-float/unsigned %double-float double-reg double-float))
1251
1252 ;;; These should be no-ops but the compiler might want to move some
1253 ;;; things around.
1254 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
1255              `(define-vop (,name)
1256                (:args (x :scs (,from-sc) :target y))
1257                (:results (y :scs (,to-sc)))
1258                (:arg-types ,from-type)
1259                (:result-types ,to-type)
1260                (:policy :fast-safe)
1261                (:note "inline float coercion")
1262                (:translate ,translate)
1263                (:vop-var vop)
1264                (:save-p :compute-only)
1265                (:generator 2
1266                 (note-this-location vop :internal-error)
1267                 (unless (location= x y)
1268                   (cond
1269                    ((zerop (tn-offset x))
1270                     ;; x is in ST0, y is in another reg. not ST0
1271                     (inst fst  y))
1272                    ((zerop (tn-offset y))
1273                     ;; y is in ST0, x is in another reg. not ST0
1274                     (copy-fp-reg-to-fr0 x))
1275                    (t
1276                     ;; Neither x or y are in ST0, and they are not in
1277                     ;; the same reg.
1278                     (inst fxch x)
1279                     (inst fst  y)
1280                     (inst fxch x))))))))
1281
1282   (frob %single-float/double-float %single-float double-reg
1283         double-float single-reg single-float)
1284
1285   (frob %double-float/single-float %double-float single-reg single-float
1286         double-reg double-float))
1287
1288 (macrolet ((frob (trans from-sc from-type round-p)
1289              `(define-vop (,(symbolicate trans "/" from-type))
1290                (:args (x :scs (,from-sc)))
1291                (:temporary (:sc signed-stack) stack-temp)
1292                ,@(unless round-p
1293                        '((:temporary (:sc unsigned-stack) scw)
1294                          (:temporary (:sc any-reg) rcw)))
1295                (:results (y :scs (signed-reg)))
1296                (:arg-types ,from-type)
1297                (:result-types signed-num)
1298                (:translate ,trans)
1299                (:policy :fast-safe)
1300                (:note "inline float truncate")
1301                (:vop-var vop)
1302                (:save-p :compute-only)
1303                (:generator 5
1304                 ,@(unless round-p
1305                    '((note-this-location vop :internal-error)
1306                      ;; Catch any pending FPE exceptions.
1307                      (inst wait)))
1308                 (,(if round-p 'progn 'pseudo-atomic)
1309                  ;; Normal mode (for now) is "round to best".
1310                  (with-tn@fp-top (x)
1311                    ,@(unless round-p
1312                      '((inst fnstcw scw) ; save current control word
1313                        (move rcw scw)   ; into 16-bit register
1314                        (inst or rcw (ash #b11 10)) ; CHOP
1315                        (move stack-temp rcw)
1316                        (inst fldcw stack-temp)))
1317                    (sc-case y
1318                      (signed-stack
1319                       (inst fist y))
1320                      (signed-reg
1321                       (inst fist stack-temp)
1322                       (inst mov y stack-temp)))
1323                    ,@(unless round-p
1324                       '((inst fldcw scw)))))))))
1325   (frob %unary-truncate single-reg single-float nil)
1326   (frob %unary-truncate double-reg double-float nil)
1327
1328   (frob %unary-round single-reg single-float t)
1329   (frob %unary-round double-reg double-float t))
1330
1331 (macrolet ((frob (trans from-sc from-type round-p)
1332              `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
1333                (:args (x :scs (,from-sc) :target fr0))
1334                (:temporary (:sc double-reg :offset fr0-offset
1335                             :from :argument :to :result) fr0)
1336                ,@(unless round-p
1337                   '((:temporary (:sc unsigned-stack) stack-temp)
1338                     (:temporary (:sc unsigned-stack) scw)
1339                     (:temporary (:sc any-reg) rcw)))
1340                (:results (y :scs (unsigned-reg)))
1341                (:arg-types ,from-type)
1342                (:result-types unsigned-num)
1343                (:translate ,trans)
1344                (:policy :fast-safe)
1345                (:note "inline float truncate")
1346                (:vop-var vop)
1347                (:save-p :compute-only)
1348                (:generator 5
1349                 ,@(unless round-p
1350                    '((note-this-location vop :internal-error)
1351                      ;; Catch any pending FPE exceptions.
1352                      (inst wait)))
1353                 ;; Normal mode (for now) is "round to best".
1354                 (unless (zerop (tn-offset x))
1355                   (copy-fp-reg-to-fr0 x))
1356                 ,@(unless round-p
1357                    '((inst fnstcw scw)  ; save current control word
1358                      (move rcw scw)     ; into 16-bit register
1359                      (inst or rcw (ash #b11 10)) ; CHOP
1360                      (move stack-temp rcw)
1361                      (inst fldcw stack-temp)))
1362                 (inst sub rsp-tn 8)
1363                 (inst fistpl (make-ea :dword :base rsp-tn))
1364                 (inst pop y)
1365                 (inst fld fr0) ; copy fr0 to at least restore stack.
1366                 (inst add rsp-tn 8)
1367                 ,@(unless round-p
1368                    '((inst fldcw scw)))))))
1369   (frob %unary-truncate single-reg single-float nil)
1370   (frob %unary-truncate double-reg double-float nil)
1371   (frob %unary-round single-reg single-float t)
1372   (frob %unary-round double-reg double-float t))
1373
1374 (define-vop (make-single-float)
1375   (:args (bits :scs (signed-reg) :target res
1376                :load-if (not (or (and (sc-is bits signed-stack)
1377                                       (sc-is res single-reg))
1378                                  (and (sc-is bits signed-stack)
1379                                       (sc-is res single-stack)
1380                                       (location= bits res))))))
1381   (:results (res :scs (single-reg single-stack)))
1382   (:temporary (:sc signed-stack) stack-temp)
1383   (:arg-types signed-num)
1384   (:result-types single-float)
1385   (:translate make-single-float)
1386   (:policy :fast-safe)
1387   (:vop-var vop)
1388   (:generator 4
1389     (sc-case res
1390        (single-stack
1391         (sc-case bits
1392           (signed-reg
1393            (inst mov res bits))
1394           (signed-stack
1395            (aver (location= bits res)))))
1396        (single-reg
1397         (sc-case bits
1398           (signed-reg
1399            ;; source must be in memory
1400            (inst mov stack-temp bits)
1401            (with-empty-tn@fp-top(res)
1402               (inst fld stack-temp)))
1403           (signed-stack
1404            (with-empty-tn@fp-top(res)
1405               (inst fld bits))))))))
1406
1407 (define-vop (make-double-float)
1408   (:args (hi-bits :scs (signed-reg))
1409          (lo-bits :scs (unsigned-reg)))
1410   (:results (res :scs (double-reg)))
1411   (:temporary (:sc double-stack) temp)
1412   (:arg-types signed-num unsigned-num)
1413   (:result-types double-float)
1414   (:translate make-double-float)
1415   (:policy :fast-safe)
1416   (:vop-var vop)
1417   (:generator 2
1418     (let ((offset (1+ (tn-offset temp))))
1419       (storew hi-bits rbp-tn (- offset))
1420       (storew lo-bits rbp-tn (- (1+ offset)))
1421       (with-empty-tn@fp-top(res)
1422         (inst fldd (make-ea :dword :base rbp-tn
1423                             :disp (- (* (1+ offset) n-word-bytes))))))))
1424
1425 (define-vop (single-float-bits)
1426   (:args (float :scs (single-reg descriptor-reg)
1427                 :load-if (not (sc-is float single-stack))))
1428   (:results (bits :scs (signed-reg)))
1429   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1430   (:arg-types single-float)
1431   (:result-types signed-num)
1432   (:translate single-float-bits)
1433   (:policy :fast-safe)
1434   (:vop-var vop)
1435   (:generator 4
1436     (sc-case bits
1437       (signed-reg
1438        (sc-case float
1439          (single-reg
1440           (with-tn@fp-top(float)
1441             (inst fst stack-temp)
1442             (inst mov bits stack-temp)))
1443          (single-stack
1444           (inst mov bits float))
1445          (descriptor-reg
1446           (loadw
1447            bits float single-float-value-slot
1448            other-pointer-lowtag))))
1449       (signed-stack
1450        (sc-case float
1451          (single-reg
1452           (with-tn@fp-top(float)
1453             (inst fst bits))))))))
1454
1455 (define-vop (double-float-high-bits)
1456   (:args (float :scs (double-reg descriptor-reg)
1457                 :load-if (not (sc-is float double-stack))))
1458   (:results (hi-bits :scs (signed-reg)))
1459   (:temporary (:sc double-stack) temp)
1460   (:arg-types double-float)
1461   (:result-types signed-num)
1462   (:translate double-float-high-bits)
1463   (:policy :fast-safe)
1464   (:vop-var vop)
1465   (:generator 5
1466      (sc-case float
1467        (double-reg
1468         (with-tn@fp-top(float)
1469           (let ((where (make-ea :dword :base rbp-tn
1470                                 :disp (- (* (+ 2 (tn-offset temp))
1471                                             n-word-bytes)))))
1472             (inst fstd where)))
1473         (loadw hi-bits rbp-tn (- (1+ (tn-offset temp)))))
1474        (double-stack
1475         (loadw hi-bits rbp-tn (- (1+ (tn-offset float)))))
1476        (descriptor-reg
1477         (loadw hi-bits float (1+ double-float-value-slot)
1478                other-pointer-lowtag)))))
1479
1480 (define-vop (double-float-low-bits)
1481   (:args (float :scs (double-reg descriptor-reg)
1482                 :load-if (not (sc-is float double-stack))))
1483   (:results (lo-bits :scs (unsigned-reg)))
1484   (:temporary (:sc double-stack) temp)
1485   (:arg-types double-float)
1486   (:result-types unsigned-num)
1487   (:translate double-float-low-bits)
1488   (:policy :fast-safe)
1489   (:vop-var vop)
1490   (:generator 5
1491      (sc-case float
1492        (double-reg
1493         (with-tn@fp-top(float)
1494           (let ((where (make-ea :dword :base rbp-tn
1495                                 :disp (- (* (+ 2 (tn-offset temp))
1496                                             n-word-bytes)))))
1497             (inst fstd where)))
1498         (loadw lo-bits rbp-tn (- (+ 2 (tn-offset temp)))))
1499        (double-stack
1500         (loadw lo-bits rbp-tn (- (+ 2 (tn-offset float)))))
1501        (descriptor-reg
1502         (loadw lo-bits float double-float-value-slot
1503                other-pointer-lowtag)))))
1504
1505 \f
1506 ;;;; float mode hackery
1507
1508 (sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16
1509 (defknown floating-point-modes () float-modes (flushable))
1510 (defknown ((setf floating-point-modes)) (float-modes)
1511   float-modes)
1512
1513 (def!constant npx-env-size (* 7 n-word-bytes))
1514 (def!constant npx-cw-offset 0)
1515 (def!constant npx-sw-offset 4)
1516
1517 (define-vop (floating-point-modes)
1518   (:results (res :scs (unsigned-reg)))
1519   (:result-types unsigned-num)
1520   (:translate floating-point-modes)
1521   (:policy :fast-safe)
1522   (:temporary (:sc unsigned-reg :offset eax-offset :target res
1523                    :to :result) eax)
1524   (:generator 8
1525    (inst sub rsp-tn npx-env-size)       ; Make space on stack.
1526    (inst wait)                          ; Catch any pending FPE exceptions
1527    (inst fstenv (make-ea :dword :base rsp-tn)) ; masks all exceptions
1528    (inst fldenv (make-ea :dword :base rsp-tn)) ; Restore previous state.
1529    ;; Move current status to high word.
1530    (inst movzxd eax (make-ea :dword :base rsp-tn :disp (- npx-sw-offset 2)))
1531    ;; Move exception mask to low word.
1532    (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset))
1533    (inst add rsp-tn npx-env-size)       ; Pop stack.
1534    (inst xor eax #x3f)            ; Flip exception mask to trap enable bits.
1535    (move res eax)))
1536
1537 ;;; XXX BROKEN
1538 (define-vop (set-floating-point-modes)
1539   (:args (new :scs (unsigned-reg) :to :result :target res))
1540   (:results (res :scs (unsigned-reg)))
1541   (:arg-types unsigned-num)
1542   (:result-types unsigned-num)
1543   (:translate (setf floating-point-modes))
1544   (:policy :fast-safe)
1545   (:temporary (:sc unsigned-reg :offset eax-offset
1546                    :from :eval :to :result) eax)
1547   (:generator 3
1548    (inst sub rsp-tn npx-env-size)       ; Make space on stack.
1549    (inst wait)                          ; Catch any pending FPE exceptions.
1550    (inst fstenv (make-ea :dword :base rsp-tn))
1551    (inst mov eax new)
1552    (inst xor eax #x3f)            ; Turn trap enable bits into exception mask.
1553    (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn)
1554    (inst shr eax 16)                    ; position status word
1555    (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn)
1556    (inst fldenv (make-ea :dword :base rsp-tn))
1557    (inst add rsp-tn npx-env-size)       ; Pop stack.
1558    (move res new)))
1559 \f
1560
1561 (progn
1562
1563 ;;; Let's use some of the 80387 special functions.
1564 ;;;
1565 ;;; These defs will not take effect unless code/irrat.lisp is modified
1566 ;;; to remove the inlined alien routine def.
1567
1568 (macrolet ((frob (func trans op)
1569              `(define-vop (,func)
1570                (:args (x :scs (double-reg) :target fr0))
1571                (:temporary (:sc double-reg :offset fr0-offset
1572                                 :from :argument :to :result) fr0)
1573                (:ignore fr0)
1574                (:results (y :scs (double-reg)))
1575                (:arg-types double-float)
1576                (:result-types double-float)
1577                (:translate ,trans)
1578                (:policy :fast-safe)
1579                (:note "inline NPX function")
1580                (:vop-var vop)
1581                (:save-p :compute-only)
1582                (:node-var node)
1583                (:generator 5
1584                 (note-this-location vop :internal-error)
1585                 (unless (zerop (tn-offset x))
1586                   (inst fxch x)         ; x to top of stack
1587                   (unless (location= x y)
1588                     (inst fst x)))      ; maybe save it
1589                 (inst ,op)              ; clobber st0
1590                 (cond ((zerop (tn-offset y))
1591                        (maybe-fp-wait node))
1592                       (t
1593                        (inst fst y)))))))
1594
1595   ;; Quick versions of fsin and fcos that require the argument to be
1596   ;; within range 2^63.
1597   (frob fsin-quick %sin-quick fsin)
1598   (frob fcos-quick %cos-quick fcos)
1599   (frob fsqrt %sqrt fsqrt))
1600
1601 ;;; Quick version of ftan that requires the argument to be within
1602 ;;; range 2^63.
1603 (define-vop (ftan-quick)
1604   (:translate %tan-quick)
1605   (:args (x :scs (double-reg) :target fr0))
1606   (:temporary (:sc double-reg :offset fr0-offset
1607                    :from :argument :to :result) fr0)
1608   (:temporary (:sc double-reg :offset fr1-offset
1609                    :from :argument :to :result) fr1)
1610   (:results (y :scs (double-reg)))
1611   (:arg-types double-float)
1612   (:result-types double-float)
1613   (:policy :fast-safe)
1614   (:note "inline tan function")
1615   (:vop-var vop)
1616   (:save-p :compute-only)
1617   (:generator 5
1618     (note-this-location vop :internal-error)
1619     (case (tn-offset x)
1620        (0
1621         (inst fstp fr1))
1622        (1
1623         (inst fstp fr0))
1624        (t
1625         (inst fstp fr0)
1626         (inst fstp fr0)
1627         (inst fldd (make-random-tn :kind :normal
1628                                    :sc (sc-or-lose 'double-reg)
1629                                    :offset (- (tn-offset x) 2)))))
1630     (inst fptan)
1631     ;; Result is in fr1
1632     (case (tn-offset y)
1633        (0
1634         (inst fxch fr1))
1635        (1)
1636        (t
1637         (inst fxch fr1)
1638         (inst fstd y)))))
1639
1640 ;;; These versions of fsin, fcos, and ftan try to use argument
1641 ;;; reduction but to do this accurately requires greater precision and
1642 ;;; it is hopelessly inaccurate.
1643 #+nil
1644 (macrolet ((frob (func trans op)
1645              `(define-vop (,func)
1646                 (:translate ,trans)
1647                 (:args (x :scs (double-reg) :target fr0))
1648                 (:temporary (:sc unsigned-reg :offset eax-offset
1649                                  :from :eval :to :result) eax)
1650                 (:temporary (:sc unsigned-reg :offset fr0-offset
1651                                  :from :argument :to :result) fr0)
1652                 (:temporary (:sc unsigned-reg :offset fr1-offset
1653                                  :from :argument :to :result) fr1)
1654                 (:results (y :scs (double-reg)))
1655                 (:arg-types double-float)
1656                 (:result-types double-float)
1657                 (:policy :fast-safe)
1658                 (:note "inline sin/cos function")
1659                 (:vop-var vop)
1660                 (:save-p :compute-only)
1661                 (:ignore eax)
1662                 (:generator 5
1663                   (note-this-location vop :internal-error)
1664                   (unless (zerop (tn-offset x))
1665                           (inst fxch x)          ; x to top of stack
1666                           (unless (location= x y)
1667                                   (inst fst x))) ; maybe save it
1668                   (inst ,op)
1669                   (inst fnstsw)                  ; status word to ax
1670                   (inst and ah-tn #x04)          ; C2
1671                   (inst jmp :z DONE)
1672                   ;; Else x was out of range so reduce it; ST0 is unchanged.
1673                   (inst fstp fr1)               ; Load 2*PI
1674                   (inst fldpi)
1675                   (inst fadd fr0)
1676                   (inst fxch fr1)
1677                   LOOP
1678                   (inst fprem1)
1679                   (inst fnstsw)         ; status word to ax
1680                   (inst and ah-tn #x04) ; C2
1681                   (inst jmp :nz LOOP)
1682                   (inst ,op)
1683                   DONE
1684                   (unless (zerop (tn-offset y))
1685                           (inst fstd y))))))
1686           (frob fsin  %sin fsin)
1687           (frob fcos  %cos fcos))
1688
1689
1690
1691 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
1692 ;;; the argument is out of range 2^63 and would thus be hopelessly
1693 ;;; inaccurate.
1694 (macrolet ((frob (func trans op)
1695              `(define-vop (,func)
1696                 (:translate ,trans)
1697                 (:args (x :scs (double-reg) :target fr0))
1698                 (:temporary (:sc double-reg :offset fr0-offset
1699                                  :from :argument :to :result) fr0)
1700                 (:temporary (:sc unsigned-reg :offset eax-offset
1701                              :from :argument :to :result) eax)
1702                 (:results (y :scs (double-reg)))
1703                 (:arg-types double-float)
1704                 (:result-types double-float)
1705                 (:policy :fast-safe)
1706                 (:note "inline sin/cos function")
1707                 (:vop-var vop)
1708                 (:save-p :compute-only)
1709                 (:ignore eax)
1710                 (:generator 5
1711                   (note-this-location vop :internal-error)
1712                   (unless (zerop (tn-offset x))
1713                           (inst fxch x)          ; x to top of stack
1714                           (unless (location= x y)
1715                                   (inst fst x))) ; maybe save it
1716                   (inst ,op)
1717                   (inst fnstsw)                  ; status word to ax
1718                   (inst and ah-tn #x04)          ; C2
1719                   (inst jmp :z DONE)
1720                   ;; Else x was out of range so reduce it; ST0 is unchanged.
1721                   (inst fstp fr0)               ; Load 0.0
1722                   (inst fldz)
1723                   DONE
1724                   (unless (zerop (tn-offset y))
1725                           (inst fstd y))))))
1726           (frob fsin  %sin fsin)
1727           (frob fcos  %cos fcos))
1728
1729 (define-vop (ftan)
1730   (:translate %tan)
1731   (:args (x :scs (double-reg) :target fr0))
1732   (:temporary (:sc double-reg :offset fr0-offset
1733                    :from :argument :to :result) fr0)
1734   (:temporary (:sc double-reg :offset fr1-offset
1735                    :from :argument :to :result) fr1)
1736   (:temporary (:sc unsigned-reg :offset eax-offset
1737                    :from :argument :to :result) eax)
1738   (:results (y :scs (double-reg)))
1739   (:arg-types double-float)
1740   (:result-types double-float)
1741   (:ignore eax)
1742   (:policy :fast-safe)
1743   (:note "inline tan function")
1744   (:vop-var vop)
1745   (:save-p :compute-only)
1746   (:ignore eax)
1747   (:generator 5
1748     (note-this-location vop :internal-error)
1749     (case (tn-offset x)
1750        (0
1751         (inst fstp fr1))
1752        (1
1753         (inst fstp fr0))
1754        (t
1755         (inst fstp fr0)
1756         (inst fstp fr0)
1757         (inst fldd (make-random-tn :kind :normal
1758                                    :sc (sc-or-lose 'double-reg)
1759                                    :offset (- (tn-offset x) 2)))))
1760     (inst fptan)
1761     (inst fnstsw)                        ; status word to ax
1762     (inst and ah-tn #x04)                ; C2
1763     (inst jmp :z DONE)
1764     ;; Else x was out of range so reduce it; ST0 is unchanged.
1765     (inst fldz)                  ; Load 0.0
1766     (inst fxch fr1)
1767     DONE
1768     ;; Result is in fr1
1769     (case (tn-offset y)
1770        (0
1771         (inst fxch fr1))
1772        (1)
1773        (t
1774         (inst fxch fr1)
1775         (inst fstd y)))))
1776
1777 #+nil
1778 (define-vop (fexp)
1779   (:translate %exp)
1780   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
1781   (:temporary (:sc double-reg :offset fr0-offset
1782                    :from :argument :to :result) fr0)
1783   (:temporary (:sc double-reg :offset fr1-offset
1784                    :from :argument :to :result) fr1)
1785   (:temporary (:sc double-reg :offset fr2-offset
1786                    :from :argument :to :result) fr2)
1787   (:results (y :scs (double-reg)))
1788   (:arg-types double-float)
1789   (:result-types double-float)
1790   (:policy :fast-safe)
1791   (:note "inline exp function")
1792   (:vop-var vop)
1793   (:save-p :compute-only)
1794   (:generator 5
1795      (note-this-location vop :internal-error)
1796      (sc-case x
1797         (double-reg
1798          (cond ((zerop (tn-offset x))
1799                 ;; x is in fr0
1800                 (inst fstp fr1)
1801                 (inst fldl2e)
1802                 (inst fmul fr1))
1803                (t
1804                 ;; x is in a FP reg, not fr0
1805                 (inst fstp fr0)
1806                 (inst fldl2e)
1807                 (inst fmul x))))
1808         ((double-stack descriptor-reg)
1809          (inst fstp fr0)
1810          (inst fldl2e)
1811          (if (sc-is x double-stack)
1812              (inst fmuld (ea-for-df-stack x))
1813            (inst fmuld (ea-for-df-desc x)))))
1814      ;; Now fr0=x log2(e)
1815      (inst fst fr1)
1816      (inst frndint)
1817      (inst fst fr2)
1818      (inst fsubp-sti fr1)
1819      (inst f2xm1)
1820      (inst fld1)
1821      (inst faddp-sti fr1)
1822      (inst fscale)
1823      (inst fld fr0)
1824      (case (tn-offset y)
1825        ((0 1))
1826        (t (inst fstd y)))))
1827
1828 ;;; Modified exp that handles the following special cases:
1829 ;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
1830 (define-vop (fexp)
1831   (:translate %exp)
1832   (:args (x :scs (double-reg) :target fr0))
1833   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
1834   (:temporary (:sc double-reg :offset fr0-offset
1835                    :from :argument :to :result) fr0)
1836   (:temporary (:sc double-reg :offset fr1-offset
1837                    :from :argument :to :result) fr1)
1838   (:temporary (:sc double-reg :offset fr2-offset
1839                    :from :argument :to :result) fr2)
1840   (:results (y :scs (double-reg)))
1841   (:arg-types double-float)
1842   (:result-types double-float)
1843   (:policy :fast-safe)
1844   (:note "inline exp function")
1845   (:vop-var vop)
1846   (:save-p :compute-only)
1847   (:ignore temp)
1848   (:generator 5
1849      (note-this-location vop :internal-error)
1850      (unless (zerop (tn-offset x))
1851        (inst fxch x)            ; x to top of stack
1852        (unless (location= x y)
1853          (inst fst x))) ; maybe save it
1854      ;; Check for Inf or NaN
1855      (inst fxam)
1856      (inst fnstsw)
1857      (inst sahf)
1858      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
1859      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
1860      (inst and ah-tn #x02)            ; Test sign of Inf.
1861      (inst jmp :z DONE)          ; +Inf gives +Inf.
1862      (inst fstp fr0)                ; -Inf gives 0
1863      (inst fldz)
1864      (inst jmp-short DONE)
1865      NOINFNAN
1866      (inst fstp fr1)
1867      (inst fldl2e)
1868      (inst fmul fr1)
1869      ;; Now fr0=x log2(e)
1870      (inst fst fr1)
1871      (inst frndint)
1872      (inst fst fr2)
1873      (inst fsubp-sti fr1)
1874      (inst f2xm1)
1875      (inst fld1)
1876      (inst faddp-sti fr1)
1877      (inst fscale)
1878      (inst fld fr0)
1879      DONE
1880      (unless (zerop (tn-offset y))
1881              (inst fstd y))))
1882
1883 ;;; Expm1 = exp(x) - 1.
1884 ;;; Handles the following special cases:
1885 ;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
1886 (define-vop (fexpm1)
1887   (:translate %expm1)
1888   (:args (x :scs (double-reg) :target fr0))
1889   (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
1890   (:temporary (:sc double-reg :offset fr0-offset
1891                    :from :argument :to :result) fr0)
1892   (:temporary (:sc double-reg :offset fr1-offset
1893                    :from :argument :to :result) fr1)
1894   (:temporary (:sc double-reg :offset fr2-offset
1895                    :from :argument :to :result) fr2)
1896   (:results (y :scs (double-reg)))
1897   (:arg-types double-float)
1898   (:result-types double-float)
1899   (:policy :fast-safe)
1900   (:note "inline expm1 function")
1901   (:vop-var vop)
1902   (:save-p :compute-only)
1903   (:ignore temp)
1904   (:generator 5
1905      (note-this-location vop :internal-error)
1906      (unless (zerop (tn-offset x))
1907        (inst fxch x)            ; x to top of stack
1908        (unless (location= x y)
1909          (inst fst x))) ; maybe save it
1910      ;; Check for Inf or NaN
1911      (inst fxam)
1912      (inst fnstsw)
1913      (inst sahf)
1914      (inst jmp :nc NOINFNAN)        ; Neither Inf or NaN.
1915      (inst jmp :np NOINFNAN)        ; NaN gives NaN? Continue.
1916      (inst and ah-tn #x02)            ; Test sign of Inf.
1917      (inst jmp :z DONE)          ; +Inf gives +Inf.
1918      (inst fstp fr0)                ; -Inf gives -1.0
1919      (inst fld1)
1920      (inst fchs)
1921      (inst jmp-short DONE)
1922      NOINFNAN
1923      ;; Free two stack slots leaving the argument on top.
1924      (inst fstp fr2)
1925      (inst fstp fr0)
1926      (inst fldl2e)
1927      (inst fmul fr1)    ; Now fr0 = x log2(e)
1928      (inst fst fr1)
1929      (inst frndint)
1930      (inst fsub-sti fr1)
1931      (inst fxch fr1)
1932      (inst f2xm1)
1933      (inst fscale)
1934      (inst fxch fr1)
1935      (inst fld1)
1936      (inst fscale)
1937      (inst fstp fr1)
1938      (inst fld1)
1939      (inst fsub fr1)
1940      (inst fsubr fr2)
1941      DONE
1942      (unless (zerop (tn-offset y))
1943        (inst fstd y))))
1944
1945 (define-vop (flog)
1946   (:translate %log)
1947   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
1948   (:temporary (:sc double-reg :offset fr0-offset
1949                    :from :argument :to :result) fr0)
1950   (:temporary (:sc double-reg :offset fr1-offset
1951                    :from :argument :to :result) fr1)
1952   (:results (y :scs (double-reg)))
1953   (:arg-types double-float)
1954   (:result-types double-float)
1955   (:policy :fast-safe)
1956   (:note "inline log function")
1957   (:vop-var vop)
1958   (:save-p :compute-only)
1959   (:generator 5
1960      (note-this-location vop :internal-error)
1961      (sc-case x
1962         (double-reg
1963          (case (tn-offset x)
1964             (0
1965              ;; x is in fr0
1966              (inst fstp fr1)
1967              (inst fldln2)
1968              (inst fxch fr1))
1969             (1
1970              ;; x is in fr1
1971              (inst fstp fr0)
1972              (inst fldln2)
1973              (inst fxch fr1))
1974             (t
1975              ;; x is in a FP reg, not fr0 or fr1
1976              (inst fstp fr0)
1977              (inst fstp fr0)
1978              (inst fldln2)
1979              (inst fldd (make-random-tn :kind :normal
1980                                         :sc (sc-or-lose 'double-reg)
1981                                         :offset (1- (tn-offset x))))))
1982          (inst fyl2x))
1983         ((double-stack descriptor-reg)
1984          (inst fstp fr0)
1985          (inst fstp fr0)
1986          (inst fldln2)
1987          (if (sc-is x double-stack)
1988              (inst fldd (ea-for-df-stack x))
1989              (inst fldd (ea-for-df-desc x)))
1990          (inst fyl2x)))
1991      (inst fld fr0)
1992      (case (tn-offset y)
1993        ((0 1))
1994        (t (inst fstd y)))))
1995
1996 (define-vop (flog10)
1997   (:translate %log10)
1998   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
1999   (:temporary (:sc double-reg :offset fr0-offset
2000                    :from :argument :to :result) fr0)
2001   (:temporary (:sc double-reg :offset fr1-offset
2002                    :from :argument :to :result) fr1)
2003   (:results (y :scs (double-reg)))
2004   (:arg-types double-float)
2005   (:result-types double-float)
2006   (:policy :fast-safe)
2007   (:note "inline log10 function")
2008   (:vop-var vop)
2009   (:save-p :compute-only)
2010   (:generator 5
2011      (note-this-location vop :internal-error)
2012      (sc-case x
2013         (double-reg
2014          (case (tn-offset x)
2015             (0
2016              ;; x is in fr0
2017              (inst fstp fr1)
2018              (inst fldlg2)
2019              (inst fxch fr1))
2020             (1
2021              ;; x is in fr1
2022              (inst fstp fr0)
2023              (inst fldlg2)
2024              (inst fxch fr1))
2025             (t
2026              ;; x is in a FP reg, not fr0 or fr1
2027              (inst fstp fr0)
2028              (inst fstp fr0)
2029              (inst fldlg2)
2030              (inst fldd (make-random-tn :kind :normal
2031                                         :sc (sc-or-lose 'double-reg)
2032                                         :offset (1- (tn-offset x))))))
2033          (inst fyl2x))
2034         ((double-stack descriptor-reg)
2035          (inst fstp fr0)
2036          (inst fstp fr0)
2037          (inst fldlg2)
2038          (if (sc-is x double-stack)
2039              (inst fldd (ea-for-df-stack x))
2040              (inst fldd (ea-for-df-desc x)))
2041          (inst fyl2x)))
2042      (inst fld fr0)
2043      (case (tn-offset y)
2044        ((0 1))
2045        (t (inst fstd y)))))
2046
2047 (define-vop (fpow)
2048   (:translate %pow)
2049   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2050          (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2051   (:temporary (:sc double-reg :offset fr0-offset
2052                    :from (:argument 0) :to :result) fr0)
2053   (:temporary (:sc double-reg :offset fr1-offset
2054                    :from (:argument 1) :to :result) fr1)
2055   (:temporary (:sc double-reg :offset fr2-offset
2056                    :from :load :to :result) fr2)
2057   (:results (r :scs (double-reg)))
2058   (:arg-types double-float double-float)
2059   (:result-types double-float)
2060   (:policy :fast-safe)
2061   (:note "inline pow function")
2062   (:vop-var vop)
2063   (:save-p :compute-only)
2064   (:generator 5
2065      (note-this-location vop :internal-error)
2066      ;; Setup x in fr0 and y in fr1
2067      (cond
2068       ;; x in fr0; y in fr1
2069       ((and (sc-is x double-reg) (zerop (tn-offset x))
2070             (sc-is y double-reg) (= 1 (tn-offset y))))
2071       ;; y in fr1; x not in fr0
2072       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2073        ;; Load x to fr0
2074        (sc-case x
2075           (double-reg
2076            (copy-fp-reg-to-fr0 x))
2077           (double-stack
2078            (inst fstp fr0)
2079            (inst fldd (ea-for-df-stack x)))
2080           (descriptor-reg
2081            (inst fstp fr0)
2082            (inst fldd (ea-for-df-desc x)))))
2083       ;; x in fr0; y not in fr1
2084       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2085        (inst fxch fr1)
2086        ;; Now load y to fr0
2087        (sc-case y
2088           (double-reg
2089            (copy-fp-reg-to-fr0 y))
2090           (double-stack
2091            (inst fstp fr0)
2092            (inst fldd (ea-for-df-stack y)))
2093           (descriptor-reg
2094            (inst fstp fr0)
2095            (inst fldd (ea-for-df-desc y))))
2096        (inst fxch fr1))
2097       ;; x in fr1; y not in fr1
2098       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2099        ;; Load y to fr0
2100        (sc-case y
2101           (double-reg
2102            (copy-fp-reg-to-fr0 y))
2103           (double-stack
2104            (inst fstp fr0)
2105            (inst fldd (ea-for-df-stack y)))
2106           (descriptor-reg
2107            (inst fstp fr0)
2108            (inst fldd (ea-for-df-desc y))))
2109        (inst fxch fr1))
2110       ;; y in fr0;
2111       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2112        (inst fxch fr1)
2113        ;; Now load x to fr0
2114        (sc-case x
2115           (double-reg
2116            (copy-fp-reg-to-fr0 x))
2117           (double-stack
2118            (inst fstp fr0)
2119            (inst fldd (ea-for-df-stack x)))
2120           (descriptor-reg
2121            (inst fstp fr0)
2122            (inst fldd (ea-for-df-desc x)))))
2123       ;; Neither x or y are in either fr0 or fr1
2124       (t
2125        ;; Load y then x
2126        (inst fstp fr0)
2127        (inst fstp fr0)
2128        (sc-case y
2129           (double-reg
2130            (inst fldd (make-random-tn :kind :normal
2131                                       :sc (sc-or-lose 'double-reg)
2132                                       :offset (- (tn-offset y) 2))))
2133           (double-stack
2134            (inst fldd (ea-for-df-stack y)))
2135           (descriptor-reg
2136            (inst fldd (ea-for-df-desc y))))
2137        ;; Load x to fr0
2138        (sc-case x
2139           (double-reg
2140            (inst fldd (make-random-tn :kind :normal
2141                                       :sc (sc-or-lose 'double-reg)
2142                                       :offset (1- (tn-offset x)))))
2143           (double-stack
2144            (inst fldd (ea-for-df-stack x)))
2145           (descriptor-reg
2146            (inst fldd (ea-for-df-desc x))))))
2147
2148      ;; Now have x at fr0; and y at fr1
2149      (inst fyl2x)
2150      ;; Now fr0=y log2(x)
2151      (inst fld fr0)
2152      (inst frndint)
2153      (inst fst fr2)
2154      (inst fsubp-sti fr1)
2155      (inst f2xm1)
2156      (inst fld1)
2157      (inst faddp-sti fr1)
2158      (inst fscale)
2159      (inst fld fr0)
2160      (case (tn-offset r)
2161        ((0 1))
2162        (t (inst fstd r)))))
2163
2164 (define-vop (fscalen)
2165   (:translate %scalbn)
2166   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2167          (y :scs (signed-stack signed-reg) :target temp))
2168   (:temporary (:sc double-reg :offset fr0-offset
2169                    :from (:argument 0) :to :result) fr0)
2170   (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
2171   (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
2172   (:results (r :scs (double-reg)))
2173   (:arg-types double-float signed-num)
2174   (:result-types double-float)
2175   (:policy :fast-safe)
2176   (:note "inline scalbn function")
2177   (:generator 5
2178      ;; Setup x in fr0 and y in fr1
2179      (sc-case x
2180        (double-reg
2181         (case (tn-offset x)
2182           (0
2183            (inst fstp fr1)
2184            (sc-case y
2185              (signed-reg
2186               (inst mov temp y)
2187               (inst fild temp))
2188              (signed-stack
2189               (inst fild y)))
2190            (inst fxch fr1))
2191           (1
2192            (inst fstp fr0)
2193            (sc-case y
2194              (signed-reg
2195               (inst mov temp y)
2196               (inst fild temp))
2197              (signed-stack
2198               (inst fild y)))
2199            (inst fxch fr1))
2200           (t
2201            (inst fstp fr0)
2202            (inst fstp fr0)
2203            (sc-case y
2204              (signed-reg
2205               (inst mov temp y)
2206               (inst fild temp))
2207              (signed-stack
2208               (inst fild y)))
2209            (inst fld (make-random-tn :kind :normal
2210                                      :sc (sc-or-lose 'double-reg)
2211                                      :offset (1- (tn-offset x)))))))
2212        ((double-stack descriptor-reg)
2213         (inst fstp fr0)
2214         (inst fstp fr0)
2215         (sc-case y
2216           (signed-reg
2217            (inst mov temp y)
2218            (inst fild temp))
2219           (signed-stack
2220            (inst fild y)))
2221         (if (sc-is x double-stack)
2222             (inst fldd (ea-for-df-stack x))
2223             (inst fldd (ea-for-df-desc x)))))
2224      (inst fscale)
2225      (unless (zerop (tn-offset r))
2226        (inst fstd r))))
2227
2228 (define-vop (fscale)
2229   (:translate %scalb)
2230   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
2231          (y :scs (double-reg double-stack descriptor-reg) :target fr1))
2232   (:temporary (:sc double-reg :offset fr0-offset
2233                    :from (:argument 0) :to :result) fr0)
2234   (:temporary (:sc double-reg :offset fr1-offset
2235                    :from (:argument 1) :to :result) fr1)
2236   (:results (r :scs (double-reg)))
2237   (:arg-types double-float double-float)
2238   (:result-types double-float)
2239   (:policy :fast-safe)
2240   (:note "inline scalb function")
2241   (:vop-var vop)
2242   (:save-p :compute-only)
2243   (:generator 5
2244      (note-this-location vop :internal-error)
2245      ;; Setup x in fr0 and y in fr1
2246      (cond
2247       ;; x in fr0; y in fr1
2248       ((and (sc-is x double-reg) (zerop (tn-offset x))
2249             (sc-is y double-reg) (= 1 (tn-offset y))))
2250       ;; y in fr1; x not in fr0
2251       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2252        ;; Load x to fr0
2253        (sc-case x
2254           (double-reg
2255            (copy-fp-reg-to-fr0 x))
2256           (double-stack
2257            (inst fstp fr0)
2258            (inst fldd (ea-for-df-stack x)))
2259           (descriptor-reg
2260            (inst fstp fr0)
2261            (inst fldd (ea-for-df-desc x)))))
2262       ;; x in fr0; y not in fr1
2263       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2264        (inst fxch fr1)
2265        ;; Now load y to fr0
2266        (sc-case y
2267           (double-reg
2268            (copy-fp-reg-to-fr0 y))
2269           (double-stack
2270            (inst fstp fr0)
2271            (inst fldd (ea-for-df-stack y)))
2272           (descriptor-reg
2273            (inst fstp fr0)
2274            (inst fldd (ea-for-df-desc y))))
2275        (inst fxch fr1))
2276       ;; x in fr1; y not in fr1
2277       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2278        ;; Load y to fr0
2279        (sc-case y
2280           (double-reg
2281            (copy-fp-reg-to-fr0 y))
2282           (double-stack
2283            (inst fstp fr0)
2284            (inst fldd (ea-for-df-stack y)))
2285           (descriptor-reg
2286            (inst fstp fr0)
2287            (inst fldd (ea-for-df-desc y))))
2288        (inst fxch fr1))
2289       ;; y in fr0;
2290       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2291        (inst fxch fr1)
2292        ;; Now load x to fr0
2293        (sc-case x
2294           (double-reg
2295            (copy-fp-reg-to-fr0 x))
2296           (double-stack
2297            (inst fstp fr0)
2298            (inst fldd (ea-for-df-stack x)))
2299           (descriptor-reg
2300            (inst fstp fr0)
2301            (inst fldd (ea-for-df-desc x)))))
2302       ;; Neither x or y are in either fr0 or fr1
2303       (t
2304        ;; Load y then x
2305        (inst fstp fr0)
2306        (inst fstp fr0)
2307        (sc-case y
2308           (double-reg
2309            (inst fldd (make-random-tn :kind :normal
2310                                       :sc (sc-or-lose 'double-reg)
2311                                       :offset (- (tn-offset y) 2))))
2312           (double-stack
2313            (inst fldd (ea-for-df-stack y)))
2314           (descriptor-reg
2315            (inst fldd (ea-for-df-desc y))))
2316        ;; Load x to fr0
2317        (sc-case x
2318           (double-reg
2319            (inst fldd (make-random-tn :kind :normal
2320                                       :sc (sc-or-lose 'double-reg)
2321                                       :offset (1- (tn-offset x)))))
2322           (double-stack
2323            (inst fldd (ea-for-df-stack x)))
2324           (descriptor-reg
2325            (inst fldd (ea-for-df-desc x))))))
2326
2327      ;; Now have x at fr0; and y at fr1
2328      (inst fscale)
2329      (unless (zerop (tn-offset r))
2330              (inst fstd r))))
2331
2332 (define-vop (flog1p)
2333   (:translate %log1p)
2334   (:args (x :scs (double-reg) :to :result))
2335   (:temporary (:sc double-reg :offset fr0-offset
2336                    :from :argument :to :result) fr0)
2337   (:temporary (:sc double-reg :offset fr1-offset
2338                    :from :argument :to :result) fr1)
2339   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
2340   (:results (y :scs (double-reg)))
2341   (:arg-types double-float)
2342   (:result-types double-float)
2343   (:policy :fast-safe)
2344   (:note "inline log1p function")
2345   (:ignore temp)
2346   (:generator 5
2347      ;; x is in a FP reg, not fr0, fr1.
2348      (inst fstp fr0)
2349      (inst fstp fr0)
2350      (inst fldd (make-random-tn :kind :normal
2351                                 :sc (sc-or-lose 'double-reg)
2352                                 :offset (- (tn-offset x) 2)))
2353      ;; Check the range
2354      (inst push #x3e947ae1)     ; Constant 0.29
2355      (inst fabs)
2356      (inst fld (make-ea :dword :base rsp-tn))
2357      (inst fcompp)
2358      (inst add rsp-tn 4)
2359      (inst fnstsw)                      ; status word to ax
2360      (inst and ah-tn #x45)
2361      (inst jmp :z WITHIN-RANGE)
2362      ;; Out of range for fyl2xp1.
2363      (inst fld1)
2364      (inst faddd (make-random-tn :kind :normal
2365                                  :sc (sc-or-lose 'double-reg)
2366                                  :offset (- (tn-offset x) 1)))
2367      (inst fldln2)
2368      (inst fxch fr1)
2369      (inst fyl2x)
2370      (inst jmp DONE)
2371
2372      WITHIN-RANGE
2373      (inst fldln2)
2374      (inst fldd (make-random-tn :kind :normal
2375                                 :sc (sc-or-lose 'double-reg)
2376                                 :offset (- (tn-offset x) 1)))
2377      (inst fyl2xp1)
2378      DONE
2379      (inst fld fr0)
2380      (case (tn-offset y)
2381        ((0 1))
2382        (t (inst fstd y)))))
2383
2384 ;;; The Pentium has a less restricted implementation of the fyl2xp1
2385 ;;; instruction and a range check can be avoided.
2386 (define-vop (flog1p-pentium)
2387   (:translate %log1p)
2388   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2389   (:temporary (:sc double-reg :offset fr0-offset
2390                    :from :argument :to :result) fr0)
2391   (:temporary (:sc double-reg :offset fr1-offset
2392                    :from :argument :to :result) fr1)
2393   (:results (y :scs (double-reg)))
2394   (:arg-types double-float)
2395   (:result-types double-float)
2396   (:policy :fast-safe)
2397   (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
2398   (:note "inline log1p with limited x range function")
2399   (:vop-var vop)
2400   (:save-p :compute-only)
2401   (:generator 4
2402      (note-this-location vop :internal-error)
2403      (sc-case x
2404         (double-reg
2405          (case (tn-offset x)
2406             (0
2407              ;; x is in fr0
2408              (inst fstp fr1)
2409              (inst fldln2)
2410              (inst fxch fr1))
2411             (1
2412              ;; x is in fr1
2413              (inst fstp fr0)
2414              (inst fldln2)
2415              (inst fxch fr1))
2416             (t
2417              ;; x is in a FP reg, not fr0 or fr1
2418              (inst fstp fr0)
2419              (inst fstp fr0)
2420              (inst fldln2)
2421              (inst fldd (make-random-tn :kind :normal
2422                                         :sc (sc-or-lose 'double-reg)
2423                                         :offset (1- (tn-offset x)))))))
2424         ((double-stack descriptor-reg)
2425          (inst fstp fr0)
2426          (inst fstp fr0)
2427          (inst fldln2)
2428          (if (sc-is x double-stack)
2429              (inst fldd (ea-for-df-stack x))
2430            (inst fldd (ea-for-df-desc x)))))
2431      (inst fyl2xp1)
2432      (inst fld fr0)
2433      (case (tn-offset y)
2434        ((0 1))
2435        (t (inst fstd y)))))
2436
2437 (define-vop (flogb)
2438   (:translate %logb)
2439   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2440   (:temporary (:sc double-reg :offset fr0-offset
2441                    :from :argument :to :result) fr0)
2442   (:temporary (:sc double-reg :offset fr1-offset
2443                    :from :argument :to :result) fr1)
2444   (:results (y :scs (double-reg)))
2445   (:arg-types double-float)
2446   (:result-types double-float)
2447   (:policy :fast-safe)
2448   (:note "inline logb function")
2449   (:vop-var vop)
2450   (:save-p :compute-only)
2451   (:generator 5
2452      (note-this-location vop :internal-error)
2453      (sc-case x
2454         (double-reg
2455          (case (tn-offset x)
2456             (0
2457              ;; x is in fr0
2458              (inst fstp fr1))
2459             (1
2460              ;; x is in fr1
2461              (inst fstp fr0))
2462             (t
2463              ;; x is in a FP reg, not fr0 or fr1
2464              (inst fstp fr0)
2465              (inst fstp fr0)
2466              (inst fldd (make-random-tn :kind :normal
2467                                         :sc (sc-or-lose 'double-reg)
2468                                         :offset (- (tn-offset x) 2))))))
2469         ((double-stack descriptor-reg)
2470          (inst fstp fr0)
2471          (inst fstp fr0)
2472          (if (sc-is x double-stack)
2473              (inst fldd (ea-for-df-stack x))
2474            (inst fldd (ea-for-df-desc x)))))
2475      (inst fxtract)
2476      (case (tn-offset y)
2477        (0
2478         (inst fxch fr1))
2479        (1)
2480        (t (inst fxch fr1)
2481           (inst fstd y)))))
2482
2483 (define-vop (fatan)
2484   (:translate %atan)
2485   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
2486   (:temporary (:sc double-reg :offset fr0-offset
2487                    :from (:argument 0) :to :result) fr0)
2488   (:temporary (:sc double-reg :offset fr1-offset
2489                    :from (:argument 0) :to :result) fr1)
2490   (:results (r :scs (double-reg)))
2491   (:arg-types double-float)
2492   (:result-types double-float)
2493   (:policy :fast-safe)
2494   (:note "inline atan function")
2495   (:vop-var vop)
2496   (:save-p :compute-only)
2497   (:generator 5
2498      (note-this-location vop :internal-error)
2499      ;; Setup x in fr1 and 1.0 in fr0
2500      (cond
2501       ;; x in fr0
2502       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2503        (inst fstp fr1))
2504       ;; x in fr1
2505       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2506        (inst fstp fr0))
2507       ;; x not in fr0 or fr1
2508       (t
2509        ;; Load x then 1.0
2510        (inst fstp fr0)
2511        (inst fstp fr0)
2512        (sc-case x
2513           (double-reg
2514            (inst fldd (make-random-tn :kind :normal
2515                                       :sc (sc-or-lose 'double-reg)
2516                                       :offset (- (tn-offset x) 2))))
2517           (double-stack
2518            (inst fldd (ea-for-df-stack x)))
2519           (descriptor-reg
2520            (inst fldd (ea-for-df-desc x))))))
2521      (inst fld1)
2522      ;; Now have x at fr1; and 1.0 at fr0
2523      (inst fpatan)
2524      (inst fld fr0)
2525      (case (tn-offset r)
2526        ((0 1))
2527        (t (inst fstd r)))))
2528
2529 (define-vop (fatan2)
2530   (:translate %atan2)
2531   (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
2532          (y :scs (double-reg double-stack descriptor-reg) :target fr0))
2533   (:temporary (:sc double-reg :offset fr0-offset
2534                    :from (:argument 1) :to :result) fr0)
2535   (:temporary (:sc double-reg :offset fr1-offset
2536                    :from (:argument 0) :to :result) fr1)
2537   (:results (r :scs (double-reg)))
2538   (:arg-types double-float double-float)
2539   (:result-types double-float)
2540   (:policy :fast-safe)
2541   (:note "inline atan2 function")
2542   (:vop-var vop)
2543   (:save-p :compute-only)
2544   (:generator 5
2545      (note-this-location vop :internal-error)
2546      ;; Setup x in fr1 and y in fr0
2547      (cond
2548       ;; y in fr0; x in fr1
2549       ((and (sc-is y double-reg) (zerop (tn-offset y))
2550             (sc-is x double-reg) (= 1 (tn-offset x))))
2551       ;; x in fr1; y not in fr0
2552       ((and (sc-is x double-reg) (= 1 (tn-offset x)))
2553        ;; Load y to fr0
2554        (sc-case y
2555           (double-reg
2556            (copy-fp-reg-to-fr0 y))
2557           (double-stack
2558            (inst fstp fr0)
2559            (inst fldd (ea-for-df-stack y)))
2560           (descriptor-reg
2561            (inst fstp fr0)
2562            (inst fldd (ea-for-df-desc y)))))
2563       ((and (sc-is x double-reg) (zerop (tn-offset x))
2564             (sc-is y double-reg) (zerop (tn-offset x)))
2565        ;; copy x to fr1
2566        (inst fst fr1))
2567       ;; y in fr0; x not in fr1
2568       ((and (sc-is y double-reg) (zerop (tn-offset y)))
2569        (inst fxch fr1)
2570        ;; Now load x to fr0
2571        (sc-case x
2572           (double-reg
2573            (copy-fp-reg-to-fr0 x))
2574           (double-stack
2575            (inst fstp fr0)
2576            (inst fldd (ea-for-df-stack x)))
2577           (descriptor-reg
2578            (inst fstp fr0)
2579            (inst fldd (ea-for-df-desc x))))
2580        (inst fxch fr1))
2581       ;; y in fr1; x not in fr1
2582       ((and (sc-is y double-reg) (= 1 (tn-offset y)))
2583        ;; Load x to fr0
2584        (sc-case x
2585           (double-reg
2586            (copy-fp-reg-to-fr0 x))
2587           (double-stack
2588            (inst fstp fr0)
2589            (inst fldd (ea-for-df-stack x)))
2590           (descriptor-reg
2591            (inst fstp fr0)
2592            (inst fldd (ea-for-df-desc x))))
2593        (inst fxch fr1))
2594       ;; x in fr0;
2595       ((and (sc-is x double-reg) (zerop (tn-offset x)))
2596        (inst fxch fr1)
2597        ;; Now load y to fr0
2598        (sc-case y
2599           (double-reg
2600            (copy-fp-reg-to-fr0 y))
2601           (double-stack
2602            (inst fstp fr0)
2603            (inst fldd (ea-for-df-stack y)))
2604           (descriptor-reg
2605            (inst fstp fr0)
2606            (inst fldd (ea-for-df-desc y)))))
2607       ;; Neither y or x are in either fr0 or fr1
2608       (t
2609        ;; Load x then y
2610        (inst fstp fr0)
2611        (inst fstp fr0)
2612        (sc-case x
2613           (double-reg
2614            (inst fldd (make-random-tn :kind :normal
2615                                       :sc (sc-or-lose 'double-reg)
2616                                       :offset (- (tn-offset x) 2))))
2617           (double-stack
2618            (inst fldd (ea-for-df-stack x)))
2619           (descriptor-reg
2620            (inst fldd (ea-for-df-desc x))))
2621        ;; Load y to fr0
2622        (sc-case y
2623           (double-reg
2624            (inst fldd (make-random-tn :kind :normal
2625                                       :sc (sc-or-lose 'double-reg)
2626                                       :offset (1- (tn-offset y)))))
2627           (double-stack
2628            (inst fldd (ea-for-df-stack y)))
2629           (descriptor-reg
2630            (inst fldd (ea-for-df-desc y))))))
2631
2632      ;; Now have y at fr0; and x at fr1
2633      (inst fpatan)
2634      (inst fld fr0)
2635      (case (tn-offset r)
2636        ((0 1))
2637        (t (inst fstd r)))))
2638 ) ; PROGN #!-LONG-FLOAT
2639 \f
2640
2641 ;;;; complex float VOPs
2642
2643 (define-vop (make-complex-single-float)
2644   (:translate complex)
2645   (:args (real :scs (single-reg) :to :result :target r
2646                :load-if (not (location= real r)))
2647          (imag :scs (single-reg) :to :save))
2648   (:arg-types single-float single-float)
2649   (:results (r :scs (complex-single-reg) :from (:argument 0)
2650                :load-if (not (sc-is r complex-single-stack))))
2651   (:result-types complex-single-float)
2652   (:note "inline complex single-float creation")
2653   (:policy :fast-safe)
2654   (:generator 5
2655     (sc-case r
2656       (complex-single-reg
2657        (let ((r-real (complex-double-reg-real-tn r)))
2658          (unless (location= real r-real)
2659            (cond ((zerop (tn-offset r-real))
2660                   (copy-fp-reg-to-fr0 real))
2661                  ((zerop (tn-offset real))
2662                   (inst fstd r-real))
2663                  (t
2664                   (inst fxch real)
2665                   (inst fstd r-real)
2666                   (inst fxch real)))))
2667        (let ((r-imag (complex-double-reg-imag-tn r)))
2668          (unless (location= imag r-imag)
2669            (cond ((zerop (tn-offset imag))
2670                   (inst fstd r-imag))
2671                  (t
2672                   (inst fxch imag)
2673                   (inst fstd r-imag)
2674                   (inst fxch imag))))))
2675       (complex-single-stack
2676        (unless (location= real r)
2677          (cond ((zerop (tn-offset real))
2678                 (inst fst (ea-for-csf-real-stack r)))
2679                (t
2680                 (inst fxch real)
2681                 (inst fst (ea-for-csf-real-stack r))
2682                 (inst fxch real))))
2683        (inst fxch imag)
2684        (inst fst (ea-for-csf-imag-stack r))
2685        (inst fxch imag)))))
2686
2687 (define-vop (make-complex-double-float)
2688   (:translate complex)
2689   (:args (real :scs (double-reg) :target r
2690                :load-if (not (location= real r)))
2691          (imag :scs (double-reg) :to :save))
2692   (:arg-types double-float double-float)
2693   (:results (r :scs (complex-double-reg) :from (:argument 0)
2694                :load-if (not (sc-is r complex-double-stack))))
2695   (:result-types complex-double-float)
2696   (:note "inline complex double-float creation")
2697   (:policy :fast-safe)
2698   (:generator 5
2699     (sc-case r
2700       (complex-double-reg
2701        (let ((r-real (complex-double-reg-real-tn r)))
2702          (unless (location= real r-real)
2703            (cond ((zerop (tn-offset r-real))
2704                   (copy-fp-reg-to-fr0 real))
2705                  ((zerop (tn-offset real))
2706                   (inst fstd r-real))
2707                  (t
2708                   (inst fxch real)
2709                   (inst fstd r-real)
2710                   (inst fxch real)))))
2711        (let ((r-imag (complex-double-reg-imag-tn r)))
2712          (unless (location= imag r-imag)
2713            (cond ((zerop (tn-offset imag))
2714                   (inst fstd r-imag))
2715                  (t
2716                   (inst fxch imag)
2717                   (inst fstd r-imag)
2718                   (inst fxch imag))))))
2719       (complex-double-stack
2720        (unless (location= real r)
2721          (cond ((zerop (tn-offset real))
2722                 (inst fstd (ea-for-cdf-real-stack r)))
2723                (t
2724                 (inst fxch real)
2725                 (inst fstd (ea-for-cdf-real-stack r))
2726                 (inst fxch real))))
2727        (inst fxch imag)
2728        (inst fstd (ea-for-cdf-imag-stack r))
2729        (inst fxch imag)))))
2730
2731 (define-vop (complex-float-value)
2732   (:args (x :target r))
2733   (:results (r))
2734   (:variant-vars offset)
2735   (:policy :fast-safe)
2736   (:generator 3
2737     (cond ((sc-is x complex-single-reg complex-double-reg)
2738            (let ((value-tn
2739                   (make-random-tn :kind :normal
2740                                   :sc (sc-or-lose 'double-reg)
2741                                   :offset (+ offset (tn-offset x)))))
2742              (unless (location= value-tn r)
2743                (cond ((zerop (tn-offset r))
2744                       (copy-fp-reg-to-fr0 value-tn))
2745                      ((zerop (tn-offset value-tn))
2746                       (inst fstd r))
2747                      (t
2748                       (inst fxch value-tn)
2749                       (inst fstd r)
2750                       (inst fxch value-tn))))))
2751           ((sc-is r single-reg)
2752            (let ((ea (sc-case x
2753                        (complex-single-stack
2754                         (ecase offset
2755                           (0 (ea-for-csf-real-stack x))
2756                           (1 (ea-for-csf-imag-stack x))))
2757                        (descriptor-reg
2758                         (ecase offset
2759                           (0 (ea-for-csf-real-desc x))
2760                           (1 (ea-for-csf-imag-desc x)))))))
2761              (with-empty-tn@fp-top(r)
2762                (inst fld ea))))
2763           ((sc-is r double-reg)
2764            (let ((ea (sc-case x
2765                        (complex-double-stack
2766                         (ecase offset
2767                           (0 (ea-for-cdf-real-stack x))
2768                           (1 (ea-for-cdf-imag-stack x))))
2769                        (descriptor-reg
2770                         (ecase offset
2771                           (0 (ea-for-cdf-real-desc x))
2772                           (1 (ea-for-cdf-imag-desc x)))))))
2773              (with-empty-tn@fp-top(r)
2774                (inst fldd ea))))
2775           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
2776
2777 (define-vop (realpart/complex-single-float complex-float-value)
2778   (:translate realpart)
2779   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
2780             :target r))
2781   (:arg-types complex-single-float)
2782   (:results (r :scs (single-reg)))
2783   (:result-types single-float)
2784   (:note "complex float realpart")
2785   (:variant 0))
2786
2787 (define-vop (realpart/complex-double-float complex-float-value)
2788   (:translate realpart)
2789   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
2790             :target r))
2791   (:arg-types complex-double-float)
2792   (:results (r :scs (double-reg)))
2793   (:result-types double-float)
2794   (:note "complex float realpart")
2795   (:variant 0))
2796
2797 (define-vop (imagpart/complex-single-float complex-float-value)
2798   (:translate imagpart)
2799   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
2800             :target r))
2801   (:arg-types complex-single-float)
2802   (:results (r :scs (single-reg)))
2803   (:result-types single-float)
2804   (:note "complex float imagpart")
2805   (:variant 1))
2806
2807 (define-vop (imagpart/complex-double-float complex-float-value)
2808   (:translate imagpart)
2809   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
2810             :target r))
2811   (:arg-types complex-double-float)
2812   (:results (r :scs (double-reg)))
2813   (:result-types double-float)
2814   (:note "complex float imagpart")
2815   (:variant 1))
2816
2817 \f
2818 ;;; hack dummy VOPs to bias the representation selection of their
2819 ;;; arguments towards a FP register, which can help avoid consing at
2820 ;;; inappropriate locations
2821 (defknown double-float-reg-bias (double-float) (values))
2822 (define-vop (double-float-reg-bias)
2823   (:translate double-float-reg-bias)
2824   (:args (x :scs (double-reg double-stack) :load-if nil))
2825   (:arg-types double-float)
2826   (:policy :fast-safe)
2827   (:note "inline dummy FP register bias")
2828   (:ignore x)
2829   (:generator 0))
2830 (defknown single-float-reg-bias (single-float) (values))
2831 (define-vop (single-float-reg-bias)
2832   (:translate single-float-reg-bias)
2833   (:args (x :scs (single-reg single-stack) :load-if nil))
2834   (:arg-types single-float)
2835   (:policy :fast-safe)
2836   (:note "inline dummy FP register bias")
2837   (:ignore x)
2838   (:generator 0))