float.lisp

开源跨平台Lisp编译器

;;;; floating point support for the x86

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

(macrolet ((ea-for-xf-desc (tn slot)
             `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag)))
  (defun ea-for-sf-desc (tn)
    (ea-for-xf-desc tn single-float-value-slot))
  (defun ea-for-df-desc (tn)
    (ea-for-xf-desc tn double-float-value-slot))
  #!+long-float
  (defun ea-for-lf-desc (tn)
    (ea-for-xf-desc tn long-float-value-slot))
  ;; complex floats
  (defun ea-for-csf-real-desc (tn)
    (ea-for-xf-desc tn complex-single-float-real-slot))
  (defun ea-for-csf-imag-desc (tn)
    (ea-for-xf-desc tn complex-single-float-imag-slot))
  (defun ea-for-cdf-real-desc (tn)
    (ea-for-xf-desc tn complex-double-float-real-slot))
  (defun ea-for-cdf-imag-desc (tn)
    (ea-for-xf-desc tn complex-double-float-imag-slot))
  #!+long-float
  (defun ea-for-clf-real-desc (tn)
    (ea-for-xf-desc tn complex-long-float-real-slot))
  #!+long-float
  (defun ea-for-clf-imag-desc (tn)
    (ea-for-xf-desc tn complex-long-float-imag-slot)))

(macrolet ((ea-for-xf-stack (tn kind)
             `(make-ea
               :dword :base ebp-tn
               :disp (frame-byte-offset
                      (+ (tn-offset ,tn)
                       (ecase ,kind (:single 0) (:double 1) (:long 2)))))))
  (defun ea-for-sf-stack (tn)
    (ea-for-xf-stack tn :single))
  (defun ea-for-df-stack (tn)
    (ea-for-xf-stack tn :double))
  #!+long-float
  (defun ea-for-lf-stack (tn)
    (ea-for-xf-stack tn :long)))

;;; Telling the FPU to wait is required in order to make signals occur
;;; at the expected place, but naturally slows things down.
;;;
;;; NODE is the node whose compilation policy controls the decision
;;; whether to just blast through carelessly or carefully emit wait
;;; instructions and whatnot.
;;;
;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
;;; #'NOTE-NEXT-INSTRUCTION.
;;;
;;; Until 2004-03-15, the implementation of this was buggy; it
;;; unconditionally emitted the WAIT instruction.  It turns out that
;;; this is the right thing to do anyway; omitting them can lead to
;;; system corruption on conforming code.  -- CSR
(defun maybe-fp-wait (node &optional note-next-instruction)
  (declare (ignore node))
  #+nil
  (when (policy node (or (= debug 3) (> safety speed))))
  (when note-next-instruction
    (note-next-instruction note-next-instruction :internal-error))
  (inst wait))

