arith.lisp

开源跨平台Lisp编译器

(in-package "SB!VM")


;;;; Multiplication and Division helping routines.

;;; ?? FIXME: Where are generic-* and generic-/?
#+sb-assembling
(define-assembly-routine
    multiply
    ((:arg x (signed-reg) nl0-offset)
     (:arg y (signed-reg) nl1-offset)

     (:res res (signed-reg) nl2-offset)

     (:temp tmp (unsigned-reg) nl3-offset)
     (:temp sign (unsigned-reg) nl4-offset))

  ;; Determine the sign of the result.
  (inst extrs x 0 1 sign :=)
  (inst sub zero-tn x x)
  (inst extrs y 0 1 tmp :=)
  (inst sub zero-tn y y)
  (inst xor sign tmp sign)

  ;; Make sure X is less then Y.
  (inst comclr x y tmp :<<)
  (inst xor x y tmp)
  (inst xor x tmp x)
  (inst xor y tmp y)
  ;; Blow out of here if the result is zero.
  (inst comb := x zero-tn done)
  (inst li 0 res)

  LOOP
  (inst extru x 31 1 zero-tn :ev)
  (inst add y res res)
  (inst extru x 30 1 zero-tn :ev)
  (inst sh1add y res res)
  (inst extru x 29 1 zero-tn :ev)
  (inst sh2add y res res)
  (inst extru x 28 1 zero-tn :ev)
  (inst sh3add y res res)

  (inst srl x 4 x)
  (inst comb :<> x zero-tn loop)
  (inst sll y 4 y)

  DONE
  (inst xor res sign res)
  (inst add res sign res))


#+sb-assembling
(define-assembly-routine
    (truncate)
    ((:arg dividend signed-reg nl0-offset)
     (:arg divisor signed-reg nl1-offset)

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

  ;; Move abs(divident) into quo.
  (inst move dividend quo :>=)
  (inst sub zero-tn quo quo)
  ;; Do one divive-step with -divisor to prime V  (use rem as a temp)
  (inst sub zero-tn divisor rem)
  (inst ds zero-tn rem zero-tn)
  ;; Shift the divident/quotient one bit, setting the carry flag.
  (inst add quo quo quo)
  ;; The first real divive-step.
  (inst ds zero-tn divisor rem)
  (inst addc quo quo quo)
  ;; And 31 more of them.
  (dotimes (i 31)
    (inst ds rem divisor rem)
    (inst addc quo quo quo))
  ;; If the remainder is negative, we need to add the absolute value of the
  ;; divisor.
  (inst comb :>= rem zero-tn remainder-positive)
  (inst comclr divisor zero-tn zero-tn :<)
  (inst add rem divisor rem :tr)
  (inst sub rem divisor rem)
  REMAINDER-POSITIVE
  ;; Now we have to fix the signs of quo and rem.
  (inst xor divisor dividend zero-tn :>=)
  (inst sub zero-tn quo quo)
  (inst move dividend zero-tn :>=)
  (inst sub zero-tn rem rem))



;;;; Generic arithmetic.

(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 lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst extru x 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst addo x y res)
  (lisp-return lra :offset 1)

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

(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 lip interior-reg lip-offset)
                          (:temp lra descriptor-reg lra-offset)
                          (:temp nargs any-reg nargs-offset)
                          (:temp ocfp any-reg ocfp-offset))
  (inst extru x 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fun :nullify t)
  (inst subo x y res)
  (lisp-return lra :offset 1)

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



;;;; Comparison routines.

(macrolet
    ((define-cond-assem-rtn (name translate static-fn cond)
       `(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 lip interior-reg lip-offset)
                                  (:temp lra descriptor-reg lra-offset)
                                  (:temp nargs any-reg nargs-offset)
                                  (:temp ocfp any-reg ocfp-offset))
          (inst extru x 31 2 zero-tn :=)
          (inst b do-static-fn :nullify t)
          (inst extru y 31 2 zero-tn :=)
          (inst b do-static-fn :nullify t)

          (inst comclr x y zero-tn ,cond)
          (inst move null-tn res :tr)
          (load-symbol res t)
          (lisp-return lra :offset 1)

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

  (define-cond-assem-rtn generic-< < two-arg-< :<)
  (define-cond-assem-rtn generic-> > two-arg-> :>))


(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 lip interior-reg lip-offset)
     (:temp lra descriptor-reg lra-offset)
     (:temp nargs any-reg nargs-offset)
     (:temp ocfp any-reg ocfp-offset))

  (inst comb := x y return-t :nullify t)
  (inst extru x 31 2 zero-tn :<>)
  (inst b return-nil :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fn :nullify t)

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

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

  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 lip interior-reg lip-offset)
     (:temp lra descriptor-reg lra-offset)
     (:temp nargs any-reg nargs-offset)
     (:temp ocfp any-reg ocfp-offset))

  (inst comb := x y return-t :nullify t)
  (inst extru x 31 2 zero-tn :=)
  (inst b do-static-fn :nullify t)
  (inst extru y 31 2 zero-tn :=)
  (inst b do-static-fn :nullify t)

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

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

  RETURN-T
  (load-symbol res t))