float.lisp

开源跨平台Lisp编译器

  (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
  (:note "complex single float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the complex-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-real (complex-single-reg-real-tn x))
             (y-real (complex-single-reg-real-tn y)))
         (inst fmovs y-real x-real))
       (let ((x-imag (complex-single-reg-imag-tn x))
             (y-imag (complex-single-reg-imag-tn y)))
         (inst fmovs y-imag x-imag)))))
;;;
(define-move-vop complex-single-move :move
  (complex-single-reg) (complex-single-reg))

(define-vop (complex-double-move)
  (:args (x :scs (complex-double-reg)
            :target y :load-if (not (location= x y))))
  (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
  (:note "complex double float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the complex-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-real (complex-double-reg-real-tn x))
             (y-real (complex-double-reg-real-tn y)))
         (move-double-reg y-real x-real))
       (let ((x-imag (complex-double-reg-imag-tn x))
             (y-imag (complex-double-reg-imag-tn y)))
         (move-double-reg y-imag x-imag)))))
;;;
(define-move-vop complex-double-move :move
  (complex-double-reg) (complex-double-reg))

#!+long-float
(define-vop (complex-long-move)
  (:args (x :scs (complex-long-reg)
            :target y :load-if (not (location= x y))))
  (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))
  (:note "complex long float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the complex-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-real (complex-long-reg-real-tn x))
             (y-real (complex-long-reg-real-tn y)))
         (move-long-reg y-real x-real))
       (let ((x-imag (complex-long-reg-imag-tn x))
             (y-imag (complex-long-reg-imag-tn y)))
         (move-long-reg y-imag x-imag)))))
;;;
#!+long-float
(define-move-vop complex-long-move :move
  (complex-long-reg) (complex-long-reg))

;;;
;;; Move from a complex float to a descriptor register allocating a
;;; new complex float object in the process.
;;;
(define-vop (move-from-complex-single)
  (:args (x :scs (complex-single-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note "complex single float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr complex-single-float-widetag
                               complex-single-float-size)
       (let ((real-tn (complex-single-reg-real-tn x)))
         (inst stf real-tn y (- (* complex-single-float-real-slot
                                   n-word-bytes)
                                other-pointer-lowtag)))
       (let ((imag-tn (complex-single-reg-imag-tn x)))
         (inst stf imag-tn y (- (* complex-single-float-imag-slot
                                   n-word-bytes)
                                other-pointer-lowtag))))))
;;;
(define-move-vop move-from-complex-single :move
  (complex-single-reg) (descriptor-reg))

(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)
  (:note "complex double float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr complex-double-float-widetag
                               complex-double-float-size)
       (let ((real-tn (complex-double-reg-real-tn x)))
         (inst stdf real-tn y (- (* complex-double-float-real-slot
                                    n-word-bytes)
                                 other-pointer-lowtag)))
       (let ((imag-tn (complex-double-reg-imag-tn x)))
         (inst stdf 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))

#!+long-float
(define-vop (move-from-complex-long)
  (:args (x :scs (complex-long-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note "complex long float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr complex-long-float-widetag
                               complex-long-float-size)
       (let ((real-tn (complex-long-reg-real-tn x)))
         (store-long-reg real-tn y (- (* complex-long-float-real-slot
                                         n-word-bytes)
                                      other-pointer-lowtag)))
       (let ((imag-tn (complex-long-reg-imag-tn x)))
         (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
                                         n-word-bytes)
                                      other-pointer-lowtag))))))
;;;
#!+long-float
(define-move-vop move-from-complex-long :move
  (complex-long-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 ldf real-tn x (- (* complex-single-float-real-slot n-word-bytes)
                             other-pointer-lowtag)))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
      (inst ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
                             other-pointer-lowtag)))))
(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)))
      (inst lddf real-tn x (- (* complex-double-float-real-slot n-word-bytes)
                              other-pointer-lowtag)))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
      (inst lddf imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
                              other-pointer-lowtag)))))
(define-move-vop move-to-complex-double :move
  (descriptor-reg) (complex-double-reg))