;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
             `(make-ea
               :dword :base ,base
               :disp (frame-byte-offset
                      (+ (tn-offset ,tn)
                       -1
                       (* (ecase ,kind
                            (:single 1)
                            (:double 2)
                            (:long 3))
                          (ecase ,slot (:real 1) (:imag 2))))))))
  (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
    (ea-for-cxf-stack tn :single :real base))
  (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
    (ea-for-cxf-stack tn :single :imag base))
  (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
    (ea-for-cxf-stack tn :double :real base))
  (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
    (ea-for-cxf-stack tn :double :imag base))
  #!+long-float
  (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
    (ea-for-cxf-stack tn :long :real base))
  #!+long-float
  (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
    (ea-for-cxf-stack tn :long :imag base)))

;;; Abstract out the copying of a FP register to the FP stack top, and
;;; provide two alternatives for its implementation. Note: it's not
;;; necessary to distinguish between a single or double register move
;;; here.
;;;
;;; Using a Pop then load.
(defun copy-fp-reg-to-fr0 (reg)
  (aver (not (zerop (tn-offset reg))))
  (inst fstp fr0-tn)
  (inst fld (make-random-tn :kind :normal
                            :sc (sc-or-lose 'double-reg)
                            :offset (1- (tn-offset reg)))))
;;; Using Fxch then Fst to restore the original reg contents.
#+nil
(defun copy-fp-reg-to-fr0 (reg)
  (aver (not (zerop (tn-offset reg))))
  (inst fxch reg)
  (inst fst  reg))

;;; The x86 can't store a long-float to memory without popping the
;;; stack and marking a register as empty, so it is necessary to
;;; restore the register from memory.
#!+long-float
(defun store-long-float (ea)
   (inst fstpl ea)
   (inst fldl ea))

;;;; move functions

;;; X is source, Y is destination.
(define-move-fun (load-single 2) (vop x y)
  ((single-stack) (single-reg))
  (with-empty-tn@fp-top(y)
     (inst fld (ea-for-sf-stack x))))

(define-move-fun (store-single 2) (vop x y)
  ((single-reg) (single-stack))
  (cond ((zerop (tn-offset x))
         (inst fst (ea-for-sf-stack y)))
        (t
         (inst fxch x)
         (inst fst (ea-for-sf-stack y))
         ;; This may not be necessary as ST0 is likely invalid now.
         (inst fxch x))))

(define-move-fun (load-double 2) (vop x y)
  ((double-stack) (double-reg))
  (with-empty-tn@fp-top(y)
     (inst fldd (ea-for-df-stack x))))

(define-move-fun (store-double 2) (vop x y)
  ((double-reg) (double-stack))
  (cond ((zerop (tn-offset x))
         (inst fstd (ea-for-df-stack y)))
        (t
         (inst fxch x)
         (inst fstd (ea-for-df-stack y))
         ;; This may not be necessary as ST0 is likely invalid now.
         (inst fxch x))))

#!+long-float
(define-move-fun (load-long 2) (vop x y)
  ((long-stack) (long-reg))
  (with-empty-tn@fp-top(y)
     (inst fldl (ea-for-lf-stack x))))

#!+long-float
(define-move-fun (store-long 2) (vop x y)
  ((long-reg) (long-stack))
  (cond ((zerop (tn-offset x))
         (store-long-float (ea-for-lf-stack y)))
        (t
         (inst fxch x)
         (store-long-float (ea-for-lf-stack y))
         ;; This may not be necessary as ST0 is likely invalid now.
         (inst fxch x))))

;;; The i387 has instructions to load some useful constants. This
;;; doesn't save much time but might cut down on memory access and
;;; reduce the size of the constant vector (CV). Intel claims they are
;;; stored in a more precise form on chip. Anyhow, might as well use
;;; the feature. It can be turned off by hacking the
;;; "immediate-constant-sc" in vm.lisp.
(eval-when (:compile-toplevel :execute)
  (setf *read-default-float-format*
        #!+long-float 'long-float #!-long-float 'double-float))
(define-move-fun (load-fp-constant 2) (vop x y)
  ((fp-constant) (single-reg double-reg #!+long-float long-reg))
  (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
    (with-empty-tn@fp-top(y)
      (cond ((zerop value)
             (inst fldz))
            ((= value 1e0)
             (inst fld1))
            ((= value (coerce pi *read-default-float-format*))
             (inst fldpi))
            ((= value (log 10e0 2e0))
             (inst fldl2t))
            ((= value (log 2.718281828459045235360287471352662e0 2e0))
             (inst fldl2e))
            ((= value (log 2e0 10e0))
             (inst fldlg2))
            ((= value (log 2e0 2.718281828459045235360287471352662e0))
             (inst fldln2))
            (t (warn "ignoring bogus i387 constant ~A" value))))))
(eval-when (:compile-toplevel :execute)
  (setf *read-default-float-format* 'single-float))

;;;; complex float move functions

(defun complex-single-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
                  :offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
                  :offset (1+ (tn-offset x))))

(defun complex-double-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
                  :offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
                  :offset (1+ (tn-offset x))))

#!+long-float
(defun complex-long-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
                  :offset (tn-offset x)))
#!+long-float
(defun complex-long-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
                  :offset (1+ (tn-offset x))))

;;; X is source, Y is destination.
(define-move-fun (load-complex-single 2) (vop x y)
  ((complex-single-stack) (complex-single-reg))
  (let ((real-tn (complex-single-reg-real-tn y)))
    (with-empty-tn@fp-top (real-tn)
      (inst fld (ea-for-csf-real-stack x))))
  (let ((imag-tn (complex-single-reg-imag-tn y)))
    (with-empty-tn@fp-top (imag-tn)
      (inst fld (ea-for-csf-imag-stack x)))))

(define-move-fun (store-complex-single 2) (vop x y)
  ((complex-single-reg) (complex-single-stack))
  (let ((real-tn (complex-single-reg-real-tn x)))
    (cond ((zerop (tn-offset real-tn))
           (inst fst (ea-for-csf-real-stack y)))
          (t
           (inst fxch real-tn)
           (inst fst (ea-for-csf-real-stack y))
           (inst fxch real-tn))))
  (let ((imag-tn (complex-single-reg-imag-tn x)))
    (inst fxch imag-tn)
    (inst fst (ea-for-csf-imag-stack y))
    (inst fxch imag-tn)))

(define-move-fun (load-complex-double 2) (vop x y)
  ((complex-double-stack) (complex-double-reg))
  (let ((real-tn (complex-double-reg-real-tn y)))
    (with-empty-tn@fp-top(real-tn)
      (inst fldd (ea-for-cdf-real-stack x))))
  (let ((imag-tn (complex-double-reg-imag-tn y)))
    (with-empty-tn@fp-top(imag-tn)
      (inst fldd (ea-for-cdf-imag-stack x)))))

(define-move-fun (store-complex-double 2) (vop x y)
  ((complex-double-reg) (complex-double-stack))
  (let ((real-tn (complex-double-reg-real-tn x)))
    (cond ((zerop (tn-offset real-tn))
           (inst fstd (ea-for-cdf-real-stack y)))
          (t
           (inst fxch real-tn)
           (inst fstd (ea-for-cdf-real-stack y))
           (inst fxch real-tn))))
  (let ((imag-tn (complex-double-reg-imag-tn x)))
    (inst fxch imag-tn)
    (inst fstd (ea-for-cdf-imag-stack y))
    (inst fxch imag-tn)))

#!+long-float
(define-move-fun (load-complex-long 2) (vop x y)
  ((complex-long-stack) (complex-long-reg))
  (let ((real-tn (complex-long-reg-real-tn y)))
    (with-empty-tn@fp-top(real-tn)
      (inst fldl (ea-for-clf-real-stack x))))
  (let ((imag-tn (complex-long-reg-imag-tn y)))
    (with-empty-tn@fp-top(imag-tn)
      (inst fldl (ea-for-clf-imag-stack x)))))

#!+long-float
(define-move-fun (store-complex-long 2) (vop x y)
  ((complex-long-reg) (complex-long-stack))
  (let ((real-tn (complex-long-reg-real-tn x)))
    (cond ((zerop (tn-offset real-tn))
           (store-long-float (ea-for-clf-real-stack y)))
          (t
           (inst fxch real-tn)
           (store-long-float (ea-for-clf-real-stack y))
           (inst fxch real-tn))))
  (let ((imag-tn (complex-long-reg-imag-tn x)))
    (inst fxch imag-tn)
    (store-long-float (ea-for-clf-imag-stack y))
    (inst fxch imag-tn)))


;;;; move VOPs

;;; float register to register moves
(define-vop (float-move)
  (:args (x))
  (:results (y))
  (:note "float move")
  (:generator 0
     (unless (location= x y)
        (cond ((zerop (tn-offset y))
               (copy-fp-reg-to-fr0 x))
              ((zerop (tn-offset x))
               (inst fstd y))
              (t
               (inst fxch x)
               (inst fstd y)
               (inst fxch x))))))

(define-vop (single-move float-move)
  (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
  (:results (y :scs (single-reg) :load-if (not (location= x y)))))
(define-move-vop single-move :move (single-reg) (single-reg))

(define-vop (double-move float-move)
  (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
  (:results (y :scs (double-reg) :load-if (not (location= x y)))))
(define-move-vop double-move :move (double-reg) (double-reg))

#!+long-float
(define-vop (long-move float-move)
  (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
  (:results (y :scs (long-reg) :load-if (not (location= x y)))))
#!+long-float
(define-move-vop long-move :move (long-reg) (long-reg))

;;; complex float register to register moves
(define-vop (complex-float-move)
  (:args (x :target y :load-if (not (location= x y))))