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

[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

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.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-serv18714 Modified Files: los-closette-compiler.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:22 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.11 movitz/losp/muerte/los-closette-compiler.lisp:1.12 --- movitz/losp/muerte/los-closette-compiler.lisp:1.11 Sun Feb 15 08:17:55 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Apr 19 18:38:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.11 2004/02/15 13:17:55 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.12 2004/04/19 22:38:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,13 +611,13 @@ :direct-superclasses direct-superclasses) class)) - (defun movitz-make-instance (metaclass &rest all-keys) - ;; (warn "movitz-make-instance: ~S ~S" metaclass all-keys) - (when (symbolp metaclass) - (setf metaclass (movitz-find-class metaclass))) - (if (eq metaclass (movitz-find-class 'funcallable-standard-class nil)) - (apply 'movitz-make-instance-funcallable metaclass all-keys) - (let ((instance (std-allocate-instance metaclass))) + (defun movitz-make-instance (class &rest all-keys) + ;; (warn "movitz-make-instance: ~S ~S" class all-keys) + (when (symbolp class) + (setf class (movitz-find-class class))) + (if (eq class (movitz-find-class 'funcallable-standard-class nil)) + (apply 'movitz-make-instance-funcallable class all-keys) + (let ((instance (std-allocate-instance class))) (dolist (slot (class-slots (movitz-class-of instance))) (let ((slot-name (slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.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-serv18506 Modified Files: defstruct.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:17 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.6 movitz/losp/muerte/defstruct.lisp:1.7 --- movitz/losp/muerte/defstruct.lisp:1.6 Sun Apr 18 19:16:49 2004 +++ movitz/losp/muerte/defstruct.lisp Mon Apr 19 18:38:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.6 2004/04/18 23:16:49 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.7 2004/04/19 22:38:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,7 +294,11 @@ (slot-number ,slot-number))) (defclass ,struct-name (structure-object) () (:metaclass structure-class) - (:slots ,canonical-slot-descriptions)) + (:slots ,(loop for (name) in canonical-slot-descriptions + as location upfrom 0 + collect (movitz-make-instance 'structure-slot-definition + :name name + :location location)))) ',struct-name)) (list `(progn @@ -332,10 +336,3 @@ (defun structure-object-name (x) (movitz-accessor x movitz-struct name)) -(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))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.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-serv18312 Modified Files: common-lisp.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:12 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.5 movitz/losp/muerte/common-lisp.lisp:1.6 --- movitz/losp/muerte/common-lisp.lisp:1.5 Sun Apr 18 19:17:04 2004 +++ movitz/losp/muerte/common-lisp.lisp Mon Apr 19 18:38:11 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.5 2004/04/18 23:17:04 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.6 2004/04/19 22:38:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -34,6 +34,7 @@ (require :muerte/inspect) (require :muerte/strings) (require :muerte/print) +(require :muerte/los-closette) (require :muerte/defstruct) (require :muerte/hash-tables) (require :muerte/packages) @@ -41,7 +42,6 @@ (require :muerte/error) (require :muerte/loop) (require :muerte/eval) -(require :muerte/los-closette) (require :muerte/environment) (require :muerte/streams) (require :muerte/restarts)

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18707 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug that would overwrite one function-argument with another in certain instances. Date: Mon Apr 19 16:34:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.55 movitz/compiler.lisp:1.56 --- movitz/compiler.lisp:1.55 Mon Apr 19 11:02:53 2004 +++ movitz/compiler.lisp Mon Apr 19 16:34:55 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.55 2004/04/19 15:02:53 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.56 2004/04/19 20:34:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3763,10 +3763,7 @@ (let ((required-vars (required-vars env)) (min-args (min-args env)) (max-args (max-args env))) - (let (#+ignore (max-used-arg (loop for (binding) in frame-map - when (typep binding 'positional-function-argument) - maximize (function-argument-argnum binding))) - (stack-setup-size stack-frame-size) + (let ((stack-setup-size stack-frame-size) (edx-needs-saving-p (and (edx-var env) (new-binding-location (edx-var env) frame-map :default nil)))) (multiple-value-bind (eax-ebx-code eax-ebx-code-post-stackframe) @@ -3830,8 +3827,8 @@ after-code `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:movl :eax (:ebp ,(stack-frame-offset + :edx) + (:movl :edx (:ebp ,(stack-frame-offset (new-binding-location binding frame-map))))))))))) (values before-code after-code))) (t (values (append @@ -3877,10 +3874,11 @@ append `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:movl :eax (:ebp ,(stack-frame-offset + :edx) + (:movl :edx (:ebp ,(stack-frame-offset (new-binding-location binding frame-map))))) - and do (setq need-normalized-ecx-p t)))))) + and do + (setq need-normalized-ecx-p t)))))) (assert (not (minusp stack-setup-size))) (let ((stack-frame-init-code (append (when (and do-check-stack-p use-stack-frame-p @@ -3889,9 +3887,9 @@ `((,*compiler-local-segment-prefix* :bound (:edi ,(global-constant-offset 'stack-bottom)) :esp))) (when use-stack-frame-p - `((:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi)))))) + `((:pushl :ebp) + (:movl :esp :ebp) + (:pushl :esi)))))) (values (append (cond @@ -4002,7 +4000,7 @@ (:movl :edi (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position))) :edx) (:movl :edx (:ebp ,(stack-frame-offset location)))))))))) - need-normalized-ecx-p)))))) + need-normalized-ecx-p)))))) (defparameter *restify-stats* (make-hash-table :test #'eql))

1 0