arith.lisp

开源跨平台Lisp编译器

;;;; the VM definition arithmetic VOPs for HPPA

;;;; 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 (fixnum-unop)
  (:args (x :scs (any-reg)))
  (:results (res :scs (any-reg)))
  (:note "inline fixnum arithmetic")
  (:arg-types tagged-num)
  (:result-types tagged-num)
  (:policy :fast-safe))

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

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

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

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

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

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

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

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

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

(defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
  `(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 ,cost
         ,(if arg-swap
              `(inst ,op y x r)
              `(inst ,op x y r))))
     (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 ,untagged-cost
         ,(if arg-swap
              `(inst ,op y x r)
              `(inst ,op x y r))))
     (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 ,untagged-cost
         ,(if arg-swap
              `(inst ,op y x r)
              `(inst ,op x y r))))))

(define-binop + 2 6 add)
(define-binop - 2 6 sub)
(define-binop logior 1 2 or)
(define-binop logand 1 2 and)
(define-binop logandc1 1 2 andcm t)
(define-binop logandc2 1 2 andcm)
(define-binop logxor 1 2 xor)

(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-c-binop (translate cost untagged-cost tagged-type
                                    untagged-type inst)
  `(progn
     (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
                  fast-fixnum-c-binop)
       (:arg-types tagged-num (:constant ,tagged-type))
       (:translate ,translate)
       (:generator ,cost
         (let ((y (fixnumize y)))
           ,inst)))
     (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))
     (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))))

(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
  (inst addi y x r))
(define-c-binop - 1 3
  (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
  (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
  (inst addi (- y) x r))

;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
;;; know that the result is going to be a fixnum.

(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 addo x y r)))

(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 addio (fixnumize y) x r)))

(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 subo x y r)))

(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 addio (- (fixnumize y)) x r)))

;;; Shifting

(define-vop (fast-ash/unsigned=>unsigned)
  (:policy :fast-safe)
  (:translate ash)
  (:note "inline word ASH")
  (:args (number :scs (unsigned-reg))
         (count :scs (signed-reg)))
  (:arg-types unsigned-num tagged-num)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 8
    (inst comb :>= count zero-tn positive :nullify t)
    (inst sub zero-tn count temp)
    (inst comiclr 31 temp zero-tn :>=)
    (inst li 31 temp)
    (inst mtctl temp :sar)
    (inst extrs number 0 1 temp)
    (inst b done)
    (inst shd temp number :variable result)
    POSITIVE
    (inst subi 31 count temp)
    (inst mtctl temp :sar)
    (inst zdep number :variable 32 result)
    DONE))

(define-vop (fast-ash/signed=>signed)
  (:policy :fast-safe)
  (:translate ash)
  (:note "inline word ASH")
  (:args (number :scs (signed-reg))
         (count :scs (signed-reg)))
  (:arg-types signed-num tagged-num)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:results (result :scs (signed-reg)))
  (:result-types signed-num)
  (:generator 8
    (inst comb :>= count zero-tn positive :nullify t)
    (inst sub zero-tn count temp)
    (inst comiclr 31 temp zero-tn :>=)
    (inst li 31 temp)
    (inst mtctl temp :sar)
    (inst extrs number 0 1 temp)
    (inst b done)
    (inst shd temp number :variable result)
    POSITIVE
    (inst subi 31 count temp)
    (inst mtctl temp :sar)
    (inst zdep number :variable 32 result)
    DONE))

(define-vop (fast-ash-c/unsigned=>unsigned)
  (:policy :fast-safe)
  (:translate ash)
  (:note nil)
  (: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 0)
           ;; It is a right shift.
           (inst srl number (min (- count) 31) result))
          ((> count 0)
           ;; It is a left shift.
           (inst sll number (min count 31) result))
          (t
           ;; Count=0?  Shouldn't happen, but it's easy:
           (move number result)))))

(define-vop (fast-ash-c/signed=>signed)
  (:policy :fast-safe)
  (:translate ash)
  (:note nil)
  (: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)
           ;; It is a right shift.
           (inst sra number (min (- count) 31) result))
          ((> count 0)
           ;; It is a left shift.
           (inst sll number (min count 31) result))
          (t
           ;; Count=0?  Shouldn't happen, but it's easy:
           (move number result)))))

