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

[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

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

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14528 Modified Files: inspect.lisp Log Message: Do a bit more safety checking in %bignum-canonicalize and %make-bignum. Date: Fri Jul 16 03:43:26 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.22 movitz/losp/muerte/inspect.lisp:1.23 --- movitz/losp/muerte/inspect.lisp:1.22 Thu Jul 15 17:02:03 2004 +++ movitz/losp/muerte/inspect.lisp Fri Jul 16 03:43:26 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.22 2004/07/16 00:02:03 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.23 2004/07/16 10:43:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,12 +265,15 @@ "Assuming x is a bignum, return the canonical integer value. That is, either return a fixnum, or destructively modify the bignum's length so that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!" + (check-type x bignum) (macrolet ((do-it () `(with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding x) :eax) (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:shrl 16 :ecx) + (:jz '(:sub-program (should-never-happen) + (:int 107))) shrink-loop (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) (:je 'shrink-no-more) @@ -308,6 +311,7 @@ (:jnc 'copy-bignum-loop)))) (defun %make-bignum (bigits) + (assert (plusp bigits)) (macrolet ((do-it () `(with-inline-assembly (:returns :eax)

1 0

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

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12224 Modified Files: integers.lisp Log Message: Fixed a nasty bug in ash which failed to handle the situation when a bignum got shifted to zero. Also fixed a bug in truncate on negatives. Date: Fri Jul 16 03:42:41 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.67 movitz/losp/muerte/integers.lisp:1.68 --- movitz/losp/muerte/integers.lisp:1.67 Thu Jul 15 17:03:05 2004 +++ movitz/losp/muerte/integers.lisp Fri Jul 16 03:42:40 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.67 2004/07/16 00:03:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.68 2004/07/16 10:42:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1133,21 +1133,23 @@ (:andl -4 :eax) (:cld))) (positive-bignum - (let* ((result-length (- (integer-length integer) count)) - (result (%make-bignum (truncate (+ result-length 31) 32)))) - (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-length (- (integer-length integer) count))) + (if (<= result-length 0) + 0 + (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) + (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)))))))))) ;;;; @@ -1540,12 +1542,12 @@ (%negatef r number divisor)))) (((integer 0 *) (integer * -1)) (multiple-value-bind (q r) - (truncate (- number) divisor) + (truncate number (- divisor)) (values (%negatef q number divisor) r))) (((integer * -1) (integer * -1)) (multiple-value-bind (q r) - (truncate (- number) divisor) + (truncate (- number) (- divisor)) (values q (%negatef r number divisor)))) ))))

1 0

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

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16497 Modified Files: memref.lisp Log Message: Fixed a bug in the compiler-macro for (setf memref <negative> <x> :unsigned-byte32). Date: Fri Jul 16 03:06:36 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.16 movitz/losp/muerte/memref.lisp:1.17 --- movitz/losp/muerte/memref.lisp:1.16 Thu Jul 15 14:07:18 2004 +++ movitz/losp/muerte/memref.lisp Fri Jul 16 03:06:36 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.16 2004/07/15 21:07:18 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.17 2004/07/16 10:06:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -352,7 +352,7 @@ (:compile-two-forms (:eax :edx) ,index-var ,offset-var) (:load-lexical (:lexical-binding ,object-var) :ebx) (:std) - (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:sarl ,movitz::+movitz-fixnum-shift+ :edx) (:addl :eax :edx) ; EDX = offset+index (:movl :ecx (:ebx :edx)) (:movl :edi :edx)

1 0

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

16 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5830 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Thu Jul 15 17:03:43 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.75 movitz/compiler.lisp:1.76 --- movitz/compiler.lisp:1.75 Tue Jul 13 15:41:06 2004 +++ movitz/compiler.lisp Thu Jul 15 17:03:42 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.75 2004/07/13 22:41:06 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.76 2004/07/16 00:03:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2347,6 +2347,9 @@ (shadowing-variable :initarg :shadowing-variable :reader shadowing-variable))) + +(defmethod binding-store-type ((binding dynamic-binding)) + (multiple-value-list (type-specifier-encode t))) (defun stack-frame-offset (stack-frame-position) (* -4 (1+ stack-frame-position)))

1 0

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

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2747 Modified Files: integers.lisp Log Message: Improved ash. Fixed a bug wrt. carry-propagation in - for bignums. Date: Thu Jul 15 17:03:05 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.66 movitz/losp/muerte/integers.lisp:1.67 --- movitz/losp/muerte/integers.lisp:1.66 Thu Jul 15 14:07:08 2004 +++ movitz/losp/muerte/integers.lisp Thu Jul 15 17:03:05 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.66 2004/07/15 21:07:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.67 2004/07/16 00:03:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -516,8 +516,11 @@ (:jne 'sub-loop) (:subl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jc '(:sub-program (should-not-happen) - (:int 107))) + (:jnc 'bignum-sub-done) + propagate-carry + (:addl 4 :edx) + (:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc 'propagate-carry) bignum-sub-done ))))) (((integer 0 *) (integer * -1)) @@ -1088,14 +1091,63 @@ (defun ash (integer count) (cond - ((not (minusp count)) - (do () ((< count 16)) - (setf integer (no-macro-call * #x10000 integer)) - (decf count 16)) - (dotimes (i count integer) - (setf integer (no-macro-call * 2 integer)))) - (t (dotimes (i (- count) integer) - (setf integer (truncate integer 2)))))) + ((= 0 count) + integer) + ((plusp count) + (let ((result-length (+ (integer-length integer) count))) + (cond + ((<= result-length 29) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) integer count) + (: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)))))) + (t (let ((count (- count))) + (etypecase integer + (fixnum + (with-inline-assembly (:returns :eax :type fixnum) + (:compile-two-forms (:eax :ecx) integer count) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:sarl :cl :eax) + (:andl -4 :eax) + (:cld))) + (positive-bignum + (let* ((result-length (- (integer-length integer) count)) + (result (%make-bignum (truncate (+ result-length 31) 32)))) + (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)))))))) ;;;; @@ -1317,10 +1369,16 @@ ;; X is the biggest factor. (let ((r 0) (f 0)) (dotimes (half-bigit (* 2 (%bignum-bigits y))) - (setf r (+ r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) - f))) + (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) + f)) (incf f 16)) - r)))))) + r))) + ((t (integer * -1)) + (%negatef (* x (- y)) x y)) + (((integer * -1) t) + (%negatef (* (- x) y) x y)) + (((integer * -1) (integer * -1)) + (* (- x) (- y)))))) (do-it))) (t (&rest factors) (declare (dynamic-extent factors)) @@ -1461,18 +1519,15 @@ (setf msb (+ (* #x10000 msb) (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8)) (memref divisor -2 msb-pos :unsigned-byte8))) - (multiple-value-bind (long-shift short-shift) - ;; This shifting stuff should be replaced by ash, - ;; when ash is properly implemented. - (truncate msb-pos 3) + (let ((guess-shift (- (* msb-pos 8)))) (do ((msb+1 (1+ msb)) (q 0) (r number)) ((< r divisor) (values q r)) - (let ((guess (truncate r msb+1))) - (dotimes (i long-shift) - (setf guess (truncate guess #x1000000))) - (dotimes (i short-shift) - (setf guess (truncate guess #x100))) + (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))) (if (= 0 guess) (setf q (1+ q) r (- r divisor))

1 0