movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

[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-serv23968 Modified Files: integers.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:51 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.10 movitz/losp/muerte/integers.lisp:1.11 --- movitz/losp/muerte/integers.lisp:1.10 Wed May 19 11:42:08 2004 +++ movitz/losp/muerte/integers.lisp Mon May 24 10:58:51 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.10 2004/05/19 15:42:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.11 2004/05/24 14:58:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,6 +22,12 @@ (defconstant most-positive-fixnum #.movitz::+movitz-most-positive-fixnum+) (defconstant most-negative-fixnum #.movitz::+movitz-most-negative-fixnum+) +(deftype positive-fixnum () + `(integer 0 ,movitz:+movitz-most-positive-fixnum+)) + +(deftype positive-bignum () + `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) + (defun fixnump (x) (typep x 'fixnum)) @@ -242,10 +248,26 @@ "Compare real <n1> with fixnum <n2>." (with-inline-assembly (:returns :nothing) ; unspecified (:testb #.movitz::+movitz-fixnum-zmask+ :al) + (:jnz 'not-fixnum) + (:cmpl :ebx :eax) + (:ret) + not-fixnum + (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) + (:testb 7 :cl) (:jnz '(:sub-program (not-integer) (:int 107) (:jmp 'not-integer))) - (:cmpl :ebx :eax) + (:movl (:eax #.movitz:+other-type-offset+) :ecx) + (:cmpw #.(movitz:tag :bignum 0) :cx) + (:jne 'not-plusbignum) + ;; compare ebx with something bigger + (:cmpl #x-10000000 :edi) + (:ret) + not-plusbignum + (:cmpw #.(movitz:tag :bignum #xff) :cx) + (:jne 'not-integer) + ;; compare ebx with something bigger + (:cmpl #x10000000 :edi) (:ret))) ;;; @@ -256,8 +278,8 @@ (movitz:movitz-constantp max env)) (let ((min (movitz:movitz-eval min env)) (max (movitz:movitz-eval max env))) - (check-type min integer) - (check-type max integer) + (check-type min fixnum) + (check-type max fixnum) ;; (warn "~D -- ~D" min max) (cond ((movitz:movitz-constantp x env) @@ -296,7 +318,7 @@ #+ignore ; this is buggy. ((movitz:movitz-constantp min env) (let ((min (movitz:movitz-eval min env))) - (check-type min integer) + (check-type min fixnum) (cond ((minusp min) `(let ((x ,x)) @@ -372,7 +394,7 @@ (declare (dynamic-extent more-numbers)) (cond ((null more-numbers) - (check-type number integer) + (check-type number fixnum) t) ((not (cdr more-numbers)) (,2op-name number (first more-numbers))) @@ -514,7 +536,7 @@ (if (< number1 number2) number2 number1)) (let ((label (gensym))) - `(with-inline-assembly (:returns :eax :type integer) + `(with-inline-assembly (:returns :eax :type fixnum) (:compile-two-forms (:eax :ebx) ,number1 ,number2) (:movl :ebx :ecx) (:orl :eax :ecx) @@ -650,7 +672,7 @@ `(*%2op ,(movitz:movitz-eval factor2 env) ,factor1)) ((movitz:movitz-constantp factor1 env) (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 integer) + (check-type f1 fixnum) (case f1 (0 `(progn ,factor2 0)) (1 factor2) @@ -708,9 +730,9 @@ `(do-result-mode-case () (:plural (no-macro-call ,@form)) - (t (truncate%2ops%1ret ,number ,divisor)))) + (t (truncate%1ret ,number ,divisor)))) -(defun truncate%2ops%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) @@ -723,7 +745,7 @@ (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:clc))) -(define-compiler-macro truncate%2ops%1ret (&whole form &environment env number divisor) +(define-compiler-macro truncate%1ret (&whole form &environment env number divisor) (cond ((movitz:movitz-constantp divisor env) (let ((d (movitz:movitz-eval divisor env))) @@ -731,7 +753,7 @@ (case d (0 (error "Truncate by zero.")) (1 number) - (t `(with-inline-assembly (:returns :eax :type integer) + (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) @@ -741,26 +763,116 @@ (:shll #.movitz::+movitz-fixnum-shift+ :eax)))))) (t form))) +(defmacro number-double-dispatch ((x y) &rest clauses) + `(let ((x ,x) (y ,y)) + (cond ,@(loop for ((x-type y-type) . then-body) in clauses + collect `((and (typep x ',x-type) (typep y ',y-type)) + ,@then-body)) + (t (error "Not numbers: ~S or ~S." x y))))) + (defun truncate (number &optional (divisor 1)) (numargs-case (1 (number) (values number 0)) (t (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) - (:movl :edx :ebx) - (:xorl :ecx :ecx) - (:movb 2 :cl) ; return values: qutient, remainder. - (:stc))))) - + (number-double-dispatch (number divisor) + ((fixnum fixnum) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :eax) number) + (:compile-form (:result-mode :ebx) divisor) + (:std) + (:cdq :eax :edx) + (:idivl :ebx :eax :edx) + (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:cld) + (:movl :edx :ebx) + (:xorl :ecx :ecx) + (:movb 2 :cl) ; return values: qutient, remainder. + (:stc))) + ((positive-bignum positive-fixnum) + (let (r n) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :ebx) number) + (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:cmpl 1 :ecx) + (:jne 'not-size1) + (:compile-form (:result-mode :ecx) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (:xorl :edx :edx) + (:divl :ecx :eax :edx) + (:movl :eax :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :edx) + (:movl :edi :eax) + (:cld) + (:pushl :edx) + (:call-global-constant normalize-u32-ecx) + (:popl :ebx) + (:jmp 'done) + not-size1 + (:cmpl 2 :ecx) + (:jne 'not-size2) + (:compile-form (:result-mode :ecx) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:movl (:ebx #.(cl:+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + :edx) + (:cmpl :ecx :edx) + (:jae 'not-size2) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (:divl :ecx :eax :edx) + (:movl :eax :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :edx) + (:movl :edi :eax) + (:cld) + (:pushl :edx) + (:call-global-constant normalize-u32-ecx) + (:popl :ebx) + (:jmp 'done) + not-size2 + (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4))) + (:jc 'shrink-not-size2) + not-shrink + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) + (:compile-form (:result-mode :eax) + (malloc-words (with-inline-assembly (:returns :eax)))) + (:store-lexical (:lexical-binding r) :eax :type t) + (:compile-form (:result-mode :ebx) number) + (:movl (:ebx #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax #.movitz:+other-type-offset+)) + (:shrl 16 :ecx) + + (:xorl :edx :edx) ; edx=hi-digit=0 + ; eax=lo-digit=msd(number) + (:std) + (:compile-form (:result-mode :esi) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :esi) + + divide-loop + (:load-lexical (:lexical-binding number) :ebx) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4)) + :eax) + (:divl :esi :eax :edx) + (:load-lexical (:lexical-binding r) :ebx) + (:movl :eax (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4))) + (:subl 1 :ecx) + (:jnz 'divide-loop) + (:movl :ebx :eax) + (:leal ((:edx #.movitz:+movitz-fixnum-factor+)) :ebx) + (:movl :edi :edx) + (:movl (:ebp -4) :esi) + (:cld) + (:jmp 'done) + shrink-not-size2 + (:int 107) + done + (:movl 2 :ecx) + (:stc)))) + )))) (defun round (number &optional (divisor 1)) "Mathematical rounding." @@ -1147,4 +1259,4 @@ (values q 0)) (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) - (floor n divisor)))) \ No newline at end of file + (floor n divisor))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.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-serv23769 Modified Files: print.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:44 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.8 movitz/losp/muerte/print.lisp:1.9 --- movitz/losp/muerte/print.lisp:1.8 Wed Apr 21 11:07:48 2004 +++ movitz/losp/muerte/print.lisp Mon May 24 10:58:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.8 2004/04/21 15:07:48 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.9 2004/05/24 14:58:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -83,7 +83,8 @@ (write-digit (rem x base) stream)))) (defun write-lowlevel-integer (x stream base comma-char comma-interval mincol padchar sign-char pos) - (let ((bigit (truncate x base))) + (multiple-value-bind (bigit rem) + (truncate x base) (cond ((zerop bigit) (when mincol @@ -94,8 +95,8 @@ (when sign-char (write-char sign-char stream))) (t (write-lowlevel-integer bigit stream base comma-char comma-interval - mincol padchar sign-char (1+ pos))))) - (write-digit (rem x base) stream) + mincol padchar sign-char (1+ pos)))) + (write-digit rem stream)) (when (and comma-interval (plusp pos) (zerop (rem pos comma-interval))) (write-char comma-char stream)) nil) @@ -239,7 +240,8 @@ (if (and (plusp (length name)) (every (lambda (c) (or (upper-case-p c) - (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) + (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& + #\/ #\< #\> #\=)) (digit-char-p c))) name) (not (every (lambda (c)

1 0

[movitz-cvs] CVS update: movitz/losp/los0.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-serv23601 Modified Files: los0.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:39 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.13 movitz/losp/los0.lisp:1.14 --- movitz/losp/los0.lisp:1.13 Fri Apr 23 11:04:07 2004 +++ movitz/losp/los0.lisp Mon May 24 10:58:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.13 2004/04/23 15:04:07 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.14 2004/05/24 14:58:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -262,6 +262,24 @@ exit (warn "exited: ~S" c))) + +(defun test-bignum () + 123456789123456) + +(defun ff32 () + #xffffffff) + +(defun one32 () + #x100000000) + +(defun test-nbignum () + -123456789123456) + +(defun gt5 (x) + (<= x 5)) + +(defun xplus (x) + (typep x '(integer 0 *))) (defstruct xxx x y (z 'init-z))

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-serv23392 Modified Files: los0-gc.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:35 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.10 movitz/losp/los0-gc.lisp:1.11 --- movitz/losp/los0-gc.lisp:1.10 Fri Apr 16 10:44:42 2004 +++ movitz/losp/los0-gc.lisp Mon May 24 10:58:34 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.10 2004/04/16 14:44:42 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.11 2004/05/24 14:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,6 +72,33 @@ (:movl :ecx (:edx 2)) (:ret))) +(define-primitive-function los0-normalize-u32-ecx () + "Make u32 in ECX into a fixnum or bignum." + (macrolet + ((do-it () + `(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 + retry-cons + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :eax) + (:cmpl #x3fff4 :eax) + (:jge '(:sub-program () + (:int 113) ; This interrupt can be retried. + (:jmp 'retry-cons))) + (:movl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) + (:edx :eax 2)) + (:movl :ecx (:edx :eax 6)) + (:addl 8 :eax) + (:movl :eax (:edx 2)) + (:leal (:edx :eax) :eax) + (:ret) + (:int 107)))) + (do-it))) + (defun los0-malloc-clumps (clumps) (check-type clumps (integer 0 4000)) (with-inline-assembly (:returns :eax) @@ -129,6 +156,10 @@ (let ((conser (symbol-value 'los0-fast-cons))) (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) + conser)) + (let ((conser (symbol-value 'los0-normalize-u32-ecx))) + (check-type conser vector) + (setf (%run-time-context-slot 'muerte::normalize-u32-ecx) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs