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

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20672 Modified Files: special-operators.lisp Log Message: Removed dead code. Date: Wed Jul 14 17:29:19 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.26 movitz/special-operators.lisp:1.27 --- movitz/special-operators.lisp:1.26 Mon Jul 12 19:26:14 2004 +++ movitz/special-operators.lisp Wed Jul 14 17:29:19 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.26 2004/07/13 02:26:14 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.27 2004/07/15 00:29:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1012,120 +1012,6 @@ (compiler-values () :returns returns :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))) - - -(define-special-operator muerte::+%2op (&all all &form form &env env &result-mode result-mode) - (assert (not (eq :boolean result-mode)) () - "Boolean result-mode for +%2op makes no sense.") - (destructuring-bind (term1 term2) - (cdr form) - (flet ((compile-constant-add (constant-term term-form) - (compiler-values-bind (&code term2-code &returns term2-returns &type term2-type - &functional-p term2-functional-p &modifies term2-modifies) - (compiler-call #'compile-form-unprotected - :result-mode (case result-mode - ((:eax :ebx :ecx :edx) - result-mode) - (t :eax)) - :defaults all - :form term-form) - (assert term2-type) - (let ((term2-type (type-specifier-primary term2-type))) -;;; (declare (ignore term2-type)) -;;; (warn "t2-type: ~S, t2-ret: ~S, rm: ~S" -;;; term2-type term2-returns result-mode) - (cond - ((and (eq 'binding-type (operator term2-type)) - (eq (second term2-type) result-mode)) - (let ((binding result-mode)) - (check-type binding lexical-binding) - (compiler-values () - :returns binding - :type (binding-type-specifier binding) - :code (append - (compiler-call #'compile-form-unprotected - :result-mode :ignore - :defaults all - :form term-form) - `((:incf-lexvar ,binding ,constant-term)))))) - ((eq :untagged-fixnum-eax term2-returns) - (case result-mode - (:untagged-fixnum-eax - (compiler-values () - :returns :untagged-fixnum-eax - :type 'integer - :functional-p term2-functional-p - :modifies term2-modifies - :code (append term2-code - `((:addl ,constant-term :eax)) - (unless (< #x-10000 constant-term #x10000) - '((:into)))))) - (t (let ((result-register (accept-register-mode result-mode))) - ;; (warn "XX") - (compiler-values () - :returns result-register - :modifies term2-modifies - :functional-p term2-functional-p - :code (append term2-code - `((:leal ((:eax ,+movitz-fixnum-factor+) - ,(* +movitz-fixnum-factor+ constant-term)) - ,result-register)))))))) - (t (multiple-value-bind (new-load-term-code add-result-mode) - (make-result-and-returns-glue (accept-register-mode term2-returns) - term2-returns - term2-code) - (let ((add-register (single-value-register add-result-mode)) - (label (gensym "not-integer-"))) - (compiler-values () - :returns add-register - :functional-p term2-functional-p - :modifies term2-modifies - :type 'integer - :code (append - new-load-term-code - (unless nil - #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) - `(integer ,+movitz-most-negative-fixnum+ - ,+movitz-most-positive-fixnum+)) - `((:testb ,+movitz-fixnum-zmask+ - ,(register32-to-low8 add-register)) - (:jnz '(:sub-program (,label) (:int 107) (:jmp (:pc+ -4)))))) - `((:addl ,(* constant-term +movitz-fixnum-factor+) ,add-register)) - (unless nil - #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) - `(integer ,(+ +movitz-most-negative-fixnum+ - constant-term) - ,(+ +movitz-most-positive-fixnum+ - constant-term))) - '((:into))))))))))))) - (cond - ((and (movitz-constantp term1 env) - (movitz-constantp term2 env)) - (compiler-call #'compile-self-evaluating - :forward all - :form (+ (eval-form term1 env) - (eval-form term2 env)))) - ((and (movitz-constantp term1 env) ; first operand zero? - (zerop (eval-form term1 env))) - (compiler-call #'compile-form-unprotected - :forward all - :form term2)) ; (+ 0 x) => x - ((and (movitz-constantp term2 env) ; second operand zero? - (zerop (eval-form term2 env))) - (compiler-call #'compile-form-unprotected - :forward all - :form term1)) ; (+ x 0) => x - ((movitz-constantp term1 env) - (let ((constant-term1 (eval-form term1 env))) - (check-type constant-term1 (signed-byte 30)) - (compile-constant-add constant-term1 term2))) - ((movitz-constantp term2 env) - (let ((constant-term2 (eval-form term2 env))) - (check-type constant-term2 (signed-byte 30)) - (compile-constant-add constant-term2 term1))) - (t (compiler-call #'compile-apply-symbol - :forward all - :form `(muerte.cl:+ ,term1 ,term2))))))) (define-special-operator muerte::include (&form form) (let ((*require-dependency-chain*

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv9312 Modified Files: debugger.lisp Log Message: Have the debugger accept bigger pointer-sizes as "reasonable". Date: Wed Jul 14 17:28:30 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.15 movitz/losp/x86-pc/debugger.lisp:1.16 --- movitz/losp/x86-pc/debugger.lisp:1.15 Mon Jul 12 04:10:40 2004 +++ movitz/losp/x86-pc/debugger.lisp Wed Jul 14 17:28:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.15 2004/07/12 11:10:40 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.16 2004/07/15 00:28:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -58,8 +58,7 @@ (defun pointer-in-range (x) (with-inline-assembly (:returns :boolean-cf=1) (:compile-form (:result-mode :eax) x) - ;; (:subl #x100000 :eax) - (:cmpl #x1000000 :eax))) + (:cmpl #x10000000 :eax))) (defun code-vector-offset (code-vector address)

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28640 Modified Files: scavenge.lisp Log Message: Minor edit. Date: Wed Jul 14 17:27:34 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.18 movitz/losp/muerte/scavenge.lisp:1.19 --- movitz/losp/muerte/scavenge.lisp:1.18 Tue Jul 13 15:44:37 2004 +++ movitz/losp/muerte/scavenge.lisp Wed Jul 14 17:27:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.18 2004/07/13 22:44:37 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.19 2004/07/15 00:27:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -181,7 +181,7 @@ (map-heap-words function (1+ interrupted-esp) frame) (error "Don't know how to scavenge across interrupt frame at ~S." interrupt-frame))))))) - (t (error "Don't know how to scavenge across a frame of kind ~S." funobj))))) + (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) (defparameter *primitive-funcall-patterns*

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20577 Modified Files: los0-gc.lisp Log Message: Some tweaking of GC messages etc. Date: Wed Jul 14 17:27:13 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.25 movitz/losp/los0-gc.lisp:1.26 --- movitz/losp/los0-gc.lisp:1.25 Tue Jul 13 06:02:45 2004 +++ movitz/losp/los0-gc.lisp Wed Jul 14 17:27:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.25 2004/07/13 13:02:45 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.26 2004/07/15 00:27:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,14 +18,14 @@ (in-package muerte.init) -(defconstant +space-size+ #xfffd) - -(defun make-space (location) +(defvar *gc-quiet* nil) + +(defun make-space (location size) "Make a space vector at a fixed location." (assert (evenp location)) (macrolet ((x (index) `(memref location 0 ,index :unsigned-byte32))) - (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ +space-size+) + (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) (cl:byte 8 8) (bt:enum-value 'movitz:other-type-byte :basic-vector)))) @@ -247,12 +247,16 @@ (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) - (format t "~&;; GC.. ") + (unless *gc-quiet* + (format t "~&;; GC.. ")) (stop-and-copy) ;; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll."))))) + (loop + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (break "Los0 GC keyboard poll.")) + ((nil) + (return)))))) (let ((conser (symbol-value 'los0-fast-cons))) (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) @@ -406,10 +410,11 @@ "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace))) ;; GC completed, oldspace is evacuated. - (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) - (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ + (unless *gc-quiet* + (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) + (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) + (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - old-size new-size (- old-size new-size))) + old-size new-size (- old-size new-size)))) (initialize-space oldspace)))) (values))

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12672 Modified Files: integers.lisp Log Message: Added %negatef, in an effort to reduce bignum consing a bit. Date: Wed Jul 14 17:26:26 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.64 movitz/losp/muerte/integers.lisp:1.65 --- movitz/losp/muerte/integers.lisp:1.64 Wed Jul 14 16:45:12 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 17:26:26 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.64 2004/07/14 23:45:12 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.65 2004/07/15 00:26:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -87,6 +87,19 @@ (define-simple-typep (bit bitp) (x) (or (eq x 0) (eq x 1))) +;;; + +(defun %negatef (x p0 p1) + "Negate x. If x is not eq to p0 or p1, negate x destructively." + (etypecase x + (fixnum (- x)) + (bignum + (if (or (eq x p0) (eq x p1)) + (- x) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:xorl #xff00 (:eax #.movitz:+other-type-offset+))))))) + ;;; Addition (define-compiler-macro + (&whole form &rest operands &environment env) @@ -364,7 +377,6 @@ (:call-global-constant cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) - pfix-pbig-done) )) (((integer * -1) (integer 0 *)) @@ -372,7 +384,7 @@ (((integer 0 *) (integer * -1)) (- x (- y))) (((integer * -1) (integer * -1)) - (+ (- x) (- y))) + (%negatef (+ (- x) (- y)) x y)) ))) (do-it))) (t (&rest terms) @@ -511,7 +523,7 @@ (((integer 0 *) (integer * -1)) (+ minuend (- subtrahend))) (((integer * -1) (integer 0 *)) - (- (+ (- minuend) subtrahend))) + (%negatef (+ (- minuend) subtrahend) minuend subtrahend)) (((integer * -1) (integer * -1)) (+ minuend (- subtrahend))) ))) @@ -520,7 +532,7 @@ (declare (dynamic-extent subtrahends)) (if subtrahends (reduce #'- subtrahends :initial-value minuend) - (- 0 minuend))))) + (- minuend))))) (define-modify-macro decf (&optional (delta-form 1)) -) @@ -1469,15 +1481,17 @@ (((integer * -1) (integer 0 *)) (multiple-value-bind (q r) (truncate (- number) divisor) - (values (- q) (- r)))) + (values (%negatef q number divisor) + (%negatef r number divisor)))) (((integer 0 *) (integer * -1)) (multiple-value-bind (q r) (truncate (- number) divisor) - (values (- q) r))) + (values (%negatef q number divisor) + r))) (((integer * -1) (integer * -1)) (multiple-value-bind (q r) (truncate (- number) divisor) - (values q (- r)))) + (values q (%negatef r number divisor)))) )))) (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-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