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

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

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11406 Modified Files: image.lisp Log Message: Minor edit. Date: Wed Apr 21 11:06:50 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.26 movitz/image.lisp:1.27 --- movitz/image.lisp:1.26 Mon Apr 19 11:06:21 2004 +++ movitz/image.lisp Wed Apr 21 11:06:50 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.26 2004/04/19 15:06:21 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.27 2004/04/21 15:06:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -549,7 +549,8 @@ muerte:run-time-context muerte.mop:standard-effective-slot-definition muerte.mop:funcallable-standard-class - muerte:basic-restart)) + muerte:basic-restart + muerte:illegal-object)) (defun class-object-offset (name) (+ (bt:slot-offset 'movitz-vector 'data)

1 0

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

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10632 Modified Files: compiler.lisp Log Message: Removed bad check-type. Date: Wed Apr 21 11:06:16 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.57 movitz/compiler.lisp:1.58 --- movitz/compiler.lisp:1.57 Tue Apr 20 19:04:12 2004 +++ movitz/compiler.lisp Wed Apr 21 11:06:16 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.57 2004/04/20 23:04:12 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.58 2004/04/21 15:06:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5831,7 +5831,6 @@ (define-extended-code-expander :endp (instruction funobj frame-map) (destructuring-bind (cell result-mode) (cdr instruction) - (check-type cell lexical-binding) (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) (location (new-binding-location (binding-target binding) frame-map)) (binding-is-list-p (binding-store-subtypep binding 'list)) @@ -5844,11 +5843,6 @@ (member location '(:eax :ebx :ecx :edx))) (make-result-and-returns-glue result-mode :boolean-zf=1 `((:cmpl :edi ,location)))) -;;; ((and binding-is-list-p -;;; (eq (result-mode-type result-mode) -;;; :boolean-branch-on-false)) -;;; (cond -;;; ((member location '(:eax :ebx :ecx :edx)) ((eq :boolean-branch-on-true (result-mode-type result-mode)) (let ((tmp-register (or tmp-register :ecx))) (append (make-load-lexical binding

1 0

[movitz-cvs] CVS update: movitz/assembly-syntax.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8352 Modified Files: assembly-syntax.lisp Log Message: Make assembly-macroexpand not barf on non-proper lists. Date: Wed Apr 21 11:05:40 2004 Author: ffjeld Index: movitz/assembly-syntax.lisp diff -u movitz/assembly-syntax.lisp:1.2 movitz/assembly-syntax.lisp:1.3 --- movitz/assembly-syntax.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/assembly-syntax.lisp Wed Apr 21 11:05:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 17:34:37 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: assembly-syntax.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: assembly-syntax.lisp,v 1.3 2004/04/21 15:05:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,29 +25,21 @@ (setf (gethash symbol (assembly-macro-environment-expanders amenv)) expander)) -;;;(defun assembly-macroexpand (prg amenv) -;;; (cond -;;; ((and (consp prg) (symbolp (car prg))) -;;; (let ((expander (assembly-macro-expander (car prg) amenv))) -;;; (if expander -;;; (assembly-macroexpand (funcall expander prg) amenv) -;;; #0=(cons (assembly-macroexpand (car prg) amenv) -;;; (assembly-macroexpand (cdr prg) amenv))))) -;;; ((consp prg) #0#) -;;; (t prg))) - (defun assembly-macroexpand (prg amenv) - (loop for p in prg - as expander = (and (consp p) - (symbolp (car p)) - (assembly-macro-expander (car p) amenv)) - if expander - append (funcall expander p) - else if (consp p) - append (list (assembly-macroexpand p amenv)) - else append (list p))) - -;;;(defmacro with-assembly-syntax (&body body) -;;; `(let ((*readtable* (copy-readtable nil))) -;;; (set-dispatch-macro-character + (let* ((fix-tail nil) + (new-prg + (loop for (p . tail) on prg + as expander = (and (consp p) + (symbolp (car p)) + (assembly-macro-expander (car p) amenv)) + if expander + append (funcall expander p) + else if (consp p) + append (list (assembly-macroexpand p amenv)) + else append (list p) + unless (listp tail) + do (setf fix-tail tail)))) + (when fix-tail + (setf (cdr (last new-prg)) fix-tail)) + new-prg))

1 0

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

21 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26391 Modified Files: symbols.lisp Log Message: Fixed a horrible bug in %create-symbol. Date: Wed Apr 21 10:00:16 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.11 movitz/losp/muerte/symbols.lisp:1.12 --- movitz/losp/muerte/symbols.lisp:1.11 Fri Apr 16 19:36:40 2004 +++ movitz/losp/muerte/symbols.lisp Wed Apr 21 10:00:15 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.11 2004/04/16 23:36:40 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.12 2004/04/21 14:00:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -149,7 +149,9 @@ (let ((symbol (%word-offset (malloc-clumps 3) 1))) (setf-movitz-accessor (symbol movitz-symbol package) package) (setf-movitz-accessor (symbol movitz-symbol name) name) - (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name)) + (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key) + 0 :unsigned-byte16) + (sxhash name)) (setf (symbol-flags symbol) flags (symbol-plist symbol) plist (symbol-function symbol) function

1 0

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

20 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8128 Modified Files: compiler.lisp Log Message: Worked on the peephole optimizer a bit. Date: Tue Apr 20 19:04:12 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.56 movitz/compiler.lisp:1.57 --- movitz/compiler.lisp:1.56 Mon Apr 19 16:34:55 2004 +++ movitz/compiler.lisp Tue Apr 20 19:04:12 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.56 2004/04/19 20:34:55 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.57 2004/04/20 23:04:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1417,7 +1417,6 @@ (and (or (not dest) (equal dest (second (twop-p c op)))) (first (twop-p c op))))) - #+ignore (isrc (c) (let ((c (ignore-instruction-prefixes c))) (ecase (length (cdr c)) @@ -1486,6 +1485,25 @@ (and (member register '(:edx)) (member (global-funcall-p i) '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))))))) + (operand-register-indirect-p (operand register) + (and (consp operand) + (tree-search operand register))) + (doesnt-read-register-p (i register) + (let ((i (ignore-instruction-prefixes i))) + (or (symbolp i) + (and (simple-instruction-p i) + (if (member (instruction-is i) '(:movl)) + (and (not (eq register (twop-src i))) + (not (operand-register-indirect-p (twop-src i) register)) + (not (operand-register-indirect-p (twop-dst i) register))) + (not (or (eq register (isrc i)) + (operand-register-indirect-p (isrc i) register) + (eq register (idst i)) + (operand-register-indirect-p (idst i) register))))) + (instruction-is i :frame-map) + (and (member register '(:edx)) + (member (global-funcall-p i) + '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))))) (register-operand (op) (and (member op '(:eax :ebx :ecx :edx :edi)) op)) @@ -1901,6 +1919,43 @@ (append (list i3 i i2) `((:movl ,reg ,(twop-dst i3))))) next-pc (cdddr pc)))) + ;; ((:movl <foo> <bar>) label (:movl <zot> <bar>)) + ;; => (label (:movl <zot> <bar>)) + ((and (instruction-is i :movl) + (or (symbolp i2) + (and (not (branch-instruction-label i2)) + (symbolp (twop-dst i)) + (doesnt-read-register-p i2 (twop-dst i)))) + (instruction-is i3 :frame-map) + (instruction-is i4 :movl) + (equal (twop-dst i) (twop-dst i4)) + (not (and (symbolp (twop-dst i)) + (operand-register-indirect-p (twop-src i4) + (twop-dst i))))) + (setq p (list i2 i3 i4) + next-pc (nthcdr 4 pc)) + (explain nil "Removed redundant store before ~A: ~A" + i2 (subseq pc 0 4))) + ((and (instruction-is i :movl) + (not (branch-instruction-label i2)) + (symbolp (twop-dst i)) + (doesnt-read-register-p i2 (twop-dst i)) + (instruction-is i3 :movl) + (equal (twop-dst i) (twop-dst i3)) + (not (and (symbolp (twop-dst i)) + (operand-register-indirect-p (twop-src i3) + (twop-dst i))))) + (setq p (list i2 i3) + next-pc (nthcdr 3 pc)) + (explain nil "Removed redundant store before ~A: ~A" + i2 (subseq pc 0 3))) + ((and (member (instruction-is i) + '(:cmpl :cmpb :cmpw :testl :testb :testw)) + (member (instruction-is i2) + '(:cmpl :cmpb :cmpw :testl :testb :testw))) + (setq p (list i2) + next-pc (nthcdr 2 pc)) + (explain nil "Trimmed double test: ~A" (subseq pc 0 4))) ;; ((:jmp x) ...(no labels).... x ..) ;; => (x ...) ((let ((x (branch-instruction-label i t nil))) @@ -1940,7 +1995,9 @@ (null (find-branches-to-label unoptimized-code i)) (not (member i keep-labels))) (setq p nil - next-pc (cdr pc)) + next-pc (if (instruction-is i2 :frame-map) + (cddr pc) + (cdr pc))) (explain nil "unused label: ~S" i)) ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label) ((and (branch-instruction-label i)

1 0

[movitz-cvs] CVS update: binary-types/binary-types.lisp
by Frode Vatvedt Fjeld 20 Apr '04

20 Apr '04

Update of /project/movitz/cvsroot/binary-types In directory common-lisp.net:/tmp/cvs-serv11619 Modified Files: binary-types.lisp Log Message: I think I simply forgot to check in this. Maybe this fixes the problem with binary-types and CMUCL. Date: Tue Apr 20 04:32:50 2004 Author: ffjeld Index: binary-types/binary-types.lisp diff -u binary-types/binary-types.lisp:1.2 binary-types/binary-types.lisp:1.3 --- binary-types/binary-types.lisp:1.2 Thu Jan 15 08:18:29 2004 +++ binary-types/binary-types.lisp Tue Apr 20 04:32:50 2004 @@ -1,7 +1,7 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 200120001999, 2003-2004, -;;;; Department of Computer Science, University of Tromsø, Norway +;;;; Copyright (C) 1999-2004, +;;;; Department of Computer Science, University of Tromsoe, Norway ;;;; ;;;; Filename: binary-types.lisp ;;;; Description: Reading and writing of binary data in streams. @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 19 18:53:57 1999 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: binary-types.lisp,v 1.2 2004/01/15 13:18:29 ffjeld Exp $ +;;;; $Id: binary-types.lisp,v 1.3 2004/04/20 08:32:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -421,14 +421,15 @@ ;;;(defun record-slot-type (s) (second s)) ;;;(defun record-slot-on-write (s) (third s)) -(defstruct record-slot - name - type - map-write - map-read - map-read-delayed - hidden-read-slot - tags) ; for map-read-delayed, the binary value is stored here. +(eval-when (:load-toplevel :compile-toplevel) + (defstruct record-slot + name + type + map-write + map-read + map-read-delayed + hidden-read-slot + tags)) ; for map-read-delayed, the binary value is stored here. (defmethod make-load-form ((object record-slot) &optional environment) (declare (ignore environment))

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv5558 Added Files: harddisk.lisp Log Message: Added Date: Mon Apr 19 18:55:55 2004 Author: ffjeld

1 0

[movitz-cvs] CVS update: Directory change: movitz/losp/tmp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv12844/tmp Log Message: Directory /project/movitz/cvsroot/movitz/losp/tmp added to the repository Date: Mon Apr 19 18:49:16 2004 Author: ffjeld New directory movitz/losp/tmp added

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19977 Modified Files: more-macros.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:33 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.6 movitz/losp/muerte/more-macros.lisp:1.7 --- movitz/losp/muerte/more-macros.lisp:1.6 Mon Apr 19 16:01:08 2004 +++ movitz/losp/muerte/more-macros.lisp Mon Apr 19 18:38:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.6 2004/04/19 20:01:08 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.7 2004/04/19 22:38:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,6 +292,14 @@ (defmacro ignore-errors (&body body) `(handler-case (progn ,@body) (error (c) (values nil c)))) + +(defmacro with-accessors (slot-entries instance-form &body declarations-and-forms) + (let ((instance-variable (gensym "with-accessors-instance-"))) + `(let ((,instance-variable ,instance-form)) + (declare (ignorable ,instance-variable)) + (symbol-macrolet ,(loop for (variable-name accessor-name) in slot-entries + collecting `(,variable-name (,accessor-name ,instance-variable))) + ,@declarations-and-forms)))) (defmacro with-slots (slot-entries instance-form &body declarations-and-forms) (let ((object-var (gensym "with-slots-object-")))

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19745 Modified Files: los-closette.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:27 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.8 movitz/losp/muerte/los-closette.lisp:1.9 --- movitz/losp/muerte/los-closette.lisp:1.8 Mon Apr 19 11:06:32 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Apr 19 18:38:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.8 2004/04/19 15:06:32 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.9 2004/04/19 22:38:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1129,7 +1129,14 @@ (defclass structure-class (class) ((slots :initarg :slots - :accessor structure-slots))) + :reader class-slots))) + +(defclass structure-slot-definition (slot-definition) + ((name + :initarg :name) + (location + :initarg :location + :reader structure-slot-location))) (defclass structure-object (t) () (:metaclass structure-class)) @@ -1303,14 +1310,14 @@ (values (slot-missing class object slot-name 'slot-value)) (slot-value-using-class class object slot)))) -(defmethod slot-value-using-class ((class standard-class) object (slot standard-effective-slot-definition)) +(defmethod slot-value-using-class ((class standard-class) object + (slot standard-effective-slot-definition)) (let ((x (standard-instance-access object (slot-definition-location slot)))) (if (eq x (load-global-constant unbound-value)) (slot-unbound class object (slot-definition-name slot)) x))) -(defmethod slot-value-using-class ((class funcallable-standard-class) - object +(defmethod slot-value-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) (let* ((location (slot-definition-location slot)) (slots (std-gf-instance-slots object)) @@ -1319,6 +1326,9 @@ (slot-unbound class object (slot-definition-name slot)) val))) +(defmethod slot-value-using-class ((class structure-class) object slot) + (structure-ref object (structure-slot-location slot))) + (defun (setf slot-value) (new-value object slot-name) (let* ((class (class-of object)) (slot (find-slot class slot-name))) @@ -1339,6 +1349,9 @@ (slots (std-gf-instance-slots object))) (setf (svref slots location) new-value))) +(defmethod (setf slot-value-using-class) (new-value (class structure-class) object slot) + (setf (structure-ref object (structure-slot-location slot)) new-value)) + (defun slot-boundp (object slot-name) (let* ((class (class-of object)) (slot (find-slot class slot-name))) @@ -1676,13 +1689,12 @@ object) (defmethod print-object ((object structure-object) stream) - (let* ((class (class-of object)) - (slots (mapcar #'car (slot-value class 'slots))) - (position 0)) + (let* ((class (class-of object))) (format stream "#S(~S" (class-name class)) - (dolist (slot slots) - (format stream " :~A ~S" slot (structure-ref object position)) - (incf position)) + (dolist (slot (class-slots class)) + (format stream " :~A ~S" + (symbol-name (slot-definition-name slot)) + (structure-ref object (structure-slot-location slot)))) (write-string ")" stream)) object)

1 0