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

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15543 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Thu Jun 16 22:55:42 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.146 movitz/compiler.lisp:1.147 --- movitz/compiler.lisp:1.146 Thu Jun 16 10:46:04 2005 +++ movitz/compiler.lisp Thu Jun 16 22:55:42 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.146 2005/06/16 08:46:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.147 2005/06/16 20:55:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5564,14 +5564,6 @@ (types (list* (type-specifier-primary (compiler-values-getf all0 :type)) (type-specifier-primary (compiler-values-getf all1 :type)) (nreverse arguments-types)))) - #+ignore - (when (and (= 4 (length argument-forms)) - (string= "WINDOW-TREE" (first argument-forms))) - (warn "final0: ~s, f1: ~S, typ: ~S, asep: ~S, aall: ~S" - final0 final1 - types - arguments-self-evaluating-p - arguments-are-load-lexicals-p)) (cond ((or arguments-self-evaluating-p (and (typep final0 'lexical-binding) @@ -5585,15 +5577,6 @@ ((and arguments-are-load-lexicals-p (typep final0 '(or lexical-binding movitz-object)) (typep final1 '(or lexical-binding movitz-object))) - (values (append arguments-code code01) - (+ -2 (length argument-forms)) - nil - types - arguments-functional-p)) - ((and (typep final0 '(or lexical-binding movitz-object)) - (typep final1 '(or lexical-binding movitz-object)) - (not (modifies-member final0 arguments-modifies)) - (not (modifies-member final1 arguments-modifies))) (values (append arguments-code code01) (+ -2 (length argument-forms)) nil

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp
by ffjeld＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8346 Modified Files: hash-tables.lisp Log Message: Various tweaks to several hash functions. Date: Thu Jun 16 12:00:52 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.7 movitz/losp/muerte/hash-tables.lisp:1.8 --- movitz/losp/muerte/hash-tables.lisp:1.7 Tue Jun 14 01:00:25 2005 +++ movitz/losp/muerte/hash-tables.lisp Thu Jun 16 12:00:51 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.7 2005/06/13 23:00:25 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.8 2005/06/16 10:00:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,20 +49,11 @@ :sxhash sxhash :count 0))) -;;;(defun hash-table-count (hash-table) -;;; (do* ((bucket (hash-table-bucket hash-table)) -;;; (length (length bucket)) -;;; (count 0) -;;; (i 0 (+ i 2))) -;;; ((>= i length) count) -;;; (unless (eq (svref bucket i) '--no-hash-key--) -;;; (incf count)))) - (defun hash-table-iterator (bucket index) (when index (do ((length (array-dimension bucket 0))) ((>= index length) nil) - (unless (eq (svref bucket index) '--no-hash-key--) + (unless (eq (svref%unsafe bucket index) '--no-hash-key--) (return (+ index 2))) (incf index 2)))) @@ -75,8 +66,8 @@ `(when (setq ,',bucket-index-var (hash-table-iterator ,',bucket-var ,',bucket-index-var)) (values t - (svref ,',bucket-var (- ,',bucket-index-var 2)) - (svref ,',bucket-var (- ,',bucket-index-var 1)))))) + (svref%unsafe ,',bucket-var (- ,',bucket-index-var 2)) + (svref%unsafe ,',bucket-var (- ,',bucket-index-var 1)))))) ,@declarations-and-body)))) (defun sxhash-subvector (vector start end &optional (limit 8)) @@ -114,7 +105,8 @@ (typecase object (null 0) (symbol - (movitz-accessor-u16 object movitz-symbol hash-key)) + (memref object (movitz-type-slot-offset 'movitz-symbol 'hash-key) + :type :unsigned-byte16)) (t (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) object) (:andl #.(cl:logxor #xffffffff movitz::+movitz-fixnum-zmask+) :eax))))) @@ -128,6 +120,7 @@ (bucket-length (length bucket)) (start-i2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)) (i2 start-i2)) + (declare (type index i2)) (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond @@ -179,10 +172,8 @@ (do* ((test (hash-table-test hash-table)) (bucket (hash-table-bucket hash-table)) (bucket-length (length bucket)) - (index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)) - (c 2 (+ c 2))) - ((>= c bucket-length) - (error "Hash-table bucket is full, needs rehashing, which isn't implemented.")) + (index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length))) + (nil) (let ((k (svref%unsafe bucket index2))) (cond ((eq k '--no-hash-key--) @@ -262,15 +253,17 @@ (do* ((bucket (hash-table-bucket hash-table)) (bucket-length (length bucket)) (i 0 (+ i 2))) - ((>= i bucket-length) hash-table) - (setf (svref bucket i) '--no-hash-key--))) + ((>= i bucket-length)) + (setf (svref bucket i) '--no-hash-key--)) + hash-table) (defun maphash (function hash-table) - (with-hash-table-iterator (get-next-entry hash-table) - (do () (nil) - (multiple-value-bind (entry-p key value) - (get-next-entry) - (if (not entry-p) - (return nil) - (funcall function key value)))))) + (with-funcallable (map function) + (with-hash-table-iterator (get-next-entry hash-table) + (do () (nil) + (multiple-value-bind (entry-p key value) + (get-next-entry) + (if (not entry-p) + (return nil) + (map key value)))))))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3756 Modified Files: compiler.lisp Log Message: Be more clever about when function-arguments can be re-ordered. We were overly optimistic before, which could result in subtle bugs. Date: Thu Jun 16 10:46:04 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.145 movitz/compiler.lisp:1.146 --- movitz/compiler.lisp:1.145 Wed Jun 15 23:48:19 2005 +++ movitz/compiler.lisp Thu Jun 16 10:46:04 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.145 2005/06/15 21:48:19 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.146 2005/06/16 08:46:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5549,10 +5549,10 @@ (setf arguments-self-evaluating-p nil) (assert (eq :load-lexical (caar code)) () "comp-lex-var produced for ~S~% ~S" form code) - (pushnew (second code) arguments-lexical-variables)) + (pushnew (cadar code) arguments-lexical-variables)) (t (setf arguments-self-evaluating-p nil arguments-are-load-lexicals-p nil))) - code)))) + code)))) (multiple-value-bind (code01 functionalp01 modifies01 all0 all1) (make-compiled-two-forms-into-registers (first argument-forms) :eax (second argument-forms) :ebx @@ -5564,6 +5564,14 @@ (types (list* (type-specifier-primary (compiler-values-getf all0 :type)) (type-specifier-primary (compiler-values-getf all1 :type)) (nreverse arguments-types)))) + #+ignore + (when (and (= 4 (length argument-forms)) + (string= "WINDOW-TREE" (first argument-forms))) + (warn "final0: ~s, f1: ~S, typ: ~S, asep: ~S, aall: ~S" + final0 final1 + types + arguments-self-evaluating-p + arguments-are-load-lexicals-p)) (cond ((or arguments-self-evaluating-p (and (typep final0 'lexical-binding) @@ -5592,9 +5600,9 @@ types arguments-functional-p)) ((and arguments-are-load-lexicals-p - (not (operators-present-in-code-p code01 - '(:store-lexical) - arguments-lexical-variables))) + (not (some (lambda (arg-binding) + (code-uses-binding-p code01 arg-binding :store t :load nil)) + arguments-lexical-variables))) (values (append arguments-code code01) (+ -2 (length argument-forms)) nil

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 15 Jun '05

15 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28097 Modified Files: compiler.lisp Log Message: Don't use ECX as temporary storage for lisp-vals! Date: Wed Jun 15 23:48:19 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.144 movitz/compiler.lisp:1.145 --- movitz/compiler.lisp:1.144 Tue May 24 08:32:27 2005 +++ movitz/compiler.lisp Wed Jun 15 23:48:19 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.144 2005/05/24 06:32:27 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.145 2005/06/15 21:48:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3606,8 +3606,8 @@ (dest-location (new-binding-location destination frame-map :default nil))) (cond ((not dest-location) ; unknown, e.g. a borrowed-binding. - (append (install-for-single-value binding binding-location :ecx nil) - (make-store-lexical result-mode :ecx nil funobj frame-map))) + (append (install-for-single-value binding binding-location :edx nil) + (make-store-lexical result-mode :edx nil funobj frame-map))) ((equal binding-location dest-location) nil) ((member binding-location '(:eax :ebx :ecx :edx)) @@ -3655,6 +3655,8 @@ (if (not shared-reference-p) (let ((tmp-reg (chose-free-register protect-registers) #+ignore(if (eq source :eax) :ebx :eax))) + (when (eq :ecx source) + (break "loading a word from ECX?")) `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) ,tmp-reg) (:movl ,source (-1 ,tmp-reg))))

1 0

[movitz-cvs] CVS update: public_html/ChangeLog
by ffjeld＠common-lisp.net 13 Jun '05

13 Jun '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv18347 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jun 14 01:00:56 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.6 public_html/ChangeLog:1.7 --- public_html/ChangeLog:1.6 Sat Jun 11 01:17:17 2005 +++ public_html/ChangeLog Tue Jun 14 01:00:56 2005 @@ -1,3 +1,7 @@ +2005-06-14 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Added dynamic growing and rehashing of hash-tables. + 2005-06-11 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Started to add support for adjustable and displaced vectors.

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp
by ffjeld＠common-lisp.net 13 Jun '05

13 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18056 Modified Files: hash-tables.lisp Log Message: Improved hash-tables somewhat: dynamically grow and rehash. Also, decreased the hash-table-size of dumped hash-tables, which apparently decreased the image-size by 10%. Date: Tue Jun 14 01:00:26 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.6 movitz/losp/muerte/hash-tables.lisp:1.7 --- movitz/losp/muerte/hash-tables.lisp:1.6 Sun May 8 03:18:29 2005 +++ movitz/losp/muerte/hash-tables.lisp Tue Jun 14 01:00:25 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.6 2005/05/08 01:18:29 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.7 2005/06/13 23:00:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,7 +31,8 @@ (defstruct (hash-table (:constructor make-hash-table-object)) test bucket - sxhash) + sxhash + count) (defun make-hash-table (&key (test 'eql) (size 47) rehash-size rehash-threshold) (declare (ignore rehash-size rehash-threshold)) @@ -45,16 +46,17 @@ (make-hash-table-object :test test :bucket (make-array (* 2 size) :initial-element '--no-hash-key--) - :sxhash sxhash))) + :sxhash sxhash + :count 0))) -(defun hash-table-count (hash-table) - (do* ((bucket (hash-table-bucket hash-table)) - (length (length bucket)) - (count 0) - (i 0 (+ i 2))) - ((>= i length) count) - (unless (eq (svref bucket i) '--no-hash-key--) - (incf count)))) +;;;(defun hash-table-count (hash-table) +;;; (do* ((bucket (hash-table-bucket hash-table)) +;;; (length (length bucket)) +;;; (count 0) +;;; (i 0 (+ i 2))) +;;; ((>= i length) count) +;;; (unless (eq (svref bucket i) '--no-hash-key--) +;;; (incf count)))) (defun hash-table-iterator (bucket index) (when index @@ -182,12 +184,30 @@ ((>= c bucket-length) (error "Hash-table bucket is full, needs rehashing, which isn't implemented.")) (let ((k (svref%unsafe bucket index2))) - (when (or (eq k '--no-hash-key--) - (funcall test k key)) + (cond + ((eq k '--no-hash-key--) + (let ((new-count (1+ (hash-table-count hash-table)))) + (cond + ((>= (truncate (* new-count 8) 3) bucket-length) + ;; Rehash.. + (setf (hash-table-bucket hash-table) (make-array (* 2 (+ bucket-length 7)) + :initial-element '--no-hash-key--) + (hash-table-count hash-table) 0) + (do ((i 0 (+ i 2))) + ((>= i bucket-length)) + (let ((old-key (svref%unsafe bucket i))) + (unless (eq old-key '--no-hash-key--) + (setf (gethash old-key hash-table) + (svref%unsafe bucket (1+ i)))))) + (return (setf (gethash key hash-table) value))) + (t (return (setf (hash-table-count hash-table) new-count + (svref%unsafe bucket index2) key + (svref%unsafe bucket (1+ index2)) value)))))) + ((funcall test k key) (return (setf (svref%unsafe bucket index2) key - (svref%unsafe bucket (1+ index2)) value)))) - (when (>= (incf index2 2) bucket-length) - (setf index2 0)))) + (svref%unsafe bucket (1+ index2)) value))) + ((>= (incf index2 2) bucket-length) + (setf index2 0)))))) (defun gethash-string (key-string start end hash-table &optional default (key 'identity)) (let ((bucket (hash-table-bucket hash-table))) @@ -223,6 +243,7 @@ (when (or (eq x '--no-hash-key--) (funcall (hash-table-test hash-table) x key)) (setf (svref bucket index2) '--no-hash-key--) + (decf (hash-table-count hash-table)) ;; Now we must rehash any entries that might have been ;; displaced by the one we have now removed. (do ((i (rem (+ index2 2) bucket-length) @@ -237,6 +258,7 @@ (return t))))) (defun clrhash (hash-table) + (setf (hash-table-count hash-table) 0) (do* ((bucket (hash-table-bucket hash-table)) (bucket-length (length bucket)) (i 0 (+ i 2)))

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by ffjeld＠common-lisp.net 13 Jun '05

13 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17871 Modified Files: storage-types.lisp Log Message: Improved hash-tables somewhat: dynamically grow and rehash. Also, decreased the hash-table-size of dumped hash-tables, which apparently decreased the image-size by 10%. Date: Tue Jun 14 01:00:19 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.53 movitz/storage-types.lisp:1.54 --- movitz/storage-types.lisp:1.53 Fri Jun 10 00:18:55 2005 +++ movitz/storage-types.lisp Tue Jun 14 01:00:17 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.53 2005/06/09 22:18:55 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.54 2005/06/13 23:00:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1021,7 +1021,8 @@ (defun make-movitz-hash-table (lisp-hash) (let* ((undef (movitz-read +undefined-hash-key+)) - (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) + (hash-count (hash-table-count lisp-hash)) + (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count))))) (bucket-data (make-array hash-size :initial-element undef))) (multiple-value-bind (hash-test hash-sxhash) (ecase (hash-table-test lisp-hash) @@ -1044,18 +1045,20 @@ (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data)) (lh (make-instance 'movitz-struct :class (muerte::movitz-find-class 'muerte::hash-table) - :length 3 + :length 4 :slot-values (list hash-test ; test-function bucket - hash-sxhash)))) + hash-sxhash + hash-count)))) lh)))) (defmethod update-movitz-object ((movitz-hash movitz-struct) (lisp-hash hash-table)) "Keep <movitz-hash> in sync with <lisp-hash>." - (assert (= 3 (length (movitz-struct-slot-values movitz-hash)))) + (assert (= 4 (length (movitz-struct-slot-values movitz-hash)))) (let* ((undef (movitz-read +undefined-hash-key+)) (old-bucket (second (movitz-struct-slot-values movitz-hash))) - (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) + (hash-count (hash-table-count lisp-hash)) + (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count))))) (bucket-data (or (and old-bucket (= (length (movitz-vector-symbolic-data old-bucket)) hash-size) @@ -1082,7 +1085,8 @@ (svref bucket-data (1+ pos)) movitz-value))) (setf (first (movitz-struct-slot-values movitz-hash)) hash-test (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data) - (third (movitz-struct-slot-values movitz-hash)) hash-sxhash) + (third (movitz-struct-slot-values movitz-hash)) hash-sxhash + (fourth (movitz-struct-slot-values movitz-hash)) hash-count) movitz-hash))) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp
by ffjeld＠common-lisp.net 12 Jun '05

