arith.lisp

开源跨平台Lisp编译器

;;;; the VM definition arithmetic VOPs for MIPS

;;;; 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")

;;;; Unary operations.

(define-vop (fast-safe-arith-op)
  (:policy :fast-safe)
  (:effects)
  (:affected))

(define-vop (fixnum-unop fast-safe-arith-op)
  (:args (x :scs (any-reg)))
  (:results (res :scs (any-reg)))
  (:note "inline fixnum arithmetic")
  (:arg-types tagged-num)
  (:result-types tagged-num))

(define-vop (signed-unop fast-safe-arith-op)
  (:args (x :scs (signed-reg)))
  (:results (res :scs (signed-reg)))
  (:note "inline (signed-byte 32) arithmetic")
  (:arg-types signed-num)
  (:result-types signed-num))

(define-vop (fast-negate/fixnum fixnum-unop)
  (:translate %negate)
  (:generator 1
    (inst subu res zero-tn x)))

(define-vop (fast-negate/signed signed-unop)
  (:translate %negate)
  (:generator 2
    (inst subu res zero-tn x)))

(define-vop (fast-lognot/fixnum fixnum-unop)
  (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
              temp)
  (:translate lognot)
  (:generator 1
    (inst li temp (fixnumize -1))
    (inst xor res x temp)))

(define-vop (fast-lognot/signed signed-unop)
  (:translate lognot)
  (:generator 2
    (inst nor res x zero-tn)))

;;;; Binary fixnum operations.

;;; Assume that any constant operand is the second arg...

(define-vop (fast-fixnum-binop fast-safe-arith-op)
  (:args (x :target r :scs (any-reg zero))
         (y :target r :scs (any-reg zero)))
  (:arg-types tagged-num tagged-num)
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:note "inline fixnum arithmetic"))

(define-vop (fast-unsigned-binop fast-safe-arith-op)
  (:args (x :target r :scs (unsigned-reg zero))
         (y :target r :scs (unsigned-reg zero)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic"))

(define-vop (fast-signed-binop fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg zero))
         (y :target r :scs (signed-reg zero)))
  (:arg-types signed-num signed-num)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:note "inline (signed-byte 32) arithmetic"))

(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
  (:args (x :target r :scs (any-reg)))
  (:info y)
  (:arg-types tagged-num (:constant integer)))

(define-vop (fast-signed-c-binop fast-signed-binop)
  (:args (x :target r :scs (signed-reg)))
  (:info y)
  (:arg-types tagged-num (:constant integer)))

(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
  (:args (x :target r :scs (unsigned-reg)))
  (:info y)
  (:arg-types tagged-num (:constant integer)))

