X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fbignum.lisp;h=c1889655d3dc0370b89e33b36f16f929b3db758c;hb=7118efc35a64ece0d37d801f9f59e886402b0d22;hp=e66c5ebd1fe76f702e6e64ad5fc021580b97d627;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index e66c5eb..c188965 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!BIGNUM") - -(file-comment - "$Header$") ;;;; notes @@ -25,7 +22,7 @@ ;;; bignum-logical-and bignum-logical-ior bignum-logical-xor ;;; bignum-logical-not bignum-load-byte bignum-deposit-byte ;;; bignum-truncate bignum-plus-p bignum-compare make-small-bignum -;;; bignum-logcount +;;; bignum-logbitp bignum-logcount ;;; These symbols define the interface to the compiler: ;;; bignum-type bignum-element-type bignum-index %allocate-bignum ;;; %bignum-length %bignum-set-length %bignum-ref %bignum-set @@ -111,13 +108,9 @@ ;;;; What's a bignum? -(eval-when (:compile-toplevel :load-toplevel :execute) ; necessary for DEFTYPE - (defconstant digit-size 32) -(defconstant maximum-bignum-length (1- (ash 1 (- 32 sb!vm:type-bits)))) - -) ; EVAL-WHEN +(defconstant maximum-bignum-length (1- (ash 1 (- 32 sb!vm:n-widetag-bits)))) ;;;; internal inline routines @@ -215,12 +208,12 @@ (logand x (1- (ash 1 digit-size)))) #!-32x16-divide -;;; This takes three digits and returns the FLOOR'ed result of dividing the -;;; first two as a 64-bit integer by the third. +;;; This takes three digits and returns the FLOOR'ed result of +;;; dividing the first two as a 64-bit integer by the third. ;;; -;;; DO WEIRD let AND setq STUFF TO SLIME THE COMPILER INTO ALLOWING THE %FLOOR -;;; TRANSFORM TO EXPAND INTO PSEUDO-ASSEMBLER FOR WHICH THE COMPILER CAN LATER -;;; CORRECTLY ALLOCATE REGISTERS. +;;; Do weird LET and SETQ stuff to bamboozle the compiler into allowing +;;; the %FLOOR transform to expand into pseudo-assembler for which the +;;; compiler can later correctly allocate registers. (defun %floor (a b c) (let ((a a) (b b) (c c)) (declare (type bignum-element-type a b c)) @@ -526,6 +519,26 @@ ;;;; GCD +;;; I'm not sure why I need this FTYPE declaration. Compiled by the +;;; target compiler, it can deduce the return type fine, but without +;;; it, we pay a heavy price in BIGNUM-GCD when compiled by the +;;; cross-compiler. -- CSR, 2004-07-19 +(declaim (ftype (sfunction (bignum-type bignum-index bignum-type bignum-index) + (unsigned-byte 29)) + bignum-factors-of-two)) +(defun bignum-factors-of-two (a len-a b len-b) + (declare (type bignum-index len-a len-b) (type bignum-type a b)) + (do ((i 0 (1+ i)) + (end (min len-a len-b))) + ((= i end) (error "Unexpected zero bignums?")) + (declare (type bignum-index i end)) + (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i)))) + (unless (zerop or-digits) + (return (do ((j 0 (1+ j)) + (or-digits or-digits (%ashr or-digits 1))) + ((oddp or-digits) (+ (* i digit-size) j)) + (declare (type (mod 32) j)))))))) + (defun bignum-gcd (a b) (declare (type bignum-type a b)) (let* ((a (if (%bignum-0-or-plusp a (%bignum-length a)) @@ -612,19 +625,6 @@ (bignum-buffer-ashift-right a len-a (+ (* index digit-size) increment))))))) - -(defun bignum-factors-of-two (a len-a b len-b) - (declare (type bignum-index len-a len-b) (type bignum-type a)) - (do ((i 0 (1+ i)) - (end (min len-a len-b))) - ((= i end) (error "Unexpected zero bignums?")) - (declare (type bignum-index i end)) - (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i)))) - (unless (zerop or-digits) - (return (do ((j 0 (1+ j)) - (or-digits or-digits (%ashr or-digits 1))) - ((oddp or-digits) (+ (* i digit-size) j)) - (declare (type (mod 32) j)))))))) ;;;; negation @@ -756,13 +756,13 @@ (%normalize-bignum res res-len)) res))))) ((> count bignum-len) - 0) + (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) ;; Since a FIXNUM should be big enough to address anything in ;; memory, including arrays of bits, and since arrays of bits ;; take up about the same space as corresponding fixnums, there ;; should be no way that we fall through to this case: any shift ;; right by a bignum should give zero. But let's check anyway: - (t (error "bignum overflow: can't shift right by ~S"))))) + (t (error "bignum overflow: can't shift right by ~S" count))))) (defun bignum-ashift-right-digits (bignum digits) (declare (type bignum-type bignum) @@ -819,7 +819,7 @@ (bignum-ashift-left-unaligned bignum digits n-bits res-len)))) ;; Left shift by a number too big to be represented as a fixnum ;; would exceed our memory capacity, since a fixnum is big enough - ;; index any array, including a bit array. + ;; to index any array, including a bit array. (error "can't represent result of left shift"))) (defun bignum-ashift-left-digits (bignum bignum-len digits) @@ -987,8 +987,16 @@ (declare (type bignum-index len)) (let ((exp (+ exp bias))) (when (> exp max) - (error "Too large to be represented as a ~S:~% ~S" - format x)) + ;; Why a SIMPLE-TYPE-ERROR? Well, this is mainly + ;; called by COERCE, which requires an error of + ;; TYPE-ERROR if the conversion can't happen + ;; (except in certain circumstances when we are + ;; coercing to a FUNCTION) -- CSR, 2002-09-18 + (error 'simple-type-error + :format-control "Too large to be represented as a ~S:~% ~S" + :format-arguments (list format x) + :expected-type format + :datum x)) exp))) (cond @@ -1008,7 +1016,7 @@ (t (round-up)))))) -;;;; integer length and logcount +;;;; integer length and logbitp/logcount (defun bignum-integer-length (bignum) (declare (type bignum-type bignum)) @@ -1020,6 +1028,17 @@ (+ (integer-length (%fixnum-digit-with-correct-sign digit)) (* len-1 digit-size)))) +(defun bignum-logbitp (index bignum) + (declare (type bignum-type bignum)) + (let ((len (%bignum-length bignum))) + (declare (type bignum-index len)) + (multiple-value-bind (word-index bit-index) + (floor index digit-size) + (if (>= word-index len) + (not (bignum-plus-p bignum)) + (not (zerop (logand (%bignum-ref bignum word-index) + (ash 1 bit-index)))))))) + (defun bignum-logcount (bignum) (declare (type bignum-type bignum)) (let* ((length (%bignum-length bignum)) @@ -1709,12 +1728,13 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (defvar *truncate-x*) (defvar *truncate-y*) -;;; This divides x by y returning the quotient and remainder. In the general -;;; case, we shift y to setup for the algorithm, and we use two buffers to save -;;; consing intermediate values. X gets destructively modified to become the -;;; remainder, and we have to shift it to account for the initial Y shift. -;;; After we multiple bind q and r, we first fix up the signs and then return -;;; the normalized results. +;;; Divide X by Y returning the quotient and remainder. In the +;;; general case, we shift Y to set up for the algorithm, and we use +;;; two buffers to save consing intermediate values. X gets +;;; destructively modified to become the remainder, and we have to +;;; shift it to account for the initial Y shift. After we multiple +;;; bind q and r, we first fix up the signs and then return the +;;; normalized results. (defun bignum-truncate (x y) (declare (type bignum-type x y)) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) @@ -1737,8 +1757,10 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (*truncate-y* (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift) - (values (do-truncate len-x+1 len-y) - ;; DO-TRUNCATE must execute first. + (values (return-quotient-leaving-remainder len-x+1 len-y) + ;; Now that RETURN-QUOTIENT-LEAVING-REMAINDER + ;; has executed, we just tidy up the remainder + ;; (in *TRUNCATE-X*) and return it. (cond ((zerop y-shift) (let ((res (%allocate-bignum len-y))) @@ -1767,13 +1789,15 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! rem (%normalize-bignum rem (%bignum-length rem)))))))) -;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes -;;; up the quotient and remainder with respect to sign and normalization. +;;; Divide X by Y when Y is a single bignum digit. BIGNUM-TRUNCATE +;;; fixes up the quotient and remainder with respect to sign and +;;; normalization. ;;; -;;; We don't have to worry about shifting y to make its most significant digit -;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit -;;; and r-digit. If y is a single digit bignum, it is already large enough -;;; for %FLOOR. That is, it has some bits on pretty high in the digit. +;;; We don't have to worry about shifting Y to make its most +;;; significant digit sufficiently large for %FLOOR to return 32-bit +;;; quantities for the q-digit and r-digit. If Y is a single digit +;;; bignum, it is already large enough for %FLOOR. That is, it has +;;; some bits on pretty high in the digit. (defun bignum-truncate-single-digit (x len-x y) (declare (type bignum-index len-x)) (let ((q (%allocate-bignum len-x)) @@ -1790,14 +1814,18 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (setf (%bignum-ref rem 0) r) (values q rem)))) -;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how -;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies -;;; *truncate-x* on each interation, and this buffer becomes our remainder. +;;; a helper function for BIGNUM-TRUNCATE +;;; +;;; Divide *TRUNCATE-X* by *TRUNCATE-Y*, returning the quotient +;;; and destructively modifying *TRUNCATE-X* so that it holds +;;; the remainder. +;;; +;;; LEN-X and LEN-Y tell us how much of the buffers we care about. ;;; -;;; *truncate-x* definitely has at least three digits, and it has one more than -;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to -;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. -(defun do-truncate (len-x len-y) +;;; *TRUNCATE-X* definitely has at least three digits, and it has one +;;; more than *TRUNCATE-Y*. This keeps i, i-1, i-2, and low-x-digit +;;; happy. Thanks to SHIFT-AND-STORE-TRUNCATE-BUFFERS. +(defun return-quotient-leaving-remainder (len-x len-y) (declare (type bignum-index len-x len-y)) (let* ((len-q (- len-x len-y)) ;; Add one for extra sign digit in case high bit is on. @@ -1814,7 +1842,7 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess - ;; This modifies *truncate-x*. Must access elements each pass. + ;; This modifies *TRUNCATE-X*. Must access elements each pass. (bignum-truncate-guess y1 y2 (%bignum-ref *truncate-x* i) (%bignum-ref *truncate-x* i-1) @@ -1826,15 +1854,17 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (shiftf i i-1 i-2 (1- i-2))))) q)) -;;; This takes a digit guess, multiplies it by *truncate-y* for a result one -;;; greater in length than len-y, and subtracts this result from *truncate-x*. -;;; Low-x-digit is the first digit of x to start the subtraction, and we know x -;;; is long enough to subtract a len-y plus one length bignum from it. Next we -;;; check the result of the subtraction, and if the high digit in x became -;;; negative, then our guess was one too big. In this case, return one less -;;; than guess passed in, and add one value of y back into x to account for -;;; subtracting one too many. Knuth shows that the guess is wrong on the order -;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. +;;; This takes a digit guess, multiplies it by *TRUNCATE-Y* for a +;;; result one greater in length than LEN-Y, and subtracts this result +;;; from *TRUNCATE-X*. LOW-X-DIGIT is the first digit of X to start +;;; the subtraction, and we know X is long enough to subtract a LEN-Y +;;; plus one length bignum from it. Next we check the result of the +;;; subtraction, and if the high digit in X became negative, then our +;;; guess was one too big. In this case, return one less than GUESS +;;; passed in, and add one value of Y back into X to account for +;;; subtracting one too many. Knuth shows that the guess is wrong on +;;; the order of 3/b, where b is the base (2 to the digit-size power) +;;; -- pretty rarely. (defun try-bignum-truncate-guess (guess len-y low-x-digit) (declare (type bignum-index low-x-digit len-y) (type bignum-element-type guess))