arith.lisp

开源跨平台Lisp编译器

                   :from (:argument 1) :to (:result 1)) r-pass)
  (:results (q :scs (signed-reg))
            (r :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 35
    (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)))


;;;; Binary conditional VOPs:

(define-vop (fast-conditional)
  (:conditional)
  (:info target not-p)
  (:effects)
  (:affected)
  (:policy :fast-safe))

(define-vop (fast-conditional/fixnum fast-conditional)
  (:args (x :scs (any-reg))
         (y :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:note "inline fixnum comparison"))

(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
  (:args (x :scs (any-reg)))
  (:arg-types tagged-num (:constant (signed-byte 9)))
  (:info target not-p y))

(define-vop (fast-conditional/signed fast-conditional)
  (:args (x :scs (signed-reg))
         (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:note "inline (signed-byte 32) comparison"))

(define-vop (fast-conditional-c/signed fast-conditional/signed)
  (:args (x :scs (signed-reg)))
  (:arg-types signed-num (:constant (signed-byte 11)))
  (:info target not-p y))

(define-vop (fast-conditional/unsigned fast-conditional)
  (:args (x :scs (unsigned-reg))
         (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 32) comparison"))

(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num (:constant (signed-byte 11)))
  (:info target not-p y))


(defmacro define-conditional-vop (translate signed-cond unsigned-cond)
  `(progn
     ,@(mapcar #'(lambda (suffix cost signed imm)
                   (unless (and (member suffix '(/fixnum -c/fixnum))
                                (eq translate 'eql))
                     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
                                                    translate suffix))
                                   ,(intern
                                     (format nil "~:@(FAST-CONDITIONAL~A~)"
                                             suffix)))
                        (:translate ,translate)
                        (:generator ,cost
                          (inst ,(if imm 'bci 'bc)
                                ,(if signed signed-cond unsigned-cond)
                                not-p
                                ,(if (eq suffix '-c/fixnum)
                                     '(fixnumize y)
                                     'y)
                                x
                                target)))))
               '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
               '(3 2 5 4 5 4)
               '(t t t t nil nil)
               '(nil t nil t nil t))))

;; We switch < and > because the immediate has to come first.

(define-conditional-vop < :> :>>)
(define-conditional-vop > :< :<<)

;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
;;; known fixnum.
;;;
(define-conditional-vop eql := :=)

;;; These versions specify a fixnum restriction on their first arg.  We have
;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
;;; the first arg and a higher cost.  The reason for doing this is to prevent
;;; fixnum specific operations from being used on word integers, spuriously
;;; consing the argument.
;;;
(define-vop (fast-eql/fixnum fast-conditional)
  (:args (x :scs (any-reg descriptor-reg))
         (y :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:note "inline fixnum comparison")
  (:translate eql)
  (:generator 3
    (inst bc := not-p x y target)))
;;;
(define-vop (generic-eql/fixnum fast-eql/fixnum)
  (:arg-types * tagged-num)
  (:variant-cost 7))

(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
  (:args (x :scs (any-reg descriptor-reg)))
  (:arg-types tagged-num (:constant (signed-byte 9)))
  (:info target not-p y)
  (:translate eql)
  (:generator 2
    (inst bci := not-p (fixnumize y) x target)))
;;;
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
  (:arg-types * (:constant (signed-byte 9)))
  (:variant-cost 6))


;;;; modular functions
(define-modular-fun +-mod32 (x y) + :unsigned 32)
(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
  (:translate +-mod32))
(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
  (:translate +-mod32))
(define-modular-fun --mod32 (x y) - :unsigned 32)
(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
  (:translate --mod32))
(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
  (:translate --mod32))

(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
             fast-ash-c/unsigned=>unsigned)
  (:translate ash-left-mod32))
(define-vop (fast-ash-left-mod32/unsigned=>unsigned
             ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
             ;; implemented, use it here.  -- CSR, 2004-08-16
             fast-ash/unsigned=>unsigned))
(deftransform ash-left-mod32 ((integer count)
                              ((unsigned-byte 32) (unsigned-byte 5)))
  (when (sb!c::constant-lvar-p count)
    (sb!c::give-up-ir1-transform))
  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))

(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
(define-vop (lognot-mod32/unsigned=>unsigned)
  (:translate lognot-mod32)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:generator 1
    (inst uaddcm zero-tn x res)))

(macrolet
    ((define-modular-backend (fun)
       (let ((mfun-name (symbolicate fun '-mod32))
             ;; FIXME: if anyone cares, add constant-arg vops.  --
             ;; CSR, 2003-09-16
             (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
             (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
         `(progn
            (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
            (define-vop (,modvop ,vop)
              (:translate ,mfun-name))))))
  (define-modular-backend logxor)
  (define-modular-backend logandc1)
  (define-modular-backend logandc2))

(define-source-transform logeqv (&rest args)
  (if (oddp (length args))
      `(logxor ,@args)
      `(lognot (logxor ,@args))))
(define-source-transform logorc1 (x y)
  `(logior (lognot ,x) ,y))
(define-source-transform logorc2 (x y)
  `(logior ,x (lognot ,y)))
(define-source-transform lognand (x y)
  `(lognot (logand ,x ,y)))
(define-source-transform lognor (x y)
  `(lognot (logior ,x y)))

(define-vop (shift-towards-someplace)
  (:policy :fast-safe)
  (:args (num :scs (unsigned-reg))
         (amount :scs (signed-reg)))
  (:arg-types unsigned-num tagged-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num))

(define-vop (shift-towards-start shift-towards-someplace)
  (:translate shift-towards-start)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:note "SHIFT-TOWARDS-START")
  (:generator 1
    (inst subi 31 amount temp)
    (inst mtctl temp :sar)
    (inst zdep num :variable 32 r)))

