float.lisp

开源跨平台Lisp编译器

  (:args (float :scs (single-reg descriptor-reg)
                :load-if (not (sc-is float single-stack))))
  (:results (bits :scs (signed-reg)
                  :load-if (or (sc-is float descriptor-reg single-stack)
                               (not (sc-is bits signed-stack)))))
  (:temporary (:scs (signed-stack)) stack-temp)
  (:arg-types single-float)
  (:result-types signed-num)
  (:translate single-float-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (sc-case bits
      (signed-reg
       (sc-case float
         (single-reg
          (inst stfs float (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes))
          (inst lwz bits (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes)))
         (single-stack
          (inst lwz bits (current-nfp-tn vop)
                (* (tn-offset float) n-word-bytes)))
         (descriptor-reg
          (loadw bits float single-float-value-slot other-pointer-lowtag))))
      (signed-stack
       (sc-case float
         (single-reg
          (inst stfs float (current-nfp-tn vop)
                (* (tn-offset bits) n-word-bytes))))))))

(define-vop (double-float-high-bits)
  (:args (float :scs (double-reg descriptor-reg)
                :load-if (not (sc-is float double-stack))))
  (:results (hi-bits :scs (signed-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types double-float)
  (:result-types signed-num)
  (:translate double-float-high-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (double-reg
        (inst stfd float (current-nfp-tn vop)
              (* (tn-offset stack-temp) n-word-bytes))
        (inst lwz hi-bits (current-nfp-tn vop)
              (* (tn-offset stack-temp) n-word-bytes)))
      (double-stack
        (inst lwz hi-bits (current-nfp-tn vop)
              (* (tn-offset float) n-word-bytes)))
      (descriptor-reg
        (loadw hi-bits float double-float-value-slot
               other-pointer-lowtag)))))

(define-vop (double-float-low-bits)
  (:args (float :scs (double-reg descriptor-reg)
                :load-if (not (sc-is float double-stack))))
  (:results (lo-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types double-float)
  (:result-types unsigned-num)
  (:translate double-float-low-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (double-reg
        (inst stfd float (current-nfp-tn vop)
              (* (tn-offset stack-temp) n-word-bytes))
        (inst lwz lo-bits (current-nfp-tn vop)
              (* (1+ (tn-offset stack-temp)) n-word-bytes)))
      (double-stack
        (inst lwz lo-bits (current-nfp-tn vop)
              (* (1+ (tn-offset float)) n-word-bytes)))
      (descriptor-reg
        (loadw lo-bits float (1+ double-float-value-slot)
               other-pointer-lowtag)))))

;;;; Float mode hackery:

(sb!xc:deftype float-modes () '(unsigned-byte 32))
(defknown floating-point-modes () float-modes (flushable))
(defknown ((setf floating-point-modes)) (float-modes)
  float-modes)

(define-vop (floating-point-modes)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate floating-point-modes)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:sc double-stack) temp)
  (:temporary (:sc single-reg) fp-temp)
  (:generator 3
    (let ((nfp (current-nfp-tn vop)))
      (inst mffs fp-temp)
      (inst stfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
      (loadw res nfp (1+ (tn-offset temp))))))

(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc double-stack) temp)
  (:temporary (:sc single-reg) fp-temp)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop)))
      (storew new nfp (1+ (tn-offset temp)))
      (inst lfd fp-temp nfp (* n-word-bytes (tn-offset temp)))
      (inst mtfsf 255 fp-temp)
      (move res new))))


;;;; Complex float VOPs

(define-vop (make-complex-single-float)
  (:translate complex)
  (:args (real :scs (single-reg) :target r
               :load-if (not (location= real r)))
         (imag :scs (single-reg) :to :save))
  (:arg-types single-float single-float)
  (:results (r :scs (complex-single-reg) :from (:argument 0)
               :load-if (not (sc-is r complex-single-stack))))
  (:result-types complex-single-float)
  (:note "inline complex single-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-single-reg
       (let ((r-real (complex-single-reg-real-tn r)))
         (unless (location= real r-real)
           (inst fmr r-real real)))
       (let ((r-imag (complex-single-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmr r-imag imag))))
      (complex-single-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (unless (location= real r)
           (inst stfs real nfp offset))
         (inst stfs imag nfp (+ offset n-word-bytes)))))))

