arith.lisp

开源跨平台Lisp编译器

                                         top))))
                    (inst ,shifted-op temp x high-half)
                    (inst ,op r temp low-half)))))
             `(inst ,op r x y))))))

;;; For logical operations, we don't have to worry about signed bit
;;; propagation from the lower half of a 32-bit operand.
(defmacro !define-const-logop (translate untagged-penalty op &optional (shifted-op nil))
  `(progn
     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
                  ,(if shifted-op
                       'fast-fixnum-logop30-c
                       'fast-fixnum-logop-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)))
               (cond
                 ((zerop high-half) (inst ,op r x low-half))
                 ((zerop low-half) (inst ,shifted-op r x high-half))
                 (t
                  (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-logop32-c
                       'fast-signed-logop-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)))
               (cond
                 ((zerop high-half) (inst ,op r x low-half))
                 ((zerop low-half) (inst ,shifted-op r x high-half))
                 (t
                  (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-logop32-c
                       'fast-unsigned-logop-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)))
               (cond
                 ((zerop high-half) (inst ,op r x low-half))
                 ((zerop low-half) (inst ,shifted-op r x high-half))
                 (t
                  (inst ,shifted-op temp x high-half)
                  (inst ,op r temp low-half))))
             `(inst ,op r x y))))))

); eval-when

(!define-var-binop + 4 add)
(!define-var-binop - 4 sub)
(!define-var-binop logand 2 and)
(!define-var-binop logandc1 2 andc t)
(!define-var-binop logandc2 2 andc)
(!define-var-binop logior 2 or)
(!define-var-binop logorc1 2 orc t t)
(!define-var-binop logorc2 2 orc nil t)
(!define-var-binop logxor 2 xor)
(!define-var-binop logeqv 2 eqv nil t)
(!define-var-binop lognand 2 nand nil t)
(!define-var-binop lognor 2 nor nil t)

(!define-const-binop + 4 addi addis)
(!define-const-binop - 4 subi)
;;; Implementing a 32-bit immediate version of LOGAND wouldn't be any
;;; better than loading the 32-bit constant via LR and then performing
;;; an /AND/.  So don't bother.  (It would be better in some cases, such
;;; as when one half of the word is zeros--we save a register--but we
;;; would have specified one temporary register in the VOP, so we lose
;;; any possible advantage.)
(!define-const-logop logand 2 andi.)
(!define-const-logop logior 2 ori oris)
(!define-const-logop logxor 2 xori xoris)


;;; Special case fixnum + and - that trap on overflow.  Useful when we
;;; don't know that the output type is a fixnum.
;;;
(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
    (let* ((no-overflow (gen-label)))
      (inst mtxer zero-tn)
      (inst addo. r x y)
      (inst bns no-overflow)
      (inst unimp (logior (ash (reg-tn-encoding r) 5)
                          fixnum-additive-overflow-trap))
      (emit-label no-overflow))))

(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
    (let* ((no-overflow (gen-label)))
      (inst mtxer zero-tn)
      (inst subo. r x y)
      (inst bns no-overflow)
      (inst unimp (logior (ash (reg-tn-encoding r) 5)
                          fixnum-additive-overflow-trap))
      (emit-label no-overflow))))

(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:translate *)
  (:generator 2
    (inst srawi temp y 2)
    (inst mullw r x temp)))

(define-vop (fast-*-c/fixnum=>fixnum fast-fixnum-binop-c)
  (:translate *)
  (:arg-types tagged-num
              (:constant (and (signed-byte 16) (not (integer 0 0)))))
  (:generator 1
    (inst mulli r x y)))

(define-vop (fast-*-bigc/fixnum=>fixnum fast-fixnum-binop-c)
  (:translate *)
  (:arg-types tagged-num
              (:constant (and fixnum (not (signed-byte 16)))))
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:generator 1
    (inst lr temp y)
    (inst mullw r x temp)))

(define-vop (fast-*/signed=>signed fast-signed-binop)
  (:translate *)
  (:generator 4
    (inst mullw r x y)))

(define-vop (fast-*-c/signed=>signed fast-signed-binop-c)
  (:translate *)
  (:generator 3
    (inst mulli r x y)))

(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
  (:translate *)
  (:generator 4
    (inst mullw r x y)))

(define-vop (fast-*-c/unsigned=>unsigned fast-unsigned-binop-c)
  (:translate *)
  (:generator 3
    (inst mulli r x y)))

;;; Shifting

(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 slw result number amount))
                     (immediate
                      (let ((amount (tn-value amount)))
                        (aver (> amount 0))
                        (inst slwi result number amount))))))))
  ;; FIXME: There's the opportunity for a sneaky optimization here, I
  ;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop.  -- CSR, 2003-09-03
  (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 (fast-ash/unsigned=>unsigned)
  (:note "inline ASH")
  (:args (number :scs (unsigned-reg) :to :save)
         (amount :scs (signed-reg)))
  (:arg-types (:or unsigned-num) signed-num)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate ash)
  (:policy :fast-safe)
  (:temporary (:sc non-descriptor-reg) ndesc)
  (:generator 5
    (let ((positive (gen-label))
          (done (gen-label)))
      (inst cmpwi amount 0)
      (inst neg ndesc amount)
      (inst bge positive)
      (inst cmpwi ndesc 31)
      (inst srw result number ndesc)
      (inst ble done)
      (move result zero-tn)
      (inst b done)

      (emit-label positive)
      ;; The result-type assures us that this shift will not overflow.
      (inst slw result number amount)

      (emit-label done))))

(define-vop (fast-ash-c/unsigned=>unsigned)
  (:note "inline constant ASH")
  (:args (number :scs (unsigned-reg)))
  (:info amount)
  (:arg-types unsigned-num (:constant integer))
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate ash)
  (:policy :fast-safe)
  (:generator 4
    (cond
      ((and (minusp amount) (< amount -31)) (move result zero-tn))
      ((minusp amount) (inst srwi result number (- amount)))
      ;; possible because this is used in the modular version too
      ((> amount 31) (move result zero-tn))
      (t (inst slwi result number amount)))))

(define-vop (fast-ash/signed=>signed)
  (:note "inline ASH")
  (:args (number :scs (signed-reg) :to :save)
         (amount :scs (signed-reg immediate)))
  (:arg-types (:or signed-num) signed-num)
  (:results (result :scs (signed-reg)))
  (:result-types (:or signed-num))
  (:translate ash)
  (:policy :fast-safe)
  (:temporary (:sc non-descriptor-reg) ndesc)
  (:generator 3
    (sc-case amount
      (signed-reg
       (let ((positive (gen-label))
             (done (gen-label)))
         (inst cmpwi amount 0)
         (inst neg ndesc amount)
         (inst bge positive)
         (inst cmpwi ndesc 31)
         (inst sraw result number ndesc)
         (inst ble done)
         (inst srawi result number 31)
         (inst b done)

         (emit-label positive)
         ;; The result-type assures us that this shift will not overflow.
         (inst slw result number amount)

         (emit-label done)))

      (immediate
       (let ((amount (tn-value amount)))
         (if (minusp amount)
             (let ((amount (min 31 (- amount))))
               (inst srawi result number amount))
             (inst slwi result number amount)))))))

(define-vop (signed-byte-32-len)
  (:translate integer-length)
  (:note "inline (signed-byte 32) integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (signed-reg)))
  (:arg-types signed-num)
  (:results (res :scs (unsigned-reg) :from :load))
  (:result-types unsigned-num)
  (:generator 6
    ; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
    (let ((nonneg (gen-label)))
      (inst cntlzw. res arg)
      (inst bne nonneg)
      (inst not res arg)
      (inst cntlzw res res)
      (emit-label nonneg)
      (inst subfic res res 32))))

(define-vop (unsigned-byte-32-len)
  (:translate integer-length)
  (:note "inline (unsigned-byte 32) integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 4
    (inst cntlzw res arg)
    (inst subfic res res 32)))

(define-vop (unsigned-byte-32-count)
  (:translate logcount)
  (:note "inline (unsigned-byte 32) logcount")
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg) :target shift))
  (:arg-types unsigned-num)
  (:results (res :scs (any-reg)))
  (:result-types positive-fixnum)
  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
  (:generator 30
    (let ((loop (gen-label))
          (done (gen-label)))
      (inst add. shift zero-tn arg)
      (move res zero-tn)
      (inst beq done)

      (emit-label loop)
      (inst subi temp shift 1)
      (inst and. shift shift temp)
      (inst addi res res (fixnumize 1))
      (inst bne loop)

      (emit-label done))))


;;;; %LDB

(defknown %%ldb (integer unsigned-byte unsigned-byte) unsigned-byte