(define-vop (shift-towards-end shift-towards-someplace)
  (:translate shift-towards-end)
  (:note "SHIFT-TOWARDS-END")
  (:generator 1
    (inst mtctl amount :sar)
    (inst shd zero-tn num :variable r)))



;;;; Bignum stuff.

(define-vop (bignum-length get-header-data)
  (:translate sb!bignum:%bignum-length)
  (:policy :fast-safe))

(define-vop (bignum-set-length set-header-data)
  (:translate sb!bignum:%bignum-set-length)
  (:policy :fast-safe))

(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
  (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)

(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
  (unsigned-reg) unsigned-num sb!bignum:%bignum-set)

(define-vop (digit-0-or-plus)
  (:translate sb!bignum:%digit-0-or-plusp)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:conditional)
  (:info target not-p)
  (:effects)
  (:affected)
  (:generator 1
    (inst bc :>= not-p digit zero-tn target)))

(define-vop (add-w/carry)
  (:translate sb!bignum:%add-with-carry)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg))
         (b :scs (unsigned-reg))
         (c :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg))
            (carry :scs (unsigned-reg)))
  (:result-types unsigned-num positive-fixnum)
  (:generator 3
    (inst addi -1 c zero-tn)
    (inst addc a b result)
    (inst addc zero-tn zero-tn carry)))

(define-vop (sub-w/borrow)
  (:translate sb!bignum:%subtract-with-borrow)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg))
         (b :scs (unsigned-reg))
         (c :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg))
            (borrow :scs (unsigned-reg)))
  (:result-types unsigned-num positive-fixnum)
  (:generator 4
    (inst addi -1 c zero-tn)
    (inst subb a b result)
    (inst addc zero-tn zero-tn borrow)))

(define-vop (bignum-mult)
  (:translate sb!bignum:%multiply)
  (:policy :fast-safe)
  (:args (x-arg :scs (unsigned-reg) :target x)
         (y-arg :scs (unsigned-reg) :target y))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:scs (signed-reg) :from (:argument 0)) x)
  (:temporary (:scs (signed-reg) :from (:argument 1)) y)
  (:temporary (:scs (signed-reg)) tmp)
  (:results (hi :scs (unsigned-reg))
            (lo :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 3
    ;; Make sure X is less then Y.
    (inst comclr x-arg y-arg tmp :<<)
    (inst xor x-arg y-arg tmp)
    (inst xor x-arg tmp x)
    (inst xor y-arg tmp y)

    ;; Blow out of here if the result is zero.
    (inst li 0 hi)
    (inst comb := x zero-tn done)
    (inst li 0 lo)
    (inst li 0 tmp)

    LOOP
    (inst comb :ev x zero-tn next-bit)
    (inst srl x 1 x)
    (inst add lo y lo)
    (inst addc hi tmp hi)
    NEXT-BIT
    (inst add y y y)
    (inst comb :<> x zero-tn loop)
    (inst addc tmp tmp tmp)

    DONE))

