arith.lisp

开源跨平台Lisp编译器

(define-assembly-routine (positive-fixnum-truncate
                          (:note "unsigned fixnum truncate")
                          (:cost 45)
                          (:translate truncate)
                          (:policy :fast-safe)
                          (:arg-types positive-fixnum positive-fixnum)
                          (:result-types positive-fixnum positive-fixnum))
                         ((:arg dividend any-reg nl0-offset)
                          (:arg divisor any-reg nl1-offset)

                          (:res quo any-reg nl2-offset)
                          (:res rem any-reg nl3-offset))
  (let ((error (generate-error-code nil division-by-zero-error
                                    dividend divisor)))
    (inst beq divisor error)
    (inst nop))

    (inst divu dividend divisor)
    (inst mflo quo)
    (inst mfhi rem)
    (inst sll quo 2))


(define-assembly-routine (fixnum-truncate
                          (:note "fixnum truncate")
                          (:cost 50)
                          (:policy :fast-safe)
                          (:translate truncate)
                          (:arg-types tagged-num tagged-num)
                          (:result-types tagged-num tagged-num))
                         ((:arg dividend any-reg nl0-offset)
                          (:arg divisor any-reg nl1-offset)

                          (:res quo any-reg nl2-offset)
                          (:res rem any-reg nl3-offset))
  (let ((error (generate-error-code nil division-by-zero-error
                                    dividend divisor)))
    (inst beq divisor error)
    (inst nop))

    (inst div dividend divisor)
    (inst mflo quo)
    (inst mfhi rem)
    (inst sll quo 2))


(define-assembly-routine (signed-truncate
                          (:note "(signed-byte 32) 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))
  (let ((error (generate-error-code nil division-by-zero-error
                                    dividend divisor)))
    (inst beq divisor error)
    (inst nop))

    (inst div dividend divisor)
    (inst mflo quo)
    (inst mfhi rem))



;;;; 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 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)
          ,cmp

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

          DONE
          (lisp-return lra lip :offset 2)

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

  (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t)
  (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil)
  (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) t)
  (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp y x) 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 lra descriptor-reg lra-offset)
                          (:temp lip interior-reg lip-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst beq x y RETURN-T)
  (inst or temp x y)
  (inst and temp fixnum-tag-mask)
  (inst bne temp DO-STATIC-FUN)
  (inst nop)

  (inst bne x y DONE)
  (move res null-tn t)

  RETURN-T
  (load-symbol res t)

  DONE
  (lisp-return lra lip :offset 2)

  DO-STATIC-FUN
  (inst lw lip null-tn (static-fun-offset 'eql))
  (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)
                          (: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 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 nop)

  (inst bne x y DONE)
  (move res null-tn t)
  (load-symbol res t)

  DONE
  (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)
                          (: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 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 nop)

  (inst beq x y DONE)
  (move res null-tn t)
  (load-symbol res t)

  DONE
  (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))