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@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)