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

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

30 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10301 Modified Files: los-closette-compiler.lisp Log Message: Have run-time-context-class be a proper metaclass for run-time-context. Date: Sun May 1 01:22:29 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.14 movitz/losp/muerte/los-closette-compiler.lisp:1.15 --- movitz/losp/muerte/los-closette-compiler.lisp:1.14 Tue Jun 8 00:14:06 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Sun May 1 01:22:28 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: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.14 2004/06/07 22:14:06 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.15 2005/04/30 23:22:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,14 +117,14 @@ slot)) (t (pushnew class-name *classes-with-old-slot-definitions*) (muerte::translate-program (vector name ; 1 - initargs ; 3 - initform ; 5 - initfunction ; 7 - allocation ; 9 - readers ; 11 - writers - nil) - :cl :muerte.cl)))) + initargs ; 3 + initform ; 5 + initfunction ; 7 + allocation ; 9 + readers ; 11 + writers + nil) + :cl :muerte.cl)))) (defun translate-direct-slot-definition (old-slot) (if (not (vectorp old-slot)) @@ -486,7 +486,7 @@ (subclassp class *the-class-standard-class*)) (break "Looking for slot ~S in class ~S, while std-class is ~S." slot-name class *the-class-standard-class*)) - (let ((slot (find slot-name + (let ((slot (find slot-name (std-slot-value class 'effective-slots) :key #'slot-definition-name))) (if (null slot) @@ -568,9 +568,11 @@ 'make-instance-built-in-class) ((eq metaclass (movitz-find-class 'funcallable-standard-class nil)) 'movitz-make-instance) - (t (warn "Unknown metaclass: ~S" metaclass) - 'make-instance-built-in-class - #+ignore 'movitz-make-instance)) + ((eq metaclass (movitz-find-class 'run-time-context-class nil)) + 'movitz-make-instance) + (t (break "Unknown metaclass: ~S" metaclass) + #+ignore 'make-instance-built-in-class + 'movitz-make-instance)) metaclass :name name all-keys))) @@ -600,18 +602,6 @@ (defun movitz-make-instance-funcallable (metaclass &rest all-keys &key name direct-superclasses direct-slots &allow-other-keys) (declare (ignore all-keys)) (let ((class (std-allocate-instance metaclass))) - #+ignore - (dolist (slot (class-slots (movitz-class-of class))) - (let ((slot-name (slot-definition-name slot))) - (multiple-value-bind (init-key init-value foundp) - (get-properties all-keys (slot-definition-initargs slot)) - (declare (ignore init-key)) - (if foundp - (setf (movitz-slot-value class slot-name) init-value) - (when (not (null (slot-definition-initform slot))) - (warn "initform: ~S" (slot-definition-initform slot)) - (setf (movitz-slot-value class slot-name) - (eval (slot-definition-initform slot)))))))) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ()) (setf (class-direct-methods class) ()) @@ -619,22 +609,38 @@ :direct-slots direct-slots :direct-superclasses direct-superclasses) class)) + + (defun movitz-make-instance-run-time-context (metaclass &rest all-keys &key name direct-superclasses direct-slots size slot-map &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) + (setf (movitz-class-name class) name) + (setf (class-direct-subclasses class) ()) + (setf (class-direct-methods class) ()) + (std-after-initialization-for-classes class + :direct-slots direct-slots + :direct-superclasses direct-superclasses) + class)) (defun movitz-make-instance (class &rest all-keys) ;; (warn "movitz-make-instance: ~S ~S" class all-keys) (when (symbolp class) (setf class (movitz-find-class class))) - (if (eq class (movitz-find-class 'funcallable-standard-class nil)) - (apply 'movitz-make-instance-funcallable class all-keys) - (let ((instance (std-allocate-instance class))) - (dolist (slot (class-slots (movitz-class-of instance))) - (let ((slot-name (slot-definition-name slot))) - (multiple-value-bind (init-key init-value foundp) - (get-properties all-keys (slot-definition-initargs slot)) - (declare (ignore init-key)) - (when foundp - (setf (movitz-slot-value instance slot-name) init-value))))) - instance))) + (cond + ((eq class (movitz-find-class 'funcallable-standard-class nil)) + (apply 'movitz-make-instance-funcallable class all-keys) ) + ((eq class (movitz-find-class 'run-time-context-class nil)) + (apply 'movitz-make-instance-run-time-context class all-keys)) + (t (let ((instance (std-allocate-instance class))) + (dolist (slot (class-slots (movitz-class-of instance))) + (let ((slot-name (slot-definition-name slot))) + (multiple-value-bind (init-key init-value foundp) + (get-properties all-keys (slot-definition-initargs slot)) + (declare (ignore init-key)) + (when foundp + (setf (movitz-slot-value instance slot-name) init-value))))) + instance)))) ;;; make-instance-standard-class creates and initializes an instance of ;;; standard-class without falling into method lookup. However, it cannot be

1 0

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

30 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10272 Modified Files: los-closette.lisp Log Message: Have run-time-context-class be a proper metaclass for run-time-context. Date: Sun May 1 01:22:20 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.26 movitz/losp/muerte/los-closette.lisp:1.27 --- movitz/losp/muerte/los-closette.lisp:1.26 Tue Jan 25 14:52:25 2005 +++ movitz/losp/muerte/los-closette.lisp Sun May 1 01:22:19 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.26 2005/01/25 13:52:25 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.27 2005/04/30 23:22:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1006,14 +1006,14 @@ (defclass infant-object (t) () (:metaclass built-in-class)) (defclass unbound-value (t) () (:metaclass built-in-class)) -(defclass run-time-context (t) - () - (:metaclass built-in-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)))) +;;;(defclass run-time-context (t) +;;; () +;;; (:metaclass built-in-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)))) (defclass stream () ()) @@ -1040,13 +1040,7 @@ (defclass funcallable-standard-object (standard-object function) ()) (defclass generic-function (metaobject funcallable-standard-object) ()) (defclass standard-generic-function (generic-function) - (#+ignore - (name - :initarg :name) ; :accessor generic-function-name - #+ignore - (lambda-list ; :accessor generic-function-lambda-list - :initarg :lambda-list) - (methods + ((methods :initform ()) ; :accessor generic-function-methods) (method-class ; :accessor generic-function-method-class :initarg :method-class) @@ -1718,11 +1712,6 @@ (write-string ")" stream))) object) -(defmethod print-object ((x run-time-context) stream) - (print-unreadable-object (x stream :type t :identity t) - (format stream " ~S" (%run-time-context-slot 'name x))) - x) - (defmethod print-object ((x illegal-object) stream) (error "Won't print illegal-object ~Z." x) ;; (print-unreadable-object (x stream :type t :identity t)) @@ -1912,3 +1901,32 @@ (values)))) +;;;; + +(defclass run-time-context-class (std-slotted-class built-in-class) ()) + +(defclass run-time-context (t) + ((name + :initarg :name + :accessor run-time-context-name) + (stack-vector + :initarg :stack-vector)) + (: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)))) + +(defmethod slot-value-using-class ((class run-time-context-class) object + (slot standard-effective-slot-definition)) + (let ((x (svref (%run-time-context-slot 'slots object) + (slot-definition-location slot)))) + (if (eq x (load-global-constant new-unbound-value)) + (slot-unbound class object (slot-definition-name slot)) + x))) + +(defmethod print-object ((x run-time-context) stream) + (print-unreadable-object (x stream :type t :identity t) + (format stream " ~S" (%run-time-context-slot 'name x))) + x)

1 0

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

30 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10254 Modified Files: image.lisp Log Message: Have run-time-context-class be a proper metaclass for run-time-context. Date: Sun May 1 01:22:14 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.92 movitz/image.lisp:1.93 --- movitz/image.lisp:1.92 Sat Apr 30 23:15:35 2005 +++ movitz/image.lisp Sun May 1 01:22:14 2005 @@ -4,12 +4,12 @@ ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; Filename: image.lisp -;;;; Description: Construction of LispOS images. +;;;; Description: Construction of Movitz images. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.92 2005/04/30 21:15:35 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.93 2005/04/30 23:22:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -876,7 +876,7 @@ (movitz-read (movitz-environment-setf-function-names *movitz-global-environment*) t)) (setf (run-time-context-class (image-run-time-context *image*)) (muerte::movitz-find-class 'muerte::run-time-context)) - (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3)) + ;; (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3)) (let ((load-address (image-start-address *image*))) (setf (image-cons-pointer *image*) (- load-address (image-ds-segment-base *image*))

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by ffjeld＠common-lisp.net 30 Apr '05

30 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30101 Modified Files: movitz-mode.el Log Message: Have in-movitz-package-p be somewhat more clever. Date: Sat Apr 30 23:19:43 2005 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.8 movitz/movitz-mode.el:1.9 --- movitz/movitz-mode.el:1.8 Tue Nov 30 15:16:18 2004 +++ movitz/movitz-mode.el Sat Apr 30 23:19:42 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.8 2004/11/30 14:16:18 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.9 2005/04/30 21:19:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,8 +33,10 @@ (or (and (< 6 (length fi:package)) (string= "MUERTE." (upcase (substring fi:package 0 7)))) (member (upcase fi:package) - '("MUERTE" "X86" "X86-PC")))) - + '("MUERTE" "X86" "X86-PC")) + (member "MUERTE" + (fi:eval-in-lisp + "(cl:mapcar #'cl:package-name (cl:package-use-list \"%s\"))" (upcase fi:package))))) (defun movitz-defun-name-and-type () (interactive)

1 0

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

30 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29946 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Sat Apr 30 23:16:12 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.46 movitz/packages.lisp:1.47 --- movitz/packages.lisp:1.46 Wed Apr 20 08:54:38 2005 +++ movitz/packages.lisp Sat Apr 30 23:16:12 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.46 2005/04/20 06:54:38 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.47 2005/04/30 21:16:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1203,6 +1203,7 @@ #:basic-restart #:illegal-object #:run-time-context + #:run-time-context-class #:current-run-time-context make-funobj

1 0

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

30 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29728 Modified Files: storage-types.lisp Log Message: Cleaned up the unbound-value protocol a bit. Date: Sat Apr 30 23:15:47 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.50 movitz/storage-types.lisp:1.51 --- movitz/storage-types.lisp:1.50 Sun Feb 27 03:31:34 2005 +++ movitz/storage-types.lisp Sat Apr 30 23:15:43 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.50 2005/02/27 02:31:34 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.51 2005/04/30 21:15:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -151,11 +151,9 @@ (ecase type (word (cond - ((eq expr 'unbound) - (slot-value (image-run-time-context *image*) 'new-unbound-value)) - ((typep expr 'movitz-object) - (movitz-intern expr)) - (t (movitz-intern (movitz-read expr))))) + ((typep expr 'movitz-object) + (movitz-intern expr)) + (t (movitz-intern (movitz-read expr))))) (code-vector-word (movitz-intern-code-vector expr)))) @@ -533,6 +531,14 @@ (deftype movitz-string () '(satisfies movitz-stringp)) +;;; + +(define-binary-class movitz-unbound-value (movitz-immediate-object) + ()) + +(defmethod movitz-intern ((obj movitz-unbound-value) &optional type) + (declare (ignore type)) + #x7fffffff) ;;; Symbols

1 0

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

30 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29704 Modified Files: image.lisp Log Message: Cleaned up the unbound-value protocol a bit. Date: Sat Apr 30 23:15:36 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.91 movitz/image.lisp:1.92 --- movitz/image.lisp:1.91 Sat Apr 30 00:36:01 2005 +++ movitz/image.lisp Sat Apr 30 23:15:35 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.91 2005/04/29 22:36:01 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.92 2005/04/30 21:15:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,6 +27,19 @@ :initform :bootup :map-binary-write 'movitz-read-and-intern :map-binary-read-delayed 'movitz-word) + (class + :binary-type word + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word + :initarg :class + :accessor run-time-context-class) + (slots + :binary-type word + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word + :initarg :slots + :initform #() + :accessor run-time-context-slots) (fast-car :binary-type code-vector-word :initform nil @@ -150,10 +163,10 @@ :reader movitz-run-time-context-null-symbol :initarg :null-symbol) (new-unbound-value - :binary-type lu32 -;;; :map-binary-read-delayed 'movitz-word -;;; :map-binary-write 'movitz-read-and-intern - :initform #x7fffffff) + :binary-type word + :map-binary-read-delayed 'movitz-word + :map-binary-write 'movitz-read-and-intern + :initform 'unbound) ;; primitive functions global constants (pop-current-values :binary-type code-vector-word @@ -598,8 +611,8 @@ (defun unbound-value () (declare (special *image*)) - (slot-value (image-run-time-context *image*) - 'new-unbound-value)) + (movitz-read (slot-value (image-run-time-context *image*) + 'new-unbound-value))) (defun edi-offset () (declare (special *image*)) @@ -861,6 +874,9 @@ (movitz-read (make-array 256 :initial-element handler)))) (setf (movitz-symbol-value (movitz-read 'muerte::*setf-namespace*)) (movitz-read (movitz-environment-setf-function-names *movitz-global-environment*) t)) + (setf (run-time-context-class (image-run-time-context *image*)) + (muerte::movitz-find-class 'muerte::run-time-context)) + (setf (run-time-context-slots (image-run-time-context *image*)) #(1 2 3)) (let ((load-address (image-start-address *image*))) (setf (image-cons-pointer *image*) (- load-address (image-ds-segment-base *image*)) @@ -1450,6 +1466,7 @@ (etypecase expr (null *movitz-nil*) ((member t) (movitz-read 'muerte.cl:t)) + ((eql unbound) (make-instance 'movitz-unbound-value)) (symbol (intern-movitz-symbol expr)) (integer (make-movitz-integer expr)) (character (make-movitz-character expr))

1 0

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

29 Apr '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv15824 Modified Files: los0-gc.lisp Log Message: *** empty log message *** Date: Sat Apr 30 00:37:08 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.49 movitz/losp/los0-gc.lisp:1.50 --- movitz/losp/los0-gc.lisp:1.49 Wed Mar 9 08:31:28 2005 +++ movitz/losp/los0-gc.lisp Sat Apr 30 00:37:08 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.49 2005/03/09 07:31:28 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.50 2005/04/29 22:37:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -392,6 +392,8 @@ new))))) ((not (object-in-space-p oldspace x)) x) + ((when (typep x 'run-time-context) + (warn "Scavengning ~S" x))) (t (or (and (eq (object-tag x) (ldb (byte 3 0) (memref (object-location x) 0 :type :unsigned-byte8)))

1 0

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

29 Apr '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv15800 Modified Files: ll-testing.lisp Log Message: *** empty log message *** Date: Sat Apr 30 00:36:49 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.5 movitz/losp/ll-testing.lisp:1.6 --- movitz/losp/ll-testing.lisp:1.5 Wed Apr 27 01:46:13 2005 +++ movitz/losp/ll-testing.lisp Sat Apr 30 00:36:49 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.5 2005/04/26 23:46:13 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.6 2005/04/29 22:36:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,6 +59,8 @@ (values)) +(defmacro control-stack-fs (stack) + `(stack-frame-ref ,stack 0 2)) (defmacro control-stack-esp (stack) `(stack-frame-ref ,stack 0 1)) @@ -137,17 +139,12 @@ :esi function))) stack) -(defun test-tt () - (multiple-value-bind (thread stack) - (muerte.init::threading) - (control-stack-bootstrap stack #'format t "Hello world!"))) - -(defun make-thread (&optional (name (gensym "thread-")) (function #'invoke-debugger) &rest args) +(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) (args '(nil))) "Make a thread and initialize its stack to apply function to args." - (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table.. + (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 muerte.init::*segment-descriptor-table*)) + (segment-descriptor-table (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) @@ -157,7 +154,8 @@ function args))) (multiple-value-bind (ebp esp) (control-stack-fixate stack) - (setf (control-stack-ebp stack) ebp + (setf (control-stack-fs stack) fs + (control-stack-ebp stack) ebp (control-stack-esp stack) esp)) (setf (%run-time-context-slot 'dynamic-env thread) 0 (%run-time-context-slot 'stack-vector thread) stack @@ -168,7 +166,7 @@ (if (>= (length stack) 200) 100 0)))) - (values thread fs)))) + (values thread)))) (defun stack-bootstrapper (&rest ignore) (declare (ignore ignore)) @@ -194,17 +192,17 @@ stack) ; XXX The extra 2 words skip the frame-setup, ; XXX which happens to be 8 bytes.. (control-stack-enter-frame stack #'yield) - (control-stack-push 0 stack) ; XXX shouldn't need this? stack) -(defun yield (target-rtc fs &optional value) +(defun yield (target-rtc &optional value) (declare (dynamic-extent values)) (assert (not (eq target-rtc (current-run-time-context)))) (let ((my-stack (%run-time-context-slot 'stack-vector)) (target-stack (%run-time-context-slot 'stack-vector target-rtc))) (assert (not (eq my-stack target-stack))) - (let ((esp (control-stack-esp target-stack)) + (let ((fs (control-stack-fs target-stack)) + (esp (control-stack-esp target-stack)) (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) (assert (location-in-object-p target-stack ebp)) @@ -217,7 +215,8 @@ (setf (%run-time-context-slot 'scratch1 target-rtc) ebp (%run-time-context-slot 'scratch2 target-rtc) esp) ;; Enable someone to yield back here.. - (setf (control-stack-ebp my-stack) (asm-register :ebp) + (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)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)

1 0

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

29 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15768 Modified Files: conditions.lisp Log Message: *** empty log message *** Date: Sat Apr 30 00:36:23 2005 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.14 movitz/losp/muerte/conditions.lisp:1.15 --- movitz/losp/muerte/conditions.lisp:1.14 Wed Apr 27 01:40:29 2005 +++ movitz/losp/muerte/conditions.lisp Sat Apr 30 00:36:23 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.14 2005/04/26 23:40:29 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.15 2005/04/29 22:36:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,7 +270,7 @@ (signal-simple 'simple-condition datum args) nil) -(defun invoke-debugger (&optional condition) +(defun invoke-debugger (condition) (when *debugger-hook* (let ((hook *debugger-hook*) (*debugger-hook* nil))

1 0