arith.lisp

开源跨平台Lisp编译器

;;;; the VM definition arithmetic VOPs for the SPARC

;;;; 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 neg res x)))

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

(define-vop (fast-lognot/fixnum fixnum-unop)
  (:translate lognot)
  (:generator 1
    (inst xor res x (fixnumize -1))))

(define-vop (fast-lognot/signed signed-unop)
  (:translate lognot)
  (:generator 2
    (inst not res x)))

;;;; 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-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (any-reg zero)))
  (:info y)
  (:arg-types tagged-num
              (:constant (and (signed-byte 11) (not (integer 0 0)))))
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:note "inline fixnum arithmetic"))

(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (unsigned-reg zero)))
  (:info y)
  (:arg-types unsigned-num
              (:constant (and (signed-byte 13) (not (integer 0 0)))))
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic"))

(define-vop (fast-signed-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg zero)))
  (:info y)
  (:arg-types signed-num
              (:constant (and (signed-byte 13) (not (integer 0 0)))))
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:note "inline (signed-byte 32) arithmetic"))


(eval-when (:compile-toplevel :load-toplevel :execute)

(defmacro define-binop (translate untagged-penalty op
                        &optional arg-swap restore-fixnum-mask)
  `(progn
     (define-vop (,(symbolicate 'fast translate '/fixnum=>fixnum)
                  fast-fixnum-binop)
       ,@(when restore-fixnum-mask
           `((:temporary (:sc non-descriptor-reg) temp)))
       (:translate ,translate)
       (:generator 2
         ,(if arg-swap
              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
         ,@(when restore-fixnum-mask
             `((inst andn r temp fixnum-tag-mask)))))
     ,@(unless arg-swap
         `((define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
                        fast-fixnum-binop-c)
             ,@(when restore-fixnum-mask
                 `((:temporary (:sc non-descriptor-reg) temp)))
             (:translate ,translate)
             (:generator 1
               (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y))
               ,@(when restore-fixnum-mask
                   `((inst andn r temp fixnum-tag-mask)))))))
     (define-vop (,(symbolicate 'fast- translate '/signed=>signed)
                  fast-signed-binop)
       (:translate ,translate)
       (:generator ,(1+ untagged-penalty)
         ,(if arg-swap
              `(inst ,op r y x)
              `(inst ,op r x y))))
     ,@(unless arg-swap
         `((define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
                        fast-signed-binop-c)
             (:translate ,translate)
             (:generator ,untagged-penalty
               (inst ,op r x y)))))
     (define-vop (,(symbolicate 'fast- translate '/unsigned=>unsigned)
                  fast-unsigned-binop)
       (:translate ,translate)
       (:generator ,(1+ untagged-penalty)
         ,(if arg-swap
              `(inst ,op r y x)
              `(inst ,op r x y))))
     ,@(unless arg-swap
         `((define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
                        fast-unsigned-binop-c)
             (:translate ,translate)
             (:generator ,untagged-penalty
               (inst ,op r x y)))))))

); eval-when

(define-binop + 4 add)
(define-binop - 4 sub)
(define-binop logand 2 and)
(define-binop logandc1 2 andn t)
(define-binop logandc2 2 andn)
(define-binop logior 2 or)
(define-binop logorc1 2 orn t t)
(define-binop logorc2 2 orn nil t)
(define-binop logxor 2 xor)
(define-binop logeqv 2 xnor nil t)

(define-vop (fast-logand/signed-unsigned=>unsigned fast-logand/unsigned=>unsigned)
  (:args (x :scs (signed-reg) :target r)
         (y :scs (unsigned-reg) :target r))
  (:arg-types signed-num unsigned-num)
  (:translate logand))

;;; Special case fixnum + and - that trap on overflow.  Useful when we
;;; don't know that the output type is a fixnum.

;;; I (Raymond Toy) took these out. They don't seem to be used
;;; anywhere at all.
#+nil
(progn
(define-vop (+/fixnum fast-+/fixnum=>fixnum)
  (:policy :safe)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types tagged-num)
  (:note "safe inline fixnum arithmetic")
  (:generator 4
    (inst taddcctv r x y)))

(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum)
  (:policy :safe)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types tagged-num)
  (:note "safe inline fixnum arithmetic")
  (:generator 3
    (inst taddcctv r x (fixnumize y))))

(define-vop (-/fixnum fast--/fixnum=>fixnum)
  (:policy :safe)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types tagged-num)
  (:note "safe inline fixnum arithmetic")
  (:generator 4
    (inst tsubcctv r x y)))

(define-vop (--c/fixnum fast---c/fixnum=>fixnum)
  (:policy :safe)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types tagged-num)
  (:note "safe inline fixnum arithmetic")
  (:generator 3
    (inst tsubcctv r x (fixnumize y))))

)

;;; Truncate

