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

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

07 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10506 Modified Files: los-closette-compiler.lisp Log Message: Be a bit more defensive in slot-location. Date: Mon Jun 7 15:14:06 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.13 movitz/losp/muerte/los-closette-compiler.lisp:1.14 --- movitz/losp/muerte/los-closette-compiler.lisp:1.13 Wed May 19 08:02:50 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Jun 7 15:14:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.13 2004/05/19 15:02:50 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.14 2004/06/07 22:14:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -468,28 +468,37 @@ ;;; + (defvar *slot-location-nesting* 0) (defun slot-location (class slot-name) - (cond - ((and (eq slot-name 'effective-slots) - (eq class *the-class-standard-class*)) - (position 'effective-slots *the-slots-of-standard-class* - :key #'slot-definition-name)) - ((eq class (movitz-find-class 'standard-effective-slot-definition nil)) - (or (position slot-name '(name type initform initfunction initargs allocation location)) - (error "No slot ~S in ~S." slot-name (movitz-class-name class)))) - (t (let ((slot (find slot-name - (std-slot-value class 'effective-slots) - :key #'slot-definition-name))) - (if (null slot) - (error "Closette compiler: The slot ~S is missing from the class ~S." - slot-name class) - (let ((pos (position slot - (remove-if-not #'instance-slot-p - (std-slot-value class 'effective-slots))))) - (if (null pos) - (error "Closette compiler: The slot ~S is not an instance slot in the class ~S." - slot-name class) - pos))))))) + (when (< 10 *slot-location-nesting*) + (break "Unbounded slot-location?")) + (let ((*slot-location-nesting* (1+ *slot-location-nesting*))) + (cond + ((and (eq slot-name 'effective-slots) + (eq class *the-class-standard-class*)) + (position 'effective-slots *the-slots-of-standard-class* + :key #'slot-definition-name)) + ((eq class (movitz-find-class 'standard-effective-slot-definition nil)) + (or (position slot-name '(name type initform initfunction initargs allocation location)) + (error "No slot ~S in ~S." slot-name (movitz-class-name class)))) + (t #+ignore + (when (and (eq slot-name 'effective-slots) + (subclassp class *the-class-standard-class*)) + (break "Looking for slot ~S in class ~S, while std-class is ~S." + slot-name class *the-class-standard-class*)) + (let ((slot (find slot-name + (std-slot-value class 'effective-slots) + :key #'slot-definition-name))) + (if (null slot) + (error "Closette compiler: The slot ~S is missing from the class ~S." + slot-name class) + (let ((pos (position slot + (remove-if-not #'instance-slot-p + (std-slot-value class 'effective-slots))))) + (if (null pos) + (error "Closette compiler: The slot ~S is not an instance slot in the class ~S." + slot-name class) + pos)))))))) (defun movitz-class-of (instance) (std-instance-class instance))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by Frode Vatvedt Fjeld 07 Jun '04

07 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9497 Modified Files: interrupt.lisp Log Message: Be slightly more clever when dealing with stack exhausted exceptions. Date: Mon Jun 7 15:13:12 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.13 movitz/losp/muerte/interrupt.lisp:1.14 --- movitz/losp/muerte/interrupt.lisp:1.13 Sat Jun 5 19:10:55 2004 +++ movitz/losp/muerte/interrupt.lisp Mon Jun 7 15:13:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.13 2004/06/06 02:10:55 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.14 2004/06/07 22:13:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -291,8 +291,9 @@ $eax $ecx)) (62 (error "Trying to save too many values: ~@Z." $ecx)) ((5 55) - (let* ((stack (%run-time-context-slot 'movitz::stack-vector)) - (old-bottom (stack-bottom)) + (let* ((old-bottom (prog1 (stack-bottom) + (setf (stack-bottom) 0))) + (stack (%run-time-context-slot 'movitz::stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) (new-bottom (cond

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by Frode Vatvedt Fjeld 07 Jun '04

07 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8622 Modified Files: movitz-mode.el Log Message: Minor edit. Date: Mon Jun 7 15:10:54 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.6 movitz/movitz-mode.el:1.7 --- movitz/movitz-mode.el:1.6 Mon May 24 07:58:17 2004 +++ movitz/movitz-mode.el Mon Jun 7 15:10:54 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.6 2004/05/24 14:58:17 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.7 2004/06/07 22:10:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,7 +63,7 @@ (point)) (progn (forward-sexp 1) (point))))) - (if (and (string-equal "method" definition-type) + (if (and (equalp "method" definition-type) (char-equal 58 (string-to-char lambda-list))) (let ((qualifier lambda-list) ;; XXX we only deal with one (potential) qualifier..

1 0

[movitz-cvs] CVS update: movitz/environment.lisp
by Frode Vatvedt Fjeld 07 Jun '04

07 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7562 Modified Files: environment.lisp Log Message: Don't return the second value from gethash. Date: Mon Jun 7 15:09:56 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.5 movitz/environment.lisp:1.6 --- movitz/environment.lisp:1.5 Tue Feb 17 12:24:00 2004 +++ movitz/environment.lisp Mon Jun 7 15:09:56 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.5 2004/02/17 20:24:00 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.6 2004/06/07 22:09:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -438,7 +438,7 @@ ;;; Accessor: movitz-env-symbol-function (defun movitz-env-symbol-function (symbol &optional env) - (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*)))) + (values (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*))))) (defun (setf movitz-env-symbol-function) (value symbol &optional env) (setf (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*)))

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 07 Jun '04

07 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7413 Modified Files: compiler-types.lisp Log Message: Slight improvement of type-specifier-nth-value. Date: Mon Jun 7 15:09:24 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.12 movitz/compiler-types.lisp:1.13 --- movitz/compiler-types.lisp:1.12 Sun Apr 18 17:29:35 2004 +++ movitz/compiler-types.lisp Mon Jun 7 15:09:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.12 2004/04/19 00:29:35 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.13 2004/06/07 22:09:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,9 +45,10 @@ ((< number (length reqs)) (nth number reqs)) ((< number (+ (length reqs) (length opts))) - `(or null ,(nth (- number (length reqs)) opts))) + (let ((x (nth (- number (length reqs)) opts))) + (if (eq x t) t `(or null ,x)))) (rest - `(or null ,rest)) + (if (eq rest t) t `(or null ,rest))) (t 'null)))))) (defun type-specifier-primary (type-specifier)

1 0

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

07 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3186 Modified Files: integers.lisp Log Message: Added multiplication of fixnum with bignum. Date: Mon Jun 7 03:39:10 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.22 movitz/losp/muerte/integers.lisp:1.23 --- movitz/losp/muerte/integers.lisp:1.22 Sun Jun 6 07:25:22 2004 +++ movitz/losp/muerte/integers.lisp Mon Jun 7 03:39:10 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.22 2004/06/06 14:25:22 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.23 2004/06/07 10:39:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -85,6 +85,7 @@ `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands)))))) (defun + (&rest terms) + (declare (without-check-stack-limit)) (numargs-case (1 (x) x) (2 (x y) @@ -822,7 +823,84 @@ fixnum-result (:movl :edi :edx) (:cld) - fixnum-done)))))) + fixnum-done))) + (((eql 0) t) 0) + (((eql 1) t) y) + ((t fixnum) (* y x)) + ((fixnum bignum) + (let (r) + (with-inline-assembly (:returns :eax) + retry + (:declare-label-set retry-jumper (retry)) + (: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)))) + + (:compile-form (:result-mode :eax) y) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* 2 movitz:+movitz-fixnum-factor+)) + :eax) + (:call-global-constant get-cons-pointer) ; New bignum into EAX + + (:load-lexical (:lexical-binding y) :ebx) ; bignum + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax ,movitz:+other-type-offset+)) + (:store-lexical (:lexical-binding r) :eax :type bignum) + + (:movl :eax :ebx) ; r into ebx + (:xorl :ecx :ecx) + (:xorl :edx :edx) ; initial carry + (:std) ; Make EAX, EDX, ESI non-GC-roots. + (:compile-form (:result-mode :esi) x) + (:sarl ,movitz:+movitz-fixnum-shift+ :esi) + (:jns 'multiply-loop) + (:negl :esi) ; can't overflow + multiply-loop + (:movl :edx (:ebx (:ecx 4) ; new + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:compile-form (:result-mode :ebx) y) + (:movl (:ebx (:ecx 4) ; old + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :eax) + + (:mull :esi :eax :edx) + (:compile-form (:result-mode :ebx) r) + (:addl :eax + (:ebx (:ecx 4) + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:adcl 0 :edx) + (:addl 1 :ecx) + (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:ja 'multiply-loop) + (:testl :edx :edx) + (:jz 'no-carry-expansion) + (:movl :edx + (:ebx (:ecx 4) + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:addl 1 :ecx) + (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + no-carry-expansion + (:movl (:ebp -4) :esi) + (:movl :ebx :eax) + (:movl :edi :edx) + (:cld) ; EAX, EDX, and ESI are GC roots again. + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,movitz:+movitz-fixnum-factor+) + :ecx) + (:call-global-constant cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ebx) x) + (:testl :ebx :ebx) + (:jns 'positive-result) + ;; Negate the resulting bignum + (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) + positive-result + ))) + ))) (do-it))) (t (&rest factors) (declare (dynamic-extent factors)) @@ -875,6 +953,8 @@ (values number 0)) (t (number divisor) (number-double-dispatch (number divisor) + ((t (eql 1)) + number) ((fixnum fixnum) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) number) @@ -894,16 +974,16 @@ `(let (r n) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :ebx) number) - (:cmpw 1 (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:cmpw 1 (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) (:jne 'not-size1) (:compile-form (:result-mode :ecx) divisor) - (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:std) - (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (: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) + (:shll ,movitz:+movitz-fixnum-shift+ :edx) (:movl :edi :eax) (:cld) (:pushl :edx) @@ -912,7 +992,7 @@ (:jmp 'done) not-size1 (:compile-form (:result-mode :ebx) number) - (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) (:declare-label-set retry-jumper (not-size1)) @@ -921,10 +1001,10 @@ 'retry-jumper) (:edi (:edi-offset atomically-status)))) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) #.movitz:+movitz-fixnum-factor+) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) :eax) ; Number of words (:call-global-constant get-cons-pointer) ; New bignum into EAX - + (:store-lexical (:lexical-binding r) :eax :type bignum) (:compile-form (:result-mode :ebx) number)

1 0

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

06 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24388 Modified Files: special-operators.lisp Log Message: The (special) operator +%2op isn't quite up to speed. This patch removes one of the most nasty assumptions about fixnums. Date: Sun Jun 6 08:12:41 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.22 movitz/special-operators.lisp:1.23 --- movitz/special-operators.lisp:1.22 Fri Apr 16 03:24:54 2004 +++ movitz/special-operators.lisp Sun Jun 6 08:12:40 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.22 2004/04/16 10:24:54 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.23 2004/06/06 15:12:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1110,12 +1110,9 @@ (let ((constant-term2 (eval-form term2 env))) (check-type constant-term2 (signed-byte 30)) (compile-constant-add constant-term2 term1))) - (t (compiler-call #'compile-form-unprotected + (t (compiler-call #'compile-apply-symbol :forward all - :form `(muerte::with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:ebx :eax) ,term1 ,term2) - (:addl :ebx :eax) - (:into)))))))) + :form `(muerte.cl:+ ,term1 ,term2))))))) (define-special-operator muerte::include (&form form) (let ((*require-dependency-chain*

1 0

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

06 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11557 Modified Files: integers.lisp Log Message: Multiplication of two fixnums, result overflowing into bignums, seems to work. Date: Sun Jun 6 07:25:22 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.21 movitz/losp/muerte/integers.lisp:1.22 --- movitz/losp/muerte/integers.lisp:1.21 Sun Jun 6 03:24:29 2004 +++ movitz/losp/muerte/integers.lisp Sun Jun 6 07:25:22 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.21 2004/06/06 10:24:29 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.22 2004/06/06 14:25:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -754,18 +754,76 @@ (numargs-case (1 (x) x) (2 (x y) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jne '(:sub-program (not-fixnum) - (:int 107))) - (:movl :ebx :ecx) - (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) - (:imull :ecx :eax :edx) - (:into))) + (macrolet + ((do-it () + `(number-double-dispatch (x y) + ((fixnum fixnum) + (let (d0 d1) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) x y) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:std) + (:imull :ecx :eax :edx) + (:jno 'fixnum-result) ; most likely/optimized path. + (:cmpl ,movitz::+movitz-fixnum-factor+ :edx) + (:jc 'u32-result) + (:cmpl #xfffffffc :edx) + (:ja 'u32-negative-result) + (:jne 'two-bigits) + (:testl :eax :eax) + (:jnz 'u32-negative-result) + ;; The result requires 2 bigits.. + two-bigits + (:shll ,movitz::+movitz-fixnum-shift+ :edx) ; guaranteed won't overflow. + (:cld) + (:store-lexical (:lexical-binding d0) :eax :type fixnum) + (:store-lexical (:lexical-binding d1) :edx :type fixnum) + (:compile-form (:result-mode :eax) + (malloc-data-words 3)) + (:movl ,(dpb 2 (byte 16 16) (movitz:tag :bignum 0)) + (:eax ,movitz:+other-type-offset+)) + (:load-lexical (:lexical-binding d0) :ecx) + (:movl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:load-lexical (:lexical-binding d1) :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ + :ecx) + (:shrdl ,movitz:+movitz-fixnum-shift+ :ecx + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:sarl ,movitz:+movitz-fixnum-shift+ + :ecx) + (:movl :ecx (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:jns 'fixnum-done) + ;; if result was negative, we must negate bignum + (:notl (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:negl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:cmc) + (:adcl 0 (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) + (:jmp 'fixnum-done) + + u32-result + (:movl :eax :ecx) + (:shrdl ,movitz::+movitz-fixnum-shift+ :edx :ecx) + (:movl :edi :edx) + (:cld) + (:call-global-constant box-u32-ecx) + (:jmp 'fixnum-done) + + u32-negative-result + (:movl :eax :ecx) + (:shrdl ,movitz::+movitz-fixnum-shift+ :edx :ecx) + (:movl :edi :edx) + (:cld) + (:negl :ecx) + (:call-global-constant box-u32-ecx) + (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) + (:jmp 'fixnum-done) + + fixnum-result + (:movl :edi :edx) + (:cld) + fixnum-done)))))) + (do-it))) (t (&rest factors) (declare (dynamic-extent factors)) (if (null factors)

1 0

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

06 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10391 Modified Files: memref.lisp Log Message: Have memref-int :unsigned-byte32 box a bignum if necessary. Date: Sun Jun 6 04:32:09 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.13 movitz/losp/muerte/memref.lisp:1.14 --- movitz/losp/muerte/memref.lisp:1.13 Wed Apr 14 13:05:26 2004 +++ movitz/losp/muerte/memref.lisp Sun Jun 6 04:32:09 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.13 2004/04/14 20:05:26 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.14 2004/06/06 11:32:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -603,11 +603,7 @@ (:addl :ecx :eax) (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale down address (,prefixes :movl (:eax) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program (overflow) (:int 4))) - (:leal ((:ecx ,movitz::+movitz-fixnum-factor+) - :edi ,(- (movitz::image-nil-word movitz::*image*))) - :eax))) + (:call-global-constant box-u32-ecx))) (:unsigned-byte16 (cond ((and (eq 0 offset) (eq 0 index))

1 0

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

06 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25792 Modified Files: integers.lisp Log Message: Starting work on *. Date: Sun Jun 6 03:24:29 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.20 movitz/losp/muerte/integers.lisp:1.21 --- movitz/losp/muerte/integers.lisp:1.20 Sat Jun 5 20:00:13 2004 +++ movitz/losp/muerte/integers.lisp Sun Jun 6 03:24:29 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.20 2004/06/06 03:00:13 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.21 2004/06/06 10:24:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -719,48 +719,36 @@ (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) - ;;; Multiplication -(define-compiler-macro *%2op (&whole form &environment env factor1 factor2) - (cond - ((and (movitz:movitz-constantp factor1 env) - (movitz:movitz-constantp factor2 env)) - (* (movitz:movitz-eval factor1 env) - (movitz:movitz-eval factor2 env))) - ((movitz:movitz-constantp factor2 env) - `(*%2op ,(movitz:movitz-eval factor2 env) ,factor1)) - ((movitz:movitz-constantp factor1 env) - (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 fixnum) - (case f1 - (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)))) - -;;;(defun *%2op (factor1 factor2) -;;; (check-type factor1 fixnum) -;;; (check-type factor2 fixnum) -;;; (with-inline-assembly (:returns :eax) -;;; (:compile-form (:result-mode :eax) factor1) -;;; (:compile-form (:result-mode :ebx) factor2) -;;; (:sarl #.movitz::+movitz-fixnum-shift+ :eax) -;;; (:imull :ebx :eax :edx) -;;; (:into))) - -(define-compiler-macro * (&whole form &rest operands) +(define-compiler-macro * (&whole form &rest operands &environment env) (case (length operands) (0 0) (1 (first operands)) - (2 `(*%2op ,(first operands) ,(second operands))) - (t `(* (*%2op ,(first operands) ,(second operands)) ,@(cddr operands))))) + (2 (let ((factor1 (first operands)) + (factor2 (second operands))) + (cond + ((and (movitz:movitz-constantp factor1 env) + (movitz:movitz-constantp factor2 env)) + (* (movitz:movitz-eval factor1 env) + (movitz:movitz-eval factor2 env))) + ((movitz:movitz-constantp factor2 env) + `(* ,(movitz:movitz-eval factor2 env) ,factor1)) + ((movitz:movitz-constantp factor1 env) + (let ((f1 (movitz:movitz-eval factor1 env))) + (check-type f1 fixnum) + (case f1 + (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 `(* (* ,(first operands) ,(second operands)) ,@(cddr operands))))) (defun * (&rest factors) (numargs-case @@ -782,7 +770,7 @@ (declare (dynamic-extent factors)) (if (null factors) 1 - (reduce '*%2op factors))))) + (reduce '* factors))))) ;;; Division @@ -1353,7 +1341,7 @@ (defun print-bignum (x) (check-type x bignum) - (loop for i from 0 to (%bignum-bigits x) - do (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) + (dotimes (i (1+ (%bignum-bigits x))) + (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) (terpri) (values))

1 0