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.

;;; static-fun-offset returns the address of the raw_addr slot of
;;; a static function's fdefn.

;;; Note that there is only one use of static-fun-offset outside this
;;; file (in genesis.lisp)

(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 temp1 non-descriptor-reg nl1-offset)
                          (:temp temp2 non-descriptor-reg nl2-offset)
                          (:temp pa-flag non-descriptor-reg nl4-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst or temp x y)
  (inst and temp fixnum-tag-mask)
  (inst bne temp DO-STATIC-FUN)
  (inst addu temp x y)
  ;; check for overflow
  (inst xor temp1 temp x)
  (inst xor temp2 temp y)
  (inst and temp1 temp2)
  (inst bltz temp1 DO-OVERFLOW)
  (inst sra temp1 x n-fixnum-tag-bits)
  (inst move res temp)
  (lisp-return lra lip :offset 2)

  DO-OVERFLOW
  ;; We did overflow, so do the bignum version
  (inst sra temp2 y n-fixnum-tag-bits)
  (inst addu temp temp1 temp2)
  (with-fixed-allocation (res pa-flag temp2 bignum-widetag
                          (1+ bignum-digits-offset) nil)
    (storew temp res bignum-digits-offset other-pointer-lowtag))
  (lisp-return lra lip :offset 2)

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg-+))
  (inst li nargs (fixnumize 2))
  (move ocfp cfp-tn)
  (inst j lip)
  (move cfp-tn csp-tn t))


(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 temp1 non-descriptor-reg nl1-offset)
                          (:temp temp2 non-descriptor-reg nl2-offset)
                          (:temp pa-flag non-descriptor-reg nl4-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst or temp x y)
  (inst and temp fixnum-tag-mask)
  (inst bne temp DO-STATIC-FUN)
  (inst subu temp x y)
  ;; check for overflow
  (inst xor temp1 x y)
  (inst xor temp2 x temp)
  (inst and temp1 temp2)
  (inst bltz temp1 DO-OVERFLOW)
  (inst sra temp1 x n-fixnum-tag-bits)
  (inst move res temp)
  (lisp-return lra lip :offset 2)

  DO-OVERFLOW
  ;; We did overflow, so do the bignum version
  (inst sra temp2 y n-fixnum-tag-bits)
  (inst subu temp temp1 temp2)
  (with-fixed-allocation (res pa-flag temp2 bignum-widetag
                          (1+ bignum-digits-offset) nil)
    (storew temp res bignum-digits-offset other-pointer-lowtag))
  (lisp-return lra lip :offset 2)

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg--))
  (inst li nargs (fixnumize 2))
  (move ocfp cfp-tn)
  (inst j lip)
  (move cfp-tn csp-tn t))



;;;; Multiplication


(define-assembly-routine (generic-*
                          (:cost 25)
                          (: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 pa-flag non-descriptor-reg nl4-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp lip interior-reg lip-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 or temp x y)
  (inst and temp fixnum-tag-mask)
  (inst bne temp DO-STATIC-FUN)
  ;; Remove the tag from one arg so that the result will have the correct
  ;; fixnum tag.
  (inst sra temp x n-fixnum-tag-bits)
  (inst mult temp y)
  (inst mflo res)
  (inst mfhi hi)
  ;; 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 res 31)
  (inst bne temp hi DO-BIGNUM)
  (inst srl lo res n-fixnum-tag-bits)
  (lisp-return lra lip :offset 2)

  DO-BIGNUM
  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
  ;; fixnum tag.
  (inst sll temp hi (- n-word-bits n-fixnum-tag-bits))
  (inst or lo temp)
  (inst sra hi n-fixnum-tag-bits)

  ;; Do we need one word or two?  Assume two.
  (inst sra temp lo 31)
  (inst bne temp hi TWO-WORDS)
  ;; Assume a two word header.
  (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))

  ;; Only need one word, fix the header.
  (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))

  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-lowtag)
    (storew temp res 0 other-pointer-lowtag))
  (storew lo res bignum-digits-offset other-pointer-lowtag)
  (lisp-return lra lip :offset 2)

  TWO-WORDS
  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
    (inst or res alloc-tn other-pointer-lowtag)
    (storew temp res 0 other-pointer-lowtag))

  (storew lo res bignum-digits-offset other-pointer-lowtag)
  (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'two-arg-*))
  (inst li nargs (fixnumize 2))
  (move ocfp cfp-tn)
  (inst j lip)
  (move cfp-tn csp-tn t))


(macrolet
    ((frob (name note cost type sc signed-p)
       `(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))
          ,@(when (eq type 'tagged-num)
              `((inst sra x 2)))
          (inst ,(if signed-p 'mult 'multu) x y)
          (inst mflo res))))
  (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
  (frob signed-* "signed *" 41 signed-num signed-reg t)
  (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))



;;;; Division.