[Git][cmucl/cmucl][rtoy-bignum-mult-less-consing] Refactor common code into a routine

[Raymond Toy]

Raymond Toy pushed to branch rtoy-bignum-mult-less-consing at cmucl / cmucl


Commits:
228359b6 by Raymond Toy at 2018-07-15T13:47:44-07:00
Refactor common code into a routine

The code for applying the correction is pretty much identical for each
negative operant, so add a routine to do that.

- - - - -


1 changed file:

- src/code/bignum.lisp


Changes:

=====================================
src/code/bignum.lisp
=====================================
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -963,31 +963,29 @@ down to individual words.")
 	    (setf carry-digit big-carry)
 	    (incf k)))
 	(setf (%bignum-ref res k) carry-digit)))
-    ;; Apply corrections if either of the arguments is negative.
-    (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)
-				       borrow)
-	      (setf (%bignum-ref res index) d)
-	      (setf borrow borrow-out))))))
-    (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)))
-	    (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))))))
+    (flet ((apply-correction (neg-arg neg-len pos-arg pos-len)
+	     ;; Applies the correction by basically subtracting out
+	     ;; 2^M*b where M is the length (in bits) of b and b is
+	     ;; the positive term in pos-arg.  neg-arg is the negative
+	     ;; arg.
+	     (let ((borrow 1))
+	       (dotimes (j pos-len)
+		 (declare (type bignum-index j))
+		 (let ((index (+ j neg-len)))
+		   (declare (type bignum-index index))
+		   (multiple-value-bind (d borrow-out)
+		       (%subtract-with-borrow (%bignum-ref res index)
+					      (%bignum-ref pos-arg j)
+					      borrow)
+		     (setf (%bignum-ref res index) d)
+		     (setf borrow borrow-out)))))))
+      ;; Apply corrections if either of the arguments is negative.
+      (unless (%bignum-0-or-plusp a len-a)
+	;; A is negative
+	(apply-correction a len-a b len-b))
+      (unless (%bignum-0-or-plusp b len-b)
+	;; B is negative
+	(apply-correction b len-b a len-a)))
     (%normalize-bignum res len-res)))
 
 (defparameter *min-karatsuba-bits* 512



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/228359b66be83465dcbda3c1a05ea1bb1cf85605

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/228359b66be83465dcbda3c1a05ea1bb1cf85605
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/20180715/2ef210eb/attachment-0001.html>