float.lisp

开源跨平台Lisp编译器

(define-vop (move-from-complex-double)
  (:args (x :scs (complex-double-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
  (:note "complex double float to pointer coercion")
  (:generator 13
    (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
                              complex-double-float-size nil)
      (let ((real-tn (complex-double-reg-real-tn x)))
        (str-double real-tn y (- (* complex-double-float-real-slot
                                    n-word-bytes)
                                 other-pointer-lowtag)))
      (let ((imag-tn (complex-double-reg-imag-tn x)))
        (str-double imag-tn y (- (* complex-double-float-imag-slot
                                    n-word-bytes)
                                 other-pointer-lowtag))))))
(define-move-vop move-from-complex-double :move
  (complex-double-reg) (descriptor-reg))

;;; Move from a descriptor to a complex float register
(define-vop (move-to-complex-single)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (complex-single-reg)))
  (:note "pointer to complex float coercion")
  (:generator 2
    (let ((real-tn (complex-single-reg-real-tn y)))
      (inst lwc1 real-tn x (- (* complex-single-float-real-slot n-word-bytes)
                              other-pointer-lowtag)))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
      (inst lwc1 imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
                              other-pointer-lowtag)))
    (inst nop)))
(define-move-vop move-to-complex-single :move
  (descriptor-reg) (complex-single-reg))

(define-vop (move-to-complex-double)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (complex-double-reg)))
  (:note "pointer to complex float coercion")
  (:generator 2
    (let ((real-tn (complex-double-reg-real-tn y)))
      (ld-double real-tn x (- (* complex-double-float-real-slot n-word-bytes)
                              other-pointer-lowtag)))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
      (ld-double imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
                              other-pointer-lowtag)))
    (inst nop)))
(define-move-vop move-to-complex-double :move
  (descriptor-reg) (complex-double-reg))

;;; complex float MOVE-ARG VOP
(define-vop (move-complex-single-float-arg)
  (:args (x :scs (complex-single-reg) :target y)
         (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
  (:results (y))
  (:note "complex single-float argument move")
  (:generator 1
    (sc-case y
      (complex-single-reg
       (unless (location= x y)
         (let ((x-real (complex-single-reg-real-tn x))
               (y-real (complex-single-reg-real-tn y)))
           (inst fmove :single y-real x-real))
         (let ((x-imag (complex-single-reg-imag-tn x))
               (y-imag (complex-single-reg-imag-tn y)))
           (inst fmove :single y-imag x-imag))))
      (complex-single-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-single-reg-real-tn x)))
           (inst swc1 real-tn nfp offset))
         (let ((imag-tn (complex-single-reg-imag-tn x)))
           (inst swc1 imag-tn nfp (+ offset n-word-bytes))))))))
(define-move-vop move-complex-single-float-arg :move-arg
  (complex-single-reg descriptor-reg) (complex-single-reg))

