arith.lisp

开源跨平台Lisp编译器

;;;; the VM definition arithmetic VOPs for the PPC

;;;; 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 subfic 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 14) (not (integer 0 0)))))
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:note "inline fixnum arithmetic"))

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

(define-vop (fast-fixnum-logop-c fast-safe-arith-op)
  (:args (x :target r :scs (any-reg zero)))
  (:info y)
  (:arg-types tagged-num
              (:constant (and (unsigned-byte 14) (not (integer 0 0)))))
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:note "inline fixnum logical op"))

(define-vop (fast-fixnum-logop30-c fast-safe-arith-op)
  (:args (x :target r :scs (any-reg zero)))
  (:info y)
  (:arg-types tagged-num
              (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:note "inline fixnum logical op"))

(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 16) (not (integer 0 0)))))
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic"))

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

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

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

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

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

(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 16) (not (integer 0 0)))))
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:note "inline (signed-byte 32) arithmetic"))

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

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

(defmacro !define-var-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))
         ;; FIXME: remind me what convention we used for 64bitizing
         ;; stuff?  -- CSR, 2003-08-27
         ,@(when restore-fixnum-mask
             `((inst clrrwi r temp (1- n-lowtag-bits))))))
     (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))))
     (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))))))

;;; FIXME: the code has really only been checked for adds; we could do
;;; subtracts, too, but my brain is not up to the task of figuring out
;;; signs and borrows.
(defmacro !define-const-binop (translate untagged-penalty op &optional (shifted-op nil))
  `(progn
     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
                  ,(if shifted-op
                       'fast-fixnum-binop30-c
                       'fast-fixnum-binop-c))
       (:translate ,translate)
       ,@(when shifted-op
          `((:temporary (:sc any-reg :target r) temp)))
       (:generator 1
        ,(if shifted-op
             `(let* ((y (fixnumize y))
                     (high-half (ldb (byte 16 16) y))
                     (low-half (ldb (byte 16 0) y)))
               ;; Compare %LR in insts.lisp.
               (cond
                 ((and (logbitp 15 low-half) (= high-half #xffff))
                  ;; Let sign-extension do the work for us, but make sure
                  ;; to turn LOW-HALF into a signed integer.
                  (inst ,op r x (dpb low-half (byte 16 0) -1)))
                 ((and (not (logbitp 15 low-half)) (zerop high-half))
                  (inst ,op r x low-half))
                 ((zerop low-half)
                  (inst ,shifted-op r x (if (logbitp 15 high-half)
                                            (dpb high-half (byte 16 0) -1)
                                            high-half)))
                 (t
                  ;; Check to see whether compensating for the sign bit
                  ;; of LOW-HALF is necessary.
                  (let ((high-half (let ((top (if (logbitp 15 low-half)
                                                  (ldb (byte 16 0)
                                                       (1+ high-half))
                                                  high-half)))
                                     (if (logbitp 15 top)
                                         (dpb top (byte 16 0) -1)
                                         top))))
                    (inst ,shifted-op temp x high-half)
                    (inst ,op r temp low-half)))))
             `(inst ,op r x (fixnumize y)))))
     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
                  ,(if shifted-op
                       'fast-signed-binop32-c
                       'fast-signed-binop-c))
       (:translate ,translate)
       ,@(when shifted-op
          `((:temporary (:sc non-descriptor-reg :target r) temp)))
       (:generator ,untagged-penalty
        ,(if shifted-op
             `(let ((high-half (ldb (byte 16 16) y))
                    (low-half (ldb (byte 16 0) y)))
               ;; Compare %LR in insts.lisp.
               (cond
                 ((and (logbitp 15 low-half) (= high-half #xffff))
                  ;; Let sign-extension do the work for us, but make sure
                  ;; to turn LOW-HALF into a signed integer.
                  (inst ,op r x (dpb low-half (byte 16 0) -1)))
                 ((and (not (logbitp 15 low-half)) (zerop high-half))
                  (inst ,op r x low-half))
                 ((zerop low-half)
                  (inst ,shifted-op r x (if (logbitp 15 high-half)
                                            (dpb high-half (byte 16 0) -1)
                                            high-half)))
                 (t
                  ;; Check to see whether compensating for the sign bit
                  ;; of LOW-HALF is necessary.
                  (let ((high-half (let ((top (if (logbitp 15 low-half)
                                                  (ldb (byte 16 0)
                                                       (1+ high-half))
                                                  high-half)))
                                     (if (logbitp 15 top)
                                         (dpb top (byte 16 0) -1)
                                         top))))
                    (inst ,shifted-op temp x high-half)
                    (inst ,op r temp low-half)))))
             `(inst ,op r x y))))
     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
                  ,(if shifted-op
                       'fast-unsigned-binop32-c
                       'fast-unsigned-binop-c))
       (:translate ,translate)
       ,@(when shifted-op
          `((:temporary (:sc non-descriptor-reg :target r) temp)))
       (:generator ,untagged-penalty
        ,(if shifted-op
             `(let ((high-half (ldb (byte 16 16) y))
                    (low-half (ldb (byte 16 0) y)))
               ;; Compare %LR in insts.lisp.
               (cond
                 ((and (logbitp 15 low-half) (= high-half #xffff))
                  ;; Let sign-extension do the work for us, but make sure
                  ;; to turn LOW-HALF into a signed integer.
                  (inst ,op r x (dpb low-half (byte 16 0) -1)))
                 ((and (not (logbitp 15 low-half)) (zerop high-half))
                  (inst ,op r x low-half))
                 ((zerop low-half)
                  (inst ,shifted-op r x (if (logbitp 15 high-half)
                                            (dpb high-half (byte 16 0) -1)
                                            high-half)))
                 (t
                  ;; Check to see whether compensating for the sign bit
                  ;; of LOW-HALF is necessary.
                  (let ((high-half (let ((top (if (logbitp 15 low-half)
                                                  (ldb (byte 16 0)
                                                       (1+ high-half))
                                                  high-half)))
                                     (if (logbitp 15 top)
                                         (dpb top (byte 16 0) -1)