float.lisp

来自「开源跨平台Lisp编译器」· LISP 代码 · 共 1,738 行 · 第 1/5 页

                     (* (tn-offset temp) n-word-bytes)))))

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

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

#!+long-float
(define-vop (long-float-exp-bits)
  (:args (float :scs (long-reg descriptor-reg)
                :load-if (not (sc-is float long-stack))))
  (:results (exp-bits :scs (signed-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types signed-num)
  (:translate long-float-exp-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
                                    :sc (sc-or-lose 'double-reg)
                                    :offset (tn-offset float))))
         (inst stdf float (current-nfp-tn vop)
               (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld exp-bits (current-nfp-tn vop)
             (* (tn-offset stack-temp) n-word-bytes)))
      (long-stack
       (inst ld exp-bits (current-nfp-tn vop)
             (* (tn-offset float) n-word-bytes)))
      (descriptor-reg
       (loadw exp-bits float long-float-value-slot
              other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-high-bits)
  (:args (float :scs (long-reg descriptor-reg)
                :load-if (not (sc-is float long-stack))))
  (:results (high-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types unsigned-num)
  (:translate long-float-high-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
                                    :sc (sc-or-lose 'double-reg)
                                    :offset (tn-offset float))))
         (inst stdf float (current-nfp-tn vop)
               (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld high-bits (current-nfp-tn vop)
             (* (1+ (tn-offset stack-temp)) n-word-bytes)))
      (long-stack
       (inst ld high-bits (current-nfp-tn vop)
             (* (1+ (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw high-bits float (1+ long-float-value-slot)
              other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-mid-bits)
  (:args (float :scs (long-reg descriptor-reg)
                :load-if (not (sc-is float long-stack))))
  (:results (mid-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types unsigned-num)
  (:translate long-float-mid-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
                                    :sc (sc-or-lose 'double-reg)
                                    :offset (+ 2 (tn-offset float)))))
         (inst stdf float (current-nfp-tn vop)
               (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld mid-bits (current-nfp-tn vop)
             (* (tn-offset stack-temp) n-word-bytes)))
      (long-stack
       (inst ld mid-bits (current-nfp-tn vop)
             (* (+ 2 (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw mid-bits float (+ 2 long-float-value-slot)
              other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-low-bits)
  (:args (float :scs (long-reg descriptor-reg)
                :load-if (not (sc-is float long-stack))))
  (:results (lo-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types unsigned-num)
  (:translate long-float-low-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
                                    :sc (sc-or-lose 'double-reg)
                                    :offset (+ 2 (tn-offset float)))))
         (inst stdf float (current-nfp-tn vop)
               (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld lo-bits (current-nfp-tn vop)
             (* (1+ (tn-offset stack-temp)) n-word-bytes)))
      (long-stack
       (inst ld lo-bits (current-nfp-tn vop)
             (* (+ 3 (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw lo-bits float (+ 3 long-float-value-slot)
              other-pointer-lowtag)))))


;;;; Float mode hackery:

(sb!xc:deftype float-modes () '(unsigned-byte 32))
(defknown floating-point-modes () float-modes (flushable))
(defknown ((setf floating-point-modes)) (float-modes)
  float-modes)

(define-vop (floating-point-modes)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate floating-point-modes)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:sc unsigned-stack) temp)
  (:generator 3
    (let ((nfp (current-nfp-tn vop)))
      (inst stfsr nfp (* n-word-bytes (tn-offset temp)))
      (loadw res nfp (tn-offset temp))
      (inst nop))))

#+nil
(define-vop (floating-point-modes)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate floating-point-modes)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:sc double-stack) temp)
  (:generator 3
    (let* ((nfp (current-nfp-tn vop))
           (offset (* 4 (tn-offset temp))))
      (inst stxfsr nfp offset)
      ;; The desired FP mode data is in the least significant 32
      ;; bits, which is stored at the next higher word in memory.
      (loadw res nfp (+ offset 4))
      ;; Is this nop needed? -- rtoy
      (inst nop))))

(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc unsigned-stack) temp)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop)))
      (storew new nfp (tn-offset temp))
      (inst ldfsr nfp (* n-word-bytes (tn-offset temp)))
      (move res new))))

#+nil
(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc double-stack) temp)
  (:temporary (:sc unsigned-reg) my-fsr)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop))
          (offset (* n-word-bytes (tn-offset temp))))
      (pseudo-atomic ()
        ;; Get the current FSR, so we can get the new %fcc's
        (inst stxfsr nfp offset)
        (inst ldx my-fsr nfp offset)
        ;; Carefully merge in the new mode bits with the rest of the
        ;; FSR.  This is only needed if we care about preserving the
        ;; high 32 bits of the FSR, which contain the additional
        ;; %fcc's on the sparc V9.  If not, we don't need this, but we
        ;; do need to make sure that the unused bits are written as
        ;; zeroes, according the V9 architecture manual.
        (inst sra new 0)
        (inst srlx my-fsr 32)
        (inst sllx my-fsr 32)
        (inst or my-fsr new)
        ;; Save it back and load it into the fsr register
        (inst stx my-fsr nfp offset)
        (inst ldxfsr nfp offset)
        (move res new)))))

#+nil
(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc double-stack) temp)
  (:temporary (:sc unsigned-reg) my-fsr)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop))
          (offset (* n-word-bytes (tn-offset temp))))
      (inst stx new nfp offset)
      (inst ldxfsr nfp offset)
      (move res new))))


;;;; Special functions.

#!-long-float
(define-vop (fsqrt)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate %sqrt)
  (:policy :fast-safe)
  (:guard (or (member :sparc-v7 *backend-subfeatures*)
              (member :sparc-v8 *backend-subfeatures*)
              (member :sparc-v9 *backend-subfeatures*)))
  (:arg-types double-float)
  (:result-types double-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (inst fsqrtd y x)))

#!+long-float
(define-vop (fsqrt-long)
  (:args (x :scs (long-reg)))
  (:results (y :scs (long-reg)))
  (:translate %sqrt)
  (:policy :fast-safe)
  (:arg-types long-float)
  (:result-types long-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (inst fsqrtq y x)))


;;;; Complex float VOPs

(define-vop (make-complex-single-float)
  (:translate complex)
  (:args (real :scs (single-reg) :target r
               :load-if (not (location= real 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)