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

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27230 Modified Files: integers.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 18:38:10 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.11 movitz/losp/muerte/integers.lisp:1.12 --- movitz/losp/muerte/integers.lisp:1.11 Mon May 24 10:58:51 2004 +++ movitz/losp/muerte/integers.lisp Mon May 24 18:38:03 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.11 2004/05/24 14:58:51 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.12 2004/05/24 22:38:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -807,7 +807,7 @@ (:movl :edi :eax) (:cld) (:pushl :edx) - (:call-global-constant normalize-u32-ecx) + (:call-global-constant box-u32-ecx) (:popl :ebx) (:jmp 'done) not-size1 @@ -827,7 +827,7 @@ (:movl :edi :eax) (:cld) (:pushl :edx) - (:call-global-constant normalize-u32-ecx) + (:call-global-constant box-u32-ecx) (:popl :ebx) (:jmp 'done) not-size2

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28476 Modified Files: arrays.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 17:51:52 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.21 movitz/losp/muerte/arrays.lisp:1.22 --- movitz/losp/muerte/arrays.lisp:1.21 Mon May 24 10:59:15 2004 +++ movitz/losp/muerte/arrays.lisp Mon May 24 17:51:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.21 2004/05/24 14:59:15 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.22 2004/05/24 21:51:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,10 +240,7 @@ (:cmpl ,(movitz:vector-type-tag :u32) :ecx) (:jne 'not-u32) (:movl (:eax (:ebx 4) 2) :ecx) ; u32 - (:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program (:overflowing-u32) - (:int 107))) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:call-global-constant box-u32-ecx) (:jmp 'done) not-u32 @@ -329,15 +326,13 @@ not-u16 (:cmpl ,(movitz:vector-type-tag :u32) :edx) (:jnz 'not-u32) - (:testl ,(ldb (byte 32 0) - (- -1 (* #xffffffff movitz:+movitz-fixnum-factor+))) - :ebx) - (:jnz '(:sub-program (not-u32-value) - (:compile-form (:result-mode :ignore) - (error "Value not (unsigned-byte 32): ~S" value)))) - (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) - (:movl :ebx (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) + ;; EBX=value, EAX=vector, ECX=index + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :edx) + (:xchgl :eax :ebx) + ;; EAX=value, EBX=vector, EDX=index + (:call-global-constant unbox-u32) + (:movl :ecx (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:movl :eax :ebx) (:jmp 'done) not-u32

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1344 Modified Files: primitive-functions.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:34:34 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.18 movitz/losp/muerte/primitive-functions.lisp:1.19 --- movitz/losp/muerte/primitive-functions.lisp:1.18 Mon May 24 10:58:56 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon May 24 15:34:34 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.18 2004/05/24 14:58:56 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.19 2004/05/24 19:34:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -505,8 +505,8 @@ (:ret))) -(define-primitive-function normalize-u32-ecx () - "Make u32 in ECX into a fixnum or bignum." +(define-primitive-function box-u32-ecx () + "Make u32 in ECX into a fixnum or bignum in EAX." (with-inline-assembly (:returns :multiple-values) (:cmpl #.movitz:+movitz-most-positive-fixnum+ :ecx) (:ja 'not-fixnum) @@ -514,6 +514,32 @@ (:ret) not-fixnum (:int 107))) ; not implemented by default! + +(define-primitive-function unbox-u32 () + "Coerce EAX into a u32 in ECX, or signal type error. +Preserve EAX, EBX, and EDX." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + (:testl ,(logior #x80000000 movitz:+movitz-fixnum-zmask+) + :eax) + (:jnz 'not-fixnum) + (:movl :eax :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:ret) + not-fixnum + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'fail) + (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) + (:eax ,movitz:+other-type-offset+)) + (:jne 'fail) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:ret) + fail + (:int 107)))) + (do-it))) ;;;;

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv15649 Modified Files: los0-gc.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:32:46 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.11 movitz/losp/los0-gc.lisp:1.12 --- movitz/losp/los0-gc.lisp:1.11 Mon May 24 10:58:34 2004 +++ movitz/losp/los0-gc.lisp Mon May 24 15:32:46 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.11 2004/05/24 14:58:34 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.12 2004/05/24 19:32:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,7 +72,7 @@ (:movl :ecx (:edx 2)) (:ret))) -(define-primitive-function los0-normalize-u32-ecx () +(define-primitive-function los0-box-u32-ecx () "Make u32 in ECX into a fixnum or bignum." (macrolet ((do-it () @@ -157,9 +157,9 @@ (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) conser)) - (let ((conser (symbol-value 'los0-normalize-u32-ecx))) + (let ((conser (symbol-value 'los0-box-u32-ecx))) (check-type conser vector) - (setf (%run-time-context-slot 'muerte::normalize-u32-ecx) + (setf (%run-time-context-slot 'muerte::box-u32-ecx) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10397 Modified Files: compiler.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:10:13 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.60 movitz/compiler.lisp:1.61 --- movitz/compiler.lisp:1.60 Mon May 24 10:58:00 2004 +++ movitz/compiler.lisp Mon May 24 15:10:12 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.60 2004/05/24 14:58:00 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.61 2004/05/24 19:10:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -4788,7 +4788,7 @@ (case (result-mode-type desired-result) ((:eax :single-value) (values (append code - `((:call (:edi ,(global-constant-offset 'normalize-u32-ecx))))) + `((:call (:edi ,(global-constant-offset 'box-u32-ecx))))) desired-result)) (t (make-result-and-returns-glue desired-result :eax (make-result-and-returns-glue :eax :untagged-fixnum-ecx code

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11810 Modified Files: image.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:05:59 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.30 movitz/image.lisp:1.31 --- movitz/image.lisp:1.30 Mon May 24 10:58:12 2004 +++ movitz/image.lisp Mon May 24 15:05:59 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.30 2004/05/24 14:58:12 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.31 2004/05/24 19:05:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -226,7 +226,12 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (normalize-u32-ecx + (box-u32-ecx + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (unbox-u32 :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3725 Modified Files: arrays.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:59:16 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.20 movitz/losp/muerte/arrays.lisp:1.21 --- movitz/losp/muerte/arrays.lisp:1.20 Fri May 21 05:41:58 2004 +++ movitz/losp/muerte/arrays.lisp Mon May 24 10:59:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.20 2004/05/21 09:41:58 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.21 2004/05/24 14:59:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -204,34 +204,34 @@ (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) (:movzxw (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) + (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) (:jae '(:sub-program () (:compile-form (:result-mode :ignore) (error "Index ~D out of bounds ~D." index (length vector))))) - (:cmpl #.(movitz:vector-type-tag :any-t) :ecx) + (:cmpl ,(movitz:vector-type-tag :any-t) :ecx) (:jne 'not-any-t) (:movl (:eax (:ebx 4) 2) :eax) (:jmp 'done) not-any-t - (:cmpl #.(movitz:vector-type-tag :character) :ecx) + (:cmpl ,(movitz:vector-type-tag :character) :ecx) (:jne 'not-character) (:movb (:eax :ebx 2) :bl) (:xorl :eax :eax) (:movb :bl :ah) - (:movb #.(movitz::tag :character) :al) ; character + (:movb ,(movitz::tag :character) :al) ; character (:jmp 'done) not-character - (:cmpl #.(movitz:vector-type-tag :u8) :ecx) + (:cmpl ,(movitz:vector-type-tag :u8) :ecx) (:jne 'not-u8) (:movzxb (:eax :ebx 2) :eax) ; u8 - (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:shll ,movitz::+movitz-fixnum-shift+ :eax) (:jmp 'done) not-u8 - (:cmpl #.(movitz:vector-type-tag :u16) :ecx) + (:cmpl ,(movitz:vector-type-tag :u16) :ecx) (:jne 'not-u16) (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 (:jmp 'done) @@ -265,7 +265,7 @@ (:compile-form (:result-mode :ebx) value) (:compile-form (:result-mode :eax) vector) - (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jnz '(:sub-program () (:compile-form (:result-mode :ignore) @@ -273,24 +273,24 @@ (:movzxw (:eax ,movitz:+other-type-offset+) :edx) (:compile-form (:result-mode :ecx) index) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) + (:testb ,movitz::+movitz-fixnum-zmask+ :cl) (:jnz '(:sub-program () (:int 107))) ; index not fixnum - (:andl #.(cl:ash #xffff movitz::+movitz-fixnum-shift+) :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) + (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx) + (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx) (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds - (:cmpl #.(movitz:vector-type-tag :any-t) :edx) + (:cmpl ,(movitz:vector-type-tag :any-t) :edx) (:jnz 'not-any-t) (:movl :ebx (:eax (:ecx 4) 2)) (:jmp 'done) not-any-t - (:cmpl #.(movitz:vector-type-tag :character) :edx) + (:cmpl ,(movitz:vector-type-tag :character) :edx) (:jnz 'not-character) - (:cmpb #.(movitz:tag :character) :bl) + (:cmpb ,(movitz:tag :character) :bl) (:jnz '(:sub-program (not-character-value) (:compile-form (:result-mode :ignore) (error "Value not character: ~S" value)))) @@ -298,40 +298,46 @@ (:jmp 'done) not-character - (:cmpl #.(movitz:vector-type-tag :u8) :edx) + (:cmpl ,(movitz:vector-type-tag :u8) :edx) (:jnz 'not-u8) - (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xff movitz:+movitz-fixnum-factor+))) :ebx) + (:testl ,(cl:ldb (cl:byte 32 0) + (- -1 (* #xff movitz:+movitz-fixnum-factor+))) + :ebx) (:jnz '(:sub-program (not-u8-value) (:compile-form (:result-mode :ignore) (error "Value not (unsigned-byte 8): ~S" value)))) - (:shrl #.movitz:+movitz-fixnum-shift+ :ebx) - (:movb :bl (:eax (:ecx 1) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movb :bl (:eax (:ecx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) (:jmp 'done) not-u8 - (:cmpl #.(movitz:vector-type-tag :u16) :edx) + (:cmpl ,(movitz:vector-type-tag :u16) :edx) (:jnz 'not-u16) - (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffff movitz:+movitz-fixnum-factor+))) :ebx) + (:testl ,(ldb (byte 32 0) + (- -1 (* #xffff movitz:+movitz-fixnum-factor+))) + :ebx) (:jnz '(:sub-program (not-u16-value) (:compile-form (:result-mode :ignore) (error "Value not (unsigned-byte 16): ~S" value)))) - (:shrl #.movitz:+movitz-fixnum-shift+ :ebx) - (:movw :bx (:eax (:ecx 2) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movw :bx (:eax (:ecx 2) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) (:jmp 'done) not-u16 - (:cmpl #.(movitz:vector-type-tag :u32) :edx) + (:cmpl ,(movitz:vector-type-tag :u32) :edx) (:jnz 'not-u32) - (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx) + (:testl ,(ldb (byte 32 0) + (- -1 (* #xffffffff movitz:+movitz-fixnum-factor+))) + :ebx) (:jnz '(:sub-program (not-u32-value) (:compile-form (:result-mode :ignore) (error "Value not (unsigned-byte 32): ~S" value)))) - (:shrl #.movitz:+movitz-fixnum-shift+ :ebx) - (:movl :ebx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movl :ebx (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) (:jmp 'done) not-u32

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3277 Modified Files: los-closette.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:59:08 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.10 movitz/losp/muerte/los-closette.lisp:1.11 --- movitz/losp/muerte/los-closette.lisp:1.10 Wed Apr 21 11:07:27 2004 +++ movitz/losp/muerte/los-closette.lisp Mon May 24 10:59:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.10 2004/04/21 15:07:27 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.11 2004/05/24 14:59:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -908,7 +908,7 @@ (assert slot (slot-name) "No slot named ~S in class ~S." slot-name class) (let ((slot-location (slot-definition-location slot))) - (check-type slot-location (integer 0 *)) + (check-type slot-location (integer 0 #xffff)) (etypecase class (standard-class (if (and (< slot-location (length *standard-effective-slot-readers*))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27543 Modified Files: typep.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:59:02 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.11 movitz/losp/muerte/typep.lisp:1.12 --- movitz/losp/muerte/typep.lisp:1.11 Mon Apr 19 15:51:01 2004 +++ movitz/losp/muerte/typep.lisp Mon May 24 10:59:01 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.11 2004/04/19 19:51:01 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.12 2004/05/24 14:59:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -170,10 +170,22 @@ ((t) 't) ((nil) 'nil) (null `(not ,object)) - ((fixnum integer number) + ((fixnum) `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,object) (:testb ,movitz::+movitz-fixnum-zmask+ :al))) + ((integer number rational) + `(with-inline-assembly-case () + (do-case (t :boolean-zf=1 :labels (done)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jz 'done) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'done) + (:cmpb ,(movitz:tag :bignum) + (:eax ,movitz:+other-type-offset+)) + done))) (symbol `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,object) @@ -246,17 +258,59 @@ ((integer) (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) (cdr type) - (let* ((min movitz:+movitz-most-negative-fixnum+) - (max movitz:+movitz-most-positive-fixnum+) - (lower-limit (if (eq lower-limit '*) min lower-limit)) - (upper-limit (if (eq upper-limit '*) max upper-limit))) - (assert (<= lower-limit upper-limit) () - "The lower limit of an integer type must be smaller than the upper limit.") + (let* ((lower-limit (if (eq lower-limit '*) nil lower-limit)) + (upper-limit (if (eq upper-limit '*) nil upper-limit))) + (assert (or (null lower-limit) + (null upper-limit) + (<= lower-limit upper-limit)) () + "The lower limit must be smaller than the upper limit.") + ;; (warn "upper: ~S, loweR: ~S" upper-limit lower-limit) (cond - ((and (= lower-limit min) (= upper-limit max)) + ((and (null lower-limit) (null upper-limit)) `(typep ,object 'integer)) + ((null lower-limit) + `(let ((x ,object)) + (and (typep x 'integer) (<= x upper-limit)))) + ((and (null upper-limit) + (= (1+ movitz:+movitz-most-positive-fixnum+) lower-limit)) + `(with-inline-assembly-case () + (do-case (t :boolean-zf=1 :labels (plusp-ok)) + (:compile-form (:result-mode :eax) ,object) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'plusp-ok) + (:cmpw ,(movitz:tag :bignum 0) + (:eax ,movitz:+other-type-offset+)) + plusp-ok))) + ((and (null upper-limit) (= 0 lower-limit)) + `(with-inline-assembly-case () + (do-case (t :boolean-zf=1 :labels (plusp-ok)) + (:compile-form (:result-mode :eax) ,object) + (:testl ,(logxor #xffffffff + (ash movitz:+movitz-most-positive-fixnum+ + movitz:+movitz-fixnum-shift+)) + :eax) + (:jz 'plusp-ok) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'plusp-ok) + (:cmpw ,(movitz:tag :bignum 0) + (:eax ,movitz:+other-type-offset+)) + plusp-ok))) + ((null upper-limit) + `(let ((x ,object)) + (and (typep x 'integer) (>= x ,lower-limit)))) ((= lower-limit upper-limit) `(eql ,object ,lower-limit)) + ((or (not (<= movitz:+movitz-most-negative-fixnum+ + upper-limit + movitz:+movitz-most-positive-fixnum+)) + (not (<= movitz:+movitz-most-negative-fixnum+ + lower-limit + movitz:+movitz-most-positive-fixnum+))) + `(let ((x ,object)) + (and (typep x 'integer) + (<= ,lower-limit x ,upper-limit)))) ((and (= lower-limit 0) (= 1 (logcount (1+ upper-limit)))) `(with-inline-assembly (:returns :boolean-zf=1)

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24737 Modified Files: primitive-functions.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:56 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.17 movitz/losp/muerte/primitive-functions.lisp:1.18 --- movitz/losp/muerte/primitive-functions.lisp:1.17 Fri May 21 05:41:11 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon May 24 10:58:56 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.17 2004/05/21 09:41:11 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.18 2004/05/24 14:58:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -441,8 +441,8 @@ (defun malloc-initialize (buffer-start buffer-size) "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units." - (check-type buffer-start integer) - (check-type buffer-size integer) + (check-type buffer-start fixnum) + (check-type buffer-size fixnum) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :eax) buffer-start) (:shll #.(cl:- 12 movitz::+movitz-fixnum-shift+) :eax) @@ -504,6 +504,17 @@ return-ok (:ret))) + +(define-primitive-function normalize-u32-ecx () + "Make u32 in ECX into a fixnum or bignum." + (with-inline-assembly (:returns :multiple-values) + (:cmpl #.movitz:+movitz-most-positive-fixnum+ :ecx) + (:ja 'not-fixnum) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) + (:ret) + not-fixnum + (:int 107))) ; not implemented by default! + ;;;; (define-primitive-function fast-class-of-even-fixnum () @@ -566,32 +577,42 @@ (:globally (:movl (:edi (:edi-offset classes)) :ebx)) (:cmpl :edi :eax) (:je 'null) - (:movl (:ebx #.(movitz::class-object-offset 'illegal-object)) :eax) + (:movl (:ebx #.(movitz:class-object-offset 'illegal-object)) :eax) (:jmp 'not-null) null - (:movl (:ebx #.(movitz::class-object-offset 'null)) :eax) + (:movl (:ebx #.(movitz:class-object-offset 'null)) :eax) not-null (:ret))) (define-primitive-function fast-class-of-other () "Return the class of an other object." - (with-inline-assembly (:returns :multiple-values) - (:movl (:eax #.movitz:+other-type-offset+) :ecx) - (:cmpb #.(movitz::tag :std-instance) :cl) - (:jne 'not-std-instance) - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) - (:ret) - not-std-instance - (:cmpw #.(cl:+ (movitz::tag :funobj) - (cl:ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8)) - :cx) - (:jne 'not-std-gf-instance) - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-funobj-standard-gf 'movitz::standard-gf-class)) - :eax) - (:ret) - not-std-gf-instance - (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) - (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :std-instance) :cl) + (:jne 'not-std-instance) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) + (:ret) + not-std-instance + (:cmpw ,(+ (movitz:tag :funobj) + (ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8)) + :cx) + (:jne 'not-std-gf-instance) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf + 'movitz::standard-gf-class)) + :eax) + (:ret) + not-std-gf-instance + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'not-bignum) + (:movl (:ebx ,(movitz:class-object-offset 'integer)) :eax) + (:ret) + not-bignum + (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) + (:jmp (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op)))))) + (do-it))) (defun complicated-class-of (object) (typecase object

1 0