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

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15296 Modified Files: basic-functions.lisp Log Message: Added operator object-tag. Date: Sun Jul 11 16:03:18 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.11 movitz/losp/muerte/basic-functions.lisp:1.12 --- movitz/losp/muerte/basic-functions.lisp:1.11 Fri Apr 16 12:25:06 2004 +++ movitz/losp/muerte/basic-functions.lisp Sun Jul 11 16:03:18 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.11 2004/04/16 19:25:06 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.12 2004/07/11 23:03:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -340,6 +340,16 @@ (defun object-location (object) "The location is the object's address divided by fixnum-factor." (object-location object)) + +(define-compiler-macro object-tag (object) + `(with-inline-assembly (:returns :register :type (integer 0 7)) + (:compile-form (:result-mode :register) ,object) + (:leal (((:result-register) ,movitz::+movitz-fixnum-factor+)) + (:result-register)) + (:andl ,(* 7 movitz::+movitz-fixnum-factor+) (:result-register)))) + +(defun object-tag (object) + (object-tag object)) ;;;(define-compiler-macro object-location-offset (object) ;;; "The offset from the object's location to it's true address."

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12742 Modified Files: arrays.lisp Log Message: Fixed a nasty bug in (setf aref) for u32 vectors. Date: Sun Jul 11 16:02:33 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.34 movitz/losp/muerte/arrays.lisp:1.35 --- movitz/losp/muerte/arrays.lisp:1.34 Thu Jul 8 14:51:48 2004 +++ movitz/losp/muerte/arrays.lisp Sun Jul 11 16:02:33 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.34 2004/07/08 21:51:48 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.35 2004/07/11 23:02:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -337,7 +337,7 @@ (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx) (:jne 'not-u32-vector) (:call-global-constant unbox-u32) - (:movl :eax + (:movl :ecx (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) (:jmp 'return) @@ -628,7 +628,7 @@ (setf (fill-pointer array) length))) (cond (initial-element - (check-type initial-element (unsigned-byte 8)) + (check-type initial-element bit) (dotimes (i length) (setf (aref array i) initial-element))) (initial-contents

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1759 Modified Files: memref.lisp Log Message: Fixed (setf memref) for type :unsigned-byte32, which was completely bogus before. Date: Sun Jul 11 16:00:41 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.14 movitz/losp/muerte/memref.lisp:1.15 --- movitz/losp/muerte/memref.lisp:1.14 Sun Jun 6 04:32:09 2004 +++ movitz/losp/muerte/memref.lisp Sun Jul 11 16:00:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.14 2004/06/06 11:32:09 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.15 2004/07/11 23:00:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -326,12 +326,16 @@ (:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value))) ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ebx :eax) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:call-global-constant unbox-u32) + (:compile-two-forms (:ebx :eax) ,object-var ,index-var) (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) (t (let ((value-var (gensym "memref-value-")) (object-var (gensym "memref-object-")) @@ -342,14 +346,16 @@ (,object-var ,object) (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:edx :untagged-fixnum-ecx) ,index-var ,offset-var) - (:addl :edx :ecx) ; offset+index in ECX - (:compile-two-forms (:eax :ebx) ,value-var ,object-var) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:call-global-constant unbox-u32) + (:compile-two-forms (:eax :edx) ,index-var ,offset-var) + (:load-lexical (:lexical-binding ,object-var) :ebx) (:std) - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) - (:movl :eax (:ebx :ecx)) - (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:addl :eax :edx) ; EDX = offset+index + (:movl :ecx (:ebx :edx)) + (:movl :edi :edx) (:cld))))))) (:unsigned-byte16 (cond

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8619 Modified Files: packages.lisp Log Message: More symbols. Date: Sun Jul 11 15:59:26 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.29 movitz/packages.lisp:1.30 --- movitz/packages.lisp:1.29 Thu Jul 8 11:53:29 2004 +++ movitz/packages.lisp Sun Jul 11 15:59:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.29 2004/07/08 18:53:29 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.30 2004/07/11 22:59:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1101,6 +1101,7 @@ print-word fixnump below print-unreadable-movitz-object + #:newline #:*print-safely* @@ -1159,6 +1160,7 @@ svref%unsafe bvref-u16 object-location + object-tag location-in-object-p inline-malloc define-compile-time-variable

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30272 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug. Function arguments located on the argument-stack would not be treated properly, e.g when copying one such variable to another. Date: Sun Jul 11 15:58:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.72 movitz/compiler.lisp:1.73 --- movitz/compiler.lisp:1.72 Sat Jul 10 06:29:11 2004 +++ movitz/compiler.lisp Sun Jul 11 15:58:56 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.72 2004/07/10 13:29:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.73 2004/07/11 22:58:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2399,7 +2399,10 @@ (list new-value) `(let ((,(car stores) (progn (assert (not (new-binding-located-p ,binding-var ,getter))) - (check-type ,new-value (or keyword binding (integer 0 *))) + (check-type ,new-value (or keyword + binding + (integer 0 *) + (cons (eql :argument-stack) *))) (acons ,binding-var ,new-value ,getter)))) ,setter ,new-value) @@ -2813,7 +2816,7 @@ (plusp (or (car (gethash binding var-counts)) 0))) (prog1 nil ; may need lending-cons (setf (new-binding-location binding frame-map) - :argument-stack))) + `(:argument-stack ,(function-argument-argnum binding))))) ((not (plusp (or (car (gethash binding var-counts)) 0))) (prog1 t (unless (or (movitz-env-get variable 'ignore nil env nil) @@ -2949,7 +2952,7 @@ (borrowed-binding) ; location is predetermined (fixed-required-function-argument (setf (new-binding-location binding frame-map) - :argument-stack)) + `(:argument-stack ,(function-argument-argnum binding)))) (located-binding (setf (new-binding-location binding frame-map) (post-incf stack-frame-position)))))) @@ -3228,7 +3231,7 @@ (when indirect-p `((:movl (-1 ,(single-value-register result-mode)) ,(single-value-register result-mode)))))) - (t (ecase lexb-location + (t (ecase (operator lexb-location) (:push (assert (member result-mode '(:eax :ebx :ecx :edx))) (assert (not indirect-p)) @@ -3324,7 +3327,7 @@ (if (integerp binding-location) `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax) (:pushl (:eax -1))) - (ecase binding-location + (ecase (operator binding-location) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3340,7 +3343,7 @@ (:push (if (integerp binding-location) `((:pushl (:ebp ,(stack-frame-offset binding-location)))) - (ecase binding-location + (ecase (operator binding-location) ((:eax :ebx :ecx :edx) `((:pushl ,binding-location))) (:argument-stack @@ -3351,7 +3354,7 @@ (if (integerp binding-location) `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:jne ',(operands result-mode))) - (ecase binding-location + (ecase (operator binding-location) ((:eax :ebx) `((:cmpl :edi ,binding-location) (:jne ',(operands result-mode)))) @@ -3362,7 +3365,7 @@ (if (integerp binding-location) `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:je ',(operands result-mode))) - (ecase binding-location + (ecase (operator binding-location) ((:eax :ebx) `((:cmpl :edi ,binding-location) (:je ',(operands result-mode)))) @@ -3378,7 +3381,7 @@ ((not dest-location) ; unknown, e.g. a borrowed-binding. (append (install-for-single-value binding binding-location :ecx nil) (make-store-lexical result-mode :ecx nil frame-map))) - ((eql binding-location dest-location) + ((equal binding-location dest-location) nil) ((member binding-location '(:eax :ebx :ecx :edx)) (make-store-lexical destination binding-location nil frame-map)) @@ -3435,7 +3438,7 @@ (if (integerp location) `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) (:movl ,source (,tmp-reg -1))) - (ecase location + (ecase (operator location) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () "store-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3444,7 +3447,7 @@ (t (let ((location (new-binding-location binding frame-map))) (if (integerp location) `((:movl ,source (:ebp ,(stack-frame-offset location)))) - (ecase location + (ecase (operator location) ((:push) `((:pushl ,source))) ((:eax :ebx :ecx :edx) @@ -4091,7 +4094,7 @@ (typecase binding (required-function-argument ;; (warn "lend: ~W => ~W" binding lended-cons-position) - (etypecase location + (etypecase (operator location) ((eql :eax) (warn "lending EAX..") `((:movl :edi @@ -4123,7 +4126,7 @@ (:ebp ,(stack-frame-offset location))))))) (closure-binding ;; (warn "lend closure-binding: ~W => ~W" binding lended-cons-position) - (etypecase location + (etypecase (operator location) ((eql :argument-stack) `((:movl (:edi ,(global-constant-offset 'unbound-function)) :edx) (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22849 Modified Files: sequences.lisp Log Message: Removed buggy implementation of replace between two u32 vectors. Date: Sun Jul 11 15:47:10 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.14 movitz/losp/muerte/sequences.lisp:1.15 --- movitz/losp/muerte/sequences.lisp:1.14 Thu Jul 8 04:30:36 2004 +++ movitz/losp/muerte/sequences.lisp Sun Jul 11 15:47:10 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.14 2004/07/08 11:30:36 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.15 2004/07/11 22:47:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -735,11 +735,6 @@ (memcopy sequence-1 sequence-2 2 start1 start2 (min (- end1 start1) (- end2 start2)) :unsigned-byte8)) - ((:u32 :u32) - (%copy-words (object-location sequence-1) - (object-location sequence-2) - (min (- end1 start1) (- end2 start2)) - start1 start2)) (t (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1) (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2) (cond

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4896 Modified Files: debugger.lisp Log Message: When filtering out conditions in safe-print-stack-frame-arglist, only catch serious-conditions. Date: Sun Jul 11 12:26:12 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.13 movitz/losp/x86-pc/debugger.lisp:1.14 --- movitz/losp/x86-pc/debugger.lisp:1.13 Thu Jun 10 09:28:27 2004 +++ movitz/losp/x86-pc/debugger.lisp Sun Jul 11 12:26:11 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.13 2004/06/10 16:28:27 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.14 2004/07/11 19:26:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -429,7 +429,7 @@ (defun safe-print-stack-frame-arglist (&rest args) (declare (dynamic-extent args)) (handler-case (apply #'print-stack-frame-arglist args) - (t (conditon) + (serious-condition (conditon) (write-string "#<error printing frame>")))) (defun backtrace (&key ((:frame initial-stack-frame)

1 0

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

10 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6574 Modified Files: integers.lisp Log Message: Implemented addition of negative fixnums and positive bignums. Date: Sat Jul 10 07:39:28 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.41 movitz/losp/muerte/integers.lisp:1.42 --- movitz/losp/muerte/integers.lisp:1.41 Sat Jul 10 06:29:23 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 10 07:39:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.41 2004/07/10 13:29:23 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.42 2004/07/10 14:39:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,9 @@ (deftype positive-bignum () `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) +(deftype negative-fixnum () + `(integer ,movitz:+movitz-most-negative-fixnum+ -1)) + (defmacro number-double-dispatch ((x y) &rest clauses) `(let ((x ,x) (y ,y)) (cond ,@(loop for ((x-type y-type) . then-body) in clauses @@ -123,7 +126,13 @@ ((positive-bignum positive-fixnum) (funcall '+ y x)) ((positive-fixnum positive-bignum) - (with-inline-assembly (:returns :eax) + (with-inline-assembly (:returns :eax :labels (retry-not-size1 + not-size1 + copy-bignum-loop + add-bignum-loop + add-bignum-done + no-expansion + pfix-pbig-done)) (:compile-two-forms (:eax :ebx) y x) (:testl :ebx :ebx) (:jz 'pfix-pbig-done) @@ -131,7 +140,7 @@ (:cmpl 1 :ecx) (:jne 'not-size1) (:compile-form (:result-mode :ecx) x) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) (:jc 'retry-not-size1) (:call-global-constant box-u32-ecx) @@ -160,7 +169,7 @@ (:jnz 'copy-bignum-loop) (:load-lexical (:lexical-binding x) :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:xorl :ebx :ebx) (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:jnc 'add-bignum-done) @@ -177,6 +186,70 @@ (:je 'no-expansion) (:addl #x10000 (: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)) + ((negative-fixnum positive-bignum) + (with-inline-assembly (:returns :eax :labels (retry-not-size1 + not-size1 + copy-bignum-loop + add-bignum-loop + add-bignum-done + no-expansion + pfix-pbig-done)) + (:compile-two-forms (:eax :ebx) y x) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:cmpl 1 :ecx) + (:jne 'not-size1) + (:compile-form (:result-mode :ecx) x) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) + (: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) + 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+) ,(* 1 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+) + :edx) + 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) + + (:load-lexical (:lexical-binding x) :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ebx :ebx) ; counter + (:negl :ecx) + (:subl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jnc 'add-bignum-done) + add-bignum-loop + (:addl 4 :ebx) + (:subl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc '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+) + :ecx) ; result bignum word-size + (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:jne 'no-expansion) + (:subl #x10000 (:eax ,movitz:+other-type-offset+)) + (:subl ,movitz:+movitz-fixnum-factor+ :ecx) no-expansion (:call-global-constant cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)

1 0

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

10 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13312 Modified Files: integers.lisp Log Message: Re-working the compilation of addition. Now use a proper extended-code instruction (which is like a "vop", I think). Date: Sat Jul 10 06:29:23 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.40 movitz/losp/muerte/integers.lisp:1.41 --- movitz/losp/muerte/integers.lisp:1.40 Thu Jul 8 14:51:08 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 10 06:29:23 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.40 2004/07/08 21:51:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.41 2004/07/10 13:29:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -71,7 +71,10 @@ (case (length operands) (0 0) (1 (first operands)) - (2 `(+%2op ,(first operands) ,(second operands))) + #+ignore (2 `(+%2op ,(first operands) ,(second operands))) + (2 `(let ((x ,(first operands)) + (y ,(second operands))) + (++%2op x y))) (t (let ((operands (loop for operand in operands if (movitz:movitz-constantp operand env) @@ -1975,8 +1978,9 @@ (movitz:movitz-eval integer env))) ; constant folding ((and (movitz:movitz-constantp size env) (movitz:movitz-constantp position env)) - (let ((size (movitz:movitz-eval size env)) - (position (movitz:movitz-eval position env))) + (let* ((size (movitz:movitz-eval size env)) + (position (movitz:movitz-eval position env)) + (result-type `(unsigned-byte ,size))) (cond ((or (minusp size) (minusp position)) (error "Negative byte-spec for ldb.")) @@ -1984,7 +1988,7 @@ `(progn ,integer 0)) ((<= (+ size position) (- 31 movitz:+movitz-fixnum-shift+)) `(with-inline-assembly (:returns :register - :type (integer 0 ,(mask-field (byte size 0) -1))) + :type ,result-type) (:compile-form (:result-mode :eax) ,integer) (:call-global-constant unbox-u32) (:andl ,(mask-field (byte size position) -1) :ecx) @@ -1992,7 +1996,7 @@ `((:shrl ,position :ecx))) (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) (:result-register)))) ((<= (+ size position) 32) - `(with-inline-assembly-case () + `(with-inline-assembly-case (:type ,result-type) (do-case (t :eax :labels (nix done)) (:compile-form (:result-mode :eax) ,integer) ,@(cond

1 0

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

10 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13088 Modified Files: special-operators.lisp Log Message: Re-working the compilation of addition. Now use a proper extended-code instruction (which is like a "vop", I think). Date: Sat Jul 10 06:29:18 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.24 movitz/special-operators.lisp:1.25 --- movitz/special-operators.lisp:1.24 Fri Jul 9 09:12:44 2004 +++ movitz/special-operators.lisp Sat Jul 10 06:29:18 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.24 2004/07/09 16:12:44 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.25 2004/07/10 13:29:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1000,6 +1000,18 @@ :forward all :env local-env :form sub-form))) + +(define-special-operator muerte::++%2op (&all all &form form &env env &result-mode result-mode) + (destructuring-bind (term1 term2) + (cdr form) + (let ((returns (ecase (result-mode-type result-mode) + ((:function :multiple-values :eax :push) :eax) + ((:ebx :ecx :edx) result-mode) + ((:lexical-binding) result-mode)))) + (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)) ()

1 0