arith.lisp

开源跨平台Lisp编译器

;;;; Stuff to handle simple cases for generic arithmetic.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

;;;; Addition and subtraction.

(define-assembly-routine (generic-+
                          (:cost 10)
                          (:return-style :full-call)
                          (:translate +)
                          (:policy :safe)
                          (:save-p t))
                         ((:arg x (descriptor-reg any-reg) a0-offset)
                          (:arg y (descriptor-reg any-reg) a1-offset)

                          (:res res (descriptor-reg any-reg) a0-offset)

                          (:temp temp non-descriptor-reg nl0-offset)
                          (:temp temp2 non-descriptor-reg nl1-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst andcc zero-tn x fixnum-tag-mask)
  (inst b :ne DO-STATIC-FUN)
  (inst andcc zero-tn y fixnum-tag-mask)
  (inst b :ne DO-STATIC-FUN)
  (inst nop)
  (inst addcc temp x y)
  (inst b :vc done)
  (inst nop)

  (inst sra temp x n-fixnum-tag-bits)
  (inst sra temp2 y n-fixnum-tag-bits)
  (inst add temp2 temp)
  (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
    (storew temp2 res bignum-digits-offset other-pointer-lowtag))
  (lisp-return lra :offset 2)

  DO-STATIC-FUN
  (inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j code-tn
        (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
  (inst move cfp-tn csp-tn)

  DONE
  (move res temp))


(define-assembly-routine (generic--
                          (:cost 10)
                          (:return-style :full-call)
                          (:translate -)
                          (:policy :safe)
                          (:save-p t))
                         ((:arg x (descriptor-reg any-reg) a0-offset)
                          (:arg y (descriptor-reg any-reg) a1-offset)

                          (:res res (descriptor-reg any-reg) a0-offset)

                          (:temp temp non-descriptor-reg nl0-offset)
                          (:temp temp2 non-descriptor-reg nl1-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst andcc zero-tn x fixnum-tag-mask)
  (inst b :ne DO-STATIC-FUN)
  (inst andcc zero-tn y fixnum-tag-mask)
  (inst b :ne DO-STATIC-FUN)
  (inst nop)
  (inst subcc temp x y)
  (inst b :vc done)
  (inst nop)

  (inst sra temp x n-fixnum-tag-bits)
  (inst sra temp2 y n-fixnum-tag-bits)
  (inst sub temp2 temp temp2)
  (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
    (storew temp2 res bignum-digits-offset other-pointer-lowtag))
  (lisp-return lra :offset 2)

  DO-STATIC-FUN
  (inst ld code-tn null-tn (static-fun-offset 'two-arg--))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j code-tn
        (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
  (inst move cfp-tn csp-tn)

  DONE
  (move res temp))



;;;; Multiplication


(define-assembly-routine (generic-*
                          (:cost 50)
                          (:return-style :full-call)
                          (:translate *)
                          (:policy :safe)
                          (:save-p t))
                         ((:arg x (descriptor-reg any-reg) a0-offset)
                          (:arg y (descriptor-reg any-reg) a1-offset)

                          (:res res (descriptor-reg any-reg) a0-offset)

                          (:temp temp non-descriptor-reg nl0-offset)
                          (:temp lo non-descriptor-reg nl1-offset)
                          (:temp hi non-descriptor-reg nl2-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  ;; If either arg is not a fixnum, call the static function.
  (inst andcc zero-tn x fixnum-tag-mask)
  (inst b :ne DO-STATIC-FUN)
  (inst andcc zero-tn y fixnum-tag-mask)
  (inst b :ne DO-STATIC-FUN)
  (inst nop)

  ;; Remove the tag from one arg so that the result will have the correct
  ;; fixnum tag.
  (inst sra temp x n-fixnum-tag-bits)
  ;; Compute the produce temp * y and return the double-word product
  ;; in hi:lo.
  (cond
    ((member :sparc-64 *backend-subfeatures*)
     ;; Sign extend y to a full 64-bits.  temp was already
     ;; sign-extended by the sra instruction above.
     (inst sra y 0)
     (inst mulx hi temp y)
     (inst move lo hi)
     (inst srax hi 32))
    ((or (member :sparc-v8 *backend-subfeatures*)
         (member :sparc-v9 *backend-subfeatures*))
     (inst smul lo temp y)
     (inst rdy hi))
    (t
     (let ((MULTIPLIER-POSITIVE (gen-label)))
       (inst wry temp)
       (inst andcc hi zero-tn)
       (inst nop)
       (inst nop)
       (dotimes (i 32)
         (inst mulscc hi y))
       (inst mulscc hi zero-tn)
       (inst cmp x)
       (inst b :ge MULTIPLIER-POSITIVE)
       (inst nop)
       (inst sub hi y)
       (emit-label MULTIPLIER-POSITIVE)
       (inst rdy lo))))
  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
  ;; is just 32 copies of the sign bit of the low word).
  (inst sra temp lo 31)
  (inst xorcc temp hi)
  (inst b :eq LOW-FITS-IN-FIXNUM)
  ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
  (inst sll temp hi 30)
  (inst srl lo n-fixnum-tag-bits)
  (inst or lo temp)
  (inst sra hi n-fixnum-tag-bits)
  ;; Allocate a BIGNUM for the result.
  #+nil
  (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
                 (let ((one-word (gen-label)))
                   (inst or res alloc-tn other-pointer-lowtag)
                   ;; We start out assuming that we need one word.  Is that correct?
                   (inst sra temp lo 31)
                   (inst xorcc temp hi)
                   (inst b :eq one-word)
                   (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
                   ;; Nope, we need two, so allocate the addition space.
                   (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
                                         (pad-data-block (1+ bignum-digits-offset))))
                   (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
                   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
                   (emit-label one-word)
                   (storew temp res 0 other-pointer-lowtag)
                   (storew lo res bignum-digits-offset other-pointer-lowtag)))
  ;; Always allocate 2 words for the bignum result, even if we only
  ;; need one.  The copying GC will take care of the extra word if it
  ;; isn't needed.
  (with-fixed-allocation
      (res temp bignum-widetag (+ 2 bignum-digits-offset))
    (let ((one-word (gen-label)))
      (inst or res alloc-tn other-pointer-lowtag)
      ;; We start out assuming that we need one word.  Is that correct?
      (inst sra temp lo 31)
      (inst xorcc temp hi)
      (inst b :eq one-word)
      (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
      ;; Need 2 words.  Set the header appropriately, and save the
      ;; high and low parts.
      (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
      (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
      (emit-label one-word)
      (storew temp res 0 other-pointer-lowtag)
      (storew lo res bignum-digits-offset other-pointer-lowtag)))
  ;; Out of here
  (lisp-return lra :offset 2)

  DO-STATIC-FUN
  (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
  (inst li nargs (fixnumize 2))
  (inst move ocfp cfp-tn)
  (inst j code-tn
        (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
  (inst move cfp-tn csp-tn)

  LOW-FITS-IN-FIXNUM
  (move res lo))

(macrolet
    ((frob (name note cost type sc)
       `(define-assembly-routine (,name
                                  (:note ,note)
                                  (:cost ,cost)
                                  (:translate *)
                                  (:policy :fast-safe)
                                  (:arg-types ,type ,type)
                                  (:result-types ,type))
                                 ((:arg x ,sc nl0-offset)
                                  (:arg y ,sc nl1-offset)
                                  (:res res ,sc nl0-offset)
                                  (:temp temp ,sc nl2-offset))
          ,@(when (eq type 'tagged-num)
              `((inst sra x 2)))
         (cond
           ((member :sparc-64 *backend-subfeatures*)
            ;; Sign extend, then multiply
            (inst sra x 0)
            (inst sra y 0)
            (inst mulx res x y))
           ((or (member :sparc-v8 *backend-subfeatures*)
                (member :sparc-v9 *backend-subfeatures*))
            (inst smul res x y))
           (t
            (inst wry x)
            (inst andcc temp zero-tn)
            (inst nop)
            (inst nop)
            (dotimes (i 32)
              (inst mulscc temp y))
            (inst mulscc temp zero-tn)
           (inst rdy res))))))
  (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
  (frob signed-* "signed *" 41 signed-num signed-reg)
  (frob fixnum-* "fixnum *" 30 tagged-num any-reg))



;;;; Division.

#+sb-assembling
(defun emit-divide-loop (divisor rem quo tagged)
  (inst li quo 0)
  (labels
      ((do-loop (depth)
         (cond
          ((zerop depth)
           (inst unimp 0))
          (t
           (let ((label-1 (gen-label))
                 (label-2 (gen-label)))
             (inst cmp divisor rem)
             (inst b :geu label-1)
             (inst nop)
             (inst sll divisor 1)
             (do-loop (1- depth))
             (inst srl divisor 1)