;; This doesn't work for some reason.
#+nil
(define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (any-reg))
         (y :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:results (quo :scs (any-reg))
            (rem :scs (any-reg)))
  (:result-types tagged-num tagged-num)
  (:note "inline fixnum arithmetic")
  (:temporary (:scs (any-reg) :target quo) q)
  (:temporary (:scs (any-reg)) r)
  (:temporary (:scs (signed-reg)) y-int)
  (:vop-var vop)
  (:save-p :compute-only)
  (:guard (or (member :sparc-v8 *backend-subfeatures*)
              (and (member :sparc-v9 *backend-subfeatures*)
                   (not (member :sparc-64 *backend-subfeatures*)))))
  (:generator 12
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst cmp y zero-tn)
      (inst b :eq zero)
      ;; Extend the sign of X into the Y register
        (inst sra r x 31)
      (inst wry r)
      ;; Remove tag bits so Q and R will be tagged correctly.
      (inst sra y-int y n-fixnum-tag-bits)
      (inst nop)
      (inst nop)

      (inst sdiv q x y-int)             ; Q is tagged.
      ;; We have the quotient so we need to compute the remainder
      (inst smul r q y-int)             ; R is tagged
      (inst sub rem x r)
      (unless (location= quo q)
        (move quo q)))))

(define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:results (quo :scs (signed-reg))
            (rem :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:note "inline (signed-byte 32) arithmetic")
  (:temporary (:scs (signed-reg) :target quo) q)
  (:temporary (:scs (signed-reg)) r)
  (:vop-var vop)
  (:save-p :compute-only)
  (:guard (or (member :sparc-v8 *backend-subfeatures*)
              (and (member :sparc-v9 *backend-subfeatures*)
                   (not (member :sparc-64 *backend-subfeatures*)))))
  (:generator 12
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst cmp y zero-tn)
      (if (member :sparc-v9 *backend-subfeatures*)
          (inst b :eq zero :pn)
          (inst b :eq zero))
      ;; Extend the sign of X into the Y register
      (inst sra r x 31)
      (inst wry r)
      (inst nop)
      (inst nop)
      (inst nop)

      (inst sdiv q x y)
      ;; We have the quotient so we need to compue the remainder
      (inst smul r q y)         ; rem
      (inst sub rem x r)
      (unless (location= quo q)
        (move quo q)))))

(define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:results (quo :scs (unsigned-reg))
            (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic")
  (:temporary (:scs (unsigned-reg) :target quo) q)
  (:temporary (:scs (unsigned-reg)) r)
  (:vop-var vop)
  (:save-p :compute-only)
  (:guard (or (member :sparc-v8 *backend-subfeatures*)
              (and (member :sparc-v9 *backend-subfeatures*)
                   (not (member :sparc-64 *backend-subfeatures*)))))
  (:generator 8
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst cmp y zero-tn)
      (if (member :sparc-v9 *backend-subfeatures*)
          (inst b :eq zero :pn)
          (inst b :eq zero))
      (inst wry zero-tn)                ; Clear out high part
      (inst nop)
      (inst nop)
      (inst nop)

      (inst udiv q x y)
      ;; Compute remainder
      (inst umul r q y)
      (inst sub rem x r)
      (unless (location= quo q)
        (inst move quo q)))))

(define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:results (quo :scs (signed-reg))
            (rem :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:note "inline (signed-byte 32) arithmetic")
  (:temporary (:scs (signed-reg) :target quo) q)
  (:temporary (:scs (signed-reg)) r)
  (:vop-var vop)
  (:save-p :compute-only)
  (:guard (member :sparc-64 *backend-subfeatures*))
  (:generator 8
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst cmp y zero-tn)
      (inst b :eq zero :pn)
      ;; Sign extend the numbers, just in case.
      (inst sra x 0)
      (inst sra y 0)
      (inst sdivx q x y)
      ;; Compute remainder
      (inst mulx r q y)
      (inst sub rem x r)
      (unless (location= quo q)
        (inst move quo q)))))

(define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:results (quo :scs (unsigned-reg))
            (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic")
  (:temporary (:scs (unsigned-reg) :target quo) q)
  (:temporary (:scs (unsigned-reg)) r)
  (:vop-var vop)
  (:save-p :compute-only)
  (:guard (member :sparc-64 *backend-subfeatures*))
  (:generator 8
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst cmp y zero-tn)
      (inst b :eq zero :pn)
      ;; Zap the higher 32 bits, just in case
      (inst srl x 0)
      (inst srl y 0)
      (inst udivx q x y)
      ;; Compute remainder
      (inst mulx r q y)
      (inst sub rem x r)
      (unless (location= quo q)
        (inst move quo q)))))

;;; Shifting

(define-vop (fast-ash/signed=>signed)
  (:note "inline ASH")
  (:args (number :scs (signed-reg) :to :save)
         (amount :scs (signed-reg) :to :save))
  (: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)
  (:generator 5
    (let ((done (gen-label)))
      (inst cmp amount)
      (inst b :ge done)
      ;; The result-type assures us that this shift will not