[movitz-cvs] CVS update: movitz/losp/lib/threading.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sun May 8 01:20:49 UTC 2005
Update of /project/movitz/cvsroot/movitz/losp/lib
In directory common-lisp.net:/tmp/cvs-serv25192
Modified Files:
threading.lisp
Log Message:
(make-instance 'thread) and yield seem to work now.. :)
Date: Sun May 8 03:20:48 2005
Author: ffjeld
Index: movitz/losp/lib/threading.lisp
diff -u movitz/losp/lib/threading.lisp:1.4 movitz/losp/lib/threading.lisp:1.5
--- movitz/losp/lib/threading.lisp:1.4 Fri May 6 08:59:03 2005
+++ movitz/losp/lib/threading.lisp Sun May 8 03:20:48 2005
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Thu Apr 28 08:30:01 2005
;;;;
-;;;; $Id: threading.lisp,v 1.4 2005/05/06 06:59:03 ffjeld Exp $
+;;;; $Id: threading.lisp,v 1.5 2005/05/08 01:20:48 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -19,36 +19,44 @@
(defpackage threading
(:use cl muerte)
(:export thread
- make-thread
yield
+ *segment-descriptor-table-manager*
+ segment-descriptor-table-manager
+ allocate-segment-selector
))
-(in-package muerte)
+(in-package threading)
-(defclass segment-descriptor-manager ()
+(defvar *segment-descriptor-table-manager*)
+
+(defclass segment-descriptor-table-manager ()
((table
- :accessor segment-descriptor-table
+ :reader segment-descriptor-table
:initarg :table
- :initform (dump-global-segment-table :entries 32))
+ :initform (setf (muerte::global-segment-descriptor-table)
+ (muerte::dump-global-segment-table :entries 64)))
+ (clients
+ :initform (make-array 64))
(range-start
:initarg :range-start
:accessor range-start
- :initform (1+ (ceiling (reduce #'max '(:cs :ds :es :ss :fs)
- :key #'segment-register)
- 8)))))
+ :initform (+ 8 (logand #xfff8 (reduce #'max '(:cs :ds :es :ss :fs)
+ :key #'segment-register))))))
-(defmethod allocate-segment-selector ((manager segment-descriptor-manager) &optional errorp)
+(defmethod allocate-segment-selector ((manager segment-descriptor-table-manager) client
+ &optional (errorp t))
(loop with table = (segment-descriptor-table manager)
- for s from (range-start manager) below (/ (length table) 2)
- do (when (zerop (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s)))
- (setf (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s)) 1)
- (return (* 8 s)))
+ with clients = (slot-value manager 'clients)
+ for selector from (range-start manager) below (* (length table) 2) by 8
+ do (when (not (aref clients (truncate selector 8)))
+ (setf (aref clients (truncate selector 8)) client)
+ (return selector))
finally (when errorp
(error "Unable to allocate a segment selector."))))
(defclass thread (run-time-context)
((segment-selector
- :initform :segment-selector))
+ :initarg :segment-selector))
(:metaclass run-time-context-class))
(defmacro control-stack-ebp (stack)
@@ -60,6 +68,45 @@
(defmacro control-stack-fs (stack)
`(stack-frame-ref ,stack 0 2))
+(defmethod initialize-instance :after ((thread thread)
+ &key (stack-size 2048) segment-selector stack-cushion
+ (function #'invoke-debugger) (args '(nil))
+ &allow-other-keys)
+ (let ((segment-selector
+ (or segment-selector
+ (let ((selector (setf (slot-value thread 'segment-selector)
+ (allocate-segment-selector *segment-descriptor-table-manager* thread))))
+ (setf (segment-descriptor (segment-descriptor-table *segment-descriptor-table-manager*)
+ selector)
+ (segment-descriptor (segment-descriptor-table *segment-descriptor-table-manager*)
+ (segment-register :fs)))
+ selector))))
+ (check-type segment-selector (unsigned-byte 16))
+ (setf (segment-descriptor-base-location (segment-descriptor-table *segment-descriptor-table-manager*)
+ segment-selector)
+ (+ (object-location thread) (location-physical-offset)))
+ (let ((stack (control-stack-init-for-yield (make-array stack-size
+ :element-type '(unsigned-byte 32))
+ function args)))
+ (multiple-value-bind (ebp esp)
+ (control-stack-fixate stack)
+ (setf (control-stack-fs stack) segment-selector
+ (control-stack-ebp stack) ebp
+ (control-stack-esp stack) esp))
+ (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0)
+ (setf (%run-time-context-slot thread 'muerte::stack-vector) stack)
+ (setf (%run-time-context-slot thread 'muerte::stack-top)
+ (+ 2 (object-location stack)
+ (length stack)))
+ (setf (%run-time-context-slot thread 'muerte::stack-bottom)
+ (+ (object-location stack) 2
+ (or stack-cushion
+ (if (>= (length stack) 200)
+ 100
+ 0))))
+ (values thread))))
+
+
(defun control-stack-push (value stack &optional (type :lisp))
(let ((i (decf (control-stack-esp stack))))
(assert (< 1 i (length stack)))
@@ -113,40 +160,11 @@
(control-stack-enter-frame stack #'yield)
stack)
-(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) 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 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)
- (+ (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)))
- (multiple-value-bind (ebp esp)
- (control-stack-fixate stack)
- (setf (control-stack-fs stack) fs
- (control-stack-ebp stack) ebp
- (control-stack-esp stack) esp))
- (setf (%run-time-context-slot thread 'dynamic-env) 0
- (%run-time-context-slot thread 'stack-vector) stack
- (%run-time-context-slot thread 'stack-top) (+ 2 (object-location stack)
- (length stack))
- (%run-time-context-slot thread 'stack-bottom) (+ (object-location stack) 2
- (or cushion
- (if (>= (length stack) 200)
- 100
- 0))))
- (values thread))))
-
(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 nil 'stack-vector))
- (target-stack (%run-time-context-slot target-rtc 'stack-vector)))
+ (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector))
+ (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector)))
(assert (not (eq my-stack target-stack)))
(let ((fs (control-stack-fs target-stack))
(esp (control-stack-esp target-stack))
@@ -159,8 +177,8 @@
;; 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 target-rtc 'scratch1) ebp
- (%run-time-context-slot target-rtc 'scratch2) esp)
+ (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp
+ (%run-time-context-slot target-rtc 'muerte::scratch2) esp)
;; Enable someone to yield back here..
(setf (control-stack-fs my-stack) (segment-register :fs)
(control-stack-ebp my-stack) (muerte::asm-register :ebp)
More information about the Movitz-cvs
mailing list