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

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19896 Modified Files: los-closette.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:38 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.31 movitz/losp/muerte/los-closette.lisp:1.32 --- movitz/losp/muerte/los-closette.lisp:1.31 Wed May 4 10:00:42 2005 +++ movitz/losp/muerte/los-closette.lisp Thu May 5 22:51:36 2005 @@ -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.31 2005/05/04 08:00:42 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.32 2005/05/05 20:51:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -220,11 +220,11 @@ (check-type class (or null class)) #+ignore (case class-name - ((t) (setf (%run-time-context-slot 'the-class-t) class)) - (null (setf (%run-time-context-slot 'the-class-null) class)) - (symbol (setf (%run-time-context-slot 'the-class-symbol) class)) - (fixnum (setf (%run-time-context-slot 'the-class-fixnum) class)) - (cons (setf (%run-time-context-slot 'the-class-cons) class))) + ((t) (setf (%run-time-context-slot nil 'the-class-t) class)) + (null (setf (%run-time-context-slot nil 'the-class-null) class)) + (symbol (setf (%run-time-context-slot 'nil the-class-symbol) class)) + (fixnum (setf (%run-time-context-slot nil 'the-class-fixnum) class)) + (cons (setf (%run-time-context-slot nil 'the-class-cons) class))) (let ((map (load-global-constant classes))) (when (member class-name (svref map 0)) (setf (svref map (1+ (position class-name (svref map 0))))

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19864 Modified Files: interrupt.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:28 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.42 movitz/losp/muerte/interrupt.lisp:1.43 --- movitz/losp/muerte/interrupt.lisp:1.42 Wed Apr 27 01:44:18 2005 +++ movitz/losp/muerte/interrupt.lisp Thu May 5 22:51:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.42 2005/04/26 23:44:18 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.43 2005/05/05 20:51:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -341,13 +341,13 @@ (with-inline-assembly (:returns :nothing) (:nop)))) (70 (error "Unaligned memref access.")) ((5 55) - (let* ((old-bottom (prog1 (%run-time-context-slot 'stack-bottom) - (setf (%run-time-context-slot 'stack-bottom) 0))) - (stack (%run-time-context-slot 'movitz::stack-vector)) + (let* ((old-bottom (prog1 (%run-time-context-slot nil 'stack-bottom) + (setf (%run-time-context-slot nil 'stack-bottom) 0))) + (stack (%run-time-context-slot nil 'stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) (old-es (segment-register :es)) - (old-dynamic-env (%run-time-context-slot 'dynamic-env)) + (old-dynamic-env (%run-time-context-slot nil 'dynamic-env)) (new-bottom (cond ((< stack-left 50) (princ "Halting CPU due to stack exhaustion.") @@ -362,7 +362,7 @@ (t (+ real-bottom (truncate stack-left 4)))))) ; Cushion the fall.. (unwind-protect (progn - (setf (%run-time-context-slot 'stack-bottom) new-bottom + (setf (%run-time-context-slot nil 'stack-bottom) new-bottom ;; (%run-time-context-slot 'dynamic-env) 0 (segment-register :es) (segment-register :ds)) (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ES.~%" @@ -375,7 +375,7 @@ old-dynamic-env)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) - (setf (%run-time-context-slot 'stack-bottom) old-bottom + (setf (%run-time-context-slot nil 'stack-bottom) old-bottom ;; (%run-time-context-slot 'dynamic-env) old-dynamic-env (segment-register :es) old-es)))) (69

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19843 Modified Files: run-time-context.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:20 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.22 movitz/losp/muerte/run-time-context.lisp:1.23 --- movitz/losp/muerte/run-time-context.lisp:1.22 Thu May 5 17:17:22 2005 +++ movitz/losp/muerte/run-time-context.lisp Thu May 5 22:51:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.22 2005/05/05 15:17:22 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.23 2005/05/05 20:51:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,27 +32,27 @@ (defmethod slot-value-using-class ((class run-time-context-class) object (slot standard-effective-slot-definition)) - (with-unbound-protect (svref (%run-time-context-slot 'slots object) + (with-unbound-protect (svref (%run-time-context-slot object 'slots) (slot-definition-location slot)) (slot-unbound class object (slot-definition-name slot)))) (defmethod (setf slot-value-using-class) (new-value (class run-time-context-class) object (slot standard-effective-slot-definition)) (let ((location (slot-definition-location slot)) - (slots (%run-time-context-slot 'slots object))) + (slots (%run-time-context-slot object 'slots))) (setf (svref slots location) new-value))) (defmethod slot-boundp-using-class ((class run-time-context-class) object (slot standard-effective-slot-definition)) (not (eq (load-global-constant new-unbound-value) - (svref (%run-time-context-slot 'slots object) + (svref (%run-time-context-slot object 'slots) (slot-definition-location slot))))) (defmethod allocate-instance ((class run-time-context-class) &rest initargs) (declare (dynamic-extent initargs) (ignore initargs)) (let ((x (clone-run-time-context))) - (setf (%run-time-context-slot 'class x) class) - (setf (%run-time-context-slot 'slots x) + (setf (%run-time-context-slot x 'class) class) + (setf (%run-time-context-slot x 'slots) (allocate-slot-storage (count-if 'instance-slot-p (class-slots class)) (load-global-constant new-unbound-value))) x)) @@ -85,14 +85,14 @@ (let ((slot-location (slot-definition-location slot))) (check-type slot-location positive-fixnum) (lambda (instance) - (with-unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) + (with-unbound-protect (svref (%run-time-context-slot instance 'slots) slot-location) (slot-unbound-trampoline instance slot-location))))) (defmethod compute-effective-slot-writer ((class run-time-context-class) slot) (let ((slot-location (slot-definition-location slot))) (check-type slot-location positive-fixnum) (lambda (value instance) - (setf (svref (%run-time-context-slot 'slots instance) slot-location) + (setf (svref (%run-time-context-slot instance 'slots) slot-location) value)))) (defmethod print-object ((x run-time-context) stream) @@ -111,8 +111,9 @@ (when errorp (error "No run-time-context slot named ~S in ~S." slot-name context)))) -(defun %run-time-context-slot (slot-name &optional (context (current-run-time-context))) - (let ((slot (find-run-time-context-slot context slot-name))) +(defun %run-time-context-slot (context slot-name) + (let* ((context (or context (current-run-time-context))) + (slot (find-run-time-context-slot context slot-name))) (ecase (second slot) (word (memref context -6 :index (third slot))) @@ -121,9 +122,10 @@ (lu32 (memref context -6 :index (third slot) :type :unsigned-byte32))))) -(defun (setf %run-time-context-slot) (value slot-name &optional (context (current-run-time-context))) - (check-type context run-time-context) - (let ((slot (find-run-time-context-slot context slot-name))) +(defun (setf %run-time-context-slot) (value context slot-name) + (let* ((context (or context (current-run-time-context))) + (slot (find-run-time-context-slot context slot-name))) + (check-type context run-time-context) (ecase (second slot) (word (setf (memref context -6 :index (third slot)) value)) @@ -136,23 +138,8 @@ (name :anonymous)) (check-type parent run-time-context) (let ((context (%shallow-copy-object parent (movitz-type-word-size 'movitz-run-time-context)))) - (setf (%run-time-context-slot 'slots context) (copy-seq (%run-time-context-slot 'slots parent)) - (%run-time-context-slot 'self context) context - (%run-time-context-slot 'atomically-continuation context) 0) + (setf (%run-time-context-slot context 'slots) (copy-seq (%run-time-context-slot parent 'slots)) + (%run-time-context-slot context 'self) context + (%run-time-context-slot context 'atomically-continuation) 0) context)) - -;;;(defun %run-time-context-install-stack (context -;;; &optional (control-stack -;;; (make-array 8192 :element-type '(unsigned-byte 32))) -;;; (cushion 1024)) -;;; (check-type control-stack vector) -;;; (assert (< cushion (array-dimension control-stack 0))) -;;; (setf (%run-time-context-slot 'control-stack context) control-stack) -;;; (setf (%run-time-context-slot 'stack-top context) -;;; (+ (object-location control-stack) 8 -;;; (* 4 (array-dimension control-stack 0)))) -;;; (setf (%run-time-context-slot 'stack-bottom context) -;;; (+ (object-location control-stack) 8 -;;; (* 4 cushion))) -;;; control-stack)

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv19822 Modified Files: los0.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:12 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.43 movitz/losp/los0.lisp:1.44 --- movitz/losp/los0.lisp:1.43 Thu May 5 20:09:28 2005 +++ movitz/losp/los0.lisp Thu May 5 22:51:12 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.43 2005/05/05 18:09:28 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.44 2005/05/05 20:51:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1517,16 +1517,16 @@ (let ((write-barrier *write-barrier*) (location (object-location object))) (assert (not (location-in-object-p - (los0::space-other (%run-time-context-slot 'nursery-space)) + (los0::space-other (%run-time-context-slot nil 'nursery-space)) location)) () "Write ~S to old-space at ~S." value location) (unless (or (eq object write-barrier) #+ignore - (location-in-object-p (%run-time-context-slot 'nursery-space) + (location-in-object-p (%run-time-context-slot nil 'nursery-space) location) - (location-in-object-p (%run-time-context-slot 'stack-vector) + (location-in-object-p (%run-time-context-slot nil 'stack-vector) location)) - (if (location-in-object-p (%run-time-context-slot 'nursery-space) + (if (location-in-object-p (%run-time-context-slot nil 'nursery-space) location) (vector-push 'stack-actually write-barrier) (vector-push object write-barrier)) @@ -1649,7 +1649,7 @@ (warn "Installing shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot function) - `(setf (%run-time-context-slot ',slot) (symbol-value ',function)))) + `(setf (%run-time-context-slot nil ',slot) (symbol-value ',function)))) (install muerte:dynamic-variable-install dynamic-variable-install-shallow) (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow) (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow) @@ -1666,7 +1666,7 @@ (%symbol-global-value name)) (setf (%symbol-global-value name) (memref env 8))))))) - (install-shallow-env (%run-time-context-slot 'muerte::dynamic-env)))) + (install-shallow-env (%run-time-context-slot nil 'muerte::dynamic-env)))) (values)) (defun deinstall-shallow-binding (&key quiet) @@ -1674,13 +1674,13 @@ (warn "Deinstalling shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot) - `(setf (%run-time-context-slot ',slot) (symbol-value ',slot)))) + `(setf (%run-time-context-slot nil ',slot) (symbol-value ',slot)))) (install muerte:dynamic-variable-install) (install muerte:dynamic-variable-uninstall) (install muerte::dynamic-unwind-next) (install muerte::dynamic-variable-store) (install muerte::dynamic-variable-lookup)) - (loop for env = (%run-time-context-slot 'muerte::dynamic-env) + (loop for env = (%run-time-context-slot nil 'muerte::dynamic-env) then (memref env 12) while (plusp env) do (let ((name (memref env 0)))

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv19805 Modified Files: los0-gc.lisp Log Message: Changed order of arguments for %run-time-context-slot, new signature is (context slot-name), where nil may be used as a designator for (current-run-time-context). Date: Thu May 5 22:51:10 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.53 movitz/losp/los0-gc.lisp:1.54 --- movitz/losp/los0-gc.lisp:1.53 Thu May 5 21:35:18 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 22:51: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.53 2005/05/05 19:35:18 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.54 2005/05/05 20:51:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -78,8 +78,8 @@ (warn "install..") (install-los0-consing 4) (warn "nursery: ~Z, other: ~Z" - (%run-time-context-slot 'muerte::nursery-space) - (space-other (%run-time-context-slot 'muerte::nursery-space))) + (%run-time-context-slot nil 'muerte::nursery-space) + (space-other (%run-time-context-slot nil 'muerte::nursery-space))) (warn "first cons: ~Z" (funcall 'truncate #x100000000 3)) (warn "second cons: ~Z" (funcall 'truncate #x100000000 3)) (halt-cpu) @@ -243,9 +243,9 @@ (let ((*standard-output* *terminal-io*)) (cond (*gc-running* - (let* ((full-space (%run-time-context-slot 'muerte::nursery-space)) + (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space)) (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) - (setf (%run-time-context-slot 'muerte::nursery-space) hack-space) + (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" full-space hack-space))) (t (let ((*gc-running* t)) @@ -268,16 +268,16 @@ (check-type code-vector code-vector) (if (eq context (current-run-time-context)) ;; The point of this is to not trigger CLOS bootstrapping. - (setf (%run-time-context-slot ',slot) code-vector) - (setf (%run-time-context-slot ',slot context) code-vector))))) + (setf (%run-time-context-slot nil ',slot) code-vector) + (setf (%run-time-context-slot context ',slot) code-vector))))) (install-primitive los0-fast-cons muerte::fast-cons) (install-primitive los0-box-u32-ecx muerte::box-u32-ecx) (install-primitive los0-cons-pointer muerte::cons-pointer) (install-primitive los0-cons-commit muerte::cons-commit)) (if (eq context (current-run-time-context)) - (setf (%run-time-context-slot 'muerte::nursery-space) + (setf (%run-time-context-slot nil 'muerte::nursery-space) actual-duo-space) - (setf (%run-time-context-slot 'muerte::nursery-space context) + (setf (%run-time-context-slot context 'muerte::nursery-space) actual-duo-space)) ;; Pretend that the heap stops here, so that we don't have to scan ;; the entire tail end of memory, which isn't going to be used. @@ -294,13 +294,13 @@ (defun report-nursery (x location) "Write a message if x is inside newspace." - (when (object-in-space-p (%run-time-context-slot 'nursery-space) x) + (when (object-in-space-p (%run-time-context-slot nil 'nursery-space) x) (format t "~&~Z: ~S: ~S from ~S" x (type-of x) x location)) x) (defun report-inactive-space (x location) "Check that x is not pointing into (what is presumably) oldspace." - (when (object-in-space-p (space-other (%run-time-context-slot 'nursery-space)) x) + (when (object-in-space-p (space-other (%run-time-context-slot nil 'nursery-space)) x) (break "~Z: ~S: ~S from ~S" x (type-of x) x location)) x) @@ -318,9 +318,9 @@ #+ignore (defun kill-the-newborns () - (let* ((oldspace (%run-time-context-slot 'nursery-space)) + (let* ((oldspace (%run-time-context-slot nil 'nursery-space)) (newspace (space-other oldspace))) - (setf (%run-time-context-slot 'nursery-space) newspace) + (setf (%run-time-context-slot nil 'nursery-space) newspace) (flet ((zap-oldspace (x location) (declare (ignore location)) (if (object-in-space-p oldspace x) @@ -332,7 +332,7 @@ (values)))) -(defparameter *x* #1000(nil)) ; Have this in static space. +(defparameter *x* #4000(nil)) ; Have this in static space. ;;;(defparameter *xx* #4000(nil)) ; Have this in static space. (defparameter *code-vector-foo* 0) @@ -344,13 +344,13 @@ (setf (fill-pointer *old-code-vectors*) 0) (multiple-value-bind (newspace oldspace) (without-interrupts - (let* ((space0 (%run-time-context-slot 'nursery-space)) + (let* ((space0 (%run-time-context-slot nil 'nursery-space)) (space1 (space-other space0))) (check-type space0 (simple-array (unsigned-byte 32) 1)) (check-type space1 (simple-array (unsigned-byte 32) 1)) (assert (eq space0 (space-other space1))) (assert (= 2 (space-fresh-pointer space1))) - (setf (%run-time-context-slot 'nursery-space) space1) + (setf (%run-time-context-slot nil 'nursery-space) space1) (values space1 space0))) ;; Evacuate-oldspace is to be mapped over every potential pointer. (let ((*code-vector-foo* (incf *code-vector-foo* 2)) @@ -458,13 +458,13 @@ old old new new (objects-equalp old new) oldspace newspace i)))))) (map-header-vals (lambda (x y) (declare (ignore y)) - (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space)) + (when (location-in-object-p (space-other (%run-time-context-slot nil 'nursery-space)) (object-location x)) (break "Seeing old object in values-vector: ~Z" x)) x) #x38 #xb8) #+ignore - (let* ((stack (%run-time-context-slot 'muerte::stack-vector)) + (let* ((stack (%run-time-context-slot nil 'muerte::stack-vector)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) ((>= i (length a))) @@ -538,7 +538,7 @@ (flet ((searcher (x ignore) (declare (ignore ignore)) (when (and (typep x '(or muerte::tag1 muerte::tag6 muerte::tag7)) - (not (eq x (%run-time-context-slot 'muerte::nursery-space))) + (not (eq x (%run-time-context-slot nil 'muerte::nursery-space))) (location-in-object-p x location) (not (member x results))) (push x results) @@ -554,7 +554,7 @@ (invoke-restart 'muerte::continue-map-header-vals))))) (dolist (range muerte::%memory-map-roots%) (map-header-vals #'searcher (car range) (cdr range))) - (let ((nursery (%run-time-context-slot 'muerte::nursery-space))) + (let ((nursery (%run-time-context-slot nil 'muerte::nursery-space))) (map-header-vals #'searcher (+ 4 (object-location nursery)) (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) @@ -563,7 +563,7 @@ (defun report-lispval (lispval &optional breakp newspace) (let* ((location (truncate lispval 4)) - (newspace (or newspace (%run-time-context-slot 'muerte::nursery-space))) + (newspace (or newspace (%run-time-context-slot nil 'muerte::nursery-space))) (oldspace (space-other newspace))) (cond ((location-in-object-p newspace location)

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv13010 Modified Files: los0-gc.lisp Log Message: Make stop-and-copy work again: Use (simple-array ..) rather than vector-u32. Date: Thu May 5 21:35:18 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.52 movitz/losp/los0-gc.lisp:1.53 --- movitz/losp/los0-gc.lisp:1.52 Thu May 5 20:08:39 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 21:35:18 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.52 2005/05/05 18:08:39 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.53 2005/05/05 19:35:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -346,8 +346,8 @@ (without-interrupts (let* ((space0 (%run-time-context-slot 'nursery-space)) (space1 (space-other space0))) - (check-type space0 vector-u32) - (check-type space1 vector-u32) + (check-type space0 (simple-array (unsigned-byte 32) 1)) + (check-type space1 (simple-array (unsigned-byte 32) 1)) (assert (eq space0 (space-other space1))) (assert (= 2 (space-fresh-pointer space1))) (setf (%run-time-context-slot 'nursery-space) space1)

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv5360 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Thu May 5 20:09:28 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.42 movitz/losp/los0.lisp:1.43 --- movitz/losp/los0.lisp:1.42 Thu May 5 17:16:54 2005 +++ movitz/losp/los0.lisp Thu May 5 20:09:28 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.42 2005/05/05 15:16:54 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.43 2005/05/05 18:09:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1077,9 +1077,9 @@ (t (describe x))) (values)) -(muerte.toplevel:define-toplevel-command :bochs-trace (form) - (muerte::with-bochs-tracing () - (eval form))) +;;;(muerte.toplevel:define-toplevel-command :bochs-trace (form) +;;; (muerte::with-bochs-tracing () +;;; (eval form))) (muerte.toplevel:define-toplevel-command :mapkey (code-char-form) (let* ((code-char (eval code-char-form))

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv5326 Modified Files: los0-gc.lisp Log Message: Disable some of the debugging cruft. Date: Thu May 5 20:08:39 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.51 movitz/losp/los0-gc.lisp:1.52 --- movitz/losp/los0-gc.lisp:1.51 Thu May 5 17:16:48 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 20:08:39 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.51 2005/05/05 15:16:48 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.52 2005/05/05 18:08:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -332,7 +332,7 @@ (values)))) -(defparameter *x* #4000(nil)) ; Have this in static space. +(defparameter *x* #1000(nil)) ; Have this in static space. ;;;(defparameter *xx* #4000(nil)) ; Have this in static space. (defparameter *code-vector-foo* 0) @@ -364,6 +364,7 @@ nil) ((object-in-space-p newspace x) x) + #+ignore ((and (typep x 'code-vector) (not (object-in-space-p oldspace x)) (not (object-in-space-p newspace x))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5291 Modified Files: more-macros.lisp Log Message: Remove with-bochs-tracing. Date: Thu May 5 20:08:20 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.25 movitz/losp/muerte/more-macros.lisp:1.26 --- movitz/losp/muerte/more-macros.lisp:1.25 Tue May 3 22:09:50 2005 +++ movitz/losp/muerte/more-macros.lisp Thu May 5 20:08:20 2005 @@ -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.25 2005/05/03 20:09:50 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.26 2005/05/05 18:08:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -225,17 +225,6 @@ `(if ,eof-errorp (error 'end-of-file :stream ,stream) ,eof-value)) - - -(defmacro with-bochs-tracing ((&optional (value 1)) &body body) - "Bochs magic." - `(let ((old-flags (muerte::%run-time-context-slot 'bochs-flags))) - (unwind-protect - (progn - (setf (muerte::%run-time-context-slot 'bochs-flags) ,value) - ,@body) - (setf (muerte::%run-time-context-slot 'bochs-flags) old-flags)))) - (defmacro handler-bind (bindings &body forms) (if (null bindings)

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 05 May '05

05 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5076 Modified Files: image.lisp Log Message: Move the non-lisp-val slots to the beginning of run-time-context, and don't have the protect-non-pointer-area stuff. Date: Thu May 5 20:01:14 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.98 movitz/image.lisp:1.99 --- movitz/image.lisp:1.98 Thu May 5 17:16:38 2005 +++ movitz/image.lisp Thu May 5 20:01:13 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.98 2005/05/05 15:16:38 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.99 2005/05/05 18:01:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,6 +22,19 @@ :initform :run-time-context) (padding :binary-type 3) + (atomically-continuation + :binary-type lu32 + :initform 0) + (raw-scratch0 ; A non-GC-root scratch register + :binary-type lu32 + :initform 0) + (pointer-start :binary-type :label) + (scratch1 + :binary-type word + :initform 0) + (scratch2 + :binary-type word + :initform 0) (class :binary-type word :map-binary-write 'movitz-intern @@ -35,12 +48,6 @@ :initarg :slots :initform #(:init nil) :accessor run-time-context-slots) - (scratch1 - :binary-type word - :initform 0) - (scratch2 - :binary-type word - :initform 0) (fast-car :binary-type code-vector-word :initform nil @@ -369,27 +376,6 @@ :binary-type word :initform 6 :map-binary-read-delayed 'movitz-word) - (protect-non-pointer-area - :binary-type lu32 - :initform 3) - (protect-non-pointer-count - :binary-type lu32 - :initform nil - :map-binary-write (lambda (x type) - (declare (ignore x type)) - (- (bt:slot-offset 'movitz-run-time-context 'non-pointers-end) - (bt:slot-offset 'movitz-run-time-context 'non-pointers-start)))) - (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= - (bochs-flags - :binary-type lu32 - :initform 0) - (raw-scratch0 ; A non-GC-root scratch register - :binary-type lu32 - :initform 0) - (atomically-continuation - :binary-type lu32 - :initform 0) - (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= (ret-trampoline :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector

1 0