(define-vop (make-complex-double-float)
  (:translate complex)
  (:args (real :scs (double-reg) :target r
               :load-if (not (location= real r)))
         (imag :scs (double-reg) :to :save))
  (:arg-types double-float double-float)
  (:results (r :scs (complex-double-reg) :from (:argument 0)
               :load-if (not (sc-is r complex-double-stack))))
  (:result-types complex-double-float)
  (:note "inline complex double-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-double-reg
       (let ((r-real (complex-double-reg-real-tn r)))
         (unless (location= real r-real)
           (inst fmr r-real real)))
       (let ((r-imag (complex-double-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmr r-imag imag))))
      (complex-double-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (unless (location= real r)
           (inst stfd real nfp offset))
         (inst stfd imag nfp (+ offset (* 2 n-word-bytes))))))))


(define-vop (complex-single-float-value)
  (:args (x :scs (complex-single-reg) :target r
            :load-if (not (sc-is x complex-single-stack))))
  (:arg-types complex-single-float)
  (:results (r :scs (single-reg)))
  (:result-types single-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (sc-case x
      (complex-single-reg
       (let ((value-tn (ecase slot
                         (:real (complex-single-reg-real-tn x))
                         (:imag (complex-single-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (inst fmr r value-tn))))
      (complex-single-stack
       (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
                                              (tn-offset x))
                                           n-word-bytes))))))

(define-vop (realpart/complex-single-float complex-single-float-value)
  (:translate realpart)
  (:note "complex single float realpart")
  (:variant :real))

(define-vop (imagpart/complex-single-float complex-single-float-value)
  (:translate imagpart)
  (:note "complex single float imagpart")
  (:variant :imag))

(define-vop (complex-double-float-value)
  (:args (x :scs (complex-double-reg) :target r
            :load-if (not (sc-is x complex-double-stack))))
  (:arg-types complex-double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (sc-case x
      (complex-double-reg
       (let ((value-tn (ecase slot
                         (:real (complex-double-reg-real-tn x))
                         (:imag (complex-double-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (inst fmr r value-tn))))
      (complex-double-stack
       (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
                                              (tn-offset x))
                                           n-word-bytes))))))

(define-vop (realpart/complex-double-float complex-double-float-value)
  (:translate realpart)
  (:note "complex double float realpart")
  (:variant :real))

(define-vop (imagpart/complex-double-float complex-double-float-value)
  (:translate imagpart)
  (:note "complex double float imagpart")
  (:variant :imag))

;; This vop and the next are intended to be used only for moving a
;; float to an integer arg location (register or stack) for C callout.
;; See %alien-funcall ir2convert in aliencomp.lisp.

#!+darwin
(define-vop (move-double-to-int-arg)
  (:args (float :scs (double-reg)))
  (:results (hi-bits :scs (signed-reg signed-stack))
            (lo-bits :scs (unsigned-reg unsigned-stack)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:temporary (:scs (signed-reg)) temp)
  (:arg-types double-float)
  (:result-types signed-num unsigned-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (double-reg
       (inst stfd float (current-nfp-tn vop)
             (* (tn-offset stack-temp) n-word-bytes))
       (sc-case hi-bits
         (signed-reg
          (inst lwz hi-bits (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes)))
         (signed-stack
          (inst lwz temp (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes))
          (inst stw temp nsp-tn
                (* (tn-offset hi-bits) n-word-bytes))))
       (sc-case lo-bits
         (unsigned-reg
          (inst lwz lo-bits (current-nfp-tn vop)
                (* (1+ (tn-offset stack-temp)) n-word-bytes)))
         (unsigned-stack
          (inst lwz temp (current-nfp-tn vop)
                (* (1+ (tn-offset stack-temp)) n-word-bytes))
          (inst stw temp nsp-tn
                (* (tn-offset lo-bits) n-word-bytes))))))))

#!+darwin
(define-vop (move-single-to-int-arg)
  (:args (float :scs (single-reg)))
  (:results (bits :scs (signed-reg signed-stack)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:temporary (:scs (signed-reg)) temp)
  (:arg-types single-float)
  (:result-types signed-num)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (single-reg
       (inst stfs float (current-nfp-tn vop)
             (* (tn-offset stack-temp) n-word-bytes))
       (sc-case bits
         (signed-reg
          (inst lwz bits (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes)))
         (signed-stack
          (inst lwz temp (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes))
          (inst stw temp nsp-tn
                (* (tn-offset bits) n-word-bytes))))))))