[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv2747

Modified Files:
	integers.lisp 
Log Message:
Improved ash. Fixed a bug wrt. carry-propagation in - for bignums.

Date: Thu Jul 15 17:03:05 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.66 movitz/losp/muerte/integers.lisp:1.67
--- movitz/losp/muerte/integers.lisp:1.66	Thu Jul 15 14:07:08 2004
+++ movitz/losp/muerte/integers.lisp	Thu Jul 15 17:03:05 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.66 2004/07/15 21:07:08 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.67 2004/07/16 00:03:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -516,8 +516,11 @@
 			(:jne 'sub-loop)
 			(:subl :ecx
 			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
-			(:jc '(:sub-program (should-not-happen)
-			       (:int 107)))
+			(:jnc 'bignum-sub-done)
+		       propagate-carry
+			(:addl 4 :edx)
+			(:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jc 'propagate-carry)
 		       bignum-sub-done
 			)))))
 		(((integer 0 *) (integer * -1))
@@ -1088,14 +1091,63 @@
   
 (defun ash (integer count)
   (cond
-   ((not (minusp count))
-    (do () ((< count 16))
-      (setf integer (no-macro-call * #x10000 integer))
-      (decf count 16))
-    (dotimes (i count integer)
-      (setf integer (no-macro-call * 2 integer))))
-   (t (dotimes (i (- count) integer)
-	(setf integer (truncate integer 2))))))
+   ((= 0 count)
+    integer)
+   ((plusp count)
+    (let ((result-length (+ (integer-length integer) count)))
+      (cond
+       ((<= result-length 29)
+	(with-inline-assembly (:returns :eax)
+	  (:compile-two-forms (:eax :ecx) integer count)
+	  (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
+	  (:shll :cl :eax)))
+       (t (check-type integer (integer 0 *))
+	  (multiple-value-bind (long short)
+	      (truncate count 16)
+	    (let ((result (%make-bignum (truncate (+ result-length 31) 32))))
+	      (dotimes (i long)
+		(setf (memref result -2 i :unsigned-byte16) 0))
+	      (etypecase integer
+		(fixnum
+		 (when (>= integer #x10000)
+		   (setf (memref result -2 (1+ long) :unsigned-byte16)
+		     (ldb (byte 16 16) integer)))
+		 (setf (memref result -2 long :unsigned-byte16)
+		   (ldb (byte 16 0) integer)))
+		(bignum
+		 (dotimes (i (* 2 (%bignum-bigits integer)))
+		   (setf (memref result -2 (+ i long) :unsigned-byte16)
+		     (memref integer -2 i :unsigned-byte16)))))
+	      (setf result (%bignum-canonicalize result))
+	      (dotimes (i short)
+		(setf result (* 2 result)))
+	      result))))))
+   (t (let ((count (- count)))
+	(etypecase integer
+	  (fixnum
+	   (with-inline-assembly (:returns :eax :type fixnum)
+	     (:compile-two-forms (:eax :ecx) integer count)
+	     (:shrl #.movitz:+movitz-fixnum-shift+ :ecx)
+	     (:std)
+	     (:sarl :cl :eax)
+	     (:andl -4 :eax)
+	     (:cld)))
+	  (positive-bignum
+	   (let* ((result-length (- (integer-length integer) count))
+		  (result (%make-bignum (truncate (+ result-length 31) 32))))
+	     (multiple-value-bind (long short)
+		 (truncate count 16)
+	       (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
+		 (dotimes (i (* 2 (%bignum-bigits result)))
+		   (let ((src (+ i long)))
+		     (setf (memref result -2 i :unsigned-byte16)
+		       (if (< src src-max-bigit)
+			   (memref integer -2 src :unsigned-byte16)
+			 0)))))
+	       (setf result (%bignum-canonicalize result))
+	       (dotimes (i short result)
+		 (setf result (truncate result 2)))
+	       result))))))))
 
 ;;;;
 
@@ -1317,10 +1369,16 @@
 		   ;; X is the biggest factor.
 		   (let ((r 0) (f 0))
 		     (dotimes (half-bigit (* 2 (%bignum-bigits y)))
-		       (setf r (+ r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
-					  f)))
+		       (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x)
+				    f))
 		       (incf f 16))
-		     r))))))
+		     r)))
+		((t (integer * -1))
+		 (%negatef (* x (- y)) x y))
+		(((integer * -1) t)
+		 (%negatef (* (- x) y) x y))
+		(((integer * -1) (integer * -1))
+		 (* (- x) (- y))))))
 	(do-it)))
    (t (&rest factors)
       (declare (dynamic-extent factors))
@@ -1461,18 +1519,15 @@
 	       (setf msb (+ (* #x10000 msb)
 			    (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8))
 			    (memref divisor -2 msb-pos :unsigned-byte8)))
-	       (multiple-value-bind (long-shift short-shift)
-		   ;; This shifting stuff should be replaced by ash,
-		   ;; when ash is properly implemented.
-		   (truncate msb-pos 3)
+	       (let ((guess-shift (- (* msb-pos 8))))
 		 (do ((msb+1 (1+ msb))
 		      (q 0) (r number))
 		     ((< r divisor) (values q r))
-		   (let ((guess (truncate r msb+1)))
-		     (dotimes (i long-shift)
-		       (setf guess (truncate guess #x1000000)))
-		     (dotimes (i short-shift)
-		       (setf guess (truncate guess #x100)))
+		   (let ((guess (ash (truncate r msb+1) guess-shift)))
+;;;		     (dotimes (i long-shift)
+;;;		       (setf guess (truncate guess #x1000000)))
+;;;		     (dotimes (i short-shift)
+;;;		       (setf guess (truncate guess #x100)))
 		     (if (= 0 guess)
 			 (setf q (1+ q)
 			       r (- r divisor))