[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>
```