1.0.12.13: sequence optimizations: SUBSEQ, part 3

[sbcl.git] / src / code / bignum.lisp

diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp
index 1ed5942..7f54a05 100644 (file)
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -499,14 +499,21 @@
                (declare (fixnum ,i1 ,i2))
                (%bignum-set ,n-dest ,i1
                             (%bignum-ref ,n-src ,i2))))
-          `(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))))))))
+          (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
@@ -543,7 +550,7 @@
 ;;; 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))
@@ -989,15 +996,14 @@
           (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
@@ -1123,8 +1129,7 @@
          (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)
@@ -1134,11 +1139,11 @@
          (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
 
@@ -1577,20 +1582,41 @@
         ;;; 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.
+                 (if (= y 1)
+                     ;; SHIFT-RIGHT-UNALIGNED won't do the right thing
+                     ;; with a shift count of 0, so special case this.
+                     ;; 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)
+                     (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)
+                       (%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))))))
         ;;; 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
@@ -1922,6 +1948,6 @@
       (let ((xi (%bignum-ref x i)))
         (mixf result
               (logand most-positive-fixnum
-                      xi
-                      (ash xi -7)))))
+                      (logxor xi
+                              (ash xi -7))))))
     result))