(define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
  #+nil ;; This would be greate if it worked, but it doesn't.
  (if (eql extra 0)
      `(multiple-value-call #'sb!bignum:%dual-word-add
         (sb!bignum:%multiply ,x ,y)
         (values ,carry))
      `(multiple-value-call #'sb!bignum:%dual-word-add
         (multiple-value-call #'sb!bignum:%dual-word-add
           (sb!bignum:%multiply ,x ,y)
           (values ,carry))
         (values ,extra)))
  (with-unique-names (hi lo)
    (if (eql extra 0)
        `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
           (sb!bignum::%dual-word-add ,hi ,lo ,carry))
        `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
           (multiple-value-bind
               (,hi ,lo)
               (sb!bignum::%dual-word-add ,hi ,lo ,carry)
             (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))

(defknown sb!bignum::%dual-word-add
          (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
  (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
  (flushable movable))

(define-vop (dual-word-add)
  (:policy :fast-safe)
  (:translate sb!bignum::%dual-word-add)
  (:args (hi :scs (unsigned-reg) :to (:result 1))
         (lo :scs (unsigned-reg))
         (extra :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:results (hi-res :scs (unsigned-reg) :from (:result 1))
            (lo-res :scs (unsigned-reg) :from (:result 0)))
  (:result-types unsigned-num unsigned-num)
  (:affected)
  (:effects)
  (:generator 3
    (inst add lo extra lo-res)
    (inst addc hi zero-tn hi-res)))

(define-vop (bignum-lognot)
  (:translate sb!bignum:%lognot)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
    (inst uaddcm zero-tn x r)))

(define-vop (fixnum-to-digit)
  (:translate sb!bignum:%fixnum-to-digit)
  (:policy :fast-safe)
  (:args (fixnum :scs (signed-reg)))
  (:arg-types tagged-num)
  (:results (digit :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
    (move fixnum digit)))

(define-vop (bignum-floor)
  (:translate sb!bignum:%floor)
  (:policy :fast-safe)
  (:args (hi :scs (unsigned-reg) :to (:argument 1))
         (lo :scs (unsigned-reg) :to (:argument 0))
         (divisor :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
  (:results (quo :scs (unsigned-reg) :from (:argument 0))
            (rem :scs (unsigned-reg) :from (:argument 1)))
  (:result-types unsigned-num unsigned-num)
  (:generator 65
    (inst sub zero-tn divisor temp)
    (inst ds zero-tn temp zero-tn)
    (inst add lo lo quo)
    (inst ds hi divisor rem)
    (inst addc quo quo quo)
    (dotimes (i 31)
      (inst ds rem divisor rem)
      (inst addc quo quo quo))
    (inst comclr rem zero-tn zero-tn :>=)
    (inst add divisor rem rem)))

(define-vop (signify-digit)
  (:translate sb!bignum:%fixnum-digit-with-correct-sign)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg) :target res))
  (:arg-types unsigned-num)
  (:results (res :scs (signed-reg)))
  (:result-types signed-num)
  (:generator 1
    (move digit res)))

(define-vop (digit-lshr)
  (:translate sb!bignum:%digit-logical-shift-right)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg))
         (count :scs (unsigned-reg)))
  (:arg-types unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 2
    (inst mtctl count :sar)
    (inst shd zero-tn digit :variable result)))

(define-vop (digit-ashr digit-lshr)
  (:translate sb!bignum:%ashr)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:generator 1
    (inst extrs digit 0 1 temp)
    (inst mtctl count :sar)
    (inst shd temp digit :variable result)))

(define-vop (digit-ashl digit-ashr)
  (:translate sb!bignum:%ashl)
  (:generator 1
    (inst subi 31 count temp)
    (inst mtctl temp :sar)
    (inst zdep digit :variable 32 result)))


;;;; Static functions.

(define-static-fun two-arg-gcd (x y) :translate gcd)
(define-static-fun two-arg-lcm (x y) :translate lcm)

(define-static-fun two-arg-* (x y) :translate *)
(define-static-fun two-arg-/ (x y) :translate /)

(define-static-fun %negate (x) :translate %negate)

(define-static-fun two-arg-and (x y) :translate logand)
(define-static-fun two-arg-ior (x y) :translate logior)
(define-static-fun two-arg-xor (x y) :translate logxor)