(defmacro define-binop (translate cost untagged-cost op
                                  tagged-type untagged-type)
  `(progn
     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
                  fast-fixnum-binop)
       (:args (x :target r :scs (any-reg))
              (y :target r :scs (any-reg)))
       (:translate ,translate)
       (:generator ,(1+ cost)
         (inst ,op r x y)))
     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
                  fast-signed-binop)
       (:args (x :target r :scs (signed-reg))
              (y :target r :scs (signed-reg)))
       (:translate ,translate)
       (:generator ,(1+ untagged-cost)
         (inst ,op r x y)))
     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
                  fast-unsigned-binop)
       (:args (x :target r :scs (unsigned-reg))
              (y :target r :scs (unsigned-reg)))
       (:translate ,translate)
       (:generator ,(1+ untagged-cost)
         (inst ,op r x y)))
     ,@(when tagged-type
         `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
                        fast-fixnum-c-binop)
                       (:arg-types tagged-num (:constant ,tagged-type))
             (:translate ,translate)
             (:generator ,cost
                         (inst ,op r x (fixnumize y))))))
     ,@(when untagged-type
         `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
                        fast-signed-c-binop)
                       (:arg-types signed-num (:constant ,untagged-type))
             (:translate ,translate)
             (:generator ,untagged-cost
                         (inst ,op r x y)))
           (define-vop (,(symbolicate "FAST-" translate
                                      "-C/UNSIGNED=>UNSIGNED")
                        fast-unsigned-c-binop)
                       (:arg-types unsigned-num (:constant ,untagged-type))
             (:translate ,translate)
             (:generator ,untagged-cost
                         (inst ,op r x y)))))))

(define-binop + 1 5 addu (signed-byte 14) (signed-byte 16))
(define-binop - 1 5 subu
  (integer #.(- 1 (ash 1 13)) #.(ash 1 13))
  (integer #.(- 1 (ash 1 15)) #.(ash 1 15)))
(define-binop logior 1 3 or (unsigned-byte 14) (unsigned-byte 16))
(define-binop logand 1 3 and (unsigned-byte 14) (unsigned-byte 16))
(define-binop logxor 1 3 xor (unsigned-byte 14) (unsigned-byte 16))

;;; No -C/ VOPs for LOGNOR because the NOR instruction doesn't take
;;; immediate args.  -- CSR, 2003-09-11
(define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop)
  (:translate lognor)
  (:args (x :target r :scs (any-reg))
         (y :target r :scs (any-reg)))
  (:temporary (:sc non-descriptor-reg) temp)
  (:generator 4
    (inst nor temp x y)
    (inst addu r temp (- fixnum-tag-mask))))

(define-vop (fast-lognor/signed=>signed fast-signed-binop)
  (:translate lognor)
  (:args (x :target r :scs (signed-reg))
         (y :target r :scs (signed-reg)))
  (:generator 4
    (inst nor r x y)))

(define-vop (fast-lognor/unsigned=>unsigned fast-unsigned-binop)
  (:translate lognor)
  (:args (x :target r :scs (unsigned-reg))
         (y :target r :scs (unsigned-reg)))
  (:generator 4
    (inst nor r x y)))

;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
;;; know that the result is going to be a fixnum.
#+nil
(progn
  (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
      (:results (r :scs (any-reg descriptor-reg)))
    (:result-types (:or signed-num unsigned-num))
    (:note nil)
    (:generator 4
                (inst add r x y)))

  (define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
      (:results (r :scs (any-reg descriptor-reg)))
    (:result-types (:or signed-num unsigned-num))
    (:note nil)
    (:generator 3
                (inst add r x (fixnumize y))))

  (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
      (:results (r :scs (any-reg descriptor-reg)))
    (:result-types (:or signed-num unsigned-num))
    (:note nil)
    (:generator 4
                (inst sub r x y)))

  (define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
      (:results (r :scs (any-reg descriptor-reg)))
    (:result-types (:or signed-num unsigned-num))
    (:note nil)
    (:generator 3
                (inst sub r x (fixnumize y))))
) ; bogus trap-to-c-land +/-

;;; Shifting

(define-vop (fast-ash/unsigned=>unsigned)
  (:note "inline ASH")
  (:args (number :scs (unsigned-reg) :to :save)
         (amount :scs (signed-reg) :to :save))
  (:arg-types unsigned-num signed-num)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate ash)
  (:policy :fast-safe)
  (:temporary (:sc non-descriptor-reg) ndesc)
  (:temporary (:sc non-descriptor-reg :to :eval) temp)
  (:generator 3
    (inst bgez amount positive)
    (inst subu ndesc zero-tn amount)
    (inst slt temp ndesc 32)
    (inst bne temp done)
    (inst srl result number ndesc)
    (inst b done)
    (move result zero-tn t)

    POSITIVE
    ;; The result-type assures us that this shift will not overflow.
    (inst sll result number amount)

    DONE))

(define-vop (fast-ash/signed=>signed)
  (:note "inline ASH")
  (:args (number :scs (signed-reg) :to :save)
         (amount :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:results (result :scs (signed-reg)))
  (:result-types signed-num)
  (:translate ash)
  (:policy :fast-safe)
  (:temporary (:sc non-descriptor-reg) ndesc)
  (:temporary (:sc non-descriptor-reg :to :eval) temp)
  (:generator 3
    (inst bgez amount positive)
    (inst subu ndesc zero-tn amount)
    (inst slt temp ndesc 31)
    (inst bne temp done)
    (inst sra result number ndesc)
    (inst b done)
    (inst sra result number 31)

    POSITIVE
    ;; The result-type assures us that this shift will not overflow.
    (inst sll result number amount)

    DONE))


(define-vop (fast-ash-c/unsigned=>unsigned)
  (:policy :fast-safe)
  (:translate ash)
  (:note "inline ASH")
  (:args (number :scs (unsigned-reg)))
  (:info count)
  (:arg-types unsigned-num (:constant integer))
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
    (cond
      ((< count -31) (move result zero-tn))
      ((< count 0) (inst srl result number (min (- count) 31)))
      ((> count 0) (inst sll result number (min count 31)))
      (t (bug "identity ASH not transformed away")))))

(define-vop (fast-ash-c/signed=>signed)
  (:policy :fast-safe)
  (:translate ash)
  (:note "inline ASH")
  (:args (number :scs (signed-reg)))
  (:info count)
  (:arg-types signed-num (:constant integer))
  (:results (result :scs (signed-reg)))
  (:result-types signed-num)
  (:generator 1
    (cond
      ((< count 0) (inst sra result number (min (- count) 31)))
      ((> count 0) (inst sll result number (min count 31)))
      (t (bug "identity ASH not transformed away")))))

(macrolet ((def (name sc-type type result-type cost)
             `(define-vop (,name)
                (:note "inline ASH")
                (:translate ash)
                (:args (number :scs (,sc-type))
                       (amount :scs (signed-reg unsigned-reg immediate)))
                (:arg-types ,type positive-fixnum)
                (:results (result :scs (,result-type)))
                (:result-types ,type)
                (:policy :fast-safe)
                (:generator ,cost
                   (sc-case amount
                     ((signed-reg unsigned-reg)
                      (inst sll result number amount))
                     (immediate
                      (let ((amount (tn-value amount)))
                        (aver (> amount 0))
                        (inst sll result number amount))))))))
  (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
  (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
  (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))

(define-vop (signed-byte-32-len)
  (:translate integer-length)
  (:note "inline (signed-byte 32) integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (signed-reg) :target shift))