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

[movitz-cvs] CVS update: movitz/losp/muerte/segments.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-serv15729 Modified Files: segments.lisp Log Message: Put the initial segment-descriptor-table in an array installed in variable muerte::*initial-segment-descriptor-table*. Don't embed it in the run-time-context. Date: Sat Apr 30 00:36:05 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.12 movitz/losp/muerte/segments.lisp:1.13 --- movitz/losp/muerte/segments.lisp:1.12 Mon Apr 25 00:11:24 2005 +++ movitz/losp/muerte/segments.lisp Sat Apr 30 00:36:05 2005 @@ -10,13 +10,15 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.12 2005/04/24 22:11:24 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.13 2005/04/29 22:36:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :muerte/segments) (in-package muerte) + +(defvar *initial-segment-descriptor-table*) (defun segment-register (segment-register-name) "Return the value of an x86 segment register, such as :cs or :ds."

1 0

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

29 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15712 Modified Files: image.lisp Log Message: Put the initial segment-descriptor-table in an array installed in variable muerte::*initial-segment-descriptor-table*. Don't embed it in the run-time-context. Date: Sat Apr 30 00:36:01 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.90 movitz/image.lisp:1.91 --- movitz/image.lisp:1.90 Wed Apr 20 08:54:50 2005 +++ movitz/image.lisp Sat Apr 30 00:36:01 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.90 2005/04/20 06:54:50 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.91 2005/04/29 22:36:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -351,13 +351,6 @@ :map-binary-read-delayed 'movitz-word :initarg :exception-handlers :accessor movitz-run-time-context-exception-handlers) -;;; (exception-handler-tails -;;; :binary-type word -;;; :initform nil -;;; :map-binary-write 'movitz-read-and-intern -;;; :map-binary-read-delayed 'movitz-word -;;; :initarg :exception-handler-tails -;;; :accessor movitz-run-time-context-exception-handler-tails) (interrupt-descriptor-table :binary-type word :accessor movitz-run-time-context-interrupt-descriptor-table @@ -423,46 +416,6 @@ (bochs-flags :binary-type lu32 :initform 0) - ;; (align-segment-descriptors :binary-type 4) - (segment-descriptor-table :binary-type :label) - (segment-descriptor-0 - :binary-type segment-descriptor - :initform (make-segment-descriptor)) - (segment-descriptor-global-code ; 1: true flat code segment - :binary-type segment-descriptor - :initform (make-segment-descriptor :base 0 :limit #xfffff :type 14 :dpl 0 - :flags '(s p d/b g))) - (segment-descriptor-global-data ; 2: true flat data segment - :binary-type segment-descriptor - :initform (make-segment-descriptor :base 0 :limit #xfffff ; data segment - :type 2 :dpl 3 - :flags '(s p d/b g))) - (segment-descriptor-shifted-code ; 3: 1 MB shifted flat code segment - :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-cs-segment-base *image*) - :limit #xfff00 :type 14 :dpl 0 - :flags '(s p d/b g))) - (segment-descriptor-shifted-data ; 4: 1 MB shifted flat data segment - :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-ds-segment-base *image*) - :limit #xfff00 ; data segment - :type 2 :dpl 3 - :flags '(s p d/b g))) - (segment-descriptor-thread-context ; 5: same as normal shifted-data for initial context. - :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-ds-segment-base *image*) - :limit #xfff00 ; data segment - :type 2 :dpl 0 - :flags '(s p d/b g))) - (segment-descriptor-stack ; 6: same as normal shifted-data, DPL=0 - :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-ds-segment-base *image*) - :limit #xfff00 ; data segment - :type 2 :dpl 0 - :flags '(s p d/b g))) - (segment-descriptor-7 - :binary-type segment-descriptor - :initform (make-segment-descriptor)) (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) @@ -799,6 +752,31 @@ x) y)) +(defun make-initial-segment-descriptor-table () + (let ((u32-list + (let ((bt:*endian* :little-endian)) + (merge-bytes (with-binary-output-to-list (octet-list) + (mapcar (lambda (init-args) + (write-binary 'segment-descriptor octet-list + (apply #'make-segment-descriptor init-args))) + `(() ; 0 + (:base 0 :limit #xfffff ; 1: physical code + :type 14 :dpl 0 :flags (s p d/b g)) + (:base 0 :limit #xfffff ; 2: physical data + :type 2 :dpl 3 :flags (s p d/b g)) + (:base ,(image-cs-segment-base *image*) ; 3: logical code + :limit #xfff00 + :type 14 :dpl 0 :flags (s p d/b g)) + (:base ,(image-ds-segment-base *image*) ; 4: logical data + :limit #xfff00 + :type 2 :dpl 0 :flags (s p d/b g)) + ))) + 8 32)))) + (movitz-read (make-movitz-vector (length u32-list) + :initial-contents u32-list + :element-type '(unsigned-byte 32))))) + + (defun make-movitz-image (&rest init-args &key start-address &allow-other-keys) (let ((*image* (apply #'make-instance 'symbolic-image :nil-object (make-movitz-nil) @@ -821,10 +799,6 @@ (ldb (byte 3 0) (image-nil-word *image*)) (tag :null)) (setf (image-run-time-context *image*) (make-movitz-run-time-context)) - (unless (= 0 (mod (+ (image-nil-word *image*) (slot-offset 'movitz-run-time-context - 'segment-descriptor-table)) - 16)) - (warn "Segment descriptor table is not aligned on a 16-byte boundary.")) (setf (image-t-symbol *image*) (movitz-read t)) ;; (warn "NIL value: #x~X" (image-nil-word *image*)) *image*)) @@ -879,6 +853,9 @@ (assert (plusp (dump-count *image*)))) (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*)) (1+ *bootblock-build*)) + (when (eq 'unbound (movitz-symbol-value (movitz-read 'muerte::*initial-segment-descriptor-table*))) + (setf (movitz-symbol-value (movitz-read 'muerte::*initial-segment-descriptor-table*)) + (make-initial-segment-descriptor-table))) (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler))) (setf (movitz-run-time-context-exception-handlers (image-run-time-context *image*)) (movitz-read (make-array 256 :initial-element handler)))) @@ -1611,10 +1588,15 @@ (:cli) (:cld) ; clear direction flag => "normal" register GC roots. - (:movw ,(1- (* 8 8)) (:esp -6)) - (:movl ,(+ (image-ds-segment-base *image*) - (image-nil-word *image*) - (global-constant-offset 'segment-descriptor-table)) + (:movw ,(1- (* 8 5)) (:esp -6)) + (:movl ,(+ (movitz-read-and-intern + 'muerte::*initial-segment-descriptor-table* 'word) + (image-ds-segment-base *image*)) + :ecx) + (:movl (:ecx ,(bt:slot-offset 'movitz-symbol 'value)) + :ecx) + (:addl ,(+ (bt:slot-offset 'movitz-basic-vector 'data) + (image-ds-segment-base *image*)) :ecx) (:movl :ecx (:esp -4)) (:lgdt (:esp -6)) @@ -1634,12 +1616,10 @@ (:movw ,(* 4 8) :cx) (:movw :cx :ds) (:movw :cx :es) + (:movw :cx :fs) + (:movw :cx :ss) (:movw ,(* 2 8) :cx) - (:movw :cx :gs) ; global context segment - (:movw ,(* 5 8) :cx) - (:movw :cx :fs) ; thread context segment - (:movw ,(* 6 8) :cx) - (:movw :cx :ss) ; stack segment + (:movw :cx :gs) ; physical context segment (:movl ,(image-nil-word *image*) :edi) (:globally (:movl (:edi (:edi-offset stack-top)) :esp))

1 0

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

28 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv22294 Added Files: threading.lisp Log Message: We do need threads, don't we? This isn't quite functional, just yet. Date: Fri Apr 29 00:05:02 2005 Author: ffjeld

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv2466 Modified Files: ll-testing.lisp Log Message: Now there is make-thread. Date: Wed Apr 27 01:46:14 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.4 movitz/losp/ll-testing.lisp:1.5 --- movitz/losp/ll-testing.lisp:1.4 Wed Apr 27 00:23:14 2005 +++ movitz/losp/ll-testing.lisp Wed Apr 27 01:46:13 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.4 2005/04/26 22:23:14 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.5 2005/04/26 23:46:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -104,7 +104,7 @@ (values (+ (control-stack-ebp stack) stack-base) (+ (control-stack-esp stack) stack-base)))) -(defun make-thread (segment-descriptor-table) +(defun alloc-context (segment-descriptor-table) (let* ((fs-index 8) (thread (muerte::clone-run-time-context :name 'subthread))) (setf (segment-descriptor segment-descriptor-table fs-index) @@ -116,7 +116,6 @@ (muerte::location-physical-offset)))) (values thread (* 8 fs-index)))) - (defun control-stack-bootstrap (stack function &rest args) (declare (dynamic-extent args)) (check-type function function) @@ -143,11 +142,16 @@ (muerte.init::threading) (control-stack-bootstrap stack #'format t "Hello world!"))) -(defun test-tr (function &rest args) - (declare (dynamic-extent args)) - (assert (= 2 (length args))) - (multiple-value-bind (thread fs) - (make-thread muerte.init::*segment-descriptor-table*) +(defun make-thread (&optional (name (gensym "thread-")) (function #'invoke-debugger) &rest args) + "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.. + (fs (* 8 fs-index)) + (thread (muerte::clone-run-time-context :name name)) + (segment-descriptor-table 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) + (+ (object-location thread) (muerte::location-physical-offset))) (let ((cushion nil) (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32)) function args))) @@ -164,33 +168,25 @@ (if (>= (length stack) 200) 100 0)))) - (values thread fs stack)))) + (values thread fs)))) -(defun stack-bootstrapper (&rest args) - (declare (ignore args)) - (with-inline-assembly (:returns :nothing) (:break)) +(defun stack-bootstrapper (&rest ignore) + (declare (ignore ignore)) (let ((frame (current-stack-frame))) (assert (eql 0 (stack-frame-uplink nil frame))) (let ((function (stack-frame-ref nil frame 1)) - (numargs (stack-frame-ref nil frame 2))) - (warn "[~S] bootstrapping function ~S with ~D args." frame function numargs) + (args (stack-frame-ref nil frame 2))) (check-type function function) - (check-type numargs (integer 0 #xffff)) - (with-inline-assembly (:returns :multiple-values) - (:load-lexical (:lexical-binding function) :esi) - (:movl (:ebp #x0c) :eax) - (:movl (:ebp #x10) :ebx) - (:call (:esi (:offset movitz-funobj code-vector%2op)))))) - (error "Stack bootstrapper stop.") + (check-type args list) + (apply function args))) + (error "Nothing left to do for ~S." (current-run-time-context)) (format *terminal-io* "~&stack-bootstrapper halt.") (loop (halt-cpu))) (defun control-stack-init-for-yield (stack function args) (check-type function function) (control-stack-init stack) - (control-stack-push (second args) stack) - (control-stack-push (first args) stack) - (control-stack-push (length args) stack) + (control-stack-push args stack) (control-stack-push function stack) (control-stack-enter-frame stack #'stack-bootstrapper) ;; Now pretend stack-bootstrapper called yield. First, the return address @@ -202,7 +198,8 @@ stack) -(defun yield (target-rtc fs) +(defun yield (target-rtc fs &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))) @@ -211,21 +208,24 @@ (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) (assert (location-in-object-p target-stack ebp)) - (assert (eq (memref ebp -4) (asm-register :esi)) () - "Cannot yield to a non-yield frame.") + (assert (eq (stack-frame-funobj nil ebp) + (asm-register :esi)) () + "Will not yield to a non-yield frame.") ;; Push eflags for later.. (setf (memref (decf esp) 0) (eflags)) + ;; Store EBP and ESP so we can get to them after the switch + (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) (control-stack-esp my-stack) (asm-register :esp)) - (with-inline-assembly (:returns :nothing) - (:cli) + (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding value) :eax) + (:cli) (:movw :cx :fs) - (:load-lexical (:lexical-binding ebp) :eax) - (:load-lexical (:lexical-binding esp) :ebx) - (:movl :eax :ebp) - (:movl :ebx :esp) + (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) + (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) (:popfl))))) (defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion)

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by ffjeld＠common-lisp.net 26 Apr '05

26 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2317 Modified Files: special-operators.lisp Log Message: Fixed stupid bug in previous fix to values compiler. Date: Wed Apr 27 01:45:48 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.50 movitz/special-operators.lisp:1.51 --- movitz/special-operators.lisp:1.50 Mon Apr 25 00:08:39 2005 +++ movitz/special-operators.lisp Wed Apr 27 01:45:48 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.50 2005/04/24 22:08:39 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.51 2005/04/26 23:45:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1132,12 +1132,9 @@ `(:locally (:popl (:edi (:edi-offset values ,(* i 4)))))) (make-immediate-move (* +movitz-fixnum-factor+ (- (length sub-forms) 2)) :ecx) - `((:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:stc)) - #+ignore - (make-compiled-funcall-by-symbol 'muerte.cl::values - (length sub-forms) - (all :funobj)) + `((:locally (:movl :ecx (:edi (:edi-offset num-values))))) + (make-immediate-move (length sub-forms) :ecx) + `((:stc)) stack-restore-code))))))))) (define-special-operator muerte::compiler-typecase (&all all &form form)

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1639 Modified Files: basic-macros.lisp Log Message: Added asm-register. Date: Wed Apr 27 01:45:00 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.57 movitz/losp/muerte/basic-macros.lisp:1.58 --- movitz/losp/muerte/basic-macros.lisp:1.57 Wed Apr 20 08:50:10 2005 +++ movitz/losp/muerte/basic-macros.lisp Wed Apr 27 01:45:00 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.57 2005/04/20 06:50:10 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.58 2005/04/26 23:45:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -367,6 +367,12 @@ ,keyform ',(mapcar #'first clauses))))) +(define-compiler-macro asm-register (register-name) + (if (member register-name '(:eax :ebx :ecx :untagged-fixnum-ecx :edx)) + `(with-inline-assembly (:returns ,register-name) ()) + `(with-inline-assembly (:returns :eax) + (:movl ,register-name :eax)))) + (defmacro movitz-accessor (object-form type slot-name) (warn "movitz-accesor deprecated.") `(with-inline-assembly (:returns :register :side-effects nil) @@ -604,7 +610,6 @@ (define-compiler-macro cdar (x) `(cdr (car ,x))) - (define-compiler-macro rest (x) `(cdr ,x)) (define-compiler-macro first (x) `(car ,x)) (define-compiler-macro second (x) `(cadr ,x))

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1623 Modified Files: error.lisp Log Message: *** empty log message *** Date: Wed Apr 27 01:44:36 2005 Author: ffjeld Index: movitz/losp/muerte/error.lisp diff -u movitz/losp/muerte/error.lisp:1.3 movitz/losp/muerte/error.lisp:1.4 --- movitz/losp/muerte/error.lisp:1.3 Wed Sep 22 18:15:41 2004 +++ movitz/losp/muerte/error.lisp Wed Apr 27 01:44:36 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: Sat Sep 1 00:49:11 2001 ;;;; -;;;; $Id: error.lisp,v 1.3 2004/09/22 16:15:41 ffjeld Exp $ +;;;; $Id: error.lisp,v 1.4 2005/04/26 23:44:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,7 +25,7 @@ (defvar *error-no-condition-for-debugger* nil "If true, don't create a simple-error object just for the debugger, (presumably) since this might trigger another bug.") -(defvar *disable-interrupts-on-error* t) +(defvar *disable-interrupts-on-error* nil) (defun error (&rest arguments) (declare (dynamic-extent arguments))

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1607 Modified Files: interrupt.lisp Log Message: Remove superfluous :locally. Date: Wed Apr 27 01:44:18 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.41 movitz/losp/muerte/interrupt.lisp:1.42 --- movitz/losp/muerte/interrupt.lisp:1.41 Wed Mar 9 08:20:54 2005 +++ movitz/losp/muerte/interrupt.lisp Wed Apr 27 01:44:18 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.41 2005/03/09 07:20:54 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.42 2005/04/26 23:44:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -129,7 +129,7 @@ (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:locally (:pushl (:edi (:edi-offset atomically-continuation)))) (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) - (:locally (:pushl :ecx)) + (:pushl :ecx) (:movcr :cr2 :ecx) (:locally (:pushl :ecx)) ,@(loop for reg in (sort (copy-list '(:eax :ebx :edx :esi))

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1578 Modified Files: run-time-context.lisp Log Message: *** empty log message *** Date: Wed Apr 27 01:43:56 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.15 movitz/losp/muerte/run-time-context.lisp:1.16 --- movitz/losp/muerte/run-time-context.lisp:1.15 Mon Oct 11 15:53:19 2004 +++ movitz/losp/muerte/run-time-context.lisp Wed Apr 27 01:43:56 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromsoe, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.15 2004/10/11 13:53:19 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.16 2005/04/26 23:43:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,39 +113,39 @@ (defun clone-run-time-context (&key (parent (current-run-time-context)) (name :anonymous)) (check-type parent run-time-context) - (let ((context (%shallow-copy-object parent #.(movitz::movitz-type-word-size 'movitz-run-time-context)))) + (let ((context (%shallow-copy-object parent (movitz-type-word-size 'movitz-run-time-context)))) (setf (%run-time-context-slot 'name context) name - (%run-time-context-slot 'self context) context) - (setf (%run-time-context-segment-base 'segment-descriptor-thread-context context) - (+ (* #.movitz::+movitz-fixnum-factor+ (object-location context)) - (%run-time-context-slot 'physical-address-offset))) + (%run-time-context-slot 'self context) context + (%run-time-context-slot 'atomically-continuation context) 0) context)) -(defun switch-to-context (context) - (check-type context run-time-context) - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :eax) context) - (:movw #.(cl:1- (cl:* 8 8)) (:esp -6)) - (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table)) - :eax) - (:addl :edi :eax) - (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax)) - (:movl :eax (:esp -4)) - (:lgdt (:esp -6)) - (:movw #x28 :ax) - (:movw :ax :fs) - (:locally (:movl (:edi (:edi-offset self)) :eax)))) - -(defun %run-time-context-install-stack (context &optional (stack-vector - (make-array 8192 :element-type 'u32)) - (cushion 1024)) - (check-type stack-vector vector) - (assert (< cushion (array-dimension stack-vector 0))) - (setf (%run-time-context-slot 'stack-vector context) stack-vector) +;;;(defun switch-to-context (context) +;;; (check-type context run-time-context) +;;; (with-inline-assembly (:returns :nothing) +;;; (:compile-form (:result-mode :eax) context) +;;; (:movw #.(cl:1- (cl:* 8 8)) (:esp -6)) +;;; (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table)) +;;; :eax) +;;; (:addl :edi :eax) +;;; (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax)) +;;; (:movl :eax (:esp -4)) +;;; (:lgdt (:esp -6)) +;;; (:movw #x28 :ax) +;;; (:movw :ax :fs) +;;; (:locally (:movl (:edi (:edi-offset self)) :eax)))) + +(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 stack-vector) 8 - (* 4 (array-dimension stack-vector 0)))) + (+ (object-location control-stack) 8 + (* 4 (array-dimension control-stack 0)))) (setf (%run-time-context-slot 'stack-bottom context) - (+ (object-location stack-vector) 8 + (+ (object-location control-stack) 8 (* 4 cushion))) - stack-vector) + control-stack) +

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1544 Modified Files: conditions.lisp Log Message: Have condition argument to invoke-debugger be optional. Date: Wed Apr 27 01:40:30 2005 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.13 movitz/losp/muerte/conditions.lisp:1.14 --- movitz/losp/muerte/conditions.lisp:1.13 Tue Nov 2 16:52:21 2004 +++ movitz/losp/muerte/conditions.lisp Wed Apr 27 01:40:29 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: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.13 2004/11/02 15:52:21 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.14 2005/04/26 23:40:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,7 +270,7 @@ (signal-simple 'simple-condition datum args) nil) -(defun invoke-debugger (condition) +(defun invoke-debugger (&optional condition) (when *debugger-hook* (let ((hook *debugger-hook*) (*debugger-hook* nil))

1 0