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")

(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 temp3 non-descriptor-reg nl2-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst and x 3 temp)
  (inst bne temp DO-STATIC-FUN)
  (inst and y 3 temp)
  (inst bne temp DO-STATIC-FUN)
  (inst addq x y res)

  ; Check whether we need a bignum.
  (inst sra res 31 temp)
  (inst beq temp DONE)
  (inst not temp temp)
  (inst beq temp DONE)
  (inst sra res 2 temp3)

  ; from move-from-signed
  (inst li 2 temp2)
  (inst sra temp3 31 temp)
  (inst cmoveq temp 1 temp2)
  (inst not temp temp)
  (inst cmoveq temp 1 temp2)
  (inst sll temp2 n-widetag-bits temp2)
  (inst bis temp2 bignum-widetag temp2)

  (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
    (inst bis alloc-tn other-pointer-lowtag res)
    (storew temp2 res 0 other-pointer-lowtag)
    (storew temp3 res bignum-digits-offset other-pointer-lowtag)
    (inst srl temp3 32 temp)
    (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag))
  DONE
  (lisp-return lra lip :offset 2)

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


(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 temp3 non-descriptor-reg nl2-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst and x 3 temp)
  (inst bne temp DO-STATIC-FUN)
  (inst and y 3 temp)
  (inst bne temp DO-STATIC-FUN)
  (inst subq x y res)

  ; Check whether we need a bignum.
  (inst sra res 31 temp)
  (inst beq temp DONE)
  (inst not temp temp)
  (inst beq temp DONE)
  (inst sra res 2 temp3)

  ; from move-from-signed
  (inst li 2 temp2)
  (inst sra temp3 31 temp)
  (inst cmoveq temp 1 temp2)
  (inst not temp temp)
  (inst cmoveq temp 1 temp2)
  (inst sll temp2 n-widetag-bits temp2)
  (inst bis temp2 bignum-widetag temp2)

  (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
    (inst bis alloc-tn other-pointer-lowtag res)
    (storew temp2 res 0 other-pointer-lowtag)
    (storew temp3 res bignum-digits-offset other-pointer-lowtag)
    (inst srl temp3 32 temp)
    (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag))
  DONE
  (lisp-return lra lip :offset 2)

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


(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 temp2 non-descriptor-reg nl3-offset)
                          (:temp lip interior-reg lip-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 and x 3 temp)
  (inst bne temp DO-STATIC-FUN)
  (inst and y 3 temp)
  (inst bne temp DO-STATIC-FUN)

  ;; Remove the tag from one arg so that the result will have the
  ;; correct fixnum tag.
  (inst sra x 2 temp)
  (inst mulq temp y lo)
  (inst sra lo 32 hi)
  (inst sll lo 32 res)
  (inst sra res 32 res)
  ;; 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 res 31 temp)
  (inst xor hi temp temp)
  (inst beq temp DONE)
  ;; Shift the double word hi:res down two bits into hi:low to get rid
  ;; of the fixnum tag.
  (inst sra lo 2 lo)
  (inst sra lo 32 hi)

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

  ;; Only need one word, fix the header.
  (inst li (logior (ash 1 n-widetag-bits) bignum-widetag) temp2)
  ;; Allocate one word.
  (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
    (inst bis alloc-tn other-pointer-lowtag res)
    (storew temp2 res 0 other-pointer-lowtag))
  ;; Store one word
  (storew lo res bignum-digits-offset other-pointer-lowtag)
  ;; Out of here
  (lisp-return lra lip :offset 2)

  TWO-WORDS
  ;; Allocate two words.
  (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))
    (inst bis alloc-tn other-pointer-lowtag res)
    (storew temp2 res 0 other-pointer-lowtag))
  ;; Store two words.
  (storew lo res bignum-digits-offset other-pointer-lowtag)
  (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
  ;; out of here
  (lisp-return lra lip :offset 2)

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

  DONE)


;;;; division

