/[noctool]/source/scheduler.lisp
ViewVC logotype

Contents of /source/scheduler.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Fri Feb 13 16:20:23 2009 UTC (5 years, 2 months ago) by jprewett
Branch: MAIN
CVS Tags: HEAD
Changes since 1.16: +5 -8 lines
ONLY SPAWN 1 THREAD / MONITOR (!!!)
1 (in-package #:net.hexapodia.noctool-scheduler)
2
3 (defvar *default-scheduler* nil)
4 (defvar *network-updates-needed* nil)
5
6 (defvar *total-processes*
7 #+darwin 8
8 #-darwin 32)
9
10 (defvar *process-semaphore* (sb-thread:make-semaphore :name "Simultaneous processes" :count *total-processes*))
11
12 (defmacro with-semaphore (semaphore &body body)
13 `(progn
14 (sb-thread:wait-on-semaphore ,semaphore)
15 (unwind-protect
16 (progn ,@body)
17 (sb-thread:signal-semaphore ,semaphore))))
18
19 (defmacro noc-thread (&body body)
20 `(with-semaphore *process-semaphore*
21 ,@body))
22
23 (defclass event ()
24 ((time :reader time :initarg :time)
25 (object :reader object :initarg :object)))
26
27 (defclass timeslot ()
28 ((time :reader time :initarg :time)
29 (events :accessor events :initarg :events :initform nil)
30 (next :accessor next :initarg :next :initform nil)
31 (prev :accessor prev :initarg :prev :initform nil)
32 (lock :accessor lock :initform (sb-thread:make-mutex :name "scheduler lock"))
33 ))
34
35 (defclass scheduler ()
36 ((first-timeslot :accessor first-timeslot :initarg :first-timeslot)
37 (last-timeslot :accessor last-timeslot :initarg :last-timeslot)
38 (lock :accessor lock :initform (sb-thread:make-mutex :name "scheduler lock"))
39 )
40 (:default-initargs :first-timeslot nil :last-timeslot nil))
41
42 (defgeneric find-object (object store))
43
44 (defmethod find-object (object (event event))
45 (equal object (object event)))
46
47 (defmethod find-object (object (timeslot timeslot))
48 (loop for event in (events timeslot)
49 when (find-object object event)
50 do (return t)))
51
52 (defmethod find-object (object (scheduler scheduler))
53 (loop with timeslot = (first-timeslot scheduler)
54 when (find-object object timeslot)
55 do (return timeslot)
56 when t
57 do (if (equal timeslot (last-timeslot scheduler))
58 (return NIL)
59 (setf timeslot (next timeslot)))))
60
61 (defmethod time ((foo null))
62 foo)
63 (defmethod first-timeslot ((foo null))
64 foo)
65
66 (defmethod last-timeslot ((foo null))
67 foo)
68 (defmethod prev ((foo null))
69 foo)
70 (defmethod next ((foo null))
71 foo)
72
73 ;;; XXX assumes a slot named "lock" in the object :P
74 ;;; D'OH!
75 (defmacro with-object-lock (scheduler &body body)
76 (let ((lock (gensym)))
77 `(let ((,lock (lock ,scheduler)))
78 (sb-thread:with-mutex (,lock)
79 ,@body))))
80
81 (defun find-timeslot (scheduler time)
82 (cond ((null (first-timeslot scheduler))
83 (let ((new (make-instance 'timeslot :time time)))
84 (setf (first-timeslot scheduler) new)
85 (setf (last-timeslot scheduler) new)
86 new))
87 ((< time (time (first-timeslot scheduler)))
88 (let ((new (make-instance 'timeslot :time time)))
89 (setf (next new) (first-timeslot scheduler))
90 (setf (prev (first-timeslot scheduler)) new)
91 (setf (first-timeslot scheduler) new)
92 new))
93 ((> time (time (last-timeslot scheduler)))
94 (let ((new (make-instance 'timeslot :time time)))
95 (setf (prev new) (last-timeslot scheduler))
96 (setf (next (last-timeslot scheduler)) new)
97 (setf (last-timeslot scheduler) new)
98 new))
99 ((= time (time (last-timeslot scheduler)))
100 (last-timeslot scheduler))
101 ((= time (time (first-timeslot scheduler)))
102 (first-timeslot scheduler))
103 (t (let ((fdiff (- time (time (first-timeslot scheduler))))
104 (ldiff (- time (time (last-timeslot scheduler)))))
105 (cond ((< ldiff fdiff)
106 (loop for here = (last-timeslot scheduler) then (prev here)
107 for next = (prev (last-timeslot scheduler)) then (prev next)
108 do (cond ((= time (time here))
109 (return here))
110 ((< (time next) time (time here))
111 (let ((new (make-instance
112 'timeslot
113 :time time
114 :next here
115 :prev next)))
116 (setf (next next) new)
117 (setf (prev here) new)
118 (return new))))))
119 (t
120 (loop for here = (first-timeslot scheduler) then (next here)
121 for next = (next (last-timeslot scheduler)) then (next next)
122 do (cond ((= time (time here))
123 (return here))
124 ((< (time next) time (time here))
125 (let ((new (make-instance
126 'timeslot
127 :time time
128 :prev here
129 :next next)))
130 (setf (next here) new)
131 (setf (prev next) new)
132 (return new)))))))))))
133
134 (defgeneric add-event (event store))
135 (defgeneric process (thing))
136
137 (defmethod add-event ((event event) (store scheduler))
138 (with-object-lock store
139 (let* ((time (time event))
140 (object (object event))
141 (slot (find-timeslot store time))
142 (found (find-object object store)))
143 (if found
144 (progn (warn "not scheduling object: ~A as it is already scheduled at ~A!~%" object (time found)))
145 (add-event event slot)))))
146
147 (defmethod add-event ((event event) (store timeslot))
148 (with-object-lock store
149 (when (= (time event) (time store))
150 (push event (events store)))))
151
152 (defun remove-timeslot (timeslot)
153 (when timeslot
154 (with-object-lock timeslot
155 (progn
156 (setf (prev (next timeslot)) (prev timeslot))
157 (setf (next (prev timeslot)) (next timeslot))
158 (setf (prev timeslot) nil)
159 (setf (next timeslot) nil)))))
160
161 (defun next-timeslot (&optional (scheduler *default-scheduler*))
162 (with-object-lock (if scheduler
163 scheduler
164 (or *default-scheduler*
165 (setf *default-scheduler*
166 (make-instance 'scheduler))))
167 (prog1
168 (first-timeslot scheduler)
169 (setf (first-timeslot scheduler) (next (first-timeslot scheduler)))
170 (unless (null (first-timeslot scheduler))
171 (setf (prev (first-timeslot scheduler)) nil))
172 (when (null (first-timeslot scheduler))
173 (setf (last-timeslot scheduler) nil)))))
174
175 (defun next-time (&optional (scheduler *default-scheduler*))
176 (when scheduler
177 (time (first-timeslot scheduler))))
178
179 (defmethod schedule (object time &optional (scheduler *default-scheduler*))
180 (let ((event (make-instance 'event :time time :object object)))
181 (when (null scheduler)
182 (setf *default-scheduler* (make-instance 'scheduler))
183 (setf scheduler *default-scheduler*))
184 (add-event event scheduler)))
185
186 #+debug
187 (defmethod process :around ((slot timeslot))
188 (format t "about to process timeslot: ~A at ~A~%"
189 (sb-int:format-universal-time NIL (time slot))
190 (sb-int:format-universal-time NIL (get-universal-time)))
191 (call-next-method)
192 (format t "done processing timeslot: ~A~%"
193 (sb-int:format-universal-time NIL (time slot)))
194 (if (next-time)
195 (format t "next timeslot: ~A~%"
196 (sb-int:format-universal-time NIL (next-time)))
197 (format t "no next timeslot!~%")))
198
199 (defmethod process ((slot timeslot))
200 (loop for event in (events slot)
201 do (process event)))
202
203 (defvar *process-mutex* (sb-thread:make-mutex :name "process lock"))
204
205 (defmethod process ((event event))
206 #-no-noctool-threads
207 (handler-case
208 (sb-ext:with-timeout 10000
209 (noc-thread (process (object event))))
210 (sb-ext::timeout ()
211 (warn "Timing out thread ~A~%" sb-thread:*current-thread*)))
212 #+no-noctool-threads
213 (process (object event)))
214
215 (defmethod process :before ((event net.hexapodia.noctool-scheduler:event))
216 (let ((obj (net.hexapodia.noctool-scheduler::object event)))
217 (when (or (noctool::proxies (noctool::equipment obj)) (noctool:proxies obj))
218 (push obj *network-updates-needed*))))
219
220 (define-symbol-macro threads (sb-thread:list-all-threads))
221
222 (defvar *scheduler-loop-control* nil "Set to NIL to terminate a running scheduler loop")
223
224 (defun scheduler-loop ()
225 (setf *scheduler-loop-control* t)
226 (loop while *scheduler-loop-control*
227 do (let ((next (next-time)))
228 (cond ((null next) (sleep 60))
229 ((<= next (get-universal-time))
230 (process (next-timeslot)))
231 (t (sleep (min 1 (- next (get-universal-time)))))))))
232

  ViewVC Help
Powered by ViewVC 1.1.5