[Git][cmucl/cmucl][rtoy-bignum-mult-less-consing] Rename functions to use the new version by default.
Raymond Toy
rtoy at common-lisp.net
Wed Jul 4 20:31:50 UTC 2018
Raymond Toy pushed to branch rtoy-bignum-mult-less-consing at cmucl / cmucl
Commits:
d652bd09 by Raymond Toy at 2018-07-04T13:31:21-07:00
Rename functions to use the new version by default.
Update tests to reflect the change in names.
- - - - -
2 changed files:
- src/code/bignum.lisp
- tests/bignum.lisp
Changes:
=====================================
src/code/bignum.lisp
=====================================
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -884,7 +884,12 @@ down to individual words.")
(negate-bignum-in-place result))
(%normalize-bignum result (1+ (* 2 n))))))))
-(defun classical-multiply-bignums (a b)
+;; Bignum multiply using Knuth's algorithm. We keep this around for
+;; now so we can compare the new algorithm against this to make sure
+;; this are working.
+;;
+;; TODO: Remove this eventually?
+(defun classical-multiply-bignums-knuth (a b)
(declare (type bignum-type a b))
(let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a)))
(b-plusp (%bignum-0-or-plusp b (%bignum-length b)))
@@ -916,16 +921,29 @@ down to individual words.")
(when negate-res (negate-bignum-in-place res))
(%normalize-bignum res len-res)))
-;; Pretend the bignums are actually unsigned, do an unsigned multiply
-;; and then correct the result. This is based on the algorithm in
-;; Hacker's Delight.
-(defun classical-multiply-bignum-hd (a b)
+;; Classical multiplication of bignums using Knuth's algorithm
+;; modified to handle signed bignums. Pretend the bignums are
+;; actually unsigned, do an unsigned multiply and then correct the
+;; result. This is based on the algorithm in Hacker's Delight.
+;;
+;; Let a[n] and b[n] represent the individual bits of each bignum with
+;; M being the number of bits in a and N being the number of bits in
+;; b. If these are interpreted as an unsigned number, then we are
+;; multiplying numbers
+;;
+;; (a + 2^M*a[M-1})*(b + 2^N*b[N-1])
+;; = a*b + 2^M*u[M-1]*b + 2^N*b[N-1]*a + 2^(M+N)*a[M-1]*b[M-1]
+;;
+;; To get the desired result, we need to subtract out the term
+;; 2^M*u[M-1]*b + 2^N*b[N-1]*a from the product. The last term
+;; doesn't need to subtracted because we know the product fits in M+N
+;; bits and this term is beyond that.
+(defun classical-multiply-bignums (a b)
(declare (type bignum-type a b))
(let* ((len-a (%bignum-length a))
(len-b (%bignum-length b))
(len-res (+ len-a len-b))
(res (%allocate-bignum len-res)))
- (negate-res (not (eq a-plusp b-plusp))))
(declare (type bignum-index len-a len-b len-res))
;; Unsigned multiply
(dotimes (i len-a)
@@ -937,36 +955,39 @@ down to individual words.")
(type bignum-element-type carry-digit x))
(dotimes (j len-b)
(multiple-value-bind (big-carry res-digit)
- (%multiply-and-add x (%bignum-ref b j)
- (%bignum-ref res k)
- carry-digit)
+ (%multiply-and-add x (%bignum-ref b j)
+ (%bignum-ref res k)
+ carry-digit)
(declare (type bignum-element-type big-carry res-digit))
(setf (%bignum-ref res k) res-digit)
(setf carry-digit big-carry)
(incf k)))
(setf (%bignum-ref res k) carry-digit)))
;; Apply corrections if either of the arguments is negative.
- ;; If a < 0, subtract b*2^M from the result
- (unless(%bignum-0-or-plusp a)
+ (unless (%bignum-0-or-plusp a len-a)
(let ((borrow 1))
(dotimes (j len-b)
+ (declare (type bignum-index j))
(let ((index (+ j len-a)))
+ (declare (type bignum-index index))
(multiple-value-bind (d borrow-out)
- (%subtract-with-borrow (bignum-ref res index)
- (bignum-ref b j)
+ (%subtract-with-borrow (%bignum-ref res index)
+ (%bignum-ref b j)
borrow)
- (setf (bignum-ref res index) d)
+ (setf (%bignum-ref res index) d)
(setf borrow borrow-out))))))
- (unless (%bignum-0-or-plusp b)
+ (unless (%bignum-0-or-plusp b len-b)
(let ((borrow 1))
(dotimes (j len-a)
+ (declare (type bignum-index j))
(let ((index (+ j len-b)))
- (multiple-value-bind (d borrow-out)
- (%subtract-with-borrow (bignum-ref res index)
- (bignum-ref a j)
- borrow)
- (setf (bignum-ref res index) d)
- (setf borrow borrow-out)))))
+ (declare (type bignum-index index))
+ (multiple-value-bind (d borrow-out)
+ (%subtract-with-borrow (%bignum-ref res index)
+ (%bignum-ref a j)
+ borrow)
+ (setf (%bignum-ref res index) d)
+ (setf borrow borrow-out))))))
(%normalize-bignum res len-res)))
(defparameter *min-karatsuba-bits* 512
=====================================
tests/bignum.lisp
=====================================
--- a/tests/bignum.lisp
+++ b/tests/bignum.lisp
@@ -21,8 +21,8 @@
(dotimes (k 100)
(let* ((r1 (gen-bignum range (random 2 rng)))
(r2 (gen-bignum range (random 2 rng)))
- (prod-knuth (bignum::classical-multiply-bignums r1 r2))
- (prod-hd (bignum::classical-multiply-bignum-hd r1 r2)))
+ (prod-knuth (bignum::classical-multiply-bignums-knuth r1 r2))
+ (prod-hd (bignum::classical-multiply-bignums r1 r2)))
(assert-equal prod-knuth prod-hd r1 r2))))))
@@ -45,12 +45,12 @@
(r2 (gen-bignum range 1)) res)
(time
(dotimes (k reps)
- (declare (fixnum k)) (setf res
- (bignum::classical-multiply-bignums r1 r2))))
+ (declare (fixnum k))
+ (setf res (bignum::classical-multiply-bignums-knuth r1 r2))))
(print res)
(time
(dotimes (k reps)
- (declare (fixnum k)) (setf res
- (bignum::classical-multiply-bignum-hd r1 r2))))
+ (declare (fixnum k))
+ (setf res (bignum::classical-multiply-bignums r1 r2))))
(print res)))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d652bd096516a2217e9c273da88ae9c63386a743
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d652bd096516a2217e9c273da88ae9c63386a743
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20180704/f1526ba3/attachment-0001.html>
More information about the cmucl-cvs
mailing list