float.lisp

开源跨平台Lisp编译器

  (frob %unary-truncate double-reg double-float cvttq/c_sv)
  (frob %unary-round single-reg single-float cvttq_sv t)
  (frob %unary-round double-reg double-float cvttq_sv))

(define-vop (make-single-float)
  (:args (bits :scs (signed-reg) :target res
               :load-if (not (sc-is bits signed-stack))))
  (:results (res :scs (single-reg)
                 :load-if (not (sc-is res single-stack))))
  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (signed-stack)) stack-temp)
  (:arg-types signed-num)
  (:result-types single-float)
  (:translate make-single-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (sc-case bits
      (signed-reg
       (sc-case res
         (single-reg
          (inst stl bits
                (* (tn-offset stack-temp) n-word-bytes)
                (current-nfp-tn vop))
          (inst lds res
                (* (tn-offset stack-temp) n-word-bytes)
                (current-nfp-tn vop)))
         (single-stack
          (inst stl bits
                (* (tn-offset res) n-word-bytes)
                (current-nfp-tn vop)))))
      (signed-stack
       (sc-case res
         (single-reg
          (inst lds res
                (* (tn-offset bits) n-word-bytes)
                (current-nfp-tn vop)))
         (single-stack
          (unless (location= bits res)
            (inst ldl temp
                  (* (tn-offset bits) n-word-bytes)
                  (current-nfp-tn vop))
            (inst stl temp
                  (* (tn-offset res) n-word-bytes)
                  (current-nfp-tn vop)))))))))

(define-vop (make-double-float)
  (:args (hi-bits :scs (signed-reg))
         (lo-bits :scs (unsigned-reg)))
  (:results (res :scs (double-reg)
                 :load-if (not (sc-is res double-stack))))
  (:temporary (:scs (double-stack)) temp)
  (:arg-types signed-num unsigned-num)
  (:result-types double-float)
  (:translate make-double-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let ((stack-tn (sc-case res
                      (double-stack res)
                      (double-reg temp))))
      (inst stl hi-bits
            (* (1+ (tn-offset stack-tn)) n-word-bytes)
            (current-nfp-tn vop))
      (inst stl lo-bits
            (* (tn-offset stack-tn) n-word-bytes)
            (current-nfp-tn vop)))
    (when (sc-is res double-reg)
      (inst ldt res
            (* (tn-offset temp) n-word-bytes)
            (current-nfp-tn vop)))))

(define-vop (single-float-bits)
  (: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 sts float
                (* (tn-offset stack-temp) n-word-bytes)
                (current-nfp-tn vop))
          (inst ldl bits
                (* (tn-offset stack-temp) n-word-bytes)
                (current-nfp-tn vop)))
         (single-stack
          (inst ldl bits
                (* (tn-offset float) n-word-bytes)
                (current-nfp-tn vop)))
         (descriptor-reg
          (loadw bits float single-float-value-slot
                 other-pointer-lowtag))))
      (signed-stack
       (sc-case float
         (single-reg
          (inst sts float
                (* (tn-offset bits) n-word-bytes)
                (current-nfp-tn vop))))))))

(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 stt float
              (* (tn-offset stack-temp) n-word-bytes)
              (current-nfp-tn vop))
        (inst ldl hi-bits
              (* (1+ (tn-offset stack-temp)) n-word-bytes)
              (current-nfp-tn vop)))
      (double-stack
        (inst ldl hi-bits
              (* (1+ (tn-offset float)) n-word-bytes)
              (current-nfp-tn vop)))
      (descriptor-reg
        (loadw hi-bits float (1+ 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 stt float
              (* (tn-offset stack-temp) n-word-bytes)
              (current-nfp-tn vop))
        (inst ldl lo-bits
              (* (tn-offset stack-temp) n-word-bytes)
              (current-nfp-tn vop)))
      (double-stack
       (inst ldl lo-bits
             (* (tn-offset float) n-word-bytes)
             (current-nfp-tn vop)))
      (descriptor-reg
       (loadw lo-bits float double-float-value-slot
              other-pointer-lowtag)))
    (inst mskll lo-bits 4 lo-bits)))


;;;; float mode hackery has moved to alpha-vm.lisp


;;;; complex float VOPs

(define-vop (make-complex-single-float)
  (:translate complex)
  (:args (real :scs (single-reg) :target 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 fmove real r-real)))
       (let ((r-imag (complex-single-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmove imag r-imag))))
      (complex-single-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (inst sts real offset nfp)
         (inst sts imag (+ offset n-word-bytes) nfp))))))

(define-vop (make-complex-double-float)
  (:translate complex)
  (:args (real :scs (double-reg) :target 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 fmove real r-real)))
       (let ((r-imag (complex-double-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmove imag r-imag))))
      (complex-double-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (inst stt real offset nfp)
         (inst stt imag (+ offset (* 2 n-word-bytes)) nfp))))))

(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 fmove value-tn r))))
      (complex-single-stack
       (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
                      n-word-bytes)
             (current-nfp-tn vop))))))

(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 fmove value-tn r))))
      (complex-double-stack
       (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
                      n-word-bytes)
             (current-nfp-tn vop))))))

(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))