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

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18932 Modified Files: common-lisp.lisp Log Message: Extracted most compiler-macros from integers.lisp into arithmetic-macros.lisp. Date: Sat Jul 17 05:16:08 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.7 movitz/losp/muerte/common-lisp.lisp:1.8 --- movitz/losp/muerte/common-lisp.lisp:1.7 Fri Apr 23 08:00:14 2004 +++ movitz/losp/muerte/common-lisp.lisp Sat Jul 17 05:16:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.7 2004/04/23 15:00:14 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.8 2004/07/17 12:16:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,6 +17,7 @@ (require :muerte/setf) (require :muerte/more-macros) +(require :muerte/arithmetic-macros) (require :muerte/memref) (require :muerte/basic-functions) (require :muerte/variables)

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16704 Added Files: arithmetic-macros.lisp Log Message: Extracted most compiler-macros from integers.lisp into arithmetic-macros.lisp. Date: Sat Jul 17 05:16:03 2004 Author: ffjeld

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18176 Modified Files: integers.lisp Log Message: This bignum multiply is twice as good in time, space, and read/portability. Date: Sat Jul 17 04:27:58 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.69 movitz/losp/muerte/integers.lisp:1.70 --- movitz/losp/muerte/integers.lisp:1.69 Fri Jul 16 18:48:08 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 17 04:27:58 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.69 2004/07/17 01:48:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.70 2004/07/17 11:27:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -487,11 +487,7 @@ 0) ((< minuend subtrahend) (let ((x (- subtrahend minuend))) - (when (typep x 'bignum) - (setf (memref x ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign) - 0 :unsigned-byte8) - #xff)) - x)) + (%negatef x subtrahend minuend))) (t (%bignum-canonicalize (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend) @@ -1093,6 +1089,7 @@ (cond ((= 0 count) integer) + ((= 0 integer) 0) ((plusp count) (let ((result-length (+ (integer-length integer) count))) (cond @@ -1382,13 +1379,11 @@ (if (< x y) (* y x) ;; X is the biggest factor. - (let ((r 0) (f 0)) - (dotimes (half-bigit (* 2 (%bignum-bigits y))) - (let* ((digit (* x (memref y -2 half-bigit :unsigned-byte16))) - (delta1 (ash digit f))) - (incf r delta1)) - (incf f 16)) - r))) + (do ((r 0) + (length (integer-length y)) + (i 0 (+ i 29))) + ((>= i length) r) + (incf r (ash (* x (ldb (byte 29 i) y)) i))))) ((t (integer * -1)) (%negatef (* x (- y)) x y)) (((integer * -1) t)

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv5834 Modified Files: los0-gc.lisp Log Message: Some cosmetics on gc. Date: Fri Jul 16 18:56:52 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.28 movitz/losp/los0-gc.lisp:1.29 --- movitz/losp/los0-gc.lisp:1.28 Thu Jul 15 14:06:33 2004 +++ movitz/losp/los0-gc.lisp Fri Jul 16 18:56:52 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.28 2004/07/15 21:06:33 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.29 2004/07/17 01:56:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,6 +19,7 @@ (in-package muerte.init) (defvar *gc-quiet* nil) +(defvar *gc-running* nil) (defun make-space (location size) "Make a space vector at a fixed location." @@ -246,15 +247,19 @@ (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy) - (loop ; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll.")) - ((nil) - (return)))))) + (when *gc-running* + (let ((muerte::*error-no-condition-for-debugger* t)) + (error "Recursive GC triggered."))) + (let ((*gc-running t)) + (unless *gc-quiet* + (format t "~&;; GC.. ")) + (stop-and-copy) + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (break "Los0 GC keyboard poll.")) + ((nil) + (return))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2)))) @@ -351,15 +356,14 @@ (cond ((not (object-in-space-p oldspace x)) x) - #+ignore - ((typep x 'muerte::tag6) - (let ((fwi (position (object-location x) *x* :test #'eq))) - (if fwi - (muerte::%word-offset (aref *x* (1+ fwi)) 6) - (let ((fw (shallow-copy x))) - (vector-push (object-location x) *x*) - (vector-push (object-location fw) *x*) - fw)))) + #+ignore ((typep x 'muerte::bignum) + (let ((fwi (position (object-location x) *x* :test #'eq))) + (if fwi + (muerte::%word-offset (aref *x* (1+ fwi)) 6) + (let ((fw (shallow-copy x))) + (vector-push (object-location x) *x*) + (vector-push (object-location fw) *x*) + fw)))) (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) (if (object-in-space-p newspace forwarded-x) (progn @@ -385,16 +389,15 @@ (+ newspace-location (space-fresh-pointer newspace))) (setf scan-pointer fresh-pointer)) - #+ignore - (dotimes (i (truncate (length *x*) 2)) - (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6)) - (y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6))) - (assert (and (object-in-space-p newspace y) - (object-in-space-p oldspace x) - (or (typep x 'muerte::std-instance) - (equalp x y))) - () - "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace))) + #+ignore (dotimes (i (truncate (length *x*) 2)) + (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6)) + (y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6))) + (assert (and (object-in-space-p newspace y) + (object-in-space-p oldspace x) + (or (typep x 'muerte::std-instance) + (equalp x y))) + () + "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace))) ;; GC completed, oldspace is evacuated. (unless *gc-quiet*

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12845 Modified Files: environment.lisp Log Message: Minor fix regarding display of memory usage in time macro. Date: Fri Jul 16 18:54:55 2004 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.7 movitz/losp/muerte/environment.lisp:1.8 --- movitz/losp/muerte/environment.lisp:1.7 Fri Apr 23 08:02:59 2004 +++ movitz/losp/muerte/environment.lisp Fri Jul 16 18:54:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.7 2004/04/23 15:02:59 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.8 2004/07/17 01:54:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,13 +138,13 @@ (constantly-true 123) (time-skew-measure start-mem x-lo x-hi)) finally (return x))))) - (clumps (- (malloc-cons-pointer) start-mem)) + (clumps (and start-mem (- (malloc-cons-pointer) start-mem))) (delta-hi (- end-time-hi start-time-hi)) (delta-lo (- end-time-lo start-time-lo skew))) (if (= 0 delta-hi) - (format t "~&;; CPU cycles: ~D.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" + (format t "~&;; CPU cycles: ~D.~@[~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" delta-lo clumps clumps) - (format t "~&;; CPU cycles: ~DM.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" + (format t "~&;; CPU cycles: ~DM.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" (+ (ash delta-hi 9) (ash delta-lo -20)) clumps clumps))))) (defmacro time (form)

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10135 Modified Files: primitive-functions.lisp Log Message: This malloc-cons-pointer sort of works with los0-gc. Date: Fri Jul 16 18:54:12 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.29 movitz/losp/muerte/primitive-functions.lisp:1.30 --- movitz/losp/muerte/primitive-functions.lisp:1.29 Thu Jul 15 14:07:22 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri Jul 16 18:54:12 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.29 2004/07/15 21:07:22 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.30 2004/07/17 01:54:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -534,6 +534,10 @@ (defun malloc-cons-pointer () "Return current cons-pointer in 8-byte units since buffer-start." + (let ((x (%run-time-context-slot 'nursery-space))) + (when (typep x 'vector) + (truncate (aref x 0) 8))) + #+ignore (with-inline-assembly (:returns :eax) (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:movl (:eax 4) :eax)

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26944 Modified Files: memref.lisp Log Message: Fixed some bugs wrt. argument evaluation order. Date: Fri Jul 16 18:53:17 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.17 movitz/losp/muerte/memref.lisp:1.18 --- movitz/losp/muerte/memref.lisp:1.17 Fri Jul 16 03:06:36 2004 +++ movitz/losp/muerte/memref.lisp Fri Jul 16 18:53:17 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.17 2004/07/16 10:06:36 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.18 2004/07/17 01:53:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -92,14 +92,23 @@ (:compile-form (:result-mode :eax) ,object) (:movzxw (:eax ,(offset-by 2)) :ecx))) ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,object ,index) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx))) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) + (let ((object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsiged-byte 16)) + (:compile-two-forms (:eax :ecx) ,object-var ,index-var) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx))))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) (:leal (:ecx (:ebx 2)) :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) @@ -378,40 +387,55 @@ (* 2 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp value env)) - (let ((value (movitz:movitz-eval value env))) + (let ((value (movitz:movitz-eval value env)) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) (check-type value (unsigned-byte 16)) - `(progn + `(let ((,object-var ,object) + (,index-var ,index)) (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :ebx) ,index ,object) + (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value))) ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) + (let ((value-var (gensym "memref-value-")) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) - `(let ((,value-var ,value)) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) - `(let ((,value-var ,value)) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,object ,index) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) (:load-lexical (:lexical-binding ,value-var) :eax) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) - (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env))) - (:andl #xff0000 :eax) - (:shrl 8 :eax) - (:movb :ah (:ebx :ecx ,(1+ (movitz:movitz-eval offset env))))) + (:movl :edi :edx) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:movl :edi :eax) + (:cld)) ,value-var)))) (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) - `(let ((,value-var ,offset) (,object-var ,object)) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-two-forms (:ebx :ecx) ,offset ,index) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) (:load-lexical (:lexical-binding ,value-var) :eax) (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax) (:leal (:ebx (:ecx 2)) :ecx) @@ -419,9 +443,12 @@ (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :ebx) (:movw :ax (:ebx :ecx)))) - `(let ((,value-var ,value) (,object-var ,object)) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,offset ,index) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) (:load-lexical (:lexical-binding ,value-var) :eax) (:leal (:ebx (:ecx 2)) :ecx) (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25105 Modified Files: inspect.lisp Log Message: Minor edits. Date: Fri Jul 16 18:52:29 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.23 movitz/losp/muerte/inspect.lisp:1.24 --- movitz/losp/muerte/inspect.lisp:1.23 Fri Jul 16 03:43:26 2004 +++ movitz/losp/muerte/inspect.lisp Fri Jul 16 18:52:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.23 2004/07/16 10:43:26 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.24 2004/07/17 01:52:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -275,11 +275,11 @@ (:jz '(:sub-program (should-never-happen) (:int 107))) shrink-loop - (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) + (:cmpl 4 :ecx) (:je 'shrink-no-more) (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) (:jnz 'shrink-done) - (:subl ,movitz:+movitz-fixnum-factor+ :ecx) + (:subl 4 :ecx) (:jmp 'shrink-loop) shrink-no-more (:cmpl ,(1+ movitz:+movitz-most-positive-fixnum+) @@ -291,7 +291,9 @@ (:jmp 'done))) shrink-done (:testb 3 :cl) - (:jnz '(:sub-program () (:int 59))) + (:jnz '(:sub-program () (:int 107))) + (:testw :cx :cx) + (:jz '(:sub-program () (:int 107))) (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))) done )))

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2318 Modified Files: special-operators.lisp Log Message: Added assembly-macro :offset. Date: Fri Jul 16 18:49:23 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.28 movitz/special-operators.lisp:1.29 --- movitz/special-operators.lisp:1.28 Thu Jul 15 14:06:28 2004 +++ movitz/special-operators.lisp Fri Jul 16 18:49:23 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.28 2004/07/15 21:06:28 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.29 2004/07/17 01:49:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -521,6 +521,16 @@ (setq side-effects t)) (setf modifies (modifies-union modifies sub-modifies)) sub-code)))) + (setf (assembly-macro-expander :offset amenv) + #'(lambda (expr) + (destructuring-bind (type slot &optional (extra 0)) + (cdr expr) + (let ((mtype (find-symbol (symbol-name type) :movitz)) + (mslot (find-symbol (symbol-name slot) :movitz))) + (assert mtype (mtype) "Type not a Movitz symbol: ~A" type) + (assert mslot (mslot) "Slot not a Movitz symbol: ~A" slot) + (list (+ (slot-offset mtype mslot) + (eval extra))))))) (setf (assembly-macro-expander :returns-mode amenv) #'(lambda (expr) (assert (= 1 (length expr)))

1 0

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

17 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18528 Modified Files: integers.lisp Log Message: Fixed bugs in ash, truncate, *, and integer-length. Date: Fri Jul 16 18:48:08 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.68 movitz/losp/muerte/integers.lisp:1.69 --- movitz/losp/muerte/integers.lisp:1.68 Fri Jul 16 03:42:40 2004 +++ movitz/losp/muerte/integers.lisp Fri Jul 16 18:48:08 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.68 2004/07/16 10:42:40 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.69 2004/07/17 01:48:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1102,26 +1102,19 @@ (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:shll :cl :eax))) (t (check-type integer (integer 0 *)) - (multiple-value-bind (long short) - (truncate count 16) - (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) - (dotimes (i long) - (setf (memref result -2 i :unsigned-byte16) 0)) - (etypecase integer - (fixnum - (when (>= integer #x10000) - (setf (memref result -2 (1+ long) :unsigned-byte16) - (ldb (byte 16 16) integer))) - (setf (memref result -2 long :unsigned-byte16) - (ldb (byte 16 0) integer))) - (bignum - (dotimes (i (* 2 (%bignum-bigits integer))) - (setf (memref result -2 (+ i long) :unsigned-byte16) - (memref integer -2 i :unsigned-byte16))))) - (setf result (%bignum-canonicalize result)) - (dotimes (i short) - (setf result (* 2 result))) - result)))))) + (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) + (dotimes (i (* 2 (%bignum-bigits result))) + (setf (memref result -2 i :unsigned-byte16) + (let ((pos (- (* i 16) count))) + (cond + ((minusp (+ pos 16)) 0) + ((<= 0 pos) + (ldb (byte 16 pos) integer)) + (t (ash (ldb (byte (+ pos 16) 0) integer) + (- pos))))))) + (assert (or (plusp (memref result -2 (+ -1 (* 2 (%bignum-bigits result))) :unsigned-byte16)) + (plusp (memref result -2 (+ -2 (* 2 (%bignum-bigits result))) :unsigned-byte16)))) + (%bignum-canonicalize result)))))) (t (let ((count (- count))) (etypecase integer (fixnum @@ -1134,22 +1127,42 @@ (:cld))) (positive-bignum (let ((result-length (- (integer-length integer) count))) - (if (<= result-length 0) - 0 - (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) - (multiple-value-bind (long short) + (cond + ((<= result-length 1) + result-length) ; 1 or 0. + (t (multiple-value-bind (long short) (truncate count 16) - (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) - (dotimes (i (* 2 (%bignum-bigits result))) - (let ((src (+ i long))) - (setf (memref result -2 i :unsigned-byte16) - (if (< src src-max-bigit) - (memref integer -2 src :unsigned-byte16) - 0))))) - (setf result (%bignum-canonicalize result)) - (dotimes (i short result) - (setf result (truncate result 2))) - result)))))))))) + (let ((result (%make-bignum (1+ (truncate (+ result-length 31) 32))))) + (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) + (dotimes (i (* 2 (%bignum-bigits result))) + (let ((src (+ i long))) + (setf (memref result -2 i :unsigned-byte16) + (if (< src src-max-bigit) + (memref integer -2 src :unsigned-byte16) + 0))))) + (%bignum-canonicalize + (macrolet + ((do-it () + `(with-inline-assembly (:returns :ebx) + (:compile-two-forms (:ecx :ebx) short result) + (:xorl :edx :edx) ; counter + (:xorl :eax :eax) ; We need to use EAX for u32 storage. + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:std) + shift-short-loop + (:addl 4 :edx) + (:cmpw :dx (:ebx (:offset movitz-bignum length))) + (:jbe 'end-shift-short-loop) + (:movl (:ebx :edx (:offset movitz-bignum bigit0)) + :eax) + (:shrdl :cl :eax + (:ebx :edx (:offset movitz-bignum bigit0 -4))) + (:jmp 'shift-short-loop) + end-shift-short-loop + (:movl :edx :eax) ; Safe EAX + (:shrl :cl (:ebx :edx (:offset movitz-bignum bigit0 -4))) + (:cld)))) + (do-it)))))))))))))) ;;;; @@ -1211,7 +1224,7 @@ (case f1 (0 `(progn ,factor2 0)) (1 factor2) -;;; (2 `(let ((x ,factor2)) (+ x x))) + (2 `(let ((x ,factor2)) (+ x x))) (t `(no-macro-call * ,factor1 ,factor2))))) (t `(no-macro-call * ,factor1 ,factor2))))) (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands))))) @@ -1371,8 +1384,9 @@ ;; X is the biggest factor. (let ((r 0) (f 0)) (dotimes (half-bigit (* 2 (%bignum-bigits y))) - (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) - f)) + (let* ((digit (* x (memref y -2 half-bigit :unsigned-byte16))) + (delta1 (ash digit f))) + (incf r delta1)) (incf f 16)) r))) ((t (integer * -1)) @@ -1512,29 +1526,27 @@ (cond ((= number divisor) (values 1 0)) ((< number divisor) (values 0 number)) - (t (let* ((msb-pos (1- (* 4 (%bignum-bigits divisor)))) - (msb (memref divisor -2 msb-pos :unsigned-byte8))) - (do () ((not (eq 0 msb))) - (decf msb-pos) - (setf msb (memref divisor -2 msb-pos :unsigned-byte8))) - (decf msb-pos 2) - (setf msb (+ (* #x10000 msb) - (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8)) - (memref divisor -2 msb-pos :unsigned-byte8))) - (let ((guess-shift (- (* msb-pos 8)))) - (do ((msb+1 (1+ msb)) - (q 0) (r number)) - ((< r divisor) (values q r)) - (let ((guess (ash (truncate r msb+1) guess-shift))) -;;; (dotimes (i long-shift) -;;; (setf guess (truncate guess #x1000000))) -;;; (dotimes (i short-shift) -;;; (setf guess (truncate guess #x100))) + (t (let* ((guess-pos (- (integer-length divisor) 29)) + (msb (ldb (byte 29 guess-pos) divisor))) + (when (eq msb most-positive-fixnum) + (decf guess-pos) + (setf msb (ash msb -1))) + (incf msb) + (do ((q 0) + (r number)) + ((< r divisor) + (assert (and (not (minusp r)) (not (minusp q))) () + "(trunc ~S ~S) r: ~S q: ~S" number divisor r q) +;;; (assert (= number (+ r (* q divisor))) () +;;; "trunc failed: q: ~S R: ~S" q r) + (values q r)) + (let* ((guess (ash (truncate r msb) (- guess-pos)))) + (let ((delta (* guess divisor))) (if (= 0 guess) (setf q (1+ q) r (- r divisor)) (setf q (+ q guess) - r (- r (* divisor guess))))))))))) + r (- r delta)))))))))) (((integer * -1) (integer 0 *)) (multiple-value-bind (q r) (truncate (- number) divisor) @@ -1562,7 +1574,7 @@ (if (= 0 r) q (error "Don't know how to divide ~S by ~S." number (first denominators))))) - (t (reduce '/ denominators :initial-value number)))) + (t (/ number (reduce '* denominators))))) (defun round (number &optional (divisor 1)) "Mathematical rounding." @@ -2010,6 +2022,7 @@ (do-it))) (positive-bignum (cond + ((= size 0) 0) ((<= size 32) ;; The result is likely to be a fixnum (or at least an u32), due to byte-size. (macrolet

1 0