;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
;;; use in modular ASH (and because they're useful anyway).  -- CSR,
;;; 2004-08-16

(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))
  (:arg-types signed-num)
  (:results (res :scs (any-reg)))
  (:result-types positive-fixnum)
  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
  (:generator 30
    (inst move arg shift :>=)
    (inst uaddcm zero-tn shift shift)
    (inst comb := shift zero-tn done)
    (inst li 0 res)
    LOOP
    (inst srl shift 1 shift)
    (inst comb :<> shift zero-tn loop)
    (inst addi (fixnumize 1) res res)
    DONE))

(define-vop (unsigned-byte-32-count)
  (:translate logcount)
  (:note "inline (unsigned-byte 32) logcount")
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg) :target num))
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
                    :target res) num)
  (:temporary (:scs (non-descriptor-reg)) mask temp)
  (:generator 30
    (inst li #x55555555 mask)
    (inst srl arg 1 temp)
    (inst and arg mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x33333333 mask)
    (inst srl num 2 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x0f0f0f0f mask)
    (inst srl num 4 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x00ff00ff mask)
    (inst srl num 8 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x0000ffff mask)
    (inst srl num 16 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp res)))

;;; Multiply and Divide.

(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
  (:args (x :scs (any-reg) :target x-pass)
         (y :scs (any-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
                   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
                   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target r
                   :from (:argument 1) :to (:result 0)) res-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
  (:temporary (:sc signed-reg :offset nl4-offset
                   :from (:argument 1) :to (:result 0)) sign)
  (:temporary (:sc interior-reg :offset lip-offset) lip)
  (:ignore lip sign)
  (:translate *)
  (:generator 30
    (unless (location= y y-pass)
      (inst sra x 2 x-pass))
    (let ((fixup (make-fixup 'multiply :assembly-routine)))
      (inst ldil fixup tmp)
      (inst ble fixup lisp-heap-space tmp))
    (if (location= y y-pass)
        (inst sra x 2 x-pass)
        (inst move y y-pass))
    (move res-pass r)))

(define-vop (fast-*/signed=>signed fast-signed-binop)
  (:translate *)
  (:args (x :scs (signed-reg) :target x-pass)
         (y :scs (signed-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
                   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
                   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target r
                   :from (:argument 1) :to (:result 0)) res-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
  (:temporary (:sc signed-reg :offset nl4-offset
                   :from (:argument 1) :to (:result 0)) sign)
  (:temporary (:sc interior-reg :offset lip-offset) lip)
  (:ignore lip sign)
  (:translate *)
  (:generator 31
    (let ((fixup (make-fixup 'multiply :assembly-routine)))
      (move x x-pass)
      (move y y-pass)
      (inst ldil fixup tmp)
      (inst ble fixup lisp-heap-space tmp :nullify t)
      (inst nop)
      (move res-pass r))))

(define-vop (fast-truncate/fixnum fast-fixnum-binop)
  (:translate truncate)
  (:args (x :scs (any-reg) :target x-pass)
         (y :scs (any-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
                   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
                   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target q
                   :from (:argument 1) :to (:result 0)) q-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :target r
                   :from (:argument 1) :to (:result 1)) r-pass)
  (:results (q :scs (signed-reg))
            (r :scs (any-reg)))
  (:result-types tagged-num tagged-num)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 30
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst bc := nil y zero-tn zero))
    (move x x-pass)
    (move y y-pass)
    (let ((fixup (make-fixup 'truncate :assembly-routine)))
      (inst ldil fixup q-pass)
      (inst ble fixup lisp-heap-space q-pass :nullify t))
    (inst nop)
    (move q-pass q)
    (move r-pass r)))

(define-vop (fast-truncate/signed fast-signed-binop)
  (:translate truncate)
  (:args (x :scs (signed-reg) :target x-pass)
         (y :scs (signed-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
                   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
                   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target q
                   :from (:argument 1) :to (:result 0)) q-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :target r