(define-vop (move-complex-double-float-arg)
  (:args (x :scs (complex-double-reg) :target y)
         (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
  (:results (y))
  (:note "complex double-float argument move")
  (:generator 2
    (sc-case y
      (complex-double-reg
       (unless (location= x y)
         (let ((x-real (complex-double-reg-real-tn x))
               (y-real (complex-double-reg-real-tn y)))
           (inst fmove :double y-real x-real))
         (let ((x-imag (complex-double-reg-imag-tn x))
               (y-imag (complex-double-reg-imag-tn y)))
           (inst fmove :double y-imag x-imag))))
      (complex-double-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-double-reg-real-tn x)))
           (str-double real-tn nfp offset))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
           (str-double imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
(define-move-vop move-complex-double-float-arg :move-arg
  (complex-double-reg descriptor-reg) (complex-double-reg))

(define-move-vop move-arg :move-arg
  (single-reg double-reg complex-single-reg complex-double-reg)
  (descriptor-reg))


;;;; stuff for c-call float-in-int-register arguments
(define-vop (move-to-single-int-reg)
  (:args (x :scs (single-reg descriptor-reg)))
  (:results (y :scs (single-int-carg-reg) :load-if nil))
  (:note "pointer to float-in-int coercion")
  (:generator 1
    (sc-case x
      (single-reg
       (inst mfc1 y x))
      (descriptor-reg
       (inst lw y x (- (* single-float-value-slot n-word-bytes)
                       other-pointer-lowtag))))
    (inst nop)))                        ;nop needed here?
(define-move-vop move-to-single-int-reg
    :move (single-reg descriptor-reg) (single-int-carg-reg))

(define-vop (move-single-int-reg)
  (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
         (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
  (:results (y :scs (single-int-carg-reg) :load-if nil))
  (:generator 1
    (unless (location= x y)
      (error "Huh? why did it do that?"))))
(define-move-vop move-single-int-reg :move-arg
  (single-int-carg-reg) (single-int-carg-reg))

(define-vop (move-to-double-int-reg)
  (:args (x :scs (double-reg descriptor-reg)))
  (:results (y :scs (double-int-carg-reg) :load-if nil))
  (:note "pointer to float-in-int coercion")
  (:generator 2
    (sc-case x
      (double-reg
       (ecase *backend-byte-order*
         (:big-endian
          (inst mfc1-odd2 y x)
          (inst mfc1-odd y x))
         (:little-endian
          (inst mfc1 y x)
          (inst mfc1-odd3 y x))))
      (descriptor-reg
       (inst lw y x (- (* double-float-value-slot n-word-bytes)
                       other-pointer-lowtag))
       (inst lw-odd y x (- (* (1+ double-float-value-slot) n-word-bytes)
                           other-pointer-lowtag))))
    (inst nop)))                        ;nop needed here?
(define-move-vop move-to-double-int-reg
    :move (double-reg descriptor-reg) (double-int-carg-reg))

(define-vop (move-double-int-reg)
  (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
         (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
  (:results (y :scs (double-int-carg-reg) :load-if nil))
  (:generator 2
    (unless (location= x y)
      (error "Huh? why did it do that?"))))
(define-move-vop move-double-int-reg :move-arg
  (double-int-carg-reg) (double-int-carg-reg))


;;;; Arithmetic VOPs:

(define-vop (float-op)
  (:args (x) (y))
  (:results (r))
  (:variant-vars format operation)
  (:policy :fast-safe)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 0
    (note-this-location vop :internal-error)
    (inst float-op operation format r x y)))

(macrolet ((frob (name sc ptype)
             `(define-vop (,name float-op)
                (:args (x :scs (,sc))
                       (y :scs (,sc)))
                (:results (r :scs (,sc)))
                (:arg-types ,ptype ,ptype)
                (:result-types ,ptype))))
  (frob single-float-op single-reg single-float)
  (frob double-float-op double-reg double-float))

(macrolet ((frob (op sname scost dname dcost)
             `(progn
                (define-vop (,sname single-float-op)
                  (:translate ,op)
                  (:variant :single ',op)
                  (:variant-cost ,scost))
                (define-vop (,dname double-float-op)
                  (:translate ,op)
                  (:variant :double ',op)
                  (:variant-cost ,dcost)))))
  (frob + +/single-float 2 +/double-float 2)
  (frob - -/single-float 2 -/double-float 2)
  (frob * */single-float 4 */double-float 5)
  (frob / //single-float 12 //double-float 19))

(macrolet ((frob (name inst translate format sc type)
             `(define-vop (,name)
                (:args (x :scs (,sc)))
                (:results (y :scs (,sc)))
                (:translate ,translate)
                (:policy :fast-safe)
                (:arg-types ,type)
                (:result-types ,type)
                (:note "inline float arithmetic")
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 1
                  (note-this-location vop :internal-error)
                  (inst ,inst ,format y x)))))
  (frob abs/single-float fabs abs :single single-reg single-float)
  (frob abs/double-float fabs abs :double double-reg double-float)
  (frob %negate/single-float fneg %negate :single single-reg single-float)
  (frob %negate/double-float fneg %negate :double double-reg double-float))


;;;; Comparison:

(define-vop (float-compare)
  (:args (x) (y))
  (:conditional)
  (:info target not-p)
  (:variant-vars format operation complement)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (note-this-location vop :internal-error)
    (inst fcmp operation format x y)
    (inst nop)
    (if (if complement (not not-p) not-p)
        (inst bc1f target)
        (inst bc1t target))
    (inst nop)))

(macrolet ((frob (name sc ptype)
             `(define-vop (,name float-compare)
                (:args (x :scs (,sc))
                       (y :scs (,sc)))
                (:arg-types ,ptype ,ptype))))
  (frob single-float-compare single-reg single-float)
  (frob double-float-compare double-reg double-float))

(macrolet ((frob (translate op complement sname dname)
             `(progn
                (define-vop (,sname single-float-compare)
                  (:translate ,translate)
                  (:variant :single ,op ,complement))
                (define-vop (,dname double-float-compare)
                  (:translate ,translate)
                  (:variant :double ,op ,complement)))))
  (frob < :lt nil </single-float </double-float)
  (frob > :ngt t >/single-float >/double-float)
  (frob = :seq nil =/single-float =/double-float))


;;;; Conversion:

(macrolet ((frob (name translate
                       from-sc from-type from-format
                       to-sc to-type to-format)
             (let ((word-p (eq from-format :word)))