float.lisp

开源跨平台Lisp编译器

                                     '((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)))))
                                (inst fxch real-tn))))
                       (let ((imag-tn (complex-double-reg-imag-tn x)))
                         (inst fxch imag-tn)
                         ,@(ecase format
                             (:single
                              '((inst fst (ea-for-csf-imag-stack y fp))))
                             (:double
                              '((inst fstd (ea-for-cdf-imag-stack y fp))))
                             #!+long-float
                             (:long
                              '((store-long-float
                                 (ea-for-clf-imag-stack y fp)))))
                         (inst fxch imag-tn))))))
                (define-move-vop ,name :move-arg
                  (,sc descriptor-reg) (,sc)))))
  (frob move-complex-single-float-arg
        complex-single-reg complex-single-stack :single)
  (frob move-complex-double-float-arg
        complex-double-reg complex-double-stack :double)
  #!+long-float
  (frob move-complex-long-float-arg
        complex-long-reg complex-long-stack :long))

(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

;;; dtc: the floating point arithmetic vops
;;;
;;; Note: Although these can accept x and y on the stack or pointed to
;;; from a descriptor register, they will work with register loading
;;; without these. Same deal with the result - it need only be a
;;; register. When load-tns are needed they will probably be in ST0
;;; and the code below should be able to correctly handle all cases.
;;;
;;; However it seems to produce better code if all arg. and result
;;; options are used; on the P86 there is no extra cost in using a
;;; memory operand to the FP instructions - not so on the PPro.
;;;
;;; It may also be useful to handle constant args?
;;;
;;; 22-Jul-97: descriptor args lose in some simple cases when
;;; a function result computed in a loop. Then Python insists
;;; on consing the intermediate values! For example
;;;
;;; (defun test(a n)
;;;   (declare (type (simple-array double-float (*)) a)
;;;        (fixnum n))
;;;   (let ((sum 0d0))
;;;     (declare (type double-float sum))
;;;   (dotimes (i n)
;;;     (incf sum (* (aref a i)(aref a i))))
;;;     sum))
;;;
;;; So, disabling descriptor args until this can be fixed elsewhere.
(macrolet
    ((frob (op fop-sti fopr-sti
               fop fopr sname scost
               fopd foprd dname dcost
               lname lcost)
       #!-long-float (declare (ignore lcost lname))
       `(progn
         (define-vop (,sname)
           (:translate ,op)
           (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
                     :to :eval)
                  (y :scs (single-reg single-stack #+nil descriptor-reg)
                     :to :eval))
           (:temporary (:sc single-reg :offset fr0-offset
                            :from :eval :to :result) fr0)
           (:results (r :scs (single-reg single-stack)))
           (:arg-types single-float single-float)
           (:result-types single-float)
           (:policy :fast-safe)
           (:note "inline float arithmetic")
           (:vop-var vop)
           (:save-p :compute-only)
           (:node-var node)
           (:generator ,scost
             ;; Handle a few special cases
             (cond
              ;; x, y, and r are the same register.
              ((and (sc-is x single-reg) (location= x r) (location= y r))
               (cond ((zerop (tn-offset r))
                      (inst ,fop fr0))
                     (t
                      (inst fxch r)
                      (inst ,fop fr0)
                      ;; XX the source register will not be valid.
                      (note-next-instruction vop :internal-error)
                      (inst fxch r))))

              ;; x and r are the same register.
              ((and (sc-is x single-reg) (location= x r))
               (cond ((zerop (tn-offset r))
                      (sc-case y
                         (single-reg
                          ;; ST(0) = ST(0) op ST(y)
                          (inst ,fop y))
                         (single-stack
                          ;; ST(0) = ST(0) op Mem
                          (inst ,fop (ea-for-sf-stack y)))
                         (descriptor-reg
                          (inst ,fop (ea-for-sf-desc y)))))
                     (t
                      ;; y to ST0
                      (sc-case y
                         (single-reg
                          (unless (zerop (tn-offset y))
                                  (copy-fp-reg-to-fr0 y)))
                         ((single-stack descriptor-reg)
                          (inst fstp fr0)
                          (if (sc-is y single-stack)
                              (inst fld (ea-for-sf-stack y))
                            (inst fld (ea-for-sf-desc y)))))
                      ;; ST(i) = ST(i) op ST0
                      (inst ,fop-sti r)))
               (maybe-fp-wait node vop))
              ;; y and r are the same register.
              ((and (sc-is y single-reg) (location= y r))
               (cond ((zerop (tn-offset r))
                      (sc-case x
                         (single-reg
                          ;; ST(0) = ST(x) op ST(0)
                          (inst ,fopr x))
                         (single-stack
                          ;; ST(0) = Mem op ST(0)
                          (inst ,fopr (ea-for-sf-stack x)))
                         (descriptor-reg
                          (inst ,fopr (ea-for-sf-desc x)))))
                     (t
                      ;; x to ST0
                      (sc-case x
                        (single-reg
                         (unless (zerop (tn-offset x))
                                 (copy-fp-reg-to-fr0 x)))
                        ((single-stack descriptor-reg)
                         (inst fstp fr0)
                         (if (sc-is x single-stack)
                             (inst fld (ea-for-sf-stack x))
                           (inst fld (ea-for-sf-desc x)))))
                      ;; ST(i) = ST(0) op ST(i)
                      (inst ,fopr-sti r)))
               (maybe-fp-wait node vop))
              ;; the default case
              (t
               ;; Get the result to ST0.

               ;; Special handling is needed if x or y are in ST0, and
               ;; simpler code is generated.
               (cond
                ;; x is in ST0
                ((and (sc-is x single-reg) (zerop (tn-offset x)))
                 ;; ST0 = ST0 op y
                 (sc-case y
                   (single-reg
                    (inst ,fop y))
                   (single-stack
                    (inst ,fop (ea-for-sf-stack y)))
                   (descriptor-reg
                    (inst ,fop (ea-for-sf-desc y)))))
                ;; y is in ST0
                ((and (sc-is y single-reg) (zerop (tn-offset y)))
                 ;; ST0 = x op ST0
                 (sc-case x
                   (single-reg
                    (inst ,fopr x))
                   (single-stack
                    (inst ,fopr (ea-for-sf-stack x)))
                   (descriptor-reg
                    (inst ,fopr (ea-for-sf-desc x)))))
                (t
                 ;; x to ST0
                 (sc-case x
                   (single-reg
                    (copy-fp-reg-to-fr0 x))
                   (single-stack
                    (inst fstp fr0)
                    (inst fld (ea-for-sf-stack x)))
                   (descriptor-reg
                    (inst fstp fr0)
                    (inst fld (ea-for-sf-desc x))))
                 ;; ST0 = ST0 op y
                 (sc-case y
                   (single-reg
                    (inst ,fop y))
                   (single-stack
                    (inst ,fop (ea-for-sf-stack y)))
                   (descriptor-reg
                    (inst ,fop (ea-for-sf-desc y))))))

               (note-next-instruction vop :internal-error)

               ;; Finally save the result.
               (sc-case r
                 (single-reg
                  (cond ((zerop (tn-offset r))
                         (maybe-fp-wait node))
                        (t
                         (inst fst r))))
                 (single-stack
                  (inst fst (ea-for-sf-stack r))))))))

         (define-vop (,dname)
           (:translate ,op)
           (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
                     :to :eval)
                  (y :scs (double-reg double-stack #+nil descriptor-reg)
                     :to :eval))
           (:temporary (:sc double-reg :offset fr0-offset
                            :from :eval :to :result) fr0)
           (:results (r :scs (double-reg double-stack)))
           (:arg-types double-float double-float)
           (:result-types double-float)
           (:policy :fast-safe)
           (:note "inline float arithmetic")
           (:vop-var vop)
           (:save-p :compute-only)
           (:node-var node)
           (:generator ,dcost
             ;; Handle a few special cases.
             (cond
              ;; x, y, and r are the same register.
              ((and (sc-is x double-reg) (location= x r) (location= y r))
               (cond ((zerop (tn-offset r))
                      (inst ,fop fr0))
                     (t
                      (inst fxch x)
                      (inst ,fopd fr0)
                      ;; XX the source register will not be valid.
                      (note-next-instruction vop :internal-error)
                      (inst fxch r))))

              ;; x and r are the same register.
              ((and (sc-is x double-reg) (location= x r))
               (cond ((zerop (tn-offset r))
                      (sc-case y
                         (double-reg
                          ;; ST(0) = ST(0) op ST(y)
                          (inst ,fopd y))
                         (double-stack
                          ;; ST(0) = ST(0) op Mem
                          (inst ,fopd (ea-for-df-stack y)))
                         (descriptor-reg
                          (inst ,fopd (ea-for-df-desc y)))))
                     (t
                      ;; y to ST0
                      (sc-case y
                         (double-reg
                          (unless (zerop (tn-offset y))
                                  (copy-fp-reg-to-fr0 y)))
                         ((double-stack descriptor-reg)
                          (inst fstp fr0)
                          (if (sc-is y double-stack)
                              (inst fldd (ea-for-df-stack y))
                            (inst fldd (ea-for-df-desc y)))))
                      ;; ST(i) = ST(i) op ST0
                      (inst ,fop-sti r)))
               (maybe-fp-wait node vop))
              ;; y and r are the same register.
              ((and (sc-is y double-reg) (location= y r))
               (cond ((zerop (tn-offset r))
                      (sc-case x
                         (double-reg
                          ;; ST(0) = ST(x) op ST(0)
                          (inst ,foprd x))
                         (double-stack
                          ;; ST(0) = Mem op ST(0)
                          (inst ,foprd (ea-for-df-stack x)))
                         (descriptor-reg
                          (inst ,foprd (ea-for-df-desc x)))))
                     (t
                      ;; x to ST0
                      (sc-case x
                         (double-reg
                          (unless (zerop (tn-offset x))
                                  (copy-fp-reg-to-fr0 x)))
                         ((double-stack descriptor-reg)
                          (inst fstp fr0)
                          (if (sc-is x double-stack)
                              (inst fldd (ea-for-df-stack x))
                            (inst fldd (ea-for-df-desc x)))))
                      ;; ST(i) = ST(0) op ST(i)
                      (inst ,fopr-sti r)))
               (maybe-fp-wait node vop))
              ;; the default case
              (t
               ;; Get the result to ST0.

               ;; Special handling is needed if x or y are in ST0, and
               ;; simpler code is generated.
               (cond
                ;; x is in ST0
                ((and (sc-is x double-reg) (zerop (tn-offset x)))
                 ;; ST0 = ST0 op y
                 (sc-case y
                   (double-reg
                    (inst ,fopd y))
                   (double-stack
                    (inst ,fopd (ea-for-df-stack y)))
                   (descriptor-reg
                    (inst ,fopd (ea-for-df-desc y)))))
                ;; y is in ST0
                ((and (sc-is y double-reg) (zerop (tn-offset y)))
                 ;; ST0 = x op ST0
                 (sc-case x
                   (double-reg
                    (inst ,foprd x))
                   (double-stack
                    (inst ,foprd (ea-for-df-stack x)))
                   (descriptor-reg
                    (inst ,foprd (ea-for-df-desc x)))))
                (t
                 ;; x to ST0
                 (sc-case x
                   (double-reg
                    (copy-fp-reg-to-fr0 x))
                   (double-stack
                    (inst fstp fr0)
                    (inst fldd (ea-for-df-stack x)))
                   (descriptor-reg
                    (inst fstp fr0)
                    (inst fldd (ea-for-df-desc x))))
                 ;; ST0 = ST0 op y
                 (sc-case y
                   (double-reg
                    (inst ,fopd y))
                   (double-stack
                    (inst ,fopd (ea-for-df-stack y)))
                   (descriptor-reg
                    (inst ,fopd (ea-for-df-desc y))))))