#!+long-float
(define-vop (move-to-complex-long)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (complex-long-reg)))
  (:note "pointer to complex float coercion")
  (:generator 2
    (let ((real-tn (complex-long-reg-real-tn y)))
      (load-long-reg real-tn x (- (* complex-long-float-real-slot n-word-bytes)
                                  other-pointer-lowtag)))
    (let ((imag-tn (complex-long-reg-imag-tn y)))
      (load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
                                  other-pointer-lowtag)))))
#!+long-float
(define-move-vop move-to-complex-long :move
  (descriptor-reg) (complex-long-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 fmovs y-real x-real))
         (let ((x-imag (complex-single-reg-imag-tn x))
               (y-imag (complex-single-reg-imag-tn y)))
           (inst fmovs 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 stf real-tn nfp offset))
         (let ((imag-tn (complex-single-reg-imag-tn x)))
           (inst stf 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)))
           (move-double-reg y-real x-real))
         (let ((x-imag (complex-double-reg-imag-tn x))
               (y-imag (complex-double-reg-imag-tn y)))
           (move-double-reg y-imag x-imag))))
      (complex-double-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-double-reg-real-tn x)))
           (inst stdf real-tn nfp offset))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
           (inst stdf 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))

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


(define-move-vop move-arg :move-arg
  (single-reg double-reg #!+long-float long-reg
   complex-single-reg complex-double-reg #!+long-float complex-long-reg)
  (descriptor-reg))


;;;; Arithmetic VOPs:

(define-vop (float-op)
  (:args (x) (y))
  (:results (r))
  (:policy :fast-safe)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only))

(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)
  #!+long-float
  (frob long-float-op long-reg long-float))

(macrolet ((frob (op sinst sname scost dinst dname dcost)
             `(progn
                (define-vop (,sname single-float-op)
                  (:translate ,op)
                  (:generator ,scost
                    (inst ,sinst r x y)))
                (define-vop (,dname double-float-op)
                  (:translate ,op)
                  (:generator ,dcost
                    (inst ,dinst r x y))))))
  (frob + fadds +/single-float 2 faddd +/double-float 2)
  (frob - fsubs -/single-float 2 fsubd -/double-float 2)
  (frob * fmuls */single-float 4 fmuld */double-float 5)
  (frob / fdivs //single-float 12 fdivd //double-float 19))

#!+long-float
(macrolet ((frob (op linst lname lcost)
             `(define-vop (,lname long-float-op)
                  (:translate ,op)
                  (:generator ,lcost
                    (inst ,linst r x y)))))
  (frob + faddq +/long-float 2)
  (frob - fsubq -/long-float 2)
  (frob * fmulq */long-float 6)
  (frob / fdivq //long-float 20))


(macrolet ((frob (name inst translate 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 y x)))))
  (frob abs/single-float fabss abs single-reg single-float)
  (frob %negate/single-float fnegs %negate single-reg single-float))

(defun negate-double-reg (dst src)
  (cond
    ((member :sparc-v9 *backend-subfeatures*)
     (inst fnegd dst src))
    (t
     ;; Negate the MS part of the numbers, then copy over the rest
     ;; of the bits.
     (inst fnegs dst src)
     (let ((dst-odd (make-random-tn :kind :normal
                                    :sc (sc-or-lose 'single-reg)
                                    :offset (+ 1 (tn-offset dst))))
           (src-odd (make-random-tn :kind :normal
                                    :sc (sc-or-lose 'single-reg)
                                    :offset (+ 1 (tn-offset src)))))
       (inst fmovs dst-odd src-odd)))))

(defun abs-double-reg (dst src)
  (cond
    ((member :sparc-v9 *backend-subfeatures*)
     (inst fabsd dst src))
    (t
     ;; Abs the MS part of the numbers, then copy over the rest
     ;; of the bits.
     (inst fabss dst src)
     (let ((dst-2 (make-random-tn :kind :normal
                                  :sc (sc-or-lose 'single-reg)
                                  :offset (+ 1 (tn-offset dst))))
           (src-2 (make-random-tn :kind :normal
                                  :sc (sc-or-lose 'single-reg)