;;; bignum-ashift-right bignum-ashift-left bignum-gcd
;;; bignum-to-float bignum-integer-length
;;; bignum-logical-and bignum-logical-ior bignum-logical-xor
-;;; bignum-logical-not bignum-load-byte bignum-deposit-byte
+;;; bignum-logical-not bignum-load-byte
;;; bignum-truncate bignum-plus-p bignum-compare make-small-bignum
;;; bignum-logbitp bignum-logcount
;;; These symbols define the interface to the compiler:
;;; %bignum-length %bignum-set-length %bignum-ref %bignum-set
;;; %digit-0-or-plusp %add-with-carry %subtract-with-borrow
;;; %multiply-and-add %multiply %lognot %logand %logior %logxor
-;;; %fixnum-to-digit %floor %fixnum-digit-with-correct-sign %ashl
+;;; %fixnum-to-digit %bigfloor %fixnum-digit-with-correct-sign %ashl
;;; %ashr %digit-logical-shift-right))
;;; The following interfaces will either be assembler routines or code
;;; LDB
;;; %FIXNUM-TO-DIGIT
;;; TRUNCATE
-;;; %FLOOR
+;;; %BIGFLOOR
;;;
;;; Note: The floating routines know about the float representation.
;;;
(%lognot digit))
;;; Each of these does the digit-size unsigned op.
-#!-sb-fluid (declaim (inline %logand %logior %logxor))
+(declaim (inline %logand %logior %logxor))
(defun %logand (a b)
(declare (type bignum-element-type a b))
(logand a b))
;;; dividing the first two as a 2*digit-size integer by the third.
;;;
;;; Do weird LET and SETQ stuff to bamboozle the compiler into allowing
-;;; the %FLOOR transform to expand into pseudo-assembler for which the
+;;; the %BIGFLOOR transform to expand into pseudo-assembler for which the
;;; compiler can later correctly allocate registers.
-(defun %floor (a b c)
+(defun %bigfloor (a b c)
(let ((a a) (b b) (c c))
(declare (type bignum-element-type a b c))
(setq a a b b c c)
- (%floor a b c)))
+ (%bigfloor a b c)))
;;; Convert the digit to a regular integer assuming that the digit is signed.
(defun %fixnum-digit-with-correct-sign (digit)
;;; These take two digit-size quantities and compare or contrast them
;;; without wasting time with incorrect type checking.
-#!-sb-fluid (declaim (inline %digit-compare %digit-greater))
+(declaim (inline %digit-compare %digit-greater))
(defun %digit-compare (x y)
(= x y))
(defun %digit-greater (x y)
;;; function to call that fixes up the result returning any useful values, such
;;; as the result. This macro may evaluate its arguments more than once.
(sb!xc:defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun)
- (let ((borrow (gensym))
- (a-digit (gensym))
- (a-sign (gensym))
- (b-digit (gensym))
- (b-sign (gensym))
- (i (gensym))
- (v (gensym))
- (k (gensym)))
+ (with-unique-names (borrow a-digit a-sign b-digit b-sign i v k)
`(let* ((,borrow 1)
(,a-sign (%sign-digit ,a ,len-a))
(,b-sign (%sign-digit ,b ,len-b)))
from-end)
(sb!int:once-only ((n-dest dest)
(n-src src))
- (let ((n-start1 (gensym))
- (n-end1 (gensym))
- (n-start2 (gensym))
- (n-end2 (gensym))
- (i1 (gensym))
- (i2 (gensym))
- (end1 (or end1 `(%bignum-length ,n-dest)))
- (end2 (or end2 `(%bignum-length ,n-src))))
- (if from-end
- `(let ((,n-start1 ,start1)
- (,n-start2 ,start2))
- (do ((,i1 (1- ,end1) (1- ,i1))
- (,i2 (1- ,end2) (1- ,i2)))
- ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2)))
- (declare (fixnum ,i1 ,i2))
- (%bignum-set ,n-dest ,i1
- (%bignum-ref ,n-src ,i2))))
- (if (eql start1 start2)
- `(let ((,n-end1 (min ,end1 ,end2)))
- (do ((,i1 ,start1 (1+ ,i1)))
- ((>= ,i1 ,n-end1))
- (declare (type bignum-index ,i1))
- (%bignum-set ,n-dest ,i1
- (%bignum-ref ,n-src ,i1))))
- `(let ((,n-end1 ,end1)
- (,n-end2 ,end2))
- (do ((,i1 ,start1 (1+ ,i1))
- (,i2 ,start2 (1+ ,i2)))
- ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2)))
- (declare (type bignum-index ,i1 ,i2))
- (%bignum-set ,n-dest ,i1
- (%bignum-ref ,n-src ,i2)))))))))
+ (with-unique-names (n-start1 n-end1 n-start2 n-end2 i1 i2)
+ (let ((end1 (or end1 `(%bignum-length ,n-dest)))
+ (end2 (or end2 `(%bignum-length ,n-src))))
+ (if from-end
+ `(let ((,n-start1 ,start1)
+ (,n-start2 ,start2))
+ (do ((,i1 (1- ,end1) (1- ,i1))
+ (,i2 (1- ,end2) (1- ,i2)))
+ ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2)))
+ (declare (fixnum ,i1 ,i2))
+ (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2))))
+ (if (eql start1 start2)
+ `(let ((,n-end1 (min ,end1 ,end2)))
+ (do ((,i1 ,start1 (1+ ,i1)))
+ ((>= ,i1 ,n-end1))
+ (declare (type bignum-index ,i1))
+ (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i1))))
+ `(let ((,n-end1 ,end1)
+ (,n-end2 ,end2))
+ (do ((,i1 ,start1 (1+ ,i1))
+ (,i2 ,start2 (1+ ,i2)))
+ ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2)))
+ (declare (type bignum-index ,i1 ,i2))
+ (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2))))))))))
(sb!xc:defmacro with-bignum-buffers (specs &body body)
#!+sb-doc
;;; 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)
- sb!vm::positive-fixnum)
+ (and unsigned-byte fixnum))
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))
(setf u-len (make-gcd-bignum-odd u u-len))
(rotatef u v)
(rotatef u-len v-len))
+ (bignum-abs-buffer u u-len)
(setf u (copy-bignum u u-len))
(let ((n (bignum-mod-gcd v1 u)))
(ash (bignum-mod-gcd u1 (if (fixnump n)
;;; This negates bignum-len digits of bignum, storing the resulting digits into
;;; result (possibly EQ to bignum) and returning whatever end-carry there is.
-(sb!xc:defmacro bignum-negate-loop (bignum
- bignum-len
- &optional (result nil resultp))
- (let ((carry (gensym))
- (end (gensym))
- (value (gensym))
- (last (gensym)))
+(sb!xc:defmacro bignum-negate-loop
+ (bignum bignum-len &optional (result nil resultp))
+ (with-unique-names (carry end value last)
`(let* (,@(if (not resultp) `(,last))
(,carry
(multiple-value-bind (,value ,carry)
(res-len-1 (1- res-len))
,@(if result `((,result (%allocate-bignum res-len)))))
(declare (type bignum-index res-len res-len-1))
- (do ((i ,start-digit i+1)
- (i+1 (1+ ,start-digit) (1+ i+1))
+ (do ((i ,start-digit (1+ i))
(j 0 (1+ j)))
,termination
- (declare (type bignum-index i i+1 j))
+ (declare (type bignum-index i j))
(setf (%bignum-ref ,(if result result source) j)
(%logior (%digit-logical-shift-right (%bignum-ref ,source i)
,start-pos)
- (%ashl (%bignum-ref ,source i+1)
+ (%ashl (%bignum-ref ,source (1+ i))
high-bits-in-first-digit))))))
) ; EVAL-WHEN
(res-len-1 (1- res-len))
(res (or res (%allocate-bignum res-len))))
(declare (type bignum-index res-len res-len-1))
- (do ((i 0 i+1)
- (i+1 1 (1+ i+1))
+ (do ((i 0 (1+ i))
(j (1+ digits) (1+ j)))
((= j res-len-1)
(setf (%bignum-ref res digits)
(if resp
(%normalize-bignum-buffer res res-len)
(%normalize-bignum res res-len)))
- (declare (type bignum-index i i+1 j))
+ (declare (type bignum-index i j))
(setf (%bignum-ref res j)
(%logior (%digit-logical-shift-right (%bignum-ref bignum i)
remaining-bits)
- (%ashl (%bignum-ref bignum i+1) n-bits))))))
+ (%ashl (%bignum-ref bignum (1+ i)) n-bits))))))
\f
;;;; relational operators
;;; normalization.
;;;
;;; We don't have to worry about shifting Y to make its most
- ;;; significant digit sufficiently large for %FLOOR to return
+ ;;; significant digit sufficiently large for %BIGFLOOR to return
;;; digit-size 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
+ ;;; %BIGFLOOR. That is, it has some bits on pretty high in the
;;; digit.
((bignum-truncate-single-digit (x len-x y)
(declare (type bignum-index len-x))
- (let ((q (%allocate-bignum len-x))
- (r 0)
- (y (%bignum-ref y 0)))
- (declare (type bignum-element-type r y))
- (do ((i (1- len-x) (1- i)))
- ((minusp i))
- (multiple-value-bind (q-digit r-digit)
- (%floor r (%bignum-ref x i) y)
- (declare (type bignum-element-type q-digit r-digit))
- (setf (%bignum-ref q i) q-digit)
- (setf r r-digit)))
- (let ((rem (%allocate-bignum 1)))
- (setf (%bignum-ref rem 0) r)
- (values q rem))))
+ (let ((y (%bignum-ref y 0)))
+ (declare (type bignum-element-type y))
+ (if (not (logtest y (1- y)))
+ ;; Y is a power of two.
+ ;; SHIFT-RIGHT-UNALIGNED won't do the right thing
+ ;; with a shift count of 0 or -1, so special case this.
+ (cond ((= y 0)
+ (error 'division-by-zero))
+ ((= y 1)
+ ;; We could probably get away with (VALUES X 0)
+ ;; here, but it's not clear that some of the
+ ;; normalization logic further down would avoid
+ ;; mutilating X. Just go ahead and cons, consing's
+ ;; cheap.
+ (values (copy-bignum x len-x) 0))
+ (t
+ (let ((n-bits (1- (integer-length y))))
+ (values
+ (shift-right-unaligned x 0 n-bits len-x
+ ((= j res-len-1)
+ (setf (%bignum-ref res j)
+ (%ashr (%bignum-ref x i) n-bits))
+ res)
+ res)
+ (logand (%bignum-ref x 0) (1- y))))))
+ (do ((i (1- len-x) (1- i))
+ (q (%allocate-bignum len-x))
+ (r 0))
+ ((minusp i)
+ (let ((rem (%allocate-bignum 1)))
+ (setf (%bignum-ref rem 0) r)
+ (values q rem)))
+ (declare (type bignum-element-type r))
+ (multiple-value-bind (q-digit r-digit)
+ (%bigfloor r (%bignum-ref x i) y)
+ (declare (type bignum-element-type q-digit r-digit))
+ (setf (%bignum-ref q i) q-digit)
+ (setf r r-digit))))))
;;; This returns a guess for the next division step. Y1 is the
;;; highest y digit, and y2 is the second to highest y
;;; digit. The x... variables are the three highest x digits
(declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2))
(let ((guess (if (%digit-compare x-i y1)
all-ones-digit
- (%floor x-i x-i-1 y1))))
+ (%bigfloor x-i x-i-1 y1))))
(declare (type bignum-element-type guess))
(loop
(multiple-value-bind (high-guess*y1 low-guess*y1)
;;; digit-size.
;;;
;;; We shift y to make it sufficiently large that doing the
- ;;; 2*digit-size by digit-size %FLOOR calls ensures the quotient and
+ ;;; 2*digit-size by digit-size %BIGFLOOR calls ensures the quotient and
;;; remainder fit in digit-size.
(shift-y-for-truncate (y)
(let* ((len (%bignum-length y))
;;;; There used to be a pile of code for implementing division for bignum digits
;;;; for machines that don't have a 2*digit-size by digit-size divide instruction.
;;;; This happens to be most machines, but all the SBCL ports seem to be content
-;;;; to implement SB-BIGNUM:%FLOOR as a VOP rather than using the code here.
+;;;; to implement SB-BIGNUM:%BIGFLOOR as a VOP rather than using the code here.
;;;; So it's been deleted. --njf, 2007-02-04
\f
;;;; general utilities
(let ((xi (%bignum-ref x i)))
(mixf result
(logand most-positive-fixnum
- xi
- (ash xi -7)))))
+ (logxor xi
+ (ash xi -7))))))
result))
projects / sbcl.git / blobdiff