[movitz-cvs] CVS update: movitz/image.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv10362

Modified Files:
	image.lisp 
Log Message:
Added concept of "thread-atomical" code, which allows some small
section of code to run atomically with respect to the same thread
(i.e. should the thread be interrupted for whatever reason).
"Atomically" is here used in the sense all-or-nothing. Such
code-blocks can still be interrupted, but if so, it will be re-started
from some declared starting-point.

Date: Tue Jun  1 06:42:06 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.31 movitz/image.lisp:1.32
--- movitz/image.lisp:1.31	Mon May 24 12:05:59 2004
+++ movitz/image.lisp	Tue Jun  1 06:42:06 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.31 2004/05/24 19:05:59 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.32 2004/06/01 13:42:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -450,11 +450,39 @@
    (segment-descriptor-7
     :binary-type segment-descriptor
     :initform (make-segment-descriptor))
+   (atomically-status
+    :binary-type (define-bitfield atomically-status (lu32)
+		   (((:enum :byte (2 3))
+		     :inactive 0
+		     :restart-primitive-function 1) ; data = slot-offset of pf.
+		    ((:bits) :reset-status-p 7
+			     :eax 8
+			     :ebx 9
+			     :ecx 10
+			     :edx 11)
+		    ((:numeric :data 16 16))))
+    :initform '(:inactive))
+   (atomically-registers
+    :binary-type lu32
+    :initform 0)
    (bochs-flags
     :binary-type lu32
     :initform 0)
    )
   (:slot-align null-cons -1))
+
+(defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)
+  (bt:enum-value 'movitz::atomically-status
+		 (list* :restart-primitive-function
+			(cons :reset-status-p
+			      (if reset-status-p 1 0))
+			(cons :data
+			      (truncate (+ (tag :null)
+					   (bt:slot-offset 'movitz-constant-block
+							   (intern (symbol-name pf-name)
+								   :movitz)))
+					4))
+			registers)))
 
 (defmethod movitz-object-offset ((obj movitz-constant-block)) 0)