(define-assembly-routine (signed-truncate
                          (:note "(signed-byte 64) truncate")
                          (:cost 60)
                          (:policy :fast-safe)
                          (:translate truncate)
                          (:arg-types signed-num signed-num)
                          (:result-types signed-num signed-num))

                         ((:arg dividend signed-reg nl0-offset)
                          (:arg divisor signed-reg nl1-offset)

                          (:res quo signed-reg nl2-offset)
                          (:res rem signed-reg nl3-offset)

                          (:temp quo-sign signed-reg nl5-offset)
                          (:temp rem-sign signed-reg nargs-offset)
                          (:temp temp1 non-descriptor-reg nl4-offset))

  (let ((error (generate-error-code nil division-by-zero-error
                                    dividend divisor)))
    (inst beq divisor error))

  (inst xor dividend divisor quo-sign)
  (inst move dividend rem-sign)
  (let ((label (gen-label)))
    (inst bge dividend label)
    (inst subq zero-tn dividend dividend)
    (emit-label label))
  (let ((label (gen-label)))
    (inst bge divisor label)
    (inst subq zero-tn divisor divisor)
    (emit-label label))
  (inst move zero-tn rem)
  (inst move zero-tn quo)

  (dotimes (i 64)
    (inst srl dividend 63 temp1)
    (inst sll rem 1 rem)
    (inst bis temp1 rem rem)
    (inst cmple divisor rem temp1)
    (inst sll quo 1 quo)
    (inst bis temp1 quo quo)
    (inst sll dividend 1 dividend)
    (inst subq temp1 1 temp1)
    (inst zap divisor temp1 temp1)
    (inst subq rem temp1 rem))

  (let ((label (gen-label)))
    ;; If the quo-sign is negative, we need to negate quo.
    (inst bge quo-sign label)
    (inst subq zero-tn quo quo)
    (emit-label label))
  (let ((label (gen-label)))
    ;; If the rem-sign is negative, we need to negate rem.
    (inst bge rem-sign label)
    (inst subq zero-tn rem rem)
    (emit-label label)))


;;;; comparison routines

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cmp not-p)
       `(define-assembly-routine (,name
                                  (:cost 10)
                                  (:return-style :full-call)
                                  (:policy :safe)
                                  (:translate ,translate)
                                  (:save-p t))
                                 ((:arg x (descriptor-reg any-reg) a0-offset)
                                  (:arg y (descriptor-reg any-reg) a1-offset)

                                  (:res res descriptor-reg a0-offset)

                                  (:temp temp non-descriptor-reg nl0-offset)
                                  (:temp lip interior-reg lip-offset)
                                  (:temp nargs any-reg nargs-offset)
                                  (:temp ocfp any-reg ocfp-offset))
          (inst and x 3 temp)
          (inst bne temp DO-STATIC-FN)
          (inst and y 3 temp)
          (inst beq temp DO-COMPARE)

          DO-STATIC-FN
          (inst ldl lip (static-fun-offset ',static-fn) null-tn)
          (inst li (fixnumize 2) nargs)
          (inst move cfp-tn ocfp)
          (inst move csp-tn cfp-tn)
          (inst jmp zero-tn lip)

          DO-COMPARE
          ,cmp
          (inst move null-tn res)
          (inst ,(if not-p 'bne 'beq) temp done)
          (load-symbol res t)
          DONE)))

  (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil)
  (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil))


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

                          (:res res descriptor-reg a0-offset)

                          (:temp temp non-descriptor-reg nl0-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst cmpeq x y temp)
  (inst bne temp RETURN-T)
  (inst and x 3 temp)
  (inst beq temp RETURN-NIL)
  (inst and y 3 temp)
  (inst bne temp DO-STATIC-FN)

  RETURN-NIL
  (inst move null-tn res)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst ldl lip (static-fun-offset 'eql) null-tn)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst move csp-tn cfp-tn)
  (inst jmp zero-tn lip)

  RETURN-T
  (load-symbol res t))

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

                          (:res res descriptor-reg a0-offset)

                          (:temp temp non-descriptor-reg nl0-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst and x 3 temp)
  (inst bne temp DO-STATIC-FN)
  (inst and y 3 temp)
  (inst bne temp DO-STATIC-FN)
  (inst cmpeq x y temp)
  (inst bne temp RETURN-T)

  (inst move null-tn res)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst ldl lip (static-fun-offset 'two-arg-=) null-tn)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst move csp-tn cfp-tn)
  (inst jmp zero-tn lip)

  RETURN-T
  (load-symbol res t))

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

                          (:res res descriptor-reg a0-offset)

                          (:temp temp non-descriptor-reg nl0-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst and x 3 temp)
  (inst bne temp DO-STATIC-FN)
  (inst and y 3 temp)
  (inst bne temp DO-STATIC-FN)
  (inst cmpeq x y temp)
  (inst bne temp RETURN-NIL)

  (load-symbol res t)
  (lisp-return lra lip :offset 2)

  DO-STATIC-FN
  (inst ldl lip (static-fun-offset 'two-arg-/=) null-tn)
  (inst li (fixnumize 2) nargs)
  (inst move cfp-tn ocfp)
  (inst move csp-tn cfp-tn)
  (inst jmp zero-tn lip)

  RETURN-NIL
  (inst move null-tn res))