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/228359b66be83465dcbda3c1a0...