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

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8436 Modified Files: compiler.lisp Log Message: Removed some debris. Date: Wed Jun 9 15:55:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.65 movitz/compiler.lisp:1.66 --- movitz/compiler.lisp:1.65 Wed Jun 9 13:24:29 2004 +++ movitz/compiler.lisp Wed Jun 9 15:55:37 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.65 2004/06/09 20:24:29 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.66 2004/06/09 22:55:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -470,9 +470,6 @@ (type-specifier-encode 'list))))) binding-usage)))) toplevel-funobj) - -(defmethod (setf borrowed-bindings) :before (x y) - (break "About to set borroweds for ~S to ~S." y x)) (defun resolve-borrowed-bindings (toplevel-funobj) "For <funobj>'s code, for every non-local binding used we create

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4087 Modified Files: integers.lisp Log Message: Added a bad expt. And a decent integer-length. Date: Wed Jun 9 15:52:12 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.30 movitz/losp/muerte/integers.lisp:1.31 --- movitz/losp/muerte/integers.lisp:1.30 Wed Jun 9 13:33:31 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 15:52:12 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.30 2004/06/09 20:33:31 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.31 2004/06/09 22:52:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -788,6 +788,34 @@ (when (< x min) (setq min x))))) +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + (list 'integer 0 (1- (ash 1 size)))) + (t (error "Illegal size for unsigned-byte.")))) + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + ;; shift (define-compiler-macro ash (&whole form integer count &environment env) @@ -857,6 +885,43 @@ (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) +(defun integer-length (integer) + "=> number-of-bits" + (etypecase integer + (fixnum + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:xorl :eax :eax) + (:compile-form (:result-mode :ecx) integer) + (:testl :ecx :ecx) + (:jns 'not-negative) + (:notl :ecx) + not-negative + (:bsrl :ecx :ecx) + (:jz 'zero) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* -1 movitz:+movitz-fixnum-factor+)) + :eax) + zero))) + (do-it))) + (positive-bignum + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) integer) + (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* -1 movitz:+movitz-fixnum-factor+)) + :eax) ; bigits-1 + (:bsrl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:shll 5 :eax) ; bits = bigits*32 + (bit-index+1) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax + ,movitz:+movitz-fixnum-factor+) + :eax)))) + (do-it))))) + ;;; Multiplication (define-compiler-macro * (&whole form &rest operands &environment env) @@ -1910,34 +1975,6 @@ (logior (mask-field bytespec newbyte) (logandc2 integer (mask-field bytespec -1)))) -;;; Types - -(define-typep integer (x &optional (min '*) (max '*)) - (and (typep x 'integer) - (or (eq min '*) (<= min x)) - (or (eq max '*) (<= x max)))) - -(deftype signed-byte (&optional (size '*)) - (cond - ((eq size '*) - 'integer) - ((typep size '(integer 1 *)) - (list 'integer - (- (ash 1 (1- size))) - (1- (ash 1 (1- size))))) - (t (error "Illegal size for signed-byte.")))) - -(deftype unsigned-byte (&optional (size '*)) - (cond - ((eq size '*) - '(integer 0)) - ((typep size '(integer 1 *)) - (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for unsigned-byte.")))) - -(define-simple-typep (bit bitp) (x) - (or (eq x 0) (eq x 1))) - ;;; (defun plus-if (x y) @@ -1996,4 +2033,19 @@ "=> natural-root" (check-type natural (integer 0 *)) (do ((i 0 (1+ i))) - ((> (* i i) natural) (1- i)))) \ No newline at end of file + ((> (* i i) natural) (1- i)))) + +(define-compiler-macro expt (&whole form base-number power-number &environment env) + (if (not (and (movitz:movitz-constantp base-number env) + (movitz:movitz-constantp power-number env))) + form + (expt (movitz:movitz-eval base-number env) + (movitz:movitz-eval power-number env)))) + + +(defun expt (base-number power-number) + "Take base-number to the power-number." + (do ((i 0 (1+ i)) + (r 1 (* r base-number))) + ((>= i power-number) r))) +

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12302 Modified Files: integers.lisp Log Message: Added a horrible isqrt. Date: Wed Jun 9 13:33:31 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.29 movitz/losp/muerte/integers.lisp:1.30 --- movitz/losp/muerte/integers.lisp:1.29 Wed Jun 9 13:23:15 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 13:33:31 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.29 2004/06/09 20:23:15 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.30 2004/06/09 20:33:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1991,3 +1991,9 @@ (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) (floor n divisor)))) + +(defun isqrt (natural) + "=> natural-root" + (check-type natural (integer 0 *)) + (do ((i 0 (1+ i))) + ((> (* i i) natural) (1- i)))) \ No newline at end of file

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29818 Modified Files: compiler.lisp Log Message: Still some tweaking of register allocation stuff. Date: Wed Jun 9 13:24:29 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.64 movitz/compiler.lisp:1.65 --- movitz/compiler.lisp:1.64 Wed Jun 9 10:26:00 2004 +++ movitz/compiler.lisp Wed Jun 9 13:24:29 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.64 2004/06/09 17:26:00 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.65 2004/06/09 20:24:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5825,9 +5825,12 @@ protect-registers protect-carry) (cdr instruction) (declare (ignore protect-registers protect-carry)) - (when init-with-register + (cond + (init-with-register (assert init-with-type) - (values binding init-with-type)))) + (values binding init-with-type)) + ((not (typep binding 'temporary-name)) + (values binding t))))) (define-find-read-bindings :init-lexvar (binding &key init-with-register &allow-other-keys) (declare (ignore binding))

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21599 Modified Files: inspect.lisp Log Message: Moved some bignum operators here from integers.lisp. Date: Wed Jun 9 13:23:48 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.10 movitz/losp/muerte/inspect.lisp:1.11 --- movitz/losp/muerte/inspect.lisp:1.10 Wed Jun 2 16:21:13 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jun 9 13:23:48 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.10 2004/06/02 23:21:13 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.11 2004/06/09 20:23:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -268,3 +268,26 @@ (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-struct) (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) + +(defun %bignum-bigits (x) + (%bignum-bigits x)) + +(defun copy-bignum (old) + (check-type old bignum) + (let* ((length (1+ (%bignum-bigits old))) + (new (malloc-data-words length))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) new old) + (:compile-form (:result-mode :edx) length) + 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)))) + +(defun print-bignum (x) + (check-type x bignum) + (dotimes (i (1+ (%bignum-bigits x))) + (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) + (terpri) + (values))

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18048 Modified Files: integers.lisp Log Message: Added function ceiling. Moved some bignum operators to inspect.lisp. Date: Wed Jun 9 13:23:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.28 movitz/losp/muerte/integers.lisp:1.29 --- movitz/losp/muerte/integers.lisp:1.28 Tue Jun 8 18:16:56 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 13:23:15 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.28 2004/06/09 01:16:56 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.29 2004/06/09 20:23:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1242,6 +1242,12 @@ (values quotient remainder)) (t (values (1- quotient) (- remainder))))))))) +(defun ceiling (number &optional (divisor 1)) + (case (+ (if (minusp number) #b10 0) + (if (minusp divisor) #b01 0)) + (#b00 (truncate (+ number divisor -1) divisor)) + (t (error "Don't know.")))) + (defun rem (dividend divisor) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) dividend) @@ -1985,35 +1991,3 @@ (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) (floor n divisor)))) - -(define-compiler-macro %bignum-bigits (x) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,x) - (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum - 'movitz::length)) - :ecx) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) - :eax))) - -(defun %bignum-bigits (x) - (%bignum-bigits x)) - -(defun copy-bignum (old) - (check-type old bignum) - (let* ((length (1+ (%bignum-bigits old))) - (new (malloc-data-words length))) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) new old) - (:compile-form (:result-mode :edx) length) - 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)))) - -(defun print-bignum (x) - (check-type x bignum) - (dotimes (i (1+ (%bignum-bigits x))) - (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) - (terpri) - (values)) \ No newline at end of file

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13331 Modified Files: lists.lisp Log Message: Added adjoin. Date: Wed Jun 9 13:18:45 2004 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.4 movitz/losp/muerte/lists.lisp:1.5 --- movitz/losp/muerte/lists.lisp:1.4 Thu Mar 18 01:24:23 2004 +++ movitz/losp/muerte/lists.lisp Wed Jun 9 13:18:45 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.4 2004/03/18 09:24:23 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.5 2004/06/09 20:18:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -436,3 +436,18 @@ +(defun subsetp (list-1 list-2 &key (key 'identity) (test 'eql) test-not) + "=> generalized-boolean" + (let ((test (if test-not + (complement test-not) + test))) + (dolist (x list-1 t) + (unless (member x list-2 :key key :test test) + (return nil))))) + +(defun adjoin (item list &key (key 'identity) (test 'eql) test-not) + "=> new-list" + (let ((test (if test-not (complement test-not) test))) + (if (member (funcall key item) list :test test) + list + (cons item list))))

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9640 Modified Files: typep.lisp Log Message: Added a rather stupid coerce function. Date: Wed Jun 9 13:13:16 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.14 movitz/losp/muerte/typep.lisp:1.15 --- movitz/losp/muerte/typep.lisp:1.14 Wed Jun 9 10:21:47 2004 +++ movitz/losp/muerte/typep.lisp Wed Jun 9 13:13:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.14 2004/06/09 17:21:47 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.15 2004/06/09 20:13:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -564,28 +564,11 @@ (defun type-of (x) (class-name (class-of x))) -;;; (typecase x -;;; (null 'null) -;;; (cons 'cons) -;;; (symbol 'symbol) -;;; (integer 'integer) -;;; (structure-object -;;; (structure-object-name x)) -;;; (t t))) +(defun coerce (object result-type) + "=> result" + (cond + ((typep object result-type) + object) + (t (error "Don't know how to coerce ~S to ~S." object result-type)))) - -;;;(defun subtypep (type-1 type-2) -;;; (cond -;;; ((eq type-1 type-2) -;;; t) -;;; ((or (atom type-1) (atom type-2)) -;;; nil) -;;; ((equal type-1 type-2) -;;; t) -;;; (t (case (car type-2) -;;; (integer -;;; (let ((low2 (second type-2)) -;;; (hi2 (third type-2))) -;;; (case (car type-1) -

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21589 Modified Files: basic-macros.lisp Log Message: Removed bogus compiler-macro for fifth. Date: Wed Jun 9 12:35:22 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.23 movitz/losp/muerte/basic-macros.lisp:1.24 --- movitz/losp/muerte/basic-macros.lisp:1.23 Wed Jun 9 10:23:16 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Jun 9 12:35:22 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.23 2004/06/09 17:23:16 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.24 2004/06/09 19:35:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -609,7 +609,6 @@ (define-compiler-macro second (x) `(cadr ,x)) (define-compiler-macro third (x) `(caddr ,x)) (define-compiler-macro fourth (x) `(cadddr ,x)) -(define-compiler-macro fifth (x) `(caddddr ,x)) (define-compiler-macro (setf car) (value cell &environment env) (if (and (movitz:movitz-constantp value env)

1 0

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

09 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7729 Modified Files: special-operators-cl.lisp Log Message: Quite a bit of cruft regarding register allocation etc. Still more work to do here, but I don't have time for it right now.. Date: Wed Jun 9 10:26:07 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.17 movitz/special-operators-cl.lisp:1.18 --- movitz/special-operators-cl.lisp:1.17 Tue Apr 13 09:55:08 2004 +++ movitz/special-operators-cl.lisp Wed Jun 9 10:26:07 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.17 2004/04/13 16:55:08 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.18 2004/06/09 17:26:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -212,14 +212,20 @@ :load t :store t)) rest-codes)))))) - ;; replace read-only lexical binding with the outer lexical binding - ;; (warn "replace ~S with outer ~S" var (second (first init-code))) - (change-class binding 'forwarding-binding - :target-binding (second (first init-code))) - nil) + ;; replace read-only binding with the outer binding + #+ignore (warn "replace ~S in ~S with outer ~S" + binding (binding-funobj binding) + (second (first init-code))) + (let ((target (second (first init-code)))) + (change-class binding 'forwarding-binding + :target-binding target) + `((:init-lexvar ,binding + :init-with-register ,target + :init-with-type ,target)))) ((and (typep binding 'located-binding) (type-specifier-singleton type) - (not (code-uses-binding-p body-code binding :load nil :store t))) + (not (code-uses-binding-p body-code binding + :load nil :store t))) ;; replace read-only lexical binding with ;; side-effect-free form #+ignore (warn "Constant binding: ~S => ~S => ~S"

1 0