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

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv24227 Modified Files: threading.lisp Log Message: *** empty log message *** Date: Thu May 5 17:21:59 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.1 movitz/losp/lib/threading.lisp:1.2 --- movitz/losp/lib/threading.lisp:1.1 Fri Apr 29 00:05:02 2005 +++ movitz/losp/lib/threading.lisp Thu May 5 17:21:59 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.1 2005/04/28 22:05:02 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.2 2005/05/05 15:21:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,11 +18,16 @@ (defpackage threading (:use cl muerte) - (:export make-thread + (:export thread + make-thread yield )) -(in-package threading) +(in-package muerte) + +(defclass thread (run-time-context) + () + (:metaclass run-time-context-class)) (defmacro control-stack-ebp (stack) `(stack-frame-ref ,stack 0 0)) @@ -46,6 +51,18 @@ (control-stack-push function stack)) stack) +(defun control-stack-fixate (stack) + (let ((stack-base (+ 2 (object-location stack)))) + (do ((frame (control-stack-ebp stack))) + ((zerop (stack-frame-uplink stack frame))) + (assert (typep (stack-frame-funobj stack frame) 'function)) + (let ((previous-frame frame)) + (setf frame (stack-frame-uplink stack frame)) + (incf (stack-frame-ref stack previous-frame 0) + stack-base))) + (values (+ (control-stack-ebp stack) stack-base) + (+ (control-stack-esp stack) stack-base)))) + (defun stack-bootstrapper (&rest ignore) "Control stacks are initialized with this function as their initial frame." (declare (ignore ignore)) @@ -57,7 +74,7 @@ (check-type args list) (apply function args))) (error "Nothing left to do for ~S." (current-run-time-context)) - (loop (halt-cpu))) + (loop (halt-cpu))) ; just to make sure (defun control-stack-init-for-yield (stack function args) "Make it so that a yield to stack will cause function to be applied to args." @@ -79,7 +96,7 @@ (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table.. (fs (* 8 fs-index)) (thread (muerte::clone-run-time-context :name name)) - (segment-descriptor-table (symbol-value 'muerte.init::*segment-descriptor-table*))) + (segment-descriptor-table nil #+ignore (symbol-value 'muerte.init::*segment-descriptor-table*))) (setf (segment-descriptor segment-descriptor-table fs-index) (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8))) (setf (segment-descriptor-base-location segment-descriptor-table fs-index) @@ -114,8 +131,8 @@ (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) (assert (location-in-object-p target-stack ebp)) - (assert (eq (stack-frame-funobj nil ebp) - (asm-register :esi)) () + (assert (eq (muerte::stack-frame-funobj nil ebp) + (muerte::asm-register :esi)) () "Will not yield to a non-yield frame.") ;; Push eflags for later.. (setf (memref (decf esp) 0) (eflags)) @@ -124,8 +141,8 @@ (%run-time-context-slot 'scratch2 target-rtc) esp) ;; Enable someone to yield back here.. (setf (control-stack-fs my-stack) (segment-register :fs) - (control-stack-ebp my-stack) (asm-register :ebp) - (control-stack-esp my-stack) (asm-register :esp)) + (control-stack-ebp my-stack) (muerte::asm-register :ebp) + (control-stack-esp my-stack) (muerte::asm-register :esp)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) (:load-lexical (:lexical-binding value) :eax) @@ -133,4 +150,4 @@ (:movw :cx :fs) (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) - (:popfl))))) \ No newline at end of file + (:popfl)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.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-serv24091 Modified Files: los-closette-compiler.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:37 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.16 movitz/losp/muerte/los-closette-compiler.lisp:1.17 --- movitz/losp/muerte/los-closette-compiler.lisp:1.16 Tue May 3 21:49:25 2005 +++ movitz/losp/muerte/los-closette-compiler.lisp Thu May 5 17:17:35 2005 @@ -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.16 2005/05/03 19:49:25 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.17 2005/05/05 15:17:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -613,9 +613,15 @@ (defun movitz-make-instance-run-time-context (metaclass &rest all-keys &key name direct-superclasses direct-slots size slot-map plist &allow-other-keys) (declare (ignore all-keys)) (let ((class (std-allocate-instance metaclass))) - (when size (setf (std-slot-value class 'size) size)) - (setf (std-slot-value class 'slot-map) slot-map - (std-slot-value class 'plist) plist) + (setf (std-slot-value class 'size) + (or size (bt:sizeof 'movitz::movitz-run-time-context))) + (setf (std-slot-value class 'slot-map) + (or slot-map + (movitz::slot-map 'movitz::movitz-run-time-context + (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context + 'movitz::run-time-context-start) + 0)))) + (setf (std-slot-value class 'plist) plist) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ()) (setf (class-direct-methods class) ())

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-serv24054 Modified Files: run-time-context.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:22 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.21 movitz/losp/muerte/run-time-context.lisp:1.22 --- movitz/losp/muerte/run-time-context.lisp:1.21 Thu May 5 00:47:17 2005 +++ movitz/losp/muerte/run-time-context.lisp Thu May 5 17:17:22 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.21 2005/05/04 22:47:17 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.22 2005/05/05 15:17:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,14 +27,8 @@ (defclass run-time-context (t) ((name :initarg :name - :initform :anonymous :accessor run-time-context-name)) - (:metaclass run-time-context-class) - (:size #.(bt:sizeof 'movitz::movitz-run-time-context)) - (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context - (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context - 'movitz::run-time-context-start) - 0)))) + (:metaclass run-time-context-class)) (defmethod slot-value-using-class ((class run-time-context-class) object (slot standard-effective-slot-definition)) @@ -103,7 +97,8 @@ (defmethod print-object ((x run-time-context) stream) (print-unreadable-object (x stream :type t :identity t) - (format stream "~S" (run-time-context-name x))) + (when (slot-boundp x 'name) + (format stream "~S" (run-time-context-name x)))) x) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.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-serv24040 Modified Files: cpu-id.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:16 2005 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.10 movitz/losp/muerte/cpu-id.lisp:1.11 --- movitz/losp/muerte/cpu-id.lisp:1.10 Wed Mar 9 08:18:14 2005 +++ movitz/losp/muerte/cpu-id.lisp Thu May 5 17:17:15 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.10 2005/03/09 07:18:14 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.11 2005/05/05 15:17:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -248,7 +248,7 @@ (defun load-idt (idt-vector) (assert (= #.(bt:enum-value 'movitz::movitz-vector-element-type :u32) - (muerte:vector-element-type idt-vector))) + (vector-element-type idt-vector))) (let ((limit (- (* (length idt-vector) 4) 1))) ;; (format t "Load-idt: ~Z / ~D~%" idt-vector limit)

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv24020 Modified Files: interrupt.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:12 2005 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.10 movitz/losp/x86-pc/interrupt.lisp:1.11 --- movitz/losp/x86-pc/interrupt.lisp:1.10 Tue Aug 10 14:59:36 2004 +++ movitz/losp/x86-pc/interrupt.lisp Thu May 5 17:17:12 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 May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.10 2004/08/10 12:59:36 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.11 2005/05/05 15:17:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (defun idt-init () (init-pic8259 32 40) (setf (pic8259-irq-mask) #xffff) - (load-idt (load-global-constant interrupt-descriptor-table)) + (load-idt (muerte::load-global-constant muerte::interrupt-descriptor-table)) nil) (defun timer-init ()

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv24004 Modified Files: textmode-console.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:17:06 2005 Author: ffjeld Index: movitz/losp/x86-pc/textmode-console.lisp diff -u movitz/losp/x86-pc/textmode-console.lisp:1.4 movitz/losp/x86-pc/textmode-console.lisp:1.5 --- movitz/losp/x86-pc/textmode-console.lisp:1.4 Sun Nov 14 23:58:16 2004 +++ movitz/losp/x86-pc/textmode-console.lisp Thu May 5 17:17:06 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 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: Tue Jul 8 15:13:24 2003 ;;;; -;;;; $Id: textmode-console.lisp,v 1.4 2004/11/14 22:58:16 ffjeld Exp $ +;;;; $Id: textmode-console.lisp,v 1.5 2005/05/05 15:17:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,23 +66,23 @@ nil)) (defmethod (setf console-char) (character (console vga-text-console) x y) - (when (and (below x (console-width console)) - (below y (console-height console))) + (when (and (< x (console-width console)) + (< y (console-height console))) (let ((index (+ x (* y (stride console))))) (setf (memref-int (base console) :index index :type :unsigned-byte16) (logior (ash (color console) 8) (char-code character))))) character) (defmethod console-char ((console vga-text-console) x y) - (when (and (below x (console-width console)) - (below y (console-height console))) + (when (and (< x (console-width console)) + (< y (console-height console))) (let* ((index (+ x (* y (stride console)))) (code (memref-int (base console) :index index :type :unsigned-byte16))) (code-char (ldb (byte 8 0) code))))) (defmethod put-string ((console vga-text-console) string x y &optional (start 0) (end (length string))) - (when (below y (console-height console)) + (when (< y (console-height console)) (loop with color = (ash (color console) 8) with base = (base console) for cursor upfrom (+ x (* y (stride console))) for column from x below (console-width console) @@ -93,7 +93,7 @@ string) (defmethod clear-line ((console vga-text-console) x y) - (when (below y (console-height console)) + (when (< y (console-height console)) (loop with base = (base console) for index upfrom (+ x (* y (stride console))) for column from x below (console-width console)

1 0

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

05 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv23981 Modified Files: misc.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:59 2005 Author: ffjeld Index: movitz/losp/lib/misc.lisp diff -u movitz/losp/lib/misc.lisp:1.7 movitz/losp/lib/misc.lisp:1.8 --- movitz/losp/lib/misc.lisp:1.7 Wed Nov 24 15:20:49 2004 +++ movitz/losp/lib/misc.lisp Thu May 5 17:16:59 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 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: Mon May 12 17:13:31 2003 ;;;; -;;;; $Id: misc.lisp,v 1.7 2004/11/24 14:20:49 ffjeld Exp $ +;;;; $Id: misc.lisp,v 1.8 2005/05/05 15:16:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (defun checksum-octets (packet &optional (start 0) (end (length packet))) "Generate sum of 16-bit big-endian words for a sequence of octets." (typecase packet - (muerte:vector-u8 + ((simple-array (unsigned-byte 8)) (assert (<= 0 start end (length packet))) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :ebx) packet) @@ -49,7 +49,7 @@ end-checksum-loop (:shll #.movitz:+movitz-fixnum-shift+ :eax) (:cld))) - (t (muerte:with-subvector-accessor (packet-ref packet start end) + (t (muerte::with-subvector-accessor (packet-ref packet start end) (cond ((or (and (evenp start) (evenp end)) (and (oddp start) (oddp end)))

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-serv23962 Modified Files: los0.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:54 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.41 movitz/losp/los0.lisp:1.42 --- movitz/losp/los0.lisp:1.41 Tue May 3 22:13:07 2005 +++ movitz/losp/los0.lisp Thu May 5 17:16:54 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.41 2005/05/03 20:13:07 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.42 2005/05/05 15:16:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,8 @@ (require :lib/net/ip4) (require :lib/repl) -(require :ll-testing) +;; (require :ll-testing) +(require :lib/threading) (defpackage muerte.init (:nicknames #:los0) @@ -1040,7 +1041,7 @@ (define-toplevel-command :restart (&optional (r 0) &rest args) (declare (dynamic-extent args)) (let* ((context (or *debugger-dynamic-context* - (current-dynamic-context))) + (muerte::current-dynamic-context))) (restart (typecase r (integer (find-restart-by-index r context)) @@ -1099,7 +1100,7 @@ (defun los0-debugger (condition) (without-interrupts - (let ((*debugger-dynamic-context* (current-dynamic-context)) + (let ((*debugger-dynamic-context* (muerte::current-dynamic-context)) (*standard-output* *debug-io*) (*standard-input* *debug-io*) (*debugger-condition* condition) @@ -1245,11 +1246,11 @@ (:shrl 2 :ecx) ((:gs-override) :addb 1 (:ecx 158)) ((:gs-override) :movb #x40 (:ecx 159))) - (do ((frame (stack-frame-uplink nil (current-stack-frame)) - (stack-frame-uplink nil frame))) + (do ((frame (muerte::stack-frame-uplink nil (muerte::current-stack-frame)) + (muerte::stack-frame-uplink nil frame))) ((plusp frame)) (when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax)) - (stack-frame-funobj nil frame)) + (muerte::stack-frame-funobj nil frame)) (error "Double interrupt."))) ;;; (dolist (range muerte::%memory-map-roots%) ;;; (map-header-vals (lambda (x type) @@ -1260,7 +1261,7 @@ (declare (ignore foo)) x) nil - (current-stack-frame)) + (muerte::current-stack-frame)) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1337,9 +1338,9 @@ (idt-init) - (setf *segment-descriptor-table* ; Ensure we have a GDT with 16 entries, in static-space. - (muerte::install-global-segment-table - (muerte::dump-global-segment-table :entries 16))) +;;; (setf *segment-descriptor-table* ; Ensure we have a GDT with 16 entries, in static-space. +;;; (muerte::install-global-segment-table +;;; (muerte::dump-global-segment-table :entries 16))) (install-los0-consing :kb-size 500) #+ignore @@ -1665,7 +1666,7 @@ (%symbol-global-value name)) (setf (%symbol-global-value name) (memref env 8))))))) - (install-shallow-env (load-global-constant dynamic-env :thread-local t)))) + (install-shallow-env (%run-time-context-slot 'muerte::dynamic-env)))) (values)) (defun deinstall-shallow-binding (&key quiet) @@ -1679,7 +1680,7 @@ (install muerte::dynamic-unwind-next) (install muerte::dynamic-variable-store) (install muerte::dynamic-variable-lookup)) - (loop for env = (load-global-constant dynamic-env :thread-local t) + (loop for env = (%run-time-context-slot '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-serv23942 Modified Files: los0-gc.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:49 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.50 movitz/losp/los0-gc.lisp:1.51 --- movitz/losp/los0-gc.lisp:1.50 Sat Apr 30 00:37:08 2005 +++ movitz/losp/los0-gc.lisp Thu May 5 17:16:48 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.50 2005/04/29 22:37:08 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.51 2005/05/05 15:16:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -333,17 +333,11 @@ (defparameter *x* #4000(nil)) ; Have this in static space. -(defparameter *xx* #4000(nil)) ; Have this in static space. +;;;(defparameter *xx* #4000(nil)) ; Have this in static space. (defparameter *code-vector-foo* 0) (defvar *old-code-vectors* #250()) (defvar *new-code-vectors* #250()) - -(defun debug (location x) - (setf (dummy x) - (let ((new (shallow-copy x))) - (warn "[~S] Migrating code-vector ~Z => ~Z." location x new) - new))) (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0)

1 0

[movitz-cvs] CVS update: movitz/losp/ll-testing.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-serv23925 Modified Files: ll-testing.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:46 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.7 movitz/losp/ll-testing.lisp:1.8 --- movitz/losp/ll-testing.lisp:1.7 Thu May 5 12:28:52 2005 +++ movitz/losp/ll-testing.lisp Thu May 5 17:16: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.7 2005/05/05 10:28:52 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.8 2005/05/05 15:16:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -93,18 +93,6 @@ (error "Stack stop.") (format *terminal-io* "~&Stack-stopper halt.") (loop (halt-cpu))) - -(defun control-stack-fixate (stack) - (let ((stack-base (+ 2 (object-location stack)))) - (do ((frame (control-stack-ebp stack))) - ((zerop (stack-frame-uplink stack frame))) - (assert (typep (stack-frame-funobj stack frame) 'function)) - (let ((previous-frame frame)) - (setf frame (stack-frame-uplink stack frame)) - (incf (stack-frame-ref stack previous-frame 0) - stack-base))) - (values (+ (control-stack-ebp stack) stack-base) - (+ (control-stack-esp stack) stack-base)))) (defun alloc-context (segment-descriptor-table) (let* ((fs-index 8)

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-serv23901 Modified Files: image.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:39 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.97 movitz/image.lisp:1.98 --- movitz/image.lisp:1.97 Thu May 5 15:21:40 2005 +++ movitz/image.lisp Thu May 5 17:16:38 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.97 2005/05/05 13:21:40 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.98 2005/05/05 15:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -572,8 +572,8 @@ muerte:run-time-context muerte.mop:standard-effective-slot-definition muerte.mop:funcallable-standard-class - muerte:basic-restart - muerte:illegal-object)) + muerte::basic-restart + muerte::illegal-object)) (defun class-object-offset (name) (let ((name (translate-program name :cl :muerte.cl)))

1 0

[movitz-cvs] CVS update: movitz/special-operators.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-serv23883 Modified Files: special-operators.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:34 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.51 movitz/special-operators.lisp:1.52 --- movitz/special-operators.lisp:1.51 Wed Apr 27 01:45:48 2005 +++ movitz/special-operators.lisp Thu May 5 17:16:33 2005 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.51 2005/04/26 23:45:48 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.52 2005/05/05 15:16:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -283,7 +283,7 @@ (setf (movitz-symbol-value (movitz-read name)) code-vector) (when symtab-property (setf (movitz-env-get name :symtab) - (translate-program symtab :movitz :muerte))) + (muerte::translate-program symtab :movitz :muerte))) (compiler-values ())))))) (define-special-operator define-prototyped-function (&form form)

1 0

[movitz-cvs] CVS update: movitz/packages.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-serv23862 Modified Files: packages.lisp Log Message: Cleaned up the exports from the muerte package, somewhat. Date: Thu May 5 17:16:30 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.47 movitz/packages.lisp:1.48 --- movitz/packages.lisp:1.47 Sat Apr 30 23:16:12 2005 +++ movitz/packages.lisp Thu May 5 17:16:29 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.47 2005/04/30 21:16:12 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.48 2005/05/05 15:16:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1088,19 +1088,15 @@ (:use muerte.mop muerte.common-lisp) (:import-from common-lisp cl:nil) (:shadow get-setf-expansion) - (:export translate-program - decode-macro-lambda-list - with-inline-assembly - with-progn-results - make-named-function - without-function-prelude - numargs-case - movitz-accessor - simple-read-from-string + (:export #:translate-program + #:decode-macro-lambda-list + #:with-inline-assembly + #:make-named-function + #:without-function-prelude + #:numargs-case + #:simple-read-from-string #:read-key - print-word - fixnump below - print-unreadable-movitz-object + #:fixnump #:newline #:*print-safely* @@ -1119,17 +1115,9 @@ #:*backtrace-print-level* #:backtrace - #:stack-ref - #:with-each-dynamic-context - #:stack-frame-uplink - #:current-stack-frame - #:current-dynamic-context - #:stack-frame-funobj - #:stack-frame-call-site - #:stack-frame-ref - #:check-stack-limit #:dit-frame-ref - #:dit-frame-casf + #:check-stack-limit + #:current-stack-frame #:interrupt-default-handler #:exception-handler @@ -1157,51 +1145,41 @@ #:movitz-type-slot-offset - vector-element-type - vector-element-size - with-subvector-accessor - svref%unsafe - bvref-u16 - object-location - object-tag - location-in-object-p - inline-malloc - define-compile-time-variable - define-primitive-function - without-gc - with-stack-check - with-symbol-mutex - spin-wait-pause - char-whitespace-p - wrong-argument-count - throw-error - *debugger-function* - *debugger-invoked-stack-frame* - *debugger-condition* - *debugger-dynamic-context* - pprint-clumps - do-trace - do-untrace - malloc-initialize - clos-bootstrap - *forward-generic-function* - halt-cpu + #:object-location + #:object-tag + #:location-in-object-p + #:define-compile-time-variable + #:define-primitive-function + #:without-gc + #:with-stack-check + #:with-symbol-mutex + #:spin-wait-pause + #:char-whitespace-p + #:wrong-argument-count + #:throw-error + #:*debugger-function* + #:*debugger-invoked-stack-frame* + #:*debugger-condition* + #:*debugger-dynamic-context* + #:pprint-clumps + #:do-trace + #:do-untrace + #:malloc-initialize + #:clos-bootstrap + #:*forward-generic-function* + #:halt-cpu - find-restart-by-index - find-restart-from-context - map-active-restarts - with-basic-restart + #:find-restart-by-index + #:find-restart-from-context + #:map-active-restarts + #:with-basic-restart #:dynamic-variable-install #:dynamic-variable-uninstall #:code-vector - #:vector-u8 - #:vector-u16 - #:vector-u32 #:pointer #:basic-restart - #:illegal-object #:run-time-context #:run-time-context-class #:current-run-time-context @@ -1234,35 +1212,23 @@ device-clear-input device-finish-record - translate-program - decode-macro-lambda-list - decode-optional-formal - decode-keyword-formal - parse-declarations-and-body - parse-docstring-declarations-and-body - unfold-circular-list - compute-function-block-name + #:unfold-circular-list + #:translate-program + #:decode-macro-lambda-list + #:decode-optional-formal + #:decode-keyword-formal + #:parse-declarations-and-body + #:parse-docstring-declarations-and-body + #:compute-function-block-name - load-global-constant - load-global-constant-u32 - runtime-context-slot - movitz-accessor - halt-cpu + #:movitz-accessor #:%object-lispval #:%lispval-object #:objects-equalp - word-nibble - &edx - - #:un-backquote - #:backquote-comma - #:backquote-comma-at - #:backquote-comma-dot + #:&edx #:memref #:memref-int - #:memcopy - #:%copy-words #:io-port #:io-register8 @@ -1383,19 +1349,19 @@ #:*compiler-allow-untagged-word-bits* ) (:import-from muerte - #:translate-program - #:decode-macro-lambda-list - #:un-backquote - #:backquote-comma - #:backquote-comma-at - #:backquote-comma-dot - - #:decode-optional-formal - #:decode-keyword-formal - #:parse-declarations-and-body - #:parse-docstring-declarations-and-body - #:unfold-circular-list - #:compute-function-block-name + muerte::translate-program + muerte::decode-macro-lambda-list + muerte::un-backquote + muerte::backquote-comma + muerte::backquote-comma-at + muerte::backquote-comma-dot + + muerte::decode-optional-formal + muerte::decode-keyword-formal + muerte::parse-declarations-and-body + muerte::parse-docstring-declarations-and-body + muerte::unfold-circular-list + muerte::compute-function-block-name ))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.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-serv16813 Modified Files: primitive-functions.lisp Log Message: Fixed class-of for run-time-context objects. Date: Thu May 5 15:59:37 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.63 movitz/losp/muerte/primitive-functions.lisp:1.64 --- movitz/losp/muerte/primitive-functions.lisp:1.63 Thu Feb 3 10:19:02 2005 +++ movitz/losp/muerte/primitive-functions.lisp Thu May 5 15:59:37 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.63 2005/02/03 09:19:02 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.64 2005/05/05 13:59:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -529,18 +529,31 @@ (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :std-instance) :cl) (:jne 'not-std-instance) - (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) (:ret) not-std-instance (:cmpw ,(+ (movitz:tag :funobj) (ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8)) :cx) (:jne 'not-std-gf-instance) - (:movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf 'movitz::standard-gf-class)) :eax) (:ret) not-std-gf-instance + + (:cmpb ,(movitz:tag :run-time-context) :cl) + (:jne 'not-rtc) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-run-time-context class + ,(- (movitz::image-nil-word movitz:*image*) + (movitz::tag :other)))) + :eax) + (:ret) + not-rtc + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) (:cmpb ,(movitz:tag :bignum) :cl) (:jne 'not-bignum) @@ -571,8 +584,6 @@ (structure-object-class object)) (character (find-class 'character)) - (run-time-context - (find-class 'run-time-context)) (null (find-class 'null)) (cons

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/packages.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-serv14081 Modified Files: packages.lisp Log Message: Removed global-properties from run-time-context. Put the hash-table of all packages in *packages* instead. Date: Thu May 5 15:21:52 2005 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.8 movitz/losp/muerte/packages.lisp:1.9 --- movitz/losp/muerte/packages.lisp:1.8 Sun Apr 17 20:18:18 2005 +++ movitz/losp/muerte/packages.lisp Thu May 5 15:21:50 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.8 2005/04/17 18:18:18 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.9 2005/05/05 13:21:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,6 +30,8 @@ shadowing-symbols-list use-list) +(defvar *packages*) ; Set by dump-image. + (defun package-name (object) (package-object-name (find-package object))) @@ -42,9 +44,7 @@ (find-package-string (string name)))) (defun find-package-string (name &optional (start 0) (end (length name)) (key 'identity)) - (values (gethash-string name start end - (get-global-property :packages) - nil key))) + (values (gethash-string name start end *packages* nil key))) (defun assert-package (name) (or (find-package name) @@ -54,7 +54,7 @@ (let (pkgs) (maphash (lambda (k v) (pushnew v pkgs)) - (get-global-property :packages)) + *packages*) pkgs)) (defun find-symbol-string (name start end key &optional (package *package*)) @@ -117,7 +117,7 @@ (symbol-var (gensym)) (loop-tag (gensym)) (end-tag (gensym))) - `(with-hash-table-iterator (,next-package (get-global-property :packages)) + `(with-hash-table-iterator (,next-package *packages*) (do () (nil) (multiple-value-bind (,more-packages-var ,dummy ,package-var) (,next-package)

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 May 2005