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

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29249 Modified Files: integers.lisp Log Message: More bignum fixes. Added some slow-but-working implementations of * and truncate for bignums. Date: Mon Jul 12 19:29:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.47 movitz/losp/muerte/integers.lisp:1.48 --- movitz/losp/muerte/integers.lisp:1.47 Mon Jul 12 07:17:14 2004 +++ movitz/losp/muerte/integers.lisp Mon Jul 12 19:29:15 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.47 2004/07/12 14:17:14 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.48 2004/07/13 02:29:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,6 +68,36 @@ (defun oddp (x) (not (evenp x))) + + +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + (list 'integer 0 (1- (ash 1 size)))) + (t (error "Illegal size for unsigned-byte.")))) + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + ;;; Addition (define-compiler-macro + (&whole form &rest operands &environment env) @@ -400,7 +430,7 @@ (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :bignum) :cl) (:jne 'not-a-number) - (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) + (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx) (:jne 'not-most-negative-fixnum) (:cmpl ,(- most-negative-fixnum) (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) @@ -423,15 +453,50 @@ ))) (do-it))) (2 (minuend subtrahend) - (cond - ((eq 0 minuend) - (- subtrahend)) - (t (check-type minuend fixnum) - (check-type subtrahend fixnum) - (with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) minuend subtrahend) - (:subl :ebx :eax) - (:into))))) + (macrolet + ((do-it () + `(number-double-dispatch (minuend subtrahend) + ((t (eql 0)) + minuend) + (((eql 0) t) + (- subtrahend)) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))) + ((bignum fixnum) + (+ (- subtrahend) minuend)) + ((fixnum bignum) + (- (+ (- minuend) subtrahend))) + ((positive-bignum positive-bignum) + (cond + ((= minuend subtrahend) + 0) + ((< minuend subtrahend) + (- (- subtrahend minuend))) + (t (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend) + (:xorl :edx :edx) ; counter + (:xorl :ecx :ecx) ; carry + sub-loop + (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:sbbl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:sbbl :ecx :ecx) + (:negl :ecx) + (:addl 4 :edx) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'sub-loop) + (:subl :ecx + (: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)) (if subtrahends @@ -1025,34 +1090,6 @@ ;;; (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) ;;; (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) -;;; Types - -(define-typep integer (x &optional (min '*) (max '*)) - (and (typep x 'integer) - (or (eq min '*) (<= min x)) - (or (eq max '*) (<= x max)))) - -(deftype signed-byte (&optional (size '*)) - (cond - ((eq size '*) - 'integer) - ((typep size '(integer 1 *)) - (list 'integer - (- (ash 1 (1- size))) - (1- (ash 1 (1- size))))) - (t (error "Illegal size for signed-byte.")))) - -(deftype unsigned-byte (&optional (size '*)) - (cond - ((eq size '*) - '(integer 0)) - ((typep size '(integer 1 *)) - (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for unsigned-byte.")))) - -(define-simple-typep (bit bitp) (x) - (or (eq x 0) (eq x 1))) - ;;;; (defun integer-length (integer) @@ -1267,10 +1304,11 @@ positive-result ))) ((positive-bignum positive-bignum) - (do ((f y) + (do ((mx (* most-positive-fixnum x)) + (f y) (r 0)) ((typep f 'fixnum) (+ r (* f x))) - (setf r (+ r (* most-positive-fixnum x))) + (setf r (+ r mx)) (setf f (- f most-positive-fixnum)))) ))) (do-it))) @@ -1402,7 +1440,9 @@ (cond ((= number divisor) (values 1 0)) ((< number divisor) (values 0 number)) - (t (error "Don't know how to divide ~S with ~S." number divisor)))) + (t (do ((q 0 (1+ q)) + (r number (- r divisor))) + ((< r divisor) (values q r)))))) )))) (defun / (number &rest denominators)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12896 Modified Files: cpu-id.lisp Log Message: Removed some dead code. Date: Mon Jul 12 19:27:20 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.5 movitz/losp/muerte/cpu-id.lisp:1.6 --- movitz/losp/muerte/cpu-id.lisp:1.5 Wed Jun 2 16:49:27 2004 +++ movitz/losp/muerte/cpu-id.lisp Mon Jul 12 19:27:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.5 2004/06/02 23:49:27 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.6 2004/07/13 02:27:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,31 +216,6 @@ (do-case (t :multiple-values) (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter))))) - -;;;(defun read-time-stamp-counter () -;;; "Read the 64-bit i686 time-stamp counter. -;;;Returned as three values: low 24 bits, mid 24 bits, high 16 bits. -;;;This is an illegal instruction on lesser CPUs." -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:std) -;;; (:rdtsc) ; Read Time-Stamp Counter into EDX:EAX -;;; ;; Load upper 16 bits (of EDX) as ternary value. -;;; (:movl :edx :ecx) -;;; (:andl #xffff0000 :edx) -;;; (:shll #.(cl:- 16 movitz::+movitz-fixnum-shift+) :edx) -;;; ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values))) -;;; ;; Bits 24-47 as fixnum into EBX -;;; (:shldl #.(cl:+ 8 movitz::+movitz-fixnum-shift+) :eax :ebx) -;;; (:andl #.(cl:* #x00ffffff movitz::+movitz-fixnum-factor+) :ebx) -;;; ;; Bits 0-23 as fixnum into EAX -;;; (:andl #x00ffffff :eax) -;;; (:shll #.movitz::+movitz-fixnum-shift+ :eax) -;;; (:cld) -;;; ;; Return 3 values -;;; ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values))) -;;; (:movl 3 :ecx) -;;; (:stc))) - (defun clear-time-stamp-counter () "Reset the i686 time-stamp-counter. This is an illegal instruction on lesser CPUs, and a no-op on some, such as bochs." @@ -256,9 +231,6 @@ (:popl (:result-register)) (:movl (:result-register) (#x1000)) (:shll 2 (:result-register)))) -;;; (:popl :ecx) -;;; (:leal ((:ecx ,movitz::+movitz-fixnum-factor+) :edi ,(movitz::edi-offset)) -;;; (:result-register)))) (defun eflags () (eflags))

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10528 Modified Files: primitive-functions.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:28 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.26 movitz/losp/muerte/primitive-functions.lisp:1.27 --- movitz/losp/muerte/primitive-functions.lisp:1.26 Thu Jul 8 08:28:57 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Jul 12 19:26:28 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.26 2004/07/08 15:28:57 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.27 2004/07/13 02:26:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -713,6 +713,9 @@ (:jnz 'push-loop) push-done (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 62))) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:addl 2 :ecx) done (:jmp :edx))) @@ -736,13 +739,15 @@ (:jmp :edx))) ;; three or more values (:subl 2 :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :ecx) (:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:subl 1 :ecx) + (:subl #.movitz:+movitz-fixnum-factor+ :ecx) pop-loop - (:locally (:popl (:edi (:ecx 4) (:edi-offset values)))) - (:subl 1 :ecx) + (:locally (:popl (:edi (:ecx 1) (:edi-offset values)))) + (:subl #.movitz:+movitz-fixnum-factor+ :ecx) (:jnc 'pop-loop) (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:popl :ebx) (:popl :eax) (:addl 2 :ecx)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10109 Modified Files: basic-functions.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:24 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.12 movitz/losp/muerte/basic-functions.lisp:1.13 --- movitz/losp/muerte/basic-functions.lisp:1.12 Sun Jul 11 16:03:18 2004 +++ movitz/losp/muerte/basic-functions.lisp Mon Jul 12 19:26:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.12 2004/07/11 23:03:18 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.13 2004/07/13 02:26:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -279,9 +279,10 @@ (3 (x y z) (with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:eax :ebx) x y) - ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values))) - (:compile-form (:result-mode :ecx) z) - ((:fs-override) :movl :ecx (:edi #.(movitz::global-constant-offset 'values))) + ((:fs-override) :movl #.movitz:+movitz-fixnum-factor+ + (:edi #.(movitz::global-constant-offset 'num-values))) + (:compile-form (:result-mode :edx) z) + ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values))) (:movl 3 :ecx) (:stc))) (t (&rest objects) @@ -298,18 +299,19 @@ (:jz 'done) (:subl 2 :ecx) (:jc 'copy-done) - ((:fs-override) :movl :ecx (:edi #.(movitz::global-constant-offset 'num-values))) + (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :edx) + ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'num-values))) (:pushl :eax) (:xorl :eax :eax) copy-loop (:movl (:ebp (:ecx 4) 4) :edx) - ((:fs-override) :movl :edx (:edi (:eax 4) #.(movitz::global-constant-offset 'values))) - (:addl 1 :eax) + ((:fs-override) :movl :edx (:edi (:eax 1) #.(movitz::global-constant-offset 'values))) + (:addl 4 :eax) (:subl 1 :ecx) (:jnc 'copy-loop) + (:leal (:eax #.(cl:- movitz:+movitz-fixnum-factor+)) :ecx) (:popl :eax) - ((:fs-override) :movl (:edi #.(movitz::global-constant-offset 'num-values)) - :ecx) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) copy-done (:addl 2 :ecx) (:jnz 'done) @@ -333,7 +335,7 @@ (define-compiler-macro object-location (object) "The location is the object's address divided by fixnum-factor." - `(with-inline-assembly (:returns :register) + `(with-inline-assembly (:returns :register :type fixnum) (:compile-form (:result-mode :register) ,object) (:andl ,(* -2 movitz::+movitz-fixnum-factor+) (:result-register))))

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 13 Jul '04

13 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9952 Modified Files: storage-types.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:19 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.27 movitz/storage-types.lisp:1.28 --- movitz/storage-types.lisp:1.27 Mon Jul 12 04:09:12 2004 +++ movitz/storage-types.lisp Mon Jul 12 19:26:19 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.27 2004/07/12 11:09:12 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.28 2004/07/13 02:26:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -891,10 +891,12 @@ :initform 0 :accessor movitz-funobj-num-jumpers :map-binary-write (lambda (x &optional type) - (declare (ignore typE)) - (* x +movitz-fixnum-factor+)) + (declare (ignore type)) + (check-type x (unsigned-byte 14)) + (* x +movitz-fixnum-factor+)) :map-binary-read (lambda (x &optional type) - (declare (ignore typE)) + (declare (ignore type)) + (assert (zerop (ldb (byte 2 0) x))) (/ x +movitz-fixnum-factor+))) (num-constants :binary-type lu16

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7730 Modified Files: special-operators.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:14 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.25 movitz/special-operators.lisp:1.26 --- movitz/special-operators.lisp:1.25 Sat Jul 10 06:29:18 2004 +++ movitz/special-operators.lisp Mon Jul 12 19:26:14 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.25 2004/07/10 13:29:18 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.26 2004/07/13 02:26:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -906,7 +906,8 @@ (* 4 i)))))) cloaked-code (when (<= 3 num-values) - `((:locally (:movl ,(- num-values 2) + `((:locally (:movl ,(* +movitz-fixnum-factor+ + (- num-values 2)) (:edi (:edi-offset num-values)))))) (loop for i downfrom (- num-values 2 1) to 0 collect @@ -1224,9 +1225,10 @@ (loop for i from (- (length sub-forms) 3) downto 0 collecting `(:locally (:popl (:edi (:edi-offset values ,(* i 4)))))) - (make-immediate-move (- (length sub-forms) 2) :ecx) - `((:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:addl 2 :ecx) + (make-immediate-move (length sub-forms) :ecx) + `((:leal ((:ecx ,+movitz-fixnum-factor+) ,(* -2 +movitz-fixnum-factor+)) + :edx) + (:locally (:movl :edx (:edi (:edi-offset num-values)))) (:stc)) #+ignore (make-compiled-funcall-by-symbol 'muerte.cl::values

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 13 Jul '04

13 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24418 Modified Files: image.lisp Log Message: Re-arranged the run-time-context structure somewhat so as to keep non-pointer slots in one place, and mark the out as such. Date: Mon Jul 12 19:24:36 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.44 movitz/image.lisp:1.45 --- movitz/image.lisp:1.44 Fri Jul 9 09:12:10 2004 +++ movitz/image.lisp Mon Jul 12 19:24:36 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.44 2004/07/09 16:12:10 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.45 2004/07/13 02:24:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -296,7 +296,7 @@ :map-binary-read-delayed 'movitz-word :map-binary-write 'movitz-intern) (num-values - :binary-type lu32 + :binary-type word ; Fixnum :initform 0) (values :binary-type #.(* 4 +movitz-multiple-values-limit+)) @@ -393,6 +393,14 @@ :initform nil :map-binary-write 'movitz-read-and-intern :map-binary-read-delayed 'movitz-word) + (protect-non-pointer-area + :binary-type lu32 + :initform 3) + (protect-non-pointer-count + :binary-type lu32 + :initform (* 4 (- (bt:slot-offset 'movitz-constant-block 'non-pointers-end) + (bt:slot-offset 'movitz-constant-block 'non-pointers-start)))) + (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= ;; (align-segment-descriptors :binary-type 4) (segment-descriptor-table :binary-type :label) (segment-descriptor-0 @@ -430,6 +438,15 @@ (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) + (bochs-flags + :binary-type lu32 + :initform 0) + (scratch0 ; A non-GC-root scratch register + :binary-type lu32 + :initform 0) + + (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= + (atomically-status :binary-type (define-bitfield atomically-status (lu32) (((:enum :byte (3 2)) @@ -455,13 +472,7 @@ :initform nil :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (bochs-flags - :binary-type lu32 - :initform 0) - (scratch0 ; A non-GC-root scratch register - :binary-type lu32 - :initform 0)) + :binary-tag :primitive-function)) (:slot-align null-cons -1)) (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24800 Modified Files: inspect.lisp Log Message: Fixed nasty bug in copy-bignum, which would cause GC corruption. Date: Mon Jul 12 19:21:08 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.17 movitz/losp/muerte/inspect.lisp:1.18 --- movitz/losp/muerte/inspect.lisp:1.17 Mon Jul 12 04:09:18 2004 +++ movitz/losp/muerte/inspect.lisp Mon Jul 12 19:21:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.17 2004/07/12 11:09:18 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.18 2004/07/13 02:21:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -199,10 +199,16 @@ (:compile-form (:result-mode :ebx) clumps) (:shll 1 :ebx) (:globally (:call (:edi (:edi-offset malloc)))) - (:addl #.(movitz::tag :other) :eax)))) - (dotimes (i clumps) - (setf (memref x -6 (* i 2) :lisp) nil - (memref x -2 (* i 2) :lisp) nil)) + (:addl #.(movitz::tag :other) :eax) + (:xorl :ecx :ecx) + reset-loop + (:movl :edi (:eax :ecx -6)) + (:addl 4 :ecx) + (:cmpl :ecx :ebx) + (:jae 'reset-loop)))) + #+ignore + (dotimes (i (* 2 clumps)) + (setf (memref x -6 i :lisp) nil)) x)) (defun malloc-data-clumps (clumps) @@ -308,16 +314,16 @@ (defun copy-bignum (old) (check-type old bignum) - (let* ((length (1+ (%bignum-bigits old))) + (let* ((length (%bignum-bigits old)) (new (malloc-data-words length))) (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) new old) (:compile-form (:result-mode :edx) length) copy-bignum-loop - (:subl #.movitz:+movitz-fixnum-factor+ :edx) (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx) (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) - (:jnz 'copy-bignum-loop)))) + (:subl #.movitz:+movitz-fixnum-factor+ :edx) + (:jnc 'copy-bignum-loop)))) (defun print-bignum (x) (check-type x bignum)

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20193 Modified Files: integers.lisp Log Message: Added a slow but working implementation of bignum multiplication. Date: Mon Jul 12 07:17:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.46 movitz/losp/muerte/integers.lisp:1.47 --- movitz/losp/muerte/integers.lisp:1.46 Mon Jul 12 06:43:43 2004 +++ movitz/losp/muerte/integers.lisp Mon Jul 12 07:17:14 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.46 2004/07/12 13:43:43 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.47 2004/07/12 14:17:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1114,12 +1114,7 @@ (0 `(progn ,factor2 0)) (1 factor2) (2 `(ash ,factor2 1)) - (t `(with-inline-assembly (:returns :eax :type integer) - (:compile-form (:result-mode :eax) ,factor2) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:imull ,f1 :eax :eax) - (:into)))))) + (t `(no-macro-call * ,factor1 ,factor2))))) (t `(no-macro-call * ,factor1 ,factor2))))) (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands))))) @@ -1271,6 +1266,12 @@ (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) positive-result ))) + ((positive-bignum positive-bignum) + (do ((f y) + (r 0)) + ((typep f 'fixnum) (+ r (* f x))) + (setf r (+ r (* most-positive-fixnum x))) + (setf f (- f most-positive-fixnum)))) ))) (do-it))) (t (&rest factors)

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32252 Modified Files: integers.lisp Log Message: More bignum tweaks. Date: Mon Jul 12 06:43:43 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.45 movitz/losp/muerte/integers.lisp:1.46 --- movitz/losp/muerte/integers.lisp:1.45 Mon Jul 12 04:09:23 2004 +++ movitz/losp/muerte/integers.lisp Mon Jul 12 06:43: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.45 2004/07/12 11:09:23 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.46 2004/07/12 13:43:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -192,6 +192,8 @@ (:edi (:edi-offset atomically-status)))) pfix-pbig-done)) + ((positive-bignum negative-fixnum) + (+ y x)) ((negative-fixnum positive-bignum) (with-inline-assembly (:returns :eax :labels (retry-not-size1 not-size1 @@ -256,31 +258,44 @@ (:edi (:edi-offset atomically-status)))) pfix-pbig-done)) - #+ignore ((positive-bignum positive-bignum) (if (< (%bignum-bigits y) (%bignum-bigits x)) (+ y x) ;; Assume x is smallest. - (with-inline-assembly (:returns :eax :labels (retry-copy + (with-inline-assembly (:returns :eax :labels (retry-not-size1 + not-size1 + term-zero copy-bignum-loop add-bignum-loop add-bignum-done no-expansion pfix-pbig-done)) - retry-copy + (:compile-two-forms (:eax :ebx) y x) + (:testl :ebx :ebx) + (:jz 'pfix-pbig-done) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) + (:jne 'not-size1) + (:movl (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) + (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) + (:jc 'retry-not-size1) + (:call-global-constant box-u32-ecx) + (:jmp 'pfix-pbig-done) + retry-not-size1 (:compile-form (:result-mode :eax) y) (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:declare-label-set retry-jumper (retry-copy)) + not-size1 + (:declare-label-set retry-jumper (retry-not-size1)) (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) 'retry-jumper) (:edi (:edi-offset atomically-status)))) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 2 movitz:+movitz-fixnum-factor+)) + (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+)) :eax) ; Number of words (:call-global-constant get-cons-pointer) (:load-lexical (:lexical-binding y) :ebx) ; bignum (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) :edx) (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB copy-bignum-loop @@ -288,31 +303,46 @@ (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx) (:movl :ecx (:eax :edx ,movitz:+other-type-offset+)) (:jnz 'copy-bignum-loop) - ;; We now have a copy of Y in EAX. - (:load-lexical (:lexical-binding x) :ebx) - (:xorl :ebx :ebx) - (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jnc 'add-bignum-done) + (:load-lexical (:lexical-binding x) :ebx) + (:xorl :edx :edx) ; counter + (:xorl :ecx :ecx) ; Carry add-bignum-loop - (:addl 4 :ebx) - (:addl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jc 'add-bignum-loop) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jbe '(:sub-program (zero-padding-loop) + (:addl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum + 'movitz::bigit0))) + (:sbbl :ecx :ecx) + (:negl :ecx) ; ECX = Add's Carry. + (:addl 4 :edx) + (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jae 'zero-padding-loop) + (: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))) + (:sbbl :ecx :ecx) + (:negl :ecx) ; ECX = Add's Carry. + (:addl 4 :edx) + (:cmpw :dx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jae 'add-bignum-loop) add-bignum-done (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) :ecx) (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) (:je 'no-expansion) - (:addl #x10000 (:eax ,movitz:+other-type-offset+)) + (:addl #x40000 (:eax ,movitz:+other-type-offset+)) (:addl ,movitz:+movitz-fixnum-factor+ :ecx) no-expansion (:call-global-constant cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) - pfix-pbig-done))) + pfix-pbig-done) + )) ))) (do-it))) (t (&rest terms) @@ -1251,43 +1281,6 @@ ;;; Division -(define-compiler-macro truncate (&whole form number &optional (divisor 1)) - `(do-result-mode-case () - (:plural - (no-macro-call ,@form)) - (t (truncate%1ret ,number ,divisor)))) - -(defun truncate%1ret (number divisor) - (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :eax) number) - (:compile-form (:result-mode :ebx) divisor) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) (:int 107))) - (:cdq :eax :edx) - (:idivl :ebx :eax :edx) - (:shll #.movitz::+movitz-fixnum-shift+ :eax) - (:clc))) - -(define-compiler-macro truncate%1ret (&whole form &environment env number divisor) - (cond - ((movitz:movitz-constantp divisor env) - (let ((d (movitz:movitz-eval divisor env))) - (check-type d number) - (case d - (0 (error "Truncate by zero.")) - (1 number) - (t `(with-inline-assembly (:returns :eax :type fixnum) - (:compile-form (:result-mode :eax) ,number) - (:compile-form (:result-mode :ebx) ,divisor) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 66))) - (:cdq :eax :edx) - (:idivl :ebx :eax :edx) - (:shll #.movitz::+movitz-fixnum-shift+ :eax)))))) - (t form))) - (defun truncate (number &optional (divisor 1)) (numargs-case (1 (number) @@ -1404,6 +1397,11 @@ (:movl 2 :ecx) (:stc))))) (do-it))) + ((positive-bignum positive-bignum) + (cond + ((= number divisor) (values 1 0)) + ((< number divisor) (values 0 number)) + (t (error "Don't know how to divide ~S with ~S." number divisor)))) )))) (defun / (number &rest denominators) @@ -1500,27 +1498,33 @@ (rem bytespec #x400)) (defun logbitp (index integer) - (check-type integer fixnum) - (with-inline-assembly (:returns :boolean-cf=1) - (:compile-two-forms (:eax :ebx) index integer) - (:testl #x80000003 :eax) - (:jnz '(:sub-program () - (:int 66))) - (:movl :eax :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl #.movitz::+movitz-fixnum-shift+ :ecx) - (:btl :ecx :ebx))) + (check-type index positive-fixnum) + (macrolet + ((do-it () + `(etypecase integer + (fixnum + (with-inline-assembly (:returns :boolean-cf=1) + (:compile-two-forms (:ecx :ebx) index integer) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:addl ,movitz::+movitz-fixnum-shift+ :ecx) + (:btl :ecx :ebx))) + (positive-bignum + (with-inline-assembly (:returns :boolean-cf=1) + (:compile-two-forms (:ecx :ebx) index integer) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))))))) + (do-it))) -(define-compiler-macro logbitp (&whole form index integer &environment env) - (if (not (movitz:movitz-constantp index env)) - form - (let ((index (movitz::movitz-eval index env))) - (check-type index (integer 0 30)) - `(with-inline-assembly (:returns :boolean-cf=1) - (:compile-form (:result-mode :eax) ,integer) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax))))) +;;;(define-compiler-macro logbitp (&whole form index integer &environment env) +;;; (if (not (movitz:movitz-constantp index env)) +;;; form +;;; (let ((index (movitz::movitz-eval index env))) +;;; (check-type index (integer 0 30)) +;;; `(with-inline-assembly (:returns :boolean-cf=1) +;;; (:compile-form (:result-mode :eax) ,integer) +;;; (:testb #.movitz::+movitz-fixnum-zmask+ :al) +;;; (:jnz '(:sub-program () (:int 107))) +;;; (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax))))) ;;;(defun logand%2op (x y)

1 0