12 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19223 Modified Files: lists.lisp Log Message: Wrote copy-tree and changed tree-equal. Date: Sun Jun 12 23:27:08 2005 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.10 movitz/losp/muerte/lists.lisp:1.11 --- movitz/losp/muerte/lists.lisp:1.10 Fri Nov 19 21:13:44 2004 +++ movitz/losp/muerte/lists.lisp Sun Jun 12 23:27:07 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 20012000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: lists.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.10 2004/11/19 20:13:44 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.11 2005/06/12 21:27:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -140,17 +140,6 @@ (defun (setf nth) (value n list) (setf (car (nthcdr n list)) value)) - -(defun tree-equal (tree-1 tree-2 &key (test 'equal)) - (cond - ((atom tree-1) - (and (atom tree-2) - (funcall test tree-1 tree-2))) - ((atom tree-2) - nil) - (t (and (tree-equal (car tree-1) (car tree-2) :test test) - (tree-equal (cdr tree-1) (cdr tree-2) :test test))))) - (defun nconc (&rest lists) (declare (dynamic-extent lists))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp
by ffjeld＠common-lisp.net 12 Jun '05

12 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19205 Modified Files: cons.lisp Log Message: Wrote copy-tree and changed tree-equal. Date: Sun Jun 12 23:27:03 2005 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.10 movitz/losp/muerte/cons.lisp:1.11 --- movitz/losp/muerte/cons.lisp:1.10 Thu May 5 00:47:02 2005 +++ movitz/losp/muerte/cons.lisp Sun Jun 12 23:27:03 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.10 2005/05/04 22:47:02 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.11 2005/06/12 21:27:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -255,3 +255,19 @@ (:compile-form (:result-mode :eax) car) (:compile-form (:result-mode :ebx) cdr) (:call-local-pf fast-cons))) + +(defun copy-tree (tree) + (if (not (consp tree)) + tree + (cons (copy-tree (car tree)) + (copy-tree (cdr tree))))) + +(defun tree-equal (tree-1 tree-2 &key test test-not) + (labels ((te (tree-1 tree-2 test) + (if (not (consp tree-1)) + (funcall test tree-1 tree-2) + (if (not (consp tree-2)) + nil + (and (te (car tree-1) (car tree-2) test) + (te (cdr tree-1) (cdr tree-2) test)))))) + (te tree-1 tree-2 (or test (and test-not (complement test-not)) #'eql))))

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by ffjeld＠common-lisp.net 12 Jun '05

12 Jun '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv16407 Modified Files: los0-gc.lisp Log Message: Let's be more consistent. Date: Sun Jun 12 22:32:44 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.56 movitz/losp/los0-gc.lisp:1.57 --- movitz/losp/los0-gc.lisp:1.56 Sat Jun 11 02:01:09 2005 +++ movitz/losp/los0-gc.lisp Sun Jun 12 22:32:44 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.56 2005/06/11 00:01:09 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.57 2005/06/12 20:32:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (defvar *gc-running* nil) (defvar *gc-break* nil) (defvar *gc-trigger* nil) -(defvar *gc-consitency-check* t) +(defvar *gc-consistency-check* nil) (defmacro space-fresh-pointer (space) @@ -397,7 +397,7 @@ forwarded-x))) (let ((forward-x (shallow-copy x))) (when (and (typep x 'muerte::pointer) - *gc-consitency-check*) + *gc-consistency-check*) (let ((a *x*)) (vector-push (%object-lispval x) a) (vector-push (memref (object-location x) 0 :type :unsigned-byte32) a) @@ -425,7 +425,7 @@ x) nil (current-stack-frame)) - (when *gc-consitency-check* + (when *gc-consistency-check* (with-simple-restart (continue "Ignore failed GC consistency check.") (without-interrupts (let ((a *x*))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/strings.lisp
by ffjeld＠common-lisp.net 12 Jun '05

12 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14624 Modified Files: strings.lisp Log Message: Use char rather than schar, in general. Date: Sun Jun 12 22:01:49 2005 Author: ffjeld Index: movitz/losp/muerte/strings.lisp diff -u movitz/losp/muerte/strings.lisp:1.2 movitz/losp/muerte/strings.lisp:1.3 --- movitz/losp/muerte/strings.lisp:1.2 Mon Jan 19 12:23:47 2004 +++ movitz/losp/muerte/strings.lisp Sun Jun 12 22:01:49 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 17:05:25 2001 ;;;; -;;;; $Id: strings.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: strings.lisp,v 1.3 2005/06/12 20:01:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,7 @@ (do ((i start1 (1+ i)) (j start2 (1+ j))) ((>= i end1) t) - (unless (char= (schar string1 i) (schar string2 j)) + (unless (char= (char string1 i) (char string2 j)) (return nil))))) (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2) @@ -45,7 +45,7 @@ (do ((i start1 (1+ i)) (j start2 (1+ j))) ((>= i end1) t) - (unless (char-equal (schar string1 i) (schar string2 j)) + (unless (char-equal (char string1 i) (char string2 j)) (return nil))))) (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) @@ -69,16 +69,16 @@ (let* ((length (- end start)) (cased-string (make-string length))) (dotimes (i length) - (setf (schar cased-string i) - (char-upcase (schar string (+ i start))))) + (setf (char cased-string i) + (char-upcase (char string (+ i start))))) cased-string)) (defun string-downcase (string &key (start 0) (end (length string))) (let* ((length (- end start)) (cased-string (make-string length))) (dotimes (i length) - (setf (schar cased-string i) - (char-downcase (schar string (+ i start))))) + (setf (char cased-string i) + (char-downcase (char string (+ i start))))) cased-string)) (defun string-capitalize (string &key (start 0) end) @@ -90,8 +90,8 @@ (j 0 (1+ j)) (between-words-p t)) ((>= i end) capitalized-string) - (setf (schar capitalized-string j) - (let ((c (schar string i))) + (setf (char capitalized-string j) + (let ((c (char string i))) (cond ((and between-words-p (char-alpha-p c)) (setf between-words-p nil)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by ffjeld＠common-lisp.net 11 Jun '05

11 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16796 Modified Files: inspect.lisp Log Message: Rename copy-vector to shallow-copy-vector, and have it understand indirect-vectors. Should fix a GC issue. Date: Sat Jun 11 02:02:04 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.54 movitz/losp/muerte/inspect.lisp:1.55 --- movitz/losp/muerte/inspect.lisp:1.54 Sat Jun 11 01:07:07 2005 +++ movitz/losp/muerte/inspect.lisp Sat Jun 11 02:02:04 2005 @@ -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.54 2005/06/10 23:07:07 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.55 2005/06/11 00:02:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -257,7 +257,7 @@ (symbol (copy-symbol old t)) (vector - (copy-vector old)) + (shallow-copy-vector old)) (function (copy-funobj old)) (structure-object

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by ffjeld＠common-lisp.net 11 Jun '05

11 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16781 Modified Files: arrays.lisp Log Message: Rename copy-vector to shallow-copy-vector, and have it understand indirect-vectors. Should fix a GC issue. Date: Sat Jun 11 02:01:56 2005 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.52 movitz/losp/muerte/arrays.lisp:1.53 --- movitz/losp/muerte/arrays.lisp:1.52 Sat Jun 11 01:08:16 2005 +++ movitz/losp/muerte/arrays.lisp Sat Jun 11 02:01:56 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.52 2005/06/10 23:08:16 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.53 2005/06/11 00:01:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -176,23 +176,25 @@ "Vector has no fill-pointer.") (%basic-vector-fill-pointer vector)))) -(defun copy-vector (vector) - (check-type vector vector) +(defun shallow-copy-vector (vector) + (check-type vector (simple-array * 1)) (let ((length (the fixnum (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))) - (ecase (vector-element-type-code vector) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) - (%shallow-copy-object vector (+ 2 length))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) - (%shallow-copy-non-pointer-object vector (+ 2 length))) + (ecase (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type) + :type :unsigned-byte8) + ((#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) + #.(bt:enum-value 'movitz::movitz-vector-element-type :indirects)) + (%shallow-copy-object vector (+ 2 length))) + ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)) + (%shallow-copy-non-pointer-object vector (+ 2 length))) ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character) #.(bt:enum-value 'movitz::movitz-vector-element-type :u8) #.(bt:enum-value 'movitz::movitz-vector-element-type :code)) (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 3 length) 4)))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16) - (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 1 length) 2)))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit) - (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 31 length) 32))))))) + ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)) + (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 1 length) 2)))) + ((#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)) + (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 31 length) 32))))))) (defun (setf fill-pointer) (new-fill-pointer vector) (etypecase vector

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by ffjeld＠common-lisp.net 11 Jun '05

11 Jun '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv16751 Modified Files: los0-gc.lisp Log Message: Remove a restart. Date: Sat Jun 11 02:01:09 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.55 movitz/losp/los0-gc.lisp:1.56 --- movitz/losp/los0-gc.lisp:1.55 Sat Jun 11 01:05:44 2005 +++ movitz/losp/los0-gc.lisp Sat Jun 11 02:01:09 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.55 2005/06/10 23:05:44 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.56 2005/06/11 00:01:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -411,15 +411,14 @@ (dolist (range muerte::%memory-map-roots%) (map-header-vals evacuator (car range) (cdr range)))) ;; Scan newspace, Cheney style. - (with-simple-restart (nil "Cheney-scanning newspace.") - (loop with newspace-location = (+ 2 (object-location newspace)) - with scan-pointer = 2 - as fresh-pointer = (space-fresh-pointer newspace) - while (< scan-pointer fresh-pointer) - do (map-header-vals evacuator - (+ newspace-location scan-pointer) - (+ newspace-location (space-fresh-pointer newspace))) - (setf scan-pointer fresh-pointer))) + (loop with newspace-location = (+ 2 (object-location newspace)) + with scan-pointer = 2 + as fresh-pointer = (space-fresh-pointer newspace) + while (< scan-pointer fresh-pointer) + do (map-header-vals evacuator + (+ newspace-location scan-pointer) + (+ newspace-location (space-fresh-pointer newspace))) + (setf scan-pointer fresh-pointer)) ;; Consistency check.. (map-stack-vector (lambda (x foo) (declare (ignore foo))

1 0

[movitz-cvs] CVS update: public_html/index.html
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv14079 Modified Files: index.html Log Message: *** empty log message *** Date: Sat Jun 11 01:19:12 2005 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.24 public_html/index.html:1.25 --- public_html/index.html:1.24 Sat Jan 29 11:42:28 2005 +++ public_html/index.html Sat Jun 11 01:19:12 2005 @@ -15,6 +15,9 @@ <h3>Most recent news</h3> + <p> <i>June 11, 2005</i> Started to add support for threads (in the + "threading" package), and also for adjustable and displaced vectors. + <p> <i>January 29, 2005</i> The stack discipline and associated GC scavenging routines have been cleaned up, now hopefully work as they should, even in the corner cases when two interrupts occur in rapid @@ -28,17 +31,7 @@ just fine (mostly to do with CLisp having CL symbols with e.g. CLOS as home package). - <p> QEMU's NE2000 device seems to work ok with Movitz, both in ISA - and PCI modes. - - <p> <i>August 18, 2004:</i> Movitz finally runs in <a - href="http://fabrice.bellard.free.fr/qemu/">QEMU</a>, which is a very - nice x86 emulator. It uses some sort of JIT technique, so it's much - faster than Bochs. There was a bug in QEMU's (version 0.6.0) - emulation of the x86 <tt>bounds</tt> instruction, which didn't agree - with Movitz, and which is now fixed in QEMU's CVS. - - <p> For more news, see the <a + <p> For more and older news, see the <a href="ChangeLog"><tt>ChangeLog</tt></a>. <h3>Introduction</h3>

1 0

[movitz-cvs] CVS update: public_html/ChangeLog
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv14053 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Jun 11 01:17:18 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.5 public_html/ChangeLog:1.6 --- public_html/ChangeLog:1.5 Sun Apr 24 23:59:59 2005 +++ public_html/ChangeLog Sat Jun 11 01:17:17 2005 @@ -1,3 +1,7 @@ +2005-06-11 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Started to add support for adjustable and displaced vectors. + 2005-04-24 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Fixed a bug in the compilation of (values ...) for more than two

1 0

[movitz-cvs] CVS update: movitz/losp/lib/threading.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv13168 Modified Files: threading.lisp Log Message: Have segment-descriptor-table-manager use *gc-hooks* to deal with moving of descriptor-table. Date: Sat Jun 11 01:09:14 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.7 movitz/losp/lib/threading.lisp:1.8 --- movitz/losp/lib/threading.lisp:1.7 Mon May 9 00:05:13 2005 +++ movitz/losp/lib/threading.lisp Sat Jun 11 01:09:14 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.7 2005/05/08 22:05:13 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.8 2005/06/10 23:09:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,8 +33,11 @@ ((table :reader segment-descriptor-table :initarg :table - :initform (setf (muerte::global-segment-descriptor-table) - (muerte::dump-global-segment-table :entries 64))) + :initform (let ((table (muerte::dump-global-segment-table :entries 64))) + (push (lambda () + (setf (muerte::global-segment-descriptor-table) table)) + *gc-hooks*) + (setf (muerte::global-segment-descriptor-table) table))) (clients :initform (make-array 64)) (range-start

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13152 Modified Files: arrays.lisp Log Message: Make the with-subvector-accessors operator know about indirect-vectors. Date: Sat Jun 11 01:08:17 2005 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.51 movitz/losp/muerte/arrays.lisp:1.52 --- movitz/losp/muerte/arrays.lisp:1.51 Fri Jun 10 00:19:02 2005 +++ movitz/losp/muerte/arrays.lisp Sat Jun 11 01:08:16 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.51 2005/06/09 22:19:02 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.52 2005/06/10 23:08:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -644,9 +644,9 @@ ;;; fast vector access -(defun subvector-accessors (vector start end) +(defun subvector-accessors (vector &optional start end) "Check that vector is a vector, that start and end are within vector's bounds, -and return accessors for that subsequence (fast & unsafe accessors, that is)." +and return basic-vector and accessors for that subsequence." (when (and start end) (assert (<= 0 start end)) (assert (<= end (array-dimension vector 0)))) @@ -654,37 +654,37 @@ (indirect-vector (with-indirect-vector (indirect vector) (if (= 0 (indirect displaced-offset)) - (values #'aref #'(setf aref)) + (subvector-accessors (indirect displaced-to) start end) (let ((offset (indirect displaced-offset))) - (values (lambda (a i) (aref a (+ i offset))) + (values vector + (lambda (a i) (aref a (+ i offset))) (lambda (v a i) (setf (aref a (+ i offset)) v))))))) (vector (case (vector-element-type-code vector) (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) - (values #'svref%unsafe #'(setf svref%unsafe))) + (values vector #'svref%unsafe #'(setf svref%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :character) - (values #'char%unsafe #'(setf char%unsafe))) + (values vector #'char%unsafe #'(setf char%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8) - (values #'u8ref%unsafe #'(setf u8ref%unsafe))) + (values vector #'u8ref%unsafe #'(setf u8ref%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) - (values #'u32ref%unsafe #'(setf u32ref%unsafe))) + (values vector #'u32ref%unsafe #'(setf u32ref%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :code) - (values #'u8ref%unsafe #'(setf u8ref%unsafe))) + (values vector #'u8ref%unsafe #'(setf u8ref%unsafe))) (t (warn "don't know about vector's element-type: ~S" vector) - (values #'aref #'(setf aref))))))) + (values vector #'aref #'(setf aref))))))) (defmacro with-subvector-accessor ((name vector-form &optional start end) &body body) "Installs name as an accessor into vector-form, bound by start and end." (let ((reader (gensym "sub-vector-reader-")) (writer (gensym "sub-vector-writer-")) (vector (gensym "sub-vector-"))) - `(let ((,vector ,vector-form)) - (multiple-value-bind (,reader ,writer) - (subvector-accessors ,vector ,start ,end) - (declare (ignorable ,reader ,writer)) - (macrolet ((,name (index) - `(accessor%unsafe (,',reader ,',writer) ,',vector ,index))) - ,@body))))) + `(multiple-value-bind (,vector ,reader ,writer) + (subvector-accessors ,vector-form ,start ,end) + (declare (ignorable ,reader ,writer)) + (macrolet ((,name (index) + `(accessor%unsafe (,',reader ,',writer) ,',vector ,index))) + ,@body)))) (defmacro accessor%unsafe ((reader writer) &rest args) (declare (ignore writer))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13134 Modified Files: inspect.lisp Log Message: vector-u16 and vector-u32 are obsolete. Date: Sat Jun 11 01:07:07 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.53 movitz/losp/muerte/inspect.lisp:1.54 --- movitz/losp/muerte/inspect.lisp:1.53 Thu May 5 22:52:02 2005 +++ movitz/losp/muerte/inspect.lisp Sat Jun 11 01:07:07 2005 @@ -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.53 2005/05/05 20:52:02 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.54 2005/06/10 23:07:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,13 +388,13 @@ (+ -1 object-location (movitz-type-word-size 'movitz-basic-vector) (* 2 (truncate (+ (array-dimension object 0) 7) 8))))) - (vector-u16 + ((simple-array (unsigned-byte 16) 1) (<= object-location location (+ -1 object-location (movitz-type-word-size 'movitz-basic-vector) (* 2 (truncate (+ (array-dimension object 0) 3) 4))))) - ((or vector-u32 simple-vector) + ((or simple-vector (simple-array (unsigned-byte 32) 1)) (<= object-location location (+ -1 object-location

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13117 Modified Files: scavenge.lisp Log Message: Add scavenger support for indirect-vectors. Date: Sat Jun 11 01:06:40 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.50 movitz/losp/muerte/scavenge.lisp:1.51 --- movitz/losp/muerte/scavenge.lisp:1.50 Thu May 5 22:51:55 2005 +++ movitz/losp/muerte/scavenge.lisp Sat Jun 11 01:06:39 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.50 2005/05/05 20:51:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.51 2005/06/10 23:06:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -180,8 +180,12 @@ (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (logand (1+ len) -2))))) ((scavenge-typep x :basic-vector) - (if (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)) + (if (or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type + :any-t)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type + :indirects))) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) ((and (eq x 3) (eq x2 0))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13099 Modified Files: variables.lisp Log Message: Define a *gc-hooks* variable, a list of functions to be called after GC. Date: Sat Jun 11 01:05:50 2005 Author: ffjeld Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.8 movitz/losp/muerte/variables.lisp:1.9 --- movitz/losp/muerte/variables.lisp:1.8 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/variables.lisp Sat Jun 11 01:05:50 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.8 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.9 2005/06/10 23:05:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,5 +42,7 @@ (defvar *multiboot-data* nil) (defvar internal-time-units-per-second) + +(defvar *gc-hooks* nil) (declaim (special *build-number*))

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv13082 Modified Files: los0-gc.lisp Log Message: Define a *gc-hooks* variable, a list of functions to be called after GC. Date: Sat Jun 11 01:05:45 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.54 movitz/losp/los0-gc.lisp:1.55 --- movitz/losp/los0-gc.lisp:1.54 Thu May 5 22:51:09 2005 +++ movitz/losp/los0-gc.lisp Sat Jun 11 01:05:44 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.54 2005/05/05 20:51:09 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.55 2005/06/10 23:05:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -493,7 +493,8 @@ (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) - + (dolist (hook *gc-hooks*) + (funcall hook)) (initialize-space oldspace) (fill oldspace #x13 :start 2) ;; (setf *gc-stack2* *gc-stack*)

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13067 Modified Files: packages.lisp Log Message: Define a *gc-hooks* variable, a list of functions to be called after GC. Date: Sat Jun 11 01:05:40 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.50 movitz/packages.lisp:1.51 --- movitz/packages.lisp:1.50 Sun May 22 00:38:29 2005 +++ movitz/packages.lisp Sat Jun 11 01:05:38 2005 @@ -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.50 2005/05/21 22:38:29 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.51 2005/06/10 23:05:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1253,6 +1253,7 @@ #:cpu-featurep #:find-cpu-features #:*cpu-features* + #:*gc-hooks* #:write-cpu-vendor-string #:read-time-stamp-counter #:clear-time-stamp-counter

1 0

[movitz-cvs] CVS update: movitz/losp/ll-testing.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv13038 Modified Files: ll-testing.lisp Log Message: Fix format-segment-table: use selector rather than indexes. Date: Sat Jun 11 01:04:45 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.9 movitz/losp/ll-testing.lisp:1.10 --- movitz/losp/ll-testing.lisp:1.9 Sun May 8 03:18:02 2005 +++ movitz/losp/ll-testing.lisp Sat Jun 11 01:04:45 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 14 08:18:43 2005 ;;;; -;;;; $Id: ll-testing.lisp,v 1.9 2005/05/08 01:18:02 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.10 2005/06/10 23:04:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -40,12 +40,13 @@ (defun format-segment-table (table &key (start 0) (end (truncate (length table) 2))) (loop for i from start below end - do (format t "~&~2D: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%" - i - (* 4 (segment-descriptor-base-location table i)) - (segment-descriptor-limit table i) - (segment-descriptor-type-s-dpl-p table i) - (segment-descriptor-avl-x-db-g table i))) + as selector = (* i 8) + do (format t "~&~3X: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%" + selector + (* 4 (segment-descriptor-base-location table selector)) + (segment-descriptor-limit table selector) + (segment-descriptor-type-s-dpl-p table selector) + (segment-descriptor-avl-x-db-g table selector))) (values))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp
by ffjeld＠common-lisp.net 10 Jun '05

10 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11308 Modified Files: segments.lisp Log Message: Fixed a nasty bug in (setf global-segment-descriptor-table) that would install the wrong (about half-size) limit, causing weird crashes. Date: Sat Jun 11 00:43:53 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.15 movitz/losp/muerte/segments.lisp:1.16 --- movitz/losp/muerte/segments.lisp:1.15 Fri Jun 10 23:15:18 2005 +++ movitz/losp/muerte/segments.lisp Sat Jun 11 00:43:52 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.15 2005/06/10 21:15:18 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.16 2005/06/10 22:43:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -176,9 +176,9 @@ (defun (setf global-segment-descriptor-table) (table) "Install <table> as the GDT. -NB! you need ensure that the table object isn't garbage-collected." +NB! you need to ensure that the table object isn't garbage-collected." (check-type table (vector (unsigned-byte 32))) - (let ((limit (1- (* 2 (length table)))) + (let ((limit (1- (* 4 (length table)))) (base (+ 2 (+ (object-location table) (location-physical-offset))))) (%lgdt base limit)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs June 2005