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

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20384 Modified Files: typep.lisp Log Message: Made typep considerably smarter about the integer type. Date: Fri Apr 16 19:34:43 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.6 movitz/losp/muerte/typep.lisp:1.7 --- movitz/losp/muerte/typep.lisp:1.6 Tue Apr 6 20:17:19 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 19:34:43 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.6 2004/04/07 00:17:19 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -239,17 +239,70 @@ (when deriver-function `(typep ,object ',(funcall deriver-function))))))) ((consp type) - (case (car type) - ((not) - (assert (and (cadr type) (not (cddr type)))) - `(not (typep ,object ',(cadr type)))) - ((or and) - `(let ((typep-object ,object)) - (,(car type) - ,@(loop for subtype in (cdr type) - collect `(typep ,object ',subtype))))) - ((not and or) - (warn "typep compilermacro: ~S" type))))) + (let ((deriver-function (gethash (car type) *compiler-derived-typespecs*))) + (if deriver-function + `(typep ,object ',(apply deriver-function (cdr type))) + (case (car type) + ((integer) + (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) + (cdr type) + (let* ((min movitz:+movitz-most-negative-fixnum+) + (max movitz:+movitz-most-positive-fixnum+) + (lower-limit (if (eq lower-limit '*) min lower-limit)) + (upper-limit (if (eq upper-limit '*) max upper-limit))) + (assert (<= lower-limit upper-limit) () + "The lower limit of an integer type must be smaller than the upper limit.") + (cond + ((and (= lower-limit min) (= upper-limit max)) + `(typep ,object 'integer)) + ((= lower-limit upper-limit) + `(eql ,object ,lower-limit)) + ((and (= lower-limit 0) + (= 1 (logcount (1+ upper-limit)))) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,object) + (:testl ,(logxor #xffffffff + (* movitz:+movitz-fixnum-factor+ upper-limit)) + :eax))) + ((= 1 (logcount (1+ (- upper-limit lower-limit)))) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,object) + (:leal (:eax ,(* movitz:+movitz-fixnum-factor+ + (- lower-limit))) + :ecx) + (:testl ,(logxor #xffffffff + (* movitz:+movitz-fixnum-factor+ + (- upper-limit lower-limit))) + :ecx))) + ((= lower-limit 0) + `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (not-fixnum)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0 + (:jnz 'not-fixnum) + (:cmpl ,(* (1+ upper-limit) movitz:+movitz-fixnum-factor+) + :eax) + not-fixnum))) + (t `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (not-fixnum)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0 + (:jnz 'not-fixnum) + (:subl ,(* lower-limit movitz:+movitz-fixnum-factor+) :eax) + (:cmpl ,(* (- upper-limit lower-limit -1) + movitz:+movitz-fixnum-factor+) + :eax) + not-fixnum))))))) + ((not) + (assert (and (cadr type) (not (cddr type)))) + `(not (typep ,object ',(cadr type)))) + ((or and) + `(let ((typep-object ,object)) + (,(car type) + ,@(loop for subtype in (cdr type) + collect `(typep ,object ',subtype))))) + ((not and or) + (warn "typep compilermacro: ~S" type))))))) form))))) (defmacro define-typep (tname lambda &body body)

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29476 Modified Files: basic-macros.lisp Log Message: Make define-compile-time-variable behave more like defvar than defparameter. Date: Fri Apr 16 19:33:36 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.12 movitz/losp/muerte/basic-macros.lisp:1.13 --- movitz/losp/muerte/basic-macros.lisp:1.12 Fri Apr 16 15:25:11 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 19:33:36 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.12 2004/04/16 19:25:11 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.13 2004/04/16 23:33:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,9 +138,11 @@ (let ((the-value (eval value))) `(progn (eval-when (:compile-toplevel) - (defparameter ,name ',the-value) - (pushnew ',name (movitz::image-compile-time-variables movitz::*image*))) - (defparameter ,name ',the-value)))) + (defvar ,name) + (unless (member ',name (movitz::image-compile-time-variables movitz::*image*)) + (setf ,name ',the-value) + (push ',name (movitz::image-compile-time-variables movitz::*image*)))) + (defvar ,name 'uninitialized-compile-time-variable)))) (defmacro let* (var-list &body body) (labels ((expand (rest-vars body)

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12854 Modified Files: basic-macros.lisp Log Message: Re-wrote the check-type macro somewhat. It should require less code-size now. Date: Fri Apr 16 15:25:12 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.11 movitz/losp/muerte/basic-macros.lisp:1.12 --- movitz/losp/muerte/basic-macros.lisp:1.11 Fri Apr 16 14:55:07 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 15:25:11 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.11 2004/04/16 18:55:07 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.12 2004/04/16 19:25:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -520,13 +520,15 @@ `((:movw ,(dpb wide-other-tag (byte 8 8) (movitz::tag other-tag)) (:eax -2)))))) (defmacro check-type (place type &optional type-string) - (declare (ignore type-string)) - `(let ((place-value ,place)) - (unless (typep place-value ',type) - (error "Place ~A is not of type ~A, its value is {~Z}." - ',place ',type place-value)))) + (if (not (stringp type-string)) + `(let ((place-value ,place)) + (unless (typep place-value ',type) + (check-type-failed place-value ',type ',place))) + `(let ((place-value ,place)) + (unless (typep place-value ',type) + (check-type-failed place-value ',type ',place ,type-string))))) -(define-compiler-macro check-type (place type &optional type-string &environment env) +(define-compiler-macro check-type (&whole form place type &optional type-string &environment env) (declare (ignore type-string)) (cond ((movitz:movitz-constantp place env) @@ -538,10 +540,7 @@ `(unless (typep ,place ',type) (with-inline-assembly (:returns :non-local-exit) (:int 66))) - `(let ((place-value ,place)) - (unless (typep place-value ',type) - (error "Place ~A is not of type ~A, its value is ~Z." - ',place ',type place-value))))))) + form)))) (defmacro assert (test-form &optional places datum-form &rest argument-forms) (declare (ignore places))

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9750 Modified Files: basic-functions.lisp Log Message: Re-wrote the check-type macro somewhat. It should require less code-size now. Date: Fri Apr 16 15:25:06 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.10 movitz/losp/muerte/basic-functions.lisp:1.11 --- movitz/losp/muerte/basic-functions.lisp:1.10 Tue Apr 6 20:20:12 2004 +++ movitz/losp/muerte/basic-functions.lisp Fri Apr 16 15:25:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.10 2004/04/07 00:20:12 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.11 2004/04/16 19:25:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -369,5 +369,12 @@ (defun %word-offset (word offset) (%word-offset word offset)) - - +(defun check-type-failed (value type &optional place-name type-description) + (cond + ((and place-name type-description) + (error "The value of ~S, ~S, is not ~A." + place-name value type-description)) + (place-name + (error "The value of ~S, ~S, is not of type ~S." + place-name value type)) + (t (error "~S is not of type ~S." value type)))) \ No newline at end of file

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8308 Modified Files: symbols.lisp Log Message: Make %symbol-global-value a function, of course. Date: Fri Apr 16 15:24:20 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.9 movitz/losp/muerte/symbols.lisp:1.10 --- movitz/losp/muerte/symbols.lisp:1.9 Fri Apr 16 15:23:23 2004 +++ movitz/losp/muerte/symbols.lisp Fri Apr 16 15:24:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.9 2004/04/16 19:23:23 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.10 2004/04/16 19:24:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,8 +56,11 @@ (defun set (symbol value) (setf (symbol-value symbol) value)) -(defmacro %symbol-global-value (symbol) +(define-compiler-macro %symbol-global-value (symbol) `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp)) + +(defun %symbol-global-value (symbol) + (%symbol-global-value symbol)) (defun symbol-function (symbol) (let ((function-value

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17516 Modified Files: symbols.lisp Log Message: Removed function symbol-global-value, added macro %symbol-global-value. Date: Fri Apr 16 15:23:23 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.8 movitz/losp/muerte/symbols.lisp:1.9 --- movitz/losp/muerte/symbols.lisp:1.8 Wed Apr 14 16:03:38 2004 +++ movitz/losp/muerte/symbols.lisp Fri Apr 16 15:23:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.8 2004/04/14 20:03:38 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.9 2004/04/16 19:23:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,13 +56,8 @@ (defun set (symbol value) (setf (symbol-value symbol) value)) -(defun symbol-global-value (symbol) - (if symbol - (let ((x (movitz-accessor symbol movitz-symbol value))) - (if (eq x (load-global-constant unbound-value)) - (error 'unbound-value :name symbol) - x)) - nil)) +(defmacro %symbol-global-value (symbol) + `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp)) (defun symbol-function (symbol) (let ((function-value

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1445 Modified Files: integers.lisp Log Message: Minor typo. Date: Fri Apr 16 15:22:21 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.6 movitz/losp/muerte/integers.lisp:1.7 --- movitz/losp/muerte/integers.lisp:1.6 Thu Apr 15 09:10:37 2004 +++ movitz/losp/muerte/integers.lisp Fri Apr 16 15:22:21 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.6 2004/04/15 13:10:37 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.7 2004/04/16 19:22:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1088,7 +1088,7 @@ '(integer 0)) ((typep size '(integer 1 *)) (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for signed-byte.")))) + (t (error "Illegal size for unsigned-byte.")))) (define-simple-typep (bit bitp) (x) (or (eq x 0) (eq x 1)))

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9718 Modified Files: eval.lisp Log Message: We can use symbol-value to evaluate constant variables, I believe. Date: Fri Apr 16 15:21:51 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.6 movitz/losp/muerte/eval.lisp:1.7 --- movitz/losp/muerte/eval.lisp:1.6 Thu Apr 15 09:16:28 2004 +++ movitz/losp/muerte/eval.lisp Fri Apr 16 15:21:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.6 2004/04/15 13:16:28 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.7 2004/04/16 19:21:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,7 +49,7 @@ (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" (if (symbol-constant-variable-p form) - (symbol-global-value form) + (symbol-value form) (let ((binding (env-binding env form))) (or (and binding (cdr binding)) (symbol-value form)))))

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11392 Modified Files: packages.lisp Log Message: More symbols. Date: Fri Apr 16 15:21:13 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.18 movitz/packages.lisp:1.19 --- movitz/packages.lisp:1.18 Fri Apr 16 10:43:44 2004 +++ movitz/packages.lisp Fri Apr 16 15:21:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.18 2004/04/16 14:43:44 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.19 2004/04/16 19:21:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1149,6 +1149,9 @@ #:%run-time-context-slot #:shallow-copy + #:%symbol-global-value + #:define-global-variable + vector-element-type vector-element-size with-subvector-accessor @@ -1303,7 +1306,9 @@ #:code-vector%3op #:code-vector-word #:lu32 - + + #:+movitz-most-positive-fixnum+ + #:+movitz-most-negative-fixnum+ #:+movitz-fixnum-factor+ #:+movitz-fixnum-shift+ #:+movitz-fixnum-zmask+

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19582 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug that would let two function parameters be assigned to the same register. By some weird accident this bug didn't seem to do much actual harm, but the potential was certainly there. Date: Fri Apr 16 15:20:46 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.48 movitz/compiler.lisp:1.49 --- movitz/compiler.lisp:1.48 Thu Apr 15 15:58:20 2004 +++ movitz/compiler.lisp Fri Apr 16 15:20:46 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.48 2004/04/15 19:58:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.49 2004/04/16 19:20:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2451,11 +2451,13 @@ (destructuring-bind (binding &key init-with-register init-with-type protect-registers protect-carry) (cdr i) - (declare (ignore binding protect-carry init-with-type)) + (declare (ignore protect-carry init-with-type)) (when init-with-register (setf free-so-far (remove-if (lambda (x) - (or (eq x init-with-register) - (member x protect-registers))) + (if (new-binding-located-p binding frame-map) + (eq x (new-binding-location binding frame-map)) + (or (eq x init-with-register) + (member x protect-registers)))) free-so-far))))) (t (case (instruction-is i) ((nil :call) @@ -2476,8 +2478,7 @@ (remove-if (lambda (r) (tree-search i r)) free-so-far))) - ((:load-constant :load-lexical :store-lexical :init-lexvar - :cons-get :endp :incf-lexvar) + ((:load-constant :load-lexical :store-lexical :cons-get :endp :incf-lexvar :init-lexvar) (assert (gethash (instruction-is i) *extended-code-expanders*)) (unless (can-expand-extended-p i frame-map) (return (values nil t))) @@ -3764,6 +3765,9 @@ (and (edx-var env) (new-binding-location (edx-var env) frame-map :default nil)))) ;; (warn "l0: ~S, l1: ~S" location-0 location-1) + (assert (not (and location-0 + (eql location-0 location-1))) () + "Compiler bug: two bindings in same location.") (cond ((and (eq :ebx location-0) (eq :eax location-1)) `((:xchgl :eax :ebx)))

1 0