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