[noctool-cvs] CVS source
jprewett
jprewett at common-lisp.net
Mon Nov 10 14:29:45 UTC 2008
Update of /project/noctool/cvsroot/source
In directory cl-net:/tmp/cvs-serv11639
Modified Files:
scheduler.lisp
Log Message:
tried to make multithreading stuff work better
XXX CHECK ME XXX
--- /project/noctool/cvsroot/source/scheduler.lisp 2008/08/26 15:54:29 1.7
+++ /project/noctool/cvsroot/source/scheduler.lisp 2008/11/10 14:29:45 1.8
@@ -2,27 +2,26 @@
(defvar *default-scheduler* nil)
(defvar *network-updates-needed* nil)
-(defvar *scheduler-loop-control* nil "Set to NIL to terminate a running scheduler loop")
(defclass event ()
((time :reader time :initarg :time)
- (object :reader object :initarg :object)
- ))
+ (object :reader object :initarg :object)))
(defclass timeslot ()
((time :reader time :initarg :time)
(events :accessor events :initarg :events :initform nil)
(next :accessor next :initarg :next :initform nil)
- (prev :accessor prev :initarg :prev :initform nil)
+ (prev :accessor prev :initarg :prev :initform nil)
+ (lock :accessor lock :initform (sb-thread:make-mutex :name "scheduler lock"))
))
(defclass scheduler ()
((first-timeslot :accessor first-timeslot :initarg :first-timeslot)
(last-timeslot :accessor last-timeslot :initarg :last-timeslot)
+ (lock :accessor lock :initform (sb-thread:make-mutex :name "scheduler lock"))
)
(:default-initargs :first-timeslot nil :last-timeslot nil))
-
(defmethod time ((foo null))
foo)
(defmethod first-timeslot ((foo null))
@@ -35,8 +34,16 @@
(defmethod next ((foo null))
foo)
+;;; XXX assumes a slot named "lock" in the object :P
+;;; D'OH!
+(defmacro with-object-lock (scheduler &body body)
+ (let ((lock (gensym)))
+ `(let ((,lock (lock ,scheduler)))
+ (sb-thread:with-mutex (,lock)
+ , at body))))
+
(defun find-timeslot (scheduler time)
- (cond ((null (first-timeslot scheduler))
+ (cond ((null (first-timeslot scheduler))
(let ((new (make-instance 'timeslot :time time)))
(setf (first-timeslot scheduler) new)
(setf (last-timeslot scheduler) new)
@@ -87,73 +94,124 @@
(setf (next here) new)
(setf (prev next) new)
(return new)))))))))))
-
(defgeneric add-event (event store))
(defgeneric process (thing))
(defmethod add-event ((event event) (store scheduler))
- (let ((time (time event)))
- (let ((slot (find-timeslot store time)))
- (add-event event slot))))
+ (with-object-lock store
+ (let ((time (time event)))
+ (let ((slot (find-timeslot store time)))
+ (add-event event slot)))))
(defmethod add-event ((event event) (store timeslot))
- (when (= (time event) (time store))
- (push event (events store))))
+ (with-object-lock store
+ (when (= (time event) (time store))
+ (push event (events store)))))
(defun remove-timeslot (timeslot)
- (setf (prev (next timeslot)) (prev timeslot))
- (setf (next (prev timeslot)) (next timeslot))
- (setf (prev timeslot) nil)
- (setf (next timeslot) nil))
+ (when timeslot
+ (with-object-lock timeslot
+ (progn
+ (setf (prev (next timeslot)) (prev timeslot))
+ (setf (next (prev timeslot)) (next timeslot))
+ (setf (prev timeslot) nil)
+ (setf (next timeslot) nil)))))
(defun next-timeslot (&optional (scheduler *default-scheduler*))
- (unless scheduler
- (unless *default-scheduler*
- (setf *default-scheduler* (make-instance 'scheduler)))
- (setf scheduler *default-scheduler*))
- (prog1
- (first-timeslot scheduler)
- (setf (first-timeslot scheduler) (next (first-timeslot scheduler)))
- (unless (null (first-timeslot scheduler))
- (setf (prev (first-timeslot scheduler)) nil))
- (when (null (first-timeslot scheduler))
- (setf (last-timeslot scheduler) nil))))
+ (with-object-lock (if scheduler
+ scheduler
+ (or *default-scheduler*
+ (setf *default-scheduler*
+ (make-instance 'scheduler))))
+ (prog1
+ (first-timeslot scheduler)
+ (setf (first-timeslot scheduler) (next (first-timeslot scheduler)))
+ (unless (null (first-timeslot scheduler))
+ (setf (prev (first-timeslot scheduler)) nil))
+ (when (null (first-timeslot scheduler))
+ (setf (last-timeslot scheduler) nil)))))
(defun next-time (&optional (scheduler *default-scheduler*))
(when scheduler
(time (first-timeslot scheduler))))
(defun schedule (object time &optional (scheduler *default-scheduler*))
- (let ((event (make-instance 'event :time time :object object)))
- (when (null scheduler)
- (setf *default-scheduler* (make-instance 'scheduler))
- (setf scheduler *default-scheduler*))
-
- (add-event event scheduler)))
+ (let ((event (make-instance 'event :time time :object object)))
+ (when (null scheduler)
+ (setf *default-scheduler* (make-instance 'scheduler))
+ (setf scheduler *default-scheduler*))
+ (add-event event scheduler)))
(defmethod process ((slot timeslot))
(loop for event in (events slot)
- do (process event)))
+ do (process event)))
+(defvar *process-mutex* (sb-thread:make-mutex :name "process lock"))
+
+(defvar *total-processes*
+ #+darwin 1
+ #-darwin 32)
+
+(defvar *available-processes*
+ (loop for i from 1 to *total-processes*
+ collect
+ (sb-thread:make-mutex)))
+
+(defvar *mini-sleep* 0.05)
+
+;; XXX is this right? XXX
+(defmacro noc-thread (&body body)
+ (let ((my-mutex (gensym))
+ (first-mutex (gensym))
+ (return-val (gensym)))
+ `(let ((,return-val NIL)
+ (,my-mutex
+ (sb-thread:with-mutex (*process-mutex*)
+ (loop as ,first-mutex = (car *available-processes*)
+ until ,first-mutex
+ do
+ (format t "+")
+ (sleep *mini-sleep*)
+ finally
+ (progn
+ (setf *available-processes* (cdr *available-processes*))
+ (return ,first-mutex))))))
+ (sb-thread:with-mutex (,my-mutex)
+ (setf ,return-val , at body))
+ (sb-thread:with-mutex (*process-mutex*)
+ (setf *available-processes* (cons ,my-mutex *available-processes*)))
+ ,return-val)))
(defmethod process ((event event))
#-no-noctool-threads
- (sb-thread:make-thread (lambda () (process (object event))))
+ (noc-thread
+ (sb-thread:make-thread
+ #'(lambda ()
+ (handler-case
+ (sb-ext:with-timeout 3000
+ (process (object event)))
+ (sb-ext::timeout ()
+ (warn "Timing out thread ~A~%" sb-thread:*current-thread*))))))
#+no-noctool-threads
(process (object event)))
(defmethod process :before ((event net.hexapodia.noctool-scheduler:event))
(let ((obj (net.hexapodia.noctool-scheduler::object event)))
- (when (or (noctool::proxies (noctool::equipment obj))
- (noctool::proxies obj))
+ (when (or (noctool::proxies (noctool::equipment obj)) (noctool:proxies obj))
(push obj *network-updates-needed*))))
+(define-symbol-macro threads (sb-thread:list-all-threads))
+
+(defvar *scheduler-loop-control* nil "Set to NIL to terminate a running scheduler loop")
+
(defun scheduler-loop ()
(setf *scheduler-loop-control* t)
- (loop while *scheduler-loop-control*
- do (let ((next (next-time)))
- (cond ((null next) (sleep 60))
- ((<= next (get-universal-time)) (process (next-timeslot)))
- (t (sleep (min 1 (- next (get-universal-time))))
- (process (next-timeslot)))))))
+ (loop while *scheduler-loop-control*
+ do (let ((next (next-time)))
+ (cond ((null next) (sleep 60))
+ ((<= next (get-universal-time))
+ (process (next-timeslot)))
+ (t (sleep (min 1 (- next (get-universal-time))))
+ (process (next-timeslot)))))))
+
More information about the noctool-cvs
mailing list