July 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10753 Modified Files: integers.lisp Log Message: Speeded up bignum truncate. Date: Wed Jul 14 16:45:12 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.63 movitz/losp/muerte/integers.lisp:1.64 --- movitz/losp/muerte/integers.lisp:1.63 Wed Jul 14 14:58:58 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 16:45:12 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.63 2004/07/14 21:58:58 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.64 2004/07/14 23:45:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1440,23 +1440,32 @@ (cond ((= number divisor) (values 1 0)) ((< number divisor) (values 0 number)) - (t (let* ((msb-pos (1- (* 2 (%bignum-bigits divisor)))) - (msb (memref divisor -2 msb-pos :unsigned-byte16))) - (when (= 0 msb) + (t (let* ((msb-pos (1- (* 4 (%bignum-bigits divisor)))) + (msb (memref divisor -2 msb-pos :unsigned-byte8))) + (do () ((not (eq 0 msb))) (decf msb-pos) - (setf msb (memref divisor -2 msb-pos :unsigned-byte16)) - (assert (plusp msb))) - (do ((msb+1 (1+ msb)) - (q 0) (r number)) - ((< r divisor) (values q r)) - (let ((guess (truncate r msb+1))) - (dotimes (i msb-pos) - (setf guess (truncate guess #x10000))) - (if (= 0 guess) - (setf q (1+ q) - r (- r divisor)) - (setf q (+ q guess) - r (- r (* divisor guess)))))))))) + (setf msb (memref divisor -2 msb-pos :unsigned-byte8))) + (decf msb-pos 2) + (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) + (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))) + (if (= 0 guess) + (setf q (1+ q) + r (- r divisor)) + (setf q (+ q guess) + r (- r (* divisor guess))))))))))) (((integer * -1) (integer 0 *)) (multiple-value-bind (q r) (truncate (- number) divisor)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10726 Modified Files: integers.lisp Log Message: Fixed carry-propagation for -. Date: Wed Jul 14 14:58:58 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.62 movitz/losp/muerte/integers.lisp:1.63 --- movitz/losp/muerte/integers.lisp:1.62 Wed Jul 14 09:17:57 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 14:58:58 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.62 2004/07/14 16:17:57 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.63 2004/07/14 21:58:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -340,7 +340,7 @@ :ecx) (:jc '(:sub-program (term1-carry) ;; The digit + carry carried over, ECX = 0 - (:movl 1 :ecx) + (:addl 1 :ecx) (:addl 4 :edx) (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) (:jae 'add-bignum-loop) @@ -474,7 +474,12 @@ ((= minuend subtrahend) 0) ((< minuend subtrahend) - (- (- subtrahend minuend))) + (let ((x (- subtrahend minuend))) + (when (typep x 'bignum) + (setf (memref x ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign) + 0 :unsigned-byte8) + #xff)) + x)) (t (%bignum-canonicalize (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend) @@ -484,8 +489,12 @@ (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) (:jc '(:sub-program (carry-overflow) - ;; - (:break))) + ;; Just propagate carry + (:addl 1 :ecx) + (:addl 4 :edx) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'sub-loop) + (:jmp 'bignum-sub-done))) (:subl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:sbbl :ecx :ecx) @@ -497,6 +506,7 @@ (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:jc '(:sub-program (should-not-happen) (:int 107))) + bignum-sub-done ))))) (((integer 0 *) (integer * -1)) (+ minuend (- subtrahend)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30017 Modified Files: integers.lisp Log Message: Fixed a braino in bignum addition; sometimes carry wasn't propagated right. I'll have to do the same fix to -. Date: Wed Jul 14 09:17:58 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.61 movitz/losp/muerte/integers.lisp:1.62 --- movitz/losp/muerte/integers.lisp:1.61 Wed Jul 14 06:53:16 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 09:17:57 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.61 2004/07/14 13:53:16 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.62 2004/07/14 16:17:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -283,7 +283,6 @@ ;; Assume x is smallest. (with-inline-assembly (:returns :eax :labels (retry-not-size1 not-size1 - term-zero copy-bignum-loop add-bignum-loop add-bignum-done @@ -339,8 +338,14 @@ (:jmp 'add-bignum-done))) (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) - term-zero - (:adcl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc '(:sub-program (term1-carry) + ;; The digit + carry carried over, ECX = 0 + (:movl 1 :ecx) + (:addl 4 :edx) + (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jae 'add-bignum-loop) + (:jmp 'add-bignum-done))) + (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:sbbl :ecx :ecx) (:negl :ecx) ; ECX = Add's Carry. (:addl 4 :edx) @@ -478,7 +483,10 @@ sub-loop (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) - (:sbbl :ecx + (:jc '(:sub-program (carry-overflow) + ;; + (:break))) + (:subl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:sbbl :ecx :ecx) (:negl :ecx) @@ -1287,8 +1295,8 @@ ;; X is the biggest factor. (let ((r 0) (f 0)) (dotimes (half-bigit (* 2 (%bignum-bigits y))) - (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) - f)) + (setf r (+ r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) + f))) (incf f 16)) r)))))) (do-it)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20715 Modified Files: integers.lisp Log Message: In ceiling, calculate correct remainder. Date: Wed Jul 14 06:53:16 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.60 movitz/losp/muerte/integers.lisp:1.61 --- movitz/losp/muerte/integers.lisp:1.60 Wed Jul 14 06:48:11 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 06:53:16 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.60 2004/07/14 13:48:11 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.61 2004/07/14 13:53:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1509,7 +1509,9 @@ (defun ceiling (number &optional (divisor 1)) (case (+ (if (minusp number) #b10 0) (if (minusp divisor) #b01 0)) - (#b00 (truncate (+ number divisor -1) divisor)) + (#b00 (multiple-value-bind (q r) + (truncate (+ number divisor -1) divisor) + (values q (- r (1- divisor))))) (t (error "Don't know.")))) (defun rem (dividend divisor)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7967 Modified Files: integers.lisp Log Message: Fixed a bug in integer-length on bignums. Date: Wed Jul 14 06:48:12 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.59 movitz/losp/muerte/integers.lisp:1.60 --- movitz/losp/muerte/integers.lisp:1.59 Wed Jul 14 05:36:50 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 06:48:11 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.59 2004/07/14 12:36:50 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.60 2004/07/14 13:48:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1098,7 +1098,7 @@ :ecx) (:leal ((:ecx 1) ,(* -1 movitz:+movitz-fixnum-factor+)) :eax) ; bigits-1 - (:bsrl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:bsrl (:ebx (:ecx 1) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) :ecx) (:shll 5 :eax) ; bits = bigits*32 + (bit-index+1) (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20640 Modified Files: integers.lisp Log Message: Implemented + on negatives in terms of -. Date: Wed Jul 14 05:36:50 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.58 movitz/losp/muerte/integers.lisp:1.59 --- movitz/losp/muerte/integers.lisp:1.58 Wed Jul 14 05:28:06 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 05:36:50 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.58 2004/07/14 12:28:06 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.59 2004/07/14 12:36:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -362,6 +362,12 @@ pfix-pbig-done) )) + (((integer * -1) (integer 0 *)) + (- y (- x))) + (((integer 0 *) (integer * -1)) + (- x (- y))) + (((integer * -1) (integer * -1)) + (+ (- x) (- y))) ))) (do-it))) (t (&rest terms)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19168 Modified Files: integers.lisp Log Message: Remember to return the remainder also, when implementing truncate on negatives in terms of truncate on positives. Date: Wed Jul 14 05:28:06 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.57 movitz/losp/muerte/integers.lisp:1.58 --- movitz/losp/muerte/integers.lisp:1.57 Wed Jul 14 05:16:28 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 05:28:06 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.57 2004/07/14 12:16:28 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.58 2004/07/14 12:28:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1434,11 +1434,17 @@ (setf q (+ q guess) r (- r (* divisor guess)))))))))) (((integer * -1) (integer 0 *)) - (- (truncate (- number) divisor))) + (multiple-value-bind (q r) + (truncate (- number) divisor) + (values (- q) (- r)))) (((integer 0 *) (integer * -1)) - (- (truncate number (- divisor)))) + (multiple-value-bind (q r) + (truncate (- number) divisor) + (values (- q) r))) (((integer * -1) (integer * -1)) - (truncate (- number) (- divisor))) + (multiple-value-bind (q r) + (truncate (- number) divisor) + (values q (- r)))) )))) (defun / (number &rest denominators)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5794 Modified Files: integers.lisp Log Message: Fixed - for negative bignums. Date: Wed Jul 14 05:16:28 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.56 movitz/losp/muerte/integers.lisp:1.57 --- movitz/losp/muerte/integers.lisp:1.56 Wed Jul 14 05:03:58 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 05:16:28 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.56 2004/07/14 12:03:58 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.57 2004/07/14 12:16:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -454,12 +454,10 @@ (:compile-two-forms (:eax :ebx) minuend subtrahend) (:subl :ebx :eax) (:into))) - ((bignum fixnum) + ((positive-bignum fixnum) (+ (- subtrahend) minuend)) - ((fixnum bignum) + ((fixnum positive-bignum) (- (+ (- minuend) subtrahend))) - (((integer 0 *) (integer * -1)) - (+ minuend (- subtrahend))) ((positive-bignum positive-bignum) (cond ((= minuend subtrahend) @@ -485,7 +483,14 @@ (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:jc '(:sub-program (should-not-happen) (:int 107))) - )))))))) + ))))) + (((integer 0 *) (integer * -1)) + (+ minuend (- subtrahend))) + (((integer * -1) (integer 0 *)) + (- (+ (- minuend) subtrahend))) + (((integer * -1) (integer * -1)) + (+ minuend (- subtrahend))) + ))) (do-it))) (t (minuend &rest subtrahends) (declare (dynamic-extent subtrahends))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11410 Modified Files: integers.lisp Log Message: Fixed bogus abs compiler-macro. Tuned up gcd a bit. Date: Wed Jul 14 05:03:58 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.55 movitz/losp/muerte/integers.lisp:1.56 --- movitz/losp/muerte/integers.lisp:1.55 Wed Jul 14 04:01:43 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 05:03:58 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.55 2004/07/14 11:01:43 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.56 2004/07/14 12:03:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -942,7 +942,7 @@ (define-compiler-macro abs (x) `(let ((x ,x)) - (if (>= 0 x) x (- x)))) + (if (>= x 0) x (- x)))) (defun abs (x) (abs x)) @@ -1427,7 +1427,14 @@ (setf q (1+ q) r (- r divisor)) (setf q (+ q guess) - r (- r (* divisor guess)))))))))))))) + r (- r (* divisor guess)))))))))) + (((integer * -1) (integer 0 *)) + (- (truncate (- number) divisor))) + (((integer 0 *) (integer * -1)) + (- (truncate number (- divisor)))) + (((integer * -1) (integer * -1)) + (truncate (- number) (- divisor))) + )))) (defun / (number &rest denominators) (declare (dynamic-extent denominators)) @@ -2275,20 +2282,18 @@ (u (abs u) (truncate u 2)) (v (abs v) (truncate v 2))) ((or (oddp u) (oddp v)) - (do ((temp (if (oddp u) (- v) (ash u -1)) - (ash temp -1))) + (do ((temp (if (oddp u) + (- v) + (truncate u 2)) + (truncate temp 2))) (nil) - (declare (fixnum temp)) (when (oddp temp) (if (plusp temp) (setq u temp) (setq v (- temp))) (setq temp (- u v)) (when (zerop temp) - (let ((res (ash u k))) - (declare (type (signed-byte 31) res) - (optimize (inhibit-warnings 3))) - (return res)))))))) + (return (ash u k)))))))) (t (&rest numbers) (declare (dynamic-extent numbers)) (do ((gcd (car numbers)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 14 Jul '04

14 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3713 Modified Files: integers.lisp Log Message: Fixed a bug in fast-compare-two-reals for negative bignums. Improved evenp and oddp, and gcd. Removed bogus compiler-macro for ash. Date: Wed Jul 14 04:01:43 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.54 movitz/losp/muerte/integers.lisp:1.55 --- movitz/losp/muerte/integers.lisp:1.54 Wed Jul 14 03:03:44 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 04:01:43 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.54 2004/07/14 10:03:44 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.55 2004/07/14 11:01:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -41,34 +41,23 @@ (defun fixnump (x) (typep x 'fixnum)) -(defun evenp (x) - (macrolet - ((do-it () - `(with-inline-assembly (:returns :ebx) - (:compile-form (:result-mode :eax) x) - (:movl :eax :ecx) - (:andl 7 :ecx) - (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx)) - (:cmpl ,(movitz:tag :even-fixnum) :ecx) - (:je 'done) - (:movl :edi :ebx) - (:cmpl ,(movitz:tag :odd-fixnum) :ecx) - (:je 'done) - (:cmpl ,(movitz:tag :other) :ecx) - (:jnz '(:sub-program (not-integer) - (:int 107))) - (:cmpb ,(movitz:tag :bignum) (:eax ,movitz:+other-type-offset+)) - (:jne 'not-integer) - (:testb 1 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jnz 'done) - (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx)) - done))) - (do-it))) +(define-compiler-macro evenp (x) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,x) + (:call-global-constant unbox-u32) + (:testb 1 :cl))) -(defun oddp (x) - (not (evenp x))) +(defun evenp (x) + (evenp x)) +(define-compiler-macro oddp (x) + `(with-inline-assembly (:returns :boolean-zf=0) + (:compile-form (:result-mode :eax) ,x) + (:call-global-constant unbox-u32) + (:testb 1 :cl))) +(defun oddp (x) + (oddp x)) ;;; Types @@ -469,6 +458,8 @@ (+ (- subtrahend) minuend)) ((fixnum bignum) (- (+ (- minuend) subtrahend))) + (((integer 0 *) (integer * -1)) + (+ minuend (- subtrahend))) ((positive-bignum positive-bignum) (cond ((= minuend subtrahend) @@ -494,8 +485,7 @@ (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:jc '(:sub-program (should-not-happen) (:int 107))) - ))))) - ))) + )))))))) (do-it))) (t (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) @@ -571,7 +561,8 @@ (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) (:je 'positive-compare-loop) positive-compare-lsb - ;; Now make the compare unsigned.. + ;; Now we have to make the compare act as unsigned, which is why + ;; we compare zero-extended 16-bit quantities. (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) :ecx) ; First compare upper 16 bits. (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) @@ -608,10 +599,22 @@ (:je 'negative-compare-loop) (:ret) negative-compare-lsb ; it's down to the LSB bigits. - (:movl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) - (:cmpl :ecx - (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + ;; Now we have to make the compare act as unsigned, which is why + ;; we compare zero-extended 16-bit quantities. + (:movzxw (:ebx :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) ; First compare upper 16 bits. + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movzxw (:eax :edx ,(+ 2 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) + (:jne 'negative-upper-16-decisive) + (:movzxw (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) ; Then compare lower 16 bits. + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movzxw (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) ; Then compare lower 16 bits. + (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) + negative-upper-16-decisive (:ret)))) (do-it))) @@ -997,13 +1000,15 @@ (define-compiler-macro ash (&whole form integer count &environment env) (if (not (movitz:movitz-constantp count env)) form - (let ((count (movitz::movitz-eval count env))) + (let ((count (movitz:movitz-eval count env))) (cond ((movitz:movitz-constantp integer env) (ash (movitz::movitz-eval integer env) count)) ((= 0 count) integer) - (t (let ((load-integer `((:compile-form (:result-mode :register) ,integer) + (t form + #+igore + (let ((load-integer `((:compile-form (:result-mode :register) ,integer) (:testb ,movitz::+movitz-fixnum-zmask+ (:result-register-low8)) (:jnz '(:sub-program () (:int 107) (:jmp (:pc+ -4))))))) (cond @@ -2267,9 +2272,9 @@ (2 (u v) ;; Code borrowed from CMUCL. (do ((k 0 (1+ k)) - (u (abs u) (ash u -1)) - (v (abs v) (ash v -1))) - ((oddp (logior u v)) + (u (abs u) (truncate u 2)) + (v (abs v) (truncate v 2))) + ((or (oddp u) (oddp v)) (do ((temp (if (oddp u) (- v) (ash u -1)) (ash temp -1))) (nil)

1 0