float.lisp

开源跨平台Lisp编译器

  (:results (y :load-if (not (location= x y))))
  (:note "complex 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)))
         (cond ((zerop (tn-offset y-real))
                (copy-fp-reg-to-fr0 x-real))
               ((zerop (tn-offset x-real))
                (inst fstd y-real))
               (t
                (inst fxch x-real)
                (inst fstd y-real)
                (inst fxch x-real))))
       (let ((x-imag (complex-double-reg-imag-tn x))
             (y-imag (complex-double-reg-imag-tn y)))
         (inst fxch x-imag)
         (inst fstd y-imag)
         (inst fxch x-imag)))))

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

(define-vop (complex-double-move complex-float-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)))))
(define-move-vop complex-double-move :move
  (complex-double-reg) (complex-double-reg))

#!+long-float
(define-vop (complex-long-move complex-float-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)))))
#!+long-float
(define-move-vop complex-long-move :move
  (complex-long-reg) (complex-long-reg))

;;; Move from float to a descriptor reg. allocating a new float
;;; object in the process.
(define-vop (move-from-single)
  (:args (x :scs (single-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:node-var node)
  (:note "float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y
                             single-float-widetag
                             single-float-size node)
       (with-tn@fp-top(x)
         (inst fst (ea-for-sf-desc y))))))
(define-move-vop move-from-single :move
  (single-reg) (descriptor-reg))

(define-vop (move-from-double)
  (:args (x :scs (double-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:node-var node)
  (:note "float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y
                             double-float-widetag
                             double-float-size
                             node)
       (with-tn@fp-top(x)
         (inst fstd (ea-for-df-desc y))))))
(define-move-vop move-from-double :move
  (double-reg) (descriptor-reg))

#!+long-float
(define-vop (move-from-long)
  (:args (x :scs (long-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:node-var node)
  (:note "float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y
                             long-float-widetag
                             long-float-size
                             node)
       (with-tn@fp-top(x)
         (store-long-float (ea-for-lf-desc y))))))
#!+long-float
(define-move-vop move-from-long :move
  (long-reg) (descriptor-reg))

(define-vop (move-from-fp-constant)
  (:args (x :scs (fp-constant)))
  (:results (y :scs (descriptor-reg)))
  (:generator 2
     (ecase (sb!c::constant-value (sb!c::tn-leaf x))
       (0f0 (load-symbol-value y *fp-constant-0f0*))
       (1f0 (load-symbol-value y *fp-constant-1f0*))
       (0d0 (load-symbol-value y *fp-constant-0d0*))
       (1d0 (load-symbol-value y *fp-constant-1d0*))
       #!+long-float
       (0l0 (load-symbol-value y *fp-constant-0l0*))
       #!+long-float
       (1l0 (load-symbol-value y *fp-constant-1l0*))
       #!+long-float
       (#.pi (load-symbol-value y *fp-constant-pi*))
       #!+long-float
       (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
       #!+long-float
       (#.(log 2.718281828459045235360287471352662L0 2l0)
          (load-symbol-value y *fp-constant-l2e*))
       #!+long-float
       (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
       #!+long-float
       (#.(log 2l0 2.718281828459045235360287471352662L0)
          (load-symbol-value y *fp-constant-ln2*)))))
(define-move-vop move-from-fp-constant :move
  (fp-constant) (descriptor-reg))

;;; Move from a descriptor to a float register.
(define-vop (move-to-single)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (single-reg)))
  (:note "pointer to float coercion")
  (:generator 2
     (with-empty-tn@fp-top(y)
       (inst fld (ea-for-sf-desc x)))))
(define-move-vop move-to-single :move (descriptor-reg) (single-reg))

(define-vop (move-to-double)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (double-reg)))
  (:note "pointer to float coercion")
  (:generator 2
     (with-empty-tn@fp-top(y)
       (inst fldd (ea-for-df-desc x)))))
(define-move-vop move-to-double :move (descriptor-reg) (double-reg))

#!+long-float
(define-vop (move-to-long)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (long-reg)))
  (:note "pointer to float coercion")
  (:generator 2
     (with-empty-tn@fp-top(y)
       (inst fldl (ea-for-lf-desc x)))))
#!+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))

;;; Move from complex float to a descriptor reg. 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)))
  (:node-var node)
  (:note "complex float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y
                             complex-single-float-widetag
                             complex-single-float-size
                             node)
       (let ((real-tn (complex-single-reg-real-tn x)))
         (with-tn@fp-top(real-tn)
           (inst fst (ea-for-csf-real-desc y))))
       (let ((imag-tn (complex-single-reg-imag-tn x)))
         (with-tn@fp-top(imag-tn)
           (inst fst (ea-for-csf-imag-desc y)))))))
(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)))
  (:node-var node)
  (:note "complex float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y
                             complex-double-float-widetag
                             complex-double-float-size
                             node)
       (let ((real-tn (complex-double-reg-real-tn x)))
         (with-tn@fp-top(real-tn)
           (inst fstd (ea-for-cdf-real-desc y))))
       (let ((imag-tn (complex-double-reg-imag-tn x)))
         (with-tn@fp-top(imag-tn)
           (inst fstd (ea-for-cdf-imag-desc y)))))))
(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)))
  (:node-var node)
  (:note "complex float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y
                             complex-long-float-widetag
                             complex-long-float-size
                             node)
       (let ((real-tn (complex-long-reg-real-tn x)))
         (with-tn@fp-top(real-tn)
           (store-long-float (ea-for-clf-real-desc y))))
       (let ((imag-tn (complex-long-reg-imag-tn x)))
         (with-tn@fp-top(imag-tn)
           (store-long-float (ea-for-clf-imag-desc y)))))))
#!+long-float
(define-move-vop move-from-complex-long :move
  (complex-long-reg) (descriptor-reg))

;;; Move from a descriptor to a complex float register.
(macrolet ((frob (name sc format)
             `(progn
                (define-vop (,name)
                  (:args (x :scs (descriptor-reg)))
                  (:results (y :scs (,sc)))
                  (:note "pointer to complex float coercion")
                  (:generator 2
                    (let ((real-tn (complex-double-reg-real-tn y)))
                      (with-empty-tn@fp-top(real-tn)
                        ,@(ecase format
                           (:single '((inst fld (ea-for-csf-real-desc x))))
                           (:double '((inst fldd (ea-for-cdf-real-desc x))))
                           #!+long-float
                           (:long '((inst fldl (ea-for-clf-real-desc x)))))))
                    (let ((imag-tn (complex-double-reg-imag-tn y)))
                      (with-empty-tn@fp-top(imag-tn)
                        ,@(ecase format
                           (:single '((inst fld (ea-for-csf-imag-desc x))))
                           (:double '((inst fldd (ea-for-cdf-imag-desc x))))
                           #!+long-float
                           (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
                (define-move-vop ,name :move (descriptor-reg) (,sc)))))
          (frob move-to-complex-single complex-single-reg :single)
          (frob move-to-complex-double complex-double-reg :double)
          #!+long-float
          (frob move-to-complex-double complex-long-reg :long))

;;;; the move argument vops
;;;;
;;;; Note these are also used to stuff fp numbers onto the c-call
;;;; stack so the order is different than the lisp-stack.

;;; the general MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
             `(progn
                (define-vop (,name)
                  (:args (x :scs (,sc) :target y)
                         (fp :scs (any-reg)
                             :load-if (not (sc-is y ,sc))))
                  (:results (y))
                  (:note "float argument move")
                  (:generator ,(case format (:single 2) (:double 3) (:long 4))
                    (sc-case y
                      (,sc
                       (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)))))
                      (,stack-sc
                       (if (= (tn-offset fp) esp-offset)
                           ;; C-call
                           (let* ((offset (* (tn-offset y) n-word-bytes))
                                  (ea (make-ea :dword :base fp :disp offset)))
                             (with-tn@fp-top(x)
                                ,@(ecase format
                                         (:single '((inst fst ea)))
                                         (:double '((inst fstd ea)))
                                         #!+long-float
                                         (:long '((store-long-float ea))))))
                           ;; Lisp stack
                           (let ((ea (make-ea
                                      :dword :base fp
                                      :disp (frame-byte-offset
                                             (+ (tn-offset y)
                                                ,(case format
                                                       (:single 0)
                                                       (:double 1)
                                                       (:long 2)))))))
                             (with-tn@fp-top(x)
                               ,@(ecase format
                                    (:single '((inst fst  ea)))
                                    (:double '((inst fstd ea)))
                                    #!+long-float
                                    (:long '((store-long-float ea)))))))))))
                (define-move-vop ,name :move-arg
                  (,sc descriptor-reg) (,sc)))))
  (frob move-single-float-arg single-reg single-stack :single)
  (frob move-double-float-arg double-reg double-stack :double)
  #!+long-float
  (frob move-long-float-arg long-reg long-stack :long))

;;;; complex float MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
             `(progn
                (define-vop (,name)
                  (:args (x :scs (,sc) :target y)
                         (fp :scs (any-reg)
                             :load-if (not (sc-is y ,sc))))
                  (:results (y))
                  (:note "complex float argument move")
                  (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
                    (sc-case y
                      (,sc
                       (unless (location= x y)
                         (let ((x-real (complex-double-reg-real-tn x))
                               (y-real (complex-double-reg-real-tn y)))
                           (cond ((zerop (tn-offset y-real))
                                  (copy-fp-reg-to-fr0 x-real))
                                 ((zerop (tn-offset x-real))
                                  (inst fstd y-real))
                                 (t
                                  (inst fxch x-real)
                                  (inst fstd y-real)
                                  (inst fxch x-real))))
                         (let ((x-imag (complex-double-reg-imag-tn x))
                               (y-imag (complex-double-reg-imag-tn y)))
                           (inst fxch x-imag)
                           (inst fstd y-imag)
                           (inst fxch x-imag))))
                      (,stack-sc
                       (let ((real-tn (complex-double-reg-real-tn x)))
                         (cond ((zerop (tn-offset real-tn))
                                ,@(ecase format
                                    (:single
                                     '((inst fst
                                        (ea-for-csf-real-stack y fp))))
                                    (:double
                                     '((inst fstd
                                        (ea-for-cdf-real-stack y fp))))
                                    #!+long-float
                                    (:long
                                     '((store-long-float
                                        (ea-for-clf-real-stack y fp))))))
                               (t
                                (inst fxch real-tn)
                                ,@(ecase format
                                    (:single