54 |
|
|
55 |
#undef DEBUG |
#undef DEBUG |
56 |
|
|
57 |
static pthread_mutex_t guile_mutex = PTHREAD_MUTEX_INITIALIZER; |
/* This thread implementation uses POSIX threads but allows only |
58 |
pthread_t guile_thread; |
thread to really execute at any one time. |
59 |
|
|
60 |
static SCM all_threads; |
XXX - more overview here. |
61 |
static int thread_count; |
*/ |
62 |
|
|
63 |
static pthread_key_t handle_key; |
/* All data is protected by a single mutex: guile_mutex. */ |
64 |
|
|
65 |
/* The following functions are for managing a threads visit in Guile |
static pthread_mutex_t guile_mutex = PTHREAD_MUTEX_INITIALIZER; |
66 |
land. A thread can be in one of three states: outside, active, or |
|
67 |
suspended. "Outside" means that the thread can not call any Guile |
/*** Threads */ |
|
related functions and can not store SCM values in local variables. |
|
|
"Active" or "suspended" means that a thread can use Guile and can |
|
|
store SCM values in its stack. An "active" thread is currently |
|
|
executing while a "suspended" one is waiting to become active |
|
|
again. There can only be one "active" thread at any one time. |
|
|
*/ |
|
68 |
|
|
69 |
typedef struct ticket { |
typedef struct scm_copt_thread { |
70 |
struct ticket *next; |
|
71 |
struct ticket **prevp; |
/* A condition variable for sleeping on. |
72 |
|
*/ |
73 |
|
pthread_cond_t sleep_cond; |
74 |
|
|
75 |
|
/* A link for the ready queue. |
76 |
|
*/ |
77 |
|
struct scm_copt_thread *next_ready; |
78 |
|
|
79 |
|
scm_root_state *root; |
80 |
|
SCM handle; |
81 |
|
pthread_t pthread; |
82 |
|
SCM result; |
83 |
|
|
84 |
|
/* For keeping track of the stack and registers. */ |
85 |
SCM_STACKITEM *base; |
SCM_STACKITEM *base; |
86 |
SCM_STACKITEM *top; |
SCM_STACKITEM *top; |
87 |
jmp_buf regs; |
jmp_buf regs; |
|
} ticket; |
|
88 |
|
|
89 |
static ticket *tickets = NULL; |
} scm_copt_thread; |
|
static pthread_key_t ticket_key; |
|
90 |
|
|
91 |
/* Enter Guile land. While in Guile land, the stack between BASE and |
static SCM |
92 |
the current stack pointer will be scanned for SCM references. Only |
make_thread (SCM args) |
|
one thread can be in Guile land at any one time. When you try to |
|
|
enter it while another one is already there, you will be put to |
|
|
sleep until it leaves or suspends. |
|
|
*/ |
|
|
static void |
|
|
enter_guile (SCM_STACKITEM *base, ticket *t) |
|
93 |
{ |
{ |
94 |
pthread_mutex_lock (&guile_mutex); |
SCM z; |
95 |
guile_thread = pthread_self (); |
scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); |
96 |
|
z = scm_cell (scm_tc16_thread, (scm_t_bits)t); |
97 |
#ifdef DEBUG |
t->handle = z; |
98 |
fprintf (stderr, "thread %ld entered\n", pthread_self ()); |
t->result = args; |
99 |
#endif |
return z; |
100 |
|
} |
101 |
|
|
102 |
/* Ok, we are in. Stamp our ticket. */ |
static void |
103 |
t->next = tickets; |
init_thread_creator (SCM thread, pthread_t th, scm_root_state *r) |
104 |
if (tickets) |
{ |
105 |
tickets->prevp = &t->next; |
scm_copt_thread *t = SCM_THREAD_DATA(thread); |
106 |
tickets = t; |
t->root = r; |
107 |
t->prevp = &tickets; |
t->pthread = th; |
108 |
|
pthread_cond_init (&t->sleep_cond, NULL); |
109 |
|
} |
110 |
|
|
111 |
|
static void |
112 |
|
init_thread_creatant (SCM thread, SCM_STACKITEM *base) |
113 |
|
{ |
114 |
|
scm_copt_thread *t = SCM_THREAD_DATA(thread); |
115 |
t->base = base; |
t->base = base; |
116 |
t->top = NULL; |
t->top = NULL; |
117 |
|
} |
118 |
|
|
119 |
pthread_setspecific (ticket_key, (void *)t); |
static SCM |
120 |
|
thread_mark (SCM obj) |
121 |
|
{ |
122 |
|
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
123 |
|
scm_gc_mark (t->result); |
124 |
|
return t->root->handle; |
125 |
} |
} |
126 |
|
|
127 |
/* Leave Guile land so that the next thread can enter. This function |
static int |
128 |
must be called from the same stack frame as the corresponding |
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
|
enter_guile. The stack of this thread will no longer be scanned. |
|
|
*/ |
|
|
static void |
|
|
leave_guile (ticket *t) |
|
129 |
{ |
{ |
130 |
/* Remove ticket... */ |
scm_copt_thread *t = SCM_THREAD_DATA (exp); |
131 |
*t->prevp = t->next; |
scm_puts ("#<thread ", port); |
132 |
if (t->next) |
scm_intprint ((unsigned long)t, 16, port); |
133 |
t->next->prevp = t->prevp; |
if (t->pthread != -1) |
134 |
|
{ |
135 |
|
scm_putc (' ', port); |
136 |
|
scm_intprint (t->pthread, 10, port); |
137 |
|
} |
138 |
|
else |
139 |
|
scm_puts (" (exited)", port); |
140 |
|
scm_putc ('>', port); |
141 |
|
return 1; |
142 |
|
} |
143 |
|
|
144 |
#ifdef DEBUG |
static size_t |
145 |
fprintf (stderr, "thread %ld left\n", pthread_self ()); |
thread_free (SCM obj) |
146 |
#endif |
{ |
147 |
|
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
148 |
|
if (t->pthread != -1) |
149 |
|
abort (); |
150 |
|
scm_gc_free (t, sizeof (*t), "thread"); |
151 |
|
return 0; |
152 |
|
} |
153 |
|
|
154 |
/* ...and leave. */ |
/*** Queues */ |
155 |
guile_thread = 0; |
|
156 |
pthread_mutex_unlock (&guile_mutex); |
static SCM |
157 |
|
make_queue () |
158 |
|
{ |
159 |
|
return scm_cons (SCM_EOL, SCM_EOL); |
160 |
|
} |
161 |
|
|
162 |
|
static void |
163 |
|
enqueue (SCM q, SCM t) |
164 |
|
{ |
165 |
|
SCM c = scm_cons (t, SCM_EOL); |
166 |
|
if (SCM_NULLP (SCM_CAR (q))) |
167 |
|
SCM_SETCAR (q, c); |
168 |
|
else |
169 |
|
SCM_SETCDR (SCM_CDR (q), c); |
170 |
|
SCM_SETCDR (q, c); |
171 |
} |
} |
172 |
|
|
173 |
/* Suspend the visit in Guile land so that other threads can resume |
static SCM |
174 |
their visit or enter. While a thread is suspended, its stack is |
dequeue (SCM q) |
175 |
scanned between BASE (as given to enter_guile) and TOP (as given |
{ |
176 |
here). |
SCM c = SCM_CAR (q); |
177 |
|
if (SCM_NULLP (c)) |
178 |
|
return SCM_BOOL_F; |
179 |
|
else |
180 |
|
{ |
181 |
|
SCM_SETCAR (q, SCM_CDR (c)); |
182 |
|
if (SCM_NULLP (SCM_CAR (q))) |
183 |
|
SCM_SETCDR (q, SCM_EOL); |
184 |
|
return SCM_CAR (c); |
185 |
|
} |
186 |
|
} |
187 |
|
|
188 |
|
/*** Ready queue */ |
189 |
|
|
190 |
|
/* Normally, queues are implemented with the procedures above, but the |
191 |
|
ready queue is special. We need to put threads on it from the |
192 |
|
'outside', i.e., when we don't hold the guile_mutex. That's why |
193 |
|
the ready queue has its own mutex and isn't implemented with SCM |
194 |
|
objects. |
195 |
*/ |
*/ |
196 |
static ticket * |
|
197 |
suspend_guile () |
static pthread_mutex_t ready_queue_mutex = PTHREAD_MUTEX_INITIALIZER; |
198 |
|
static scm_copt_thread *next_ready = NULL; |
199 |
|
static scm_copt_thread *last_ready = NULL; |
200 |
|
|
201 |
|
static void |
202 |
|
get_ready (scm_copt_thread *t) |
203 |
{ |
{ |
204 |
ticket *t = pthread_getspecific (ticket_key); |
pthread_mutex_lock (&ready_queue_mutex); |
205 |
|
t->next_ready = NULL; |
206 |
|
if (last_ready) |
207 |
|
last_ready->next_ready = t; |
208 |
|
else |
209 |
|
next_ready = t; |
210 |
|
last_ready = t; |
211 |
|
pthread_mutex_unlock (&ready_queue_mutex); |
212 |
|
} |
213 |
|
|
214 |
if (t == NULL) |
static scm_copt_thread * |
215 |
abort (); |
get_next_ready () |
216 |
|
{ |
217 |
|
scm_copt_thread *t; |
218 |
|
pthread_mutex_lock (&ready_queue_mutex); |
219 |
|
t = next_ready; |
220 |
|
if (t) |
221 |
|
{ |
222 |
|
next_ready = t->next_ready; |
223 |
|
if (next_ready == NULL) |
224 |
|
last_ready = NULL; |
225 |
|
} |
226 |
|
return t; |
227 |
|
pthread_mutex_unlock (&ready_queue_mutex); |
228 |
|
} |
229 |
|
|
230 |
|
/*** Running and sleeping */ |
231 |
|
|
232 |
|
static SCM cur_thread; |
233 |
|
|
234 |
|
/* Kick the next runnable thread if there is one. |
235 |
|
*/ |
236 |
|
static void |
237 |
|
kick_next () |
238 |
|
{ |
239 |
|
scm_copt_thread *next = get_next_ready (ready_queue); |
240 |
|
if (next) |
241 |
|
pthread_cond_signal (&next->sleep_cond); |
242 |
|
} |
243 |
|
|
244 |
|
static SCM |
245 |
|
suspend () |
246 |
|
{ |
247 |
|
SCM cur = cur_thread; |
248 |
|
scm_copt_thread *c = SCM_THREAD_DATA (cur); |
249 |
|
|
250 |
/* Record top of stack...*/ |
/* record top of stack for the GC */ |
251 |
t->top = (SCM_STACKITEM *)&t; |
c->top = (SCM_STACKITEM *)&c; |
252 |
/* ...save registers for the GC...*/ |
/* save registers. */ |
253 |
SCM_FLUSH_REGISTER_WINDOWS; |
SCM_FLUSH_REGISTER_WINDOWS; |
254 |
setjmp (t->regs); |
setjmp (c->regs); |
255 |
|
|
256 |
#ifdef DEBUG |
return cur; |
257 |
fprintf (stderr, "thread %ld suspended\n", pthread_self ()); |
} |
|
#endif |
|
258 |
|
|
259 |
/* ... and leave temporarily. */ |
static void |
260 |
guile_thread = 0; |
release () |
261 |
|
{ |
262 |
pthread_mutex_unlock (&guile_mutex); |
pthread_mutex_unlock (&guile_mutex); |
|
return t; |
|
263 |
} |
} |
264 |
|
|
|
/* Resume the visit. This must be called from the same frame as the |
|
|
corresponding suspend_guile. |
|
|
*/ |
|
265 |
static void |
static void |
266 |
resume_guile (ticket *t) |
acquire () |
267 |
{ |
{ |
268 |
|
please = 1; |
269 |
pthread_mutex_lock (&guile_mutex); |
pthread_mutex_lock (&guile_mutex); |
|
guile_thread = pthread_self (); |
|
|
#ifdef DEBUG |
|
|
fprintf (stderr, "thread %ld resumed\n", pthread_self ()); |
|
|
#endif |
|
|
t->top = NULL; |
|
270 |
} |
} |
271 |
|
|
|
static ticket main_ticket; |
|
|
|
|
|
int scm_switch_counter; |
|
|
|
|
272 |
static void |
static void |
273 |
init_queue (scm_copt_queue *q) |
resume (SCM cur) |
274 |
{ |
{ |
275 |
q->first = NULL; |
scm_copt_thread *c = SCM_THREAD_DATA (cur); |
276 |
q->lastp = &q->first; |
cur_thread = cur; |
277 |
|
c->top = NULL; |
278 |
} |
} |
279 |
|
|
280 |
static void |
static void |
281 |
enqueue (scm_copt_queue *q, scm_copt_thread *t) |
block () |
282 |
{ |
{ |
283 |
t->prevp = q->lastp; |
SCM cur = suspend (); |
284 |
t->next = NULL; |
scm_copt_thread *c = SCM_THREAD_DATA (cur); |
285 |
*t->prevp = t; |
pthread_cond_wait (&c->sleep_cond, &guile_mutex); |
286 |
q->lastp = &t->next; |
resume (cur); |
287 |
} |
} |
288 |
|
|
289 |
static scm_copt_thread * |
/* Yielding consists of getting the next thread from the ready_queue |
290 |
dequeue (scm_copt_queue *q) |
and if there is one, putting ourselves on the ready queue and |
291 |
|
block. |
292 |
|
*/ |
293 |
|
SCM |
294 |
|
scm_yield () |
295 |
{ |
{ |
296 |
scm_copt_thread *t = q->first; |
scm_copt_thread *next = get_next_ready (); |
297 |
if (t) |
if (next) |
298 |
{ |
{ |
299 |
*t->prevp = t->next; |
pthread_cond_signal (&next->sleep_cond); |
300 |
if (t->next) |
get_ready (SCM_THREAD_DATA (cur_thread)); |
301 |
t->next->prevp = t->prevp; |
block (); |
|
else |
|
|
q->lastp = t->prevp; |
|
302 |
} |
} |
303 |
return t; |
return SCM_BOOL_T; |
304 |
|
} |
305 |
|
|
306 |
|
int scm_switch_counter; |
307 |
|
|
308 |
|
/*** Thread creation */ |
309 |
|
|
310 |
|
static SCM all_threads; |
311 |
|
static int thread_count; |
312 |
|
|
313 |
|
typedef struct scheme_launch_data { |
314 |
|
SCM rootcont; |
315 |
|
SCM body; |
316 |
|
SCM handler; |
317 |
|
} scheme_launch_data; |
318 |
|
|
319 |
|
static SCM |
320 |
|
scheme_body_bootstrip (scheme_launch_data* data) |
321 |
|
{ |
322 |
|
/* First save the new root continuation */ |
323 |
|
data->rootcont = scm_root->rootcont; |
324 |
|
return scm_call_0 (data->body); |
325 |
} |
} |
326 |
|
|
327 |
static SCM |
static SCM |
328 |
make_thread () |
scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args) |
329 |
{ |
{ |
330 |
SCM z; |
scm_root->rootcont = data->rootcont; |
331 |
scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); |
return scm_apply_1 (data->handler, tag, throw_args); |
|
z = scm_cell (scm_tc16_thread, (scm_t_bits)t); |
|
|
t->handle = z; |
|
|
return z; |
|
332 |
} |
} |
333 |
|
|
334 |
static void |
static void |
335 |
init_thread_creator (SCM thread, pthread_t th, scm_root_state *r) |
really_launch (SCM_STACKITEM *base, SCM thread) |
336 |
{ |
{ |
337 |
scm_copt_thread *t = SCM_THREAD_DATA(thread); |
scm_copt_thread *t = SCM_THREAD_DATA (thread); |
338 |
t->root = r; |
scheme_launch_data data; |
339 |
t->pthread = th; |
init_thread_creatant (thread, base); |
340 |
t->result = SCM_BOOL_F; |
resume (thread); |
341 |
pthread_cond_init (&t->block, NULL); |
|
342 |
|
/* Ok, we bullied our way in, now be nice and stand in queue. |
343 |
|
*/ |
344 |
|
scm_yield (); |
345 |
|
|
346 |
|
data.rootcont = SCM_BOOL_F; |
347 |
|
data.body = SCM_CAR (t->result); |
348 |
|
data.handler = SCM_CADR (t->result); |
349 |
|
t->result = |
350 |
|
scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip, |
351 |
|
&data, |
352 |
|
(scm_t_catch_handler) scheme_handler_bootstrip, |
353 |
|
&data, base); |
354 |
|
pthread_detach (t->pthread); |
355 |
|
|
356 |
|
{ |
357 |
|
SCM next = dequeue (ready_queue); |
358 |
|
if (!SCM_FALSEP (next)) |
359 |
|
{ |
360 |
|
scm_copt_thread *n = SCM_THREAD_DATA (next); |
361 |
|
pthread_cond_signal (&n->sleep_cond); |
362 |
|
} |
363 |
|
} |
364 |
|
|
365 |
|
all_threads = scm_delq (thread, all_threads); |
366 |
|
t->pthread = -1; |
367 |
|
thread_count--; |
368 |
|
suspend (); |
369 |
} |
} |
370 |
|
|
371 |
static void |
static void * |
372 |
init_thread_creatant (SCM thread) |
scheme_launch_thread (void *p) |
373 |
{ |
{ |
374 |
scm_copt_thread *t = SCM_THREAD_DATA(thread); |
acquire (); |
375 |
pthread_setspecific (handle_key, t); |
really_launch ((SCM_STACKITEM *)&p, (SCM)p); |
376 |
|
release (); |
377 |
|
return NULL; |
378 |
|
} |
379 |
|
|
380 |
|
|
381 |
|
SCM |
382 |
|
scm_call_with_new_thread (SCM argl) |
383 |
|
#define FUNC_NAME s_call_with_new_thread |
384 |
|
{ |
385 |
|
SCM thread; |
386 |
|
|
387 |
|
/* Check arguments. */ |
388 |
|
{ |
389 |
|
register SCM args = argl; |
390 |
|
SCM thunk, handler; |
391 |
|
if (!SCM_CONSP (args)) |
392 |
|
SCM_WRONG_NUM_ARGS (); |
393 |
|
thunk = SCM_CAR (args); |
394 |
|
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), |
395 |
|
thunk, |
396 |
|
SCM_ARG1, |
397 |
|
s_call_with_new_thread); |
398 |
|
args = SCM_CDR (args); |
399 |
|
if (!SCM_CONSP (args)) |
400 |
|
SCM_WRONG_NUM_ARGS (); |
401 |
|
handler = SCM_CAR (args); |
402 |
|
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), |
403 |
|
handler, |
404 |
|
SCM_ARG2, |
405 |
|
s_call_with_new_thread); |
406 |
|
if (!SCM_NULLP (SCM_CDR (args))) |
407 |
|
SCM_WRONG_NUM_ARGS (); |
408 |
|
} |
409 |
|
|
410 |
|
/* Make new thread. The first thing the new thread will do is to |
411 |
|
lock guile_mutex. Thus, we can safely complete its |
412 |
|
initialization after creating it. While the new thread starts, |
413 |
|
all its data is protected via all_threads. |
414 |
|
*/ |
415 |
|
|
416 |
|
{ |
417 |
|
pthread_t th; |
418 |
|
SCM root, old_winds; |
419 |
|
|
420 |
|
/* Unwind wind chain. */ |
421 |
|
old_winds = scm_dynwinds; |
422 |
|
scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); |
423 |
|
|
424 |
|
/* Allocate thread locals. */ |
425 |
|
root = scm_make_root (scm_root->handle); |
426 |
|
/* Make thread. */ |
427 |
|
thread = make_thread (argl); |
428 |
|
SCM_DEFER_INTS; |
429 |
|
pthread_create (&th, NULL, scheme_launch_thread, (void *) thread); |
430 |
|
init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
431 |
|
all_threads = scm_cons (thread, all_threads); |
432 |
|
thread_count++; |
433 |
|
#ifdef DEBUG |
434 |
|
fprintf (stderr, "thread %ld created\n", th); |
435 |
|
#endif |
436 |
|
SCM_ALLOW_INTS; |
437 |
|
|
438 |
|
/* Return to old dynamic context. */ |
439 |
|
scm_dowinds (old_winds, - scm_ilength (old_winds)); |
440 |
|
} |
441 |
|
|
442 |
|
return thread; |
443 |
} |
} |
444 |
|
#undef FUNC_NAME |
445 |
|
|
446 |
|
/*** Mutexes */ |
447 |
|
|
448 |
|
/* We implement our own mutex type since we want them to be 'fair', |
449 |
|
we want to do fancy things while waiting for them (like running |
450 |
|
asyncs) and we want to support waiting on many things at once. |
451 |
|
*/ |
452 |
|
|
453 |
|
typedef struct scm_copt_mutex { |
454 |
|
/* the thread currently owning the mutex, or SCM_BOOL_F. */ |
455 |
|
SCM owner; |
456 |
|
/* how much the owner owns us. */ |
457 |
|
int level; |
458 |
|
/* the threads waiting for this mutex. */ |
459 |
|
SCM waiting; |
460 |
|
} scm_copt_mutex; |
461 |
|
|
462 |
static SCM |
static SCM |
463 |
thread_mark (SCM obj) |
mutex_mark (SCM mx) |
464 |
{ |
{ |
465 |
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
scm_copt_mutex *m = SCM_MUTEX_DATA (mx); |
466 |
scm_gc_mark (t->result); |
scm_gc_mark (m->owner); |
467 |
return t->root->handle; |
return m->waiting; |
468 |
} |
} |
469 |
|
|
470 |
static int |
SCM |
471 |
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
scm_make_mutex () |
472 |
{ |
{ |
473 |
scm_copt_thread *t = SCM_THREAD_DATA (exp); |
SCM mx = scm_make_smob (scm_tc16_mutex); |
474 |
scm_puts ("#<thread ", port); |
scm_copt_mutex *m = SCM_MUTEX_DATA (mx); |
475 |
scm_intprint ((unsigned long)t, 16, port); |
m->owner = SCM_BOOL_F; |
476 |
if (t->pthread != -1) |
m->level = 0; |
477 |
|
m->waiting = make_queue (); |
478 |
|
return mx; |
479 |
|
} |
480 |
|
|
481 |
|
SCM |
482 |
|
scm_lock_mutex (SCM mx) |
483 |
|
#define FUNC_NAME s_lock_mutex |
484 |
|
{ |
485 |
|
scm_copt_mutex *m; |
486 |
|
SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); |
487 |
|
m = SCM_MUTEX_DATA (mx); |
488 |
|
|
489 |
|
if (m->owner == SCM_BOOL_F) |
490 |
|
m->owner = cur_thread; |
491 |
|
else if (m->owner == cur_thread) |
492 |
|
m->level++; |
493 |
|
else |
494 |
{ |
{ |
495 |
scm_putc (' ', port); |
while (m->owner != cur_thread) |
496 |
scm_intprint (t->pthread, 10, port); |
{ |
497 |
|
enqueue (m->waiting, cur_thread); |
498 |
|
kick_next (); |
499 |
|
block (); |
500 |
|
SCM_ASYNC_TICK; |
501 |
|
} |
502 |
} |
} |
503 |
else |
return SCM_BOOL_T; |
|
scm_puts (" (exited)", port); |
|
|
scm_putc ('>', port); |
|
|
return 1; |
|
504 |
} |
} |
505 |
|
#undef FUNC_NAME |
506 |
|
|
507 |
static size_t |
SCM |
508 |
thread_free (SCM obj) |
scm_unlock_mutex (SCM mx) |
509 |
|
#define FUNC_NAME s_lock_mutex |
510 |
{ |
{ |
511 |
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
scm_copt_mutex *m; |
512 |
if (t->pthread != -1) |
SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); |
513 |
abort (); |
m = SCM_MUTEX_DATA (mx); |
514 |
scm_gc_free (t, sizeof (*t), "thread"); |
|
515 |
return 0; |
if (m->owner != cur_thread) |
516 |
|
{ |
517 |
|
if (m->owner == SCM_BOOL_F) |
518 |
|
SCM_MISC_ERROR ("mutex not locked", SCM_EOL); |
519 |
|
else |
520 |
|
SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL); |
521 |
|
} |
522 |
|
else if (m->level > 0) |
523 |
|
m->level--; |
524 |
|
else |
525 |
|
{ |
526 |
|
SCM next = dequeue (m->waiting); |
527 |
|
if (!SCM_FALSEP (next)) |
528 |
|
{ |
529 |
|
m->owner = next; |
530 |
|
enqueue (ready_queue, next); |
531 |
|
scm_yield (); |
532 |
|
} |
533 |
|
else |
534 |
|
m->owner = SCM_BOOL_F; |
535 |
|
} |
536 |
|
return SCM_BOOL_T; |
537 |
} |
} |
538 |
|
#undef FUNC_NAME |
539 |
|
|
540 |
static scm_copt_queue yield_queue; |
/*** Initialization */ |
541 |
|
|
542 |
void |
void |
543 |
scm_threads_init (SCM_STACKITEM *base) |
scm_threads_init (SCM_STACKITEM *base) |
544 |
{ |
{ |
545 |
SCM main_thread; |
scm_tc16_thread = scm_make_smob_type ("thread", 0); |
546 |
pthread_key_create (&handle_key, NULL); |
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex)); |
547 |
pthread_key_create (&ticket_key, NULL); |
scm_tc16_condvar = scm_make_smob_type ("condition-variable", 0); |
548 |
|
|
549 |
scm_switch_counter = SCM_THREAD_SWITCH_COUNT; |
scm_switch_counter = SCM_THREAD_SWITCH_COUNT; |
550 |
enter_guile (base, &main_ticket); |
|
551 |
main_thread = make_thread (); |
acquire (); |
552 |
|
cur_thread = make_thread (SCM_BOOL_F); |
553 |
/* root is set later from init.c */ |
/* root is set later from init.c */ |
554 |
init_thread_creator (main_thread, pthread_self(), NULL); |
init_thread_creator (cur_thread, pthread_self(), NULL); |
555 |
init_thread_creatant (main_thread); |
init_thread_creatant (cur_thread, base); |
556 |
scm_gc_register_root (&all_threads); |
resume (cur_thread); |
|
all_threads = scm_cons (main_thread, SCM_EOL); |
|
557 |
thread_count = 1; |
thread_count = 1; |
558 |
|
scm_gc_register_root (&all_threads); |
559 |
|
all_threads = scm_cons (cur_thread, SCM_EOL); |
560 |
|
|
561 |
scm_set_smob_mark (scm_tc16_thread, thread_mark); |
scm_set_smob_mark (scm_tc16_thread, thread_mark); |
562 |
scm_set_smob_print (scm_tc16_thread, thread_print); |
scm_set_smob_print (scm_tc16_thread, thread_print); |
563 |
scm_set_smob_free (scm_tc16_thread, thread_free); |
scm_set_smob_free (scm_tc16_thread, thread_free); |
564 |
init_queue (&yield_queue); |
|
565 |
|
scm_set_smob_mark (scm_tc16_mutex, mutex_mark); |
566 |
|
|
567 |
|
ready_queue = scm_permanent_object (make_queue ()); |
568 |
} |
} |
569 |
|
|
570 |
|
/*** Marking stacks */ |
571 |
|
|
572 |
/* XXX - what to do with this? Do we need to handle this for blocked |
/* XXX - what to do with this? Do we need to handle this for blocked |
573 |
threads as well? |
threads as well? |
574 |
*/ |
*/ |
590 |
void |
void |
591 |
scm_threads_mark_stacks (void) |
scm_threads_mark_stacks (void) |
592 |
{ |
{ |
593 |
ticket *t; |
volatile SCM c; |
594 |
|
for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c)) |
|
for (t = tickets; t; t = t->next) |
|
595 |
{ |
{ |
596 |
|
scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c)); |
597 |
|
if (t->base == NULL) |
598 |
|
{ |
599 |
|
/* Not fully initialized yet. */ |
600 |
|
continue; |
601 |
|
} |
602 |
if (t->top == NULL) |
if (t->top == NULL) |
603 |
{ |
{ |
604 |
/* Active thread */ |
/* Active thread */ |
665 |
} |
} |
666 |
} |
} |
667 |
|
|
668 |
/* NOTE: There are TWO mechanisms for starting a thread: The first one |
/*** Select */ |
|
is used when spawning a thread from Scheme, while the second one is |
|
|
used from C. |
|
|
|
|
|
It might be argued that the first should be implemented in terms of |
|
|
the second. The reason it isn't is that that would require an |
|
|
extra unnecessary malloc (the thread_args structure). By providing |
|
|
one pair of extra functions (c_launch_thread, scm_spawn_thread) the |
|
|
Scheme threads are started more efficiently. */ |
|
669 |
|
|
670 |
/* This is the first thread spawning mechanism: threads from Scheme */ |
#include "libguile/iselect.h" |
671 |
|
|
672 |
typedef struct scheme_launch_data { |
int |
673 |
SCM rootcont; |
scm_internal_select (int nfds, |
674 |
SCM body; |
SELECT_TYPE *readfds, |
675 |
SCM handler; |
SELECT_TYPE *writefds, |
676 |
} scheme_launch_data; |
SELECT_TYPE *exceptfds, |
677 |
|
struct timeval *timeout) |
678 |
|
{ |
679 |
|
int res; |
680 |
|
SCM cur = suspend (); |
681 |
|
release (); |
682 |
|
res = select (nfds, readfds, writefds, exceptfds, timeout); |
683 |
|
acquire (); |
684 |
|
resume (cur); |
685 |
|
SCM_ASYNC_TICK; |
686 |
|
return res; |
687 |
|
} |
688 |
|
|
689 |
static SCM |
void |
690 |
scheme_body_bootstrip (scheme_launch_data* data) |
scm_init_iselect () |
691 |
{ |
{ |
|
/* First save the new root continuation */ |
|
|
data->rootcont = scm_root->rootcont; |
|
|
return scm_call_0 (data->body); |
|
692 |
} |
} |
693 |
|
|
694 |
static SCM |
/*** Misc */ |
695 |
scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args) |
|
696 |
|
SCM |
697 |
|
scm_current_thread (void) |
698 |
{ |
{ |
699 |
scm_root->rootcont = data->rootcont; |
return cur_thread; |
|
return scm_apply_1 (data->handler, tag, throw_args); |
|
700 |
} |
} |
701 |
|
|
702 |
static void |
SCM |
703 |
really_launch (void *p) |
scm_all_threads (void) |
704 |
{ |
{ |
705 |
SCM argl = (SCM) p; |
return all_threads; |
|
SCM thread = SCM_CAR (argl); |
|
|
scm_copt_thread *t = SCM_THREAD_DATA (thread); |
|
|
SCM result; |
|
|
scheme_launch_data data; |
|
|
init_thread_creatant (thread); |
|
|
data.rootcont = SCM_BOOL_F; |
|
|
data.body = SCM_CADR (argl); |
|
|
data.handler = SCM_CADDR (argl); |
|
|
result = scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip, |
|
|
&data, |
|
|
(scm_t_catch_handler) scheme_handler_bootstrip, |
|
|
&data, |
|
|
(SCM_STACKITEM *) &thread); |
|
|
all_threads = scm_delq (thread, all_threads); |
|
|
t->result = result; |
|
|
pthread_detach (t->pthread); |
|
|
t->pthread = -1; |
|
|
thread_count--; |
|
706 |
} |
} |
707 |
|
|
708 |
static void * |
scm_root_state * |
709 |
scheme_launch_thread (void *p) |
scm_i_thread_root (SCM thread) |
710 |
{ |
{ |
711 |
ticket t; |
return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root; |
|
enter_guile ((SCM_STACKITEM *)&t, &t); |
|
|
really_launch (p); |
|
|
leave_guile (&t); |
|
|
return NULL; |
|
712 |
} |
} |
713 |
|
|
714 |
|
void * |
715 |
|
scm_copt_thread_data (void) |
716 |
|
{ |
717 |
|
scm_copt_thread *t = SCM_THREAD_DATA (cur_thread); |
718 |
|
return t->root; |
719 |
|
} |
720 |
|
|
721 |
SCM |
void |
722 |
scm_call_with_new_thread (SCM argl) |
scm_copt_set_thread_data (void *d) |
|
#define FUNC_NAME s_call_with_new_thread |
|
723 |
{ |
{ |
724 |
SCM thread; |
scm_copt_thread *t = SCM_THREAD_DATA (cur_thread); |
725 |
|
t->root = d; |
726 |
|
} |
727 |
|
|
728 |
/* Check arguments. */ |
/* XXX from here to end */ |
|
{ |
|
|
register SCM args = argl; |
|
|
SCM thunk, handler; |
|
|
if (!SCM_CONSP (args)) |
|
|
SCM_WRONG_NUM_ARGS (); |
|
|
thunk = SCM_CAR (args); |
|
|
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), |
|
|
thunk, |
|
|
SCM_ARG1, |
|
|
s_call_with_new_thread); |
|
|
args = SCM_CDR (args); |
|
|
if (!SCM_CONSP (args)) |
|
|
SCM_WRONG_NUM_ARGS (); |
|
|
handler = SCM_CAR (args); |
|
|
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), |
|
|
handler, |
|
|
SCM_ARG2, |
|
|
s_call_with_new_thread); |
|
|
if (!SCM_NULLP (SCM_CDR (args))) |
|
|
SCM_WRONG_NUM_ARGS (); |
|
|
} |
|
729 |
|
|
730 |
/* Make new thread. The first thing the new thread will do is to |
#if 0 |
731 |
call enter_guile. Thus, we can safely complete its |
/* NOTE: There are TWO mechanisms for starting a thread: The first one |
732 |
initialization after creating it. */ |
is used when spawning a thread from Scheme, while the second one is |
733 |
{ |
used from C. |
|
pthread_t th; |
|
|
SCM root, old_winds; |
|
|
|
|
|
/* Unwind wind chain. */ |
|
|
old_winds = scm_dynwinds; |
|
|
scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); |
|
734 |
|
|
735 |
/* Allocate thread locals. */ |
It might be argued that the first should be implemented in terms of |
736 |
root = scm_make_root (scm_root->handle); |
the second. The reason it isn't is that that would require an |
737 |
/* Make thread. */ |
extra unnecessary malloc (the thread_args structure). By providing |
738 |
thread = make_thread (); |
one pair of extra functions (c_launch_thread, scm_spawn_thread) the |
739 |
SCM_DEFER_INTS; |
Scheme threads are started more efficiently. */ |
740 |
argl = scm_cons (thread, argl); |
|
741 |
/* Note that we couldn't pass a pointer to argl as data since the |
/* This is the first thread spawning mechanism: threads from Scheme */ |
|
argl variable may not exist in memory when the thread starts. */ |
|
|
pthread_create (&th, NULL, scheme_launch_thread, (void *) argl); |
|
|
init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
|
|
all_threads = scm_cons (thread, all_threads); |
|
|
thread_count++; |
|
|
#ifdef DEBUG |
|
|
fprintf (stderr, "thread %ld created\n", th); |
|
|
#endif |
|
|
SCM_ALLOW_INTS; |
|
742 |
|
|
|
/* Return to old dynamic context. */ |
|
|
scm_dowinds (old_winds, - scm_ilength (old_winds)); |
|
|
} |
|
|
|
|
|
return thread; |
|
|
} |
|
|
#undef FUNC_NAME |
|
743 |
|
|
744 |
|
|
745 |
/* This is the second thread spawning mechanism: threads from C */ |
/* This is the second thread spawning mechanism: threads from C */ |
840 |
|
|
841 |
return thread; |
return thread; |
842 |
} |
} |
843 |
|
#endif |
|
SCM |
|
|
scm_current_thread (void) |
|
|
{ |
|
|
scm_copt_thread *t = pthread_getspecific (handle_key); |
|
|
if (t == NULL) |
|
|
abort (); /* XXX - should ceate a new handle. */ |
|
|
else |
|
|
return t->handle; |
|
|
} |
|
|
|
|
|
SCM |
|
|
scm_all_threads (void) |
|
|
{ |
|
|
return all_threads; |
|
|
} |
|
|
|
|
|
scm_root_state * |
|
|
scm_i_thread_root (SCM thread) |
|
|
{ |
|
|
return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root; |
|
|
} |
|
844 |
|
|
845 |
SCM |
SCM |
846 |
scm_join_thread (SCM thread) |
scm_join_thread (SCM thread) |
847 |
#define FUNC_NAME s_join_thread |
#define FUNC_NAME s_join_thread |
848 |
{ |
{ |
849 |
|
#if 0 |
850 |
scm_copt_thread *t; |
scm_copt_thread *t; |
851 |
SCM res; |
SCM res; |
852 |
|
|
862 |
res = t->result; |
res = t->result; |
863 |
t->result = SCM_BOOL_F; |
t->result = SCM_BOOL_F; |
864 |
return res; |
return res; |
865 |
|
#endif |
866 |
|
return SCM_BOOL_F; |
867 |
} |
} |
868 |
#undef FUNC_NAME |
#undef FUNC_NAME |
869 |
|
|
879 |
#undef FUNC_NAME |
#undef FUNC_NAME |
880 |
|
|
881 |
SCM |
SCM |
|
scm_yield (void) |
|
|
{ |
|
|
fprintf (stderr, "yield\n"); |
|
|
if (yield_queue.first) |
|
|
{ |
|
|
ticket *t; |
|
|
scm_copt_thread *me = pthread_getspecific (handle_key); |
|
|
scm_copt_thread *next = dequeue (&yield_queue); |
|
|
enqueue (&yield_queue, me); |
|
|
pthread_cond_signal (&next->block); |
|
|
t = suspend_guile_2 (); |
|
|
pthread_cond_wait (&me->block, &guile_mutex); |
|
|
resume_guile_2 (t); |
|
|
} |
|
|
return SCM_BOOL_T; |
|
|
} |
|
|
|
|
|
void |
|
|
scm_copt_mutex_init (scm_copt_mutex *m) |
|
|
{ |
|
|
pthread_mutex_init (&m->mutex, NULL); |
|
|
m->owner = NULL; |
|
|
m->level = 0; |
|
|
init_queue (&m->waiting); |
|
|
} |
|
|
|
|
|
void |
|
|
scm_copt_mutex_destroy (scm_copt_mutex *m) |
|
|
{ |
|
|
pthread_mutex_destroy (&m->mutex); |
|
|
} |
|
|
|
|
|
void |
|
|
scm_copt_mutex_lock (scm_copt_mutex *m) |
|
|
{ |
|
|
scm_copt_thread *t = pthread_getspecific (handle_key); |
|
|
pthread_mutex_lock (&m->mutex); |
|
|
if (m->owner == t) |
|
|
m->level++; |
|
|
else if (m->owner == NULL) |
|
|
{ |
|
|
m->owner = t; |
|
|
} |
|
|
else |
|
|
{ |
|
|
enqueue (&m->waiting, t); |
|
|
do |
|
|
{ |
|
|
ticket *tt = suspend_guile (); |
|
|
pthread_cond_wait (&t->block, &m->mutex); |
|
|
resume_guile (tt); |
|
|
SCM_ASYNC_TICK; |
|
|
} |
|
|
while (m->owner != t); |
|
|
} |
|
|
pthread_mutex_unlock (&m->mutex); |
|
|
} |
|
|
|
|
|
void |
|
|
scm_copt_mutex_unlock (scm_copt_mutex *m) |
|
|
{ |
|
|
pthread_mutex_lock (&m->mutex); |
|
|
if (m->level == 0) |
|
|
{ |
|
|
scm_copt_thread *t = dequeue (&m->waiting); |
|
|
m->owner = t; |
|
|
if (t) |
|
|
pthread_cond_signal (&t->block); |
|
|
} |
|
|
else |
|
|
m->level--; |
|
|
pthread_mutex_unlock (&m->mutex); |
|
|
} |
|
|
|
|
|
SCM |
|
|
scm_make_mutex (void) |
|
|
{ |
|
|
SCM m = scm_make_smob (scm_tc16_mutex); |
|
|
scm_copt_mutex_init (SCM_MUTEX_DATA (m)); |
|
|
return m; |
|
|
} |
|
|
|
|
|
SCM |
|
|
scm_lock_mutex (SCM m) |
|
|
{ |
|
|
ticket *t; |
|
|
SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex); |
|
|
t = suspend_guile (); |
|
|
scm_copt_mutex_lock (SCM_MUTEX_DATA (m)); |
|
|
resume_guile (t); |
|
|
return SCM_BOOL_T; |
|
|
} |
|
|
|
|
|
SCM |
|
|
scm_unlock_mutex (SCM m) |
|
|
{ |
|
|
SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex); |
|
|
scm_copt_mutex_unlock(SCM_MUTEX_DATA (m)); |
|
|
return SCM_BOOL_T; |
|
|
} |
|
|
|
|
|
SCM |
|
882 |
scm_make_condition_variable (void) |
scm_make_condition_variable (void) |
883 |
{ |
{ |
884 |
SCM c = scm_make_smob (scm_tc16_condvar); |
abort (); |
|
pthread_cond_init (SCM_CONDVAR_DATA (c), NULL); |
|
|
return c; |
|
885 |
} |
} |
886 |
|
|
887 |
SCM |
SCM |
888 |
scm_wait_condition_variable (SCM c, SCM m) |
scm_timed_wait_condition_variable (SCM c, SCM m, SCM t) |
889 |
{ |
{ |
890 |
ticket *t; |
abort (); |
|
SCM_ASSERT (SCM_CONDVARP (c), |
|
|
c, |
|
|
SCM_ARG1, |
|
|
s_wait_condition_variable); |
|
|
SCM_ASSERT (SCM_MUTEXP (m), |
|
|
m, |
|
|
SCM_ARG2, |
|
|
s_wait_condition_variable); |
|
|
t = suspend_guile (); |
|
|
pthread_cond_wait (SCM_CONDVAR_DATA (c), SCM_MUTEX_DATA (m)); |
|
|
resume_guile (t); |
|
|
return SCM_BOOL_T; |
|
891 |
} |
} |
892 |
|
|
893 |
SCM |
SCM |
894 |
scm_signal_condition_variable (SCM c) |
scm_signal_condition_variable (SCM c) |
895 |
{ |
{ |
896 |
SCM_ASSERT (SCM_CONDVARP (c), |
abort (); |
|
c, |
|
|
SCM_ARG1, |
|
|
s_signal_condition_variable); |
|
|
pthread_cond_signal (SCM_CONDVAR_DATA (c)); |
|
|
return SCM_BOOL_T; |
|
|
} |
|
|
|
|
|
void * |
|
|
scm_copt_thread_data (void) |
|
|
{ |
|
|
scm_copt_thread *t = pthread_getspecific (handle_key); |
|
|
if (t == NULL) |
|
|
abort (); |
|
|
else |
|
|
return t->root; |
|
|
} |
|
|
|
|
|
void |
|
|
scm_copt_set_thread_data (void *d) |
|
|
{ |
|
|
scm_copt_thread *t = pthread_getspecific (handle_key); |
|
|
if (t == NULL) |
|
|
abort (); |
|
|
else |
|
|
t->root = d; |
|
897 |
} |
} |
898 |
|
|
899 |
unsigned long |
unsigned long |
900 |
scm_thread_usleep (unsigned long usec) |
scm_thread_usleep (unsigned long usec) |
901 |
{ |
{ |
902 |
ticket *t; |
return usleep (usec); |
|
unsigned long ret; |
|
|
t = suspend_guile (); |
|
|
ret = usleep (usec); |
|
|
resume_guile (t); |
|
|
return ret; |
|
903 |
} |
} |
904 |
|
|
905 |
unsigned long |
unsigned long |
906 |
scm_thread_sleep (unsigned long sec) |
scm_thread_sleep (unsigned long sec) |
907 |
{ |
{ |
908 |
ticket *t; |
return sleep (sec); |
|
unsigned long ret; |
|
|
t = suspend_guile (); |
|
|
ret = sleep (sec); |
|
|
resume_guile (t); |
|
|
return ret; |
|
909 |
} |
} |
910 |
|
|
|
#include "libguile/iselect.h" |
|
911 |
|
|
912 |
int |
SCM |
913 |
scm_internal_select (int nfds, |
scm_try_mutex (SCM mx) |
|
SELECT_TYPE *readfds, |
|
|
SELECT_TYPE *writefds, |
|
|
SELECT_TYPE *exceptfds, |
|
|
struct timeval *timeout) |
|
914 |
{ |
{ |
915 |
ticket *t; |
abort (); |
|
int res; |
|
|
t = suspend_guile (); |
|
|
res = select (nfds, readfds, writefds, exceptfds, timeout); |
|
|
resume_guile (t); |
|
|
SCM_ASYNC_TICK; |
|
|
return res; |
|
916 |
} |
} |
917 |
|
|
918 |
void |
SCM |
919 |
scm_init_iselect () |
scm_broadcast_condition_variable (SCM cv) |
920 |
{ |
{ |
921 |
|
abort (); |
922 |
} |
} |
923 |
|
|
924 |
|
|
925 |
/* |
/* |
926 |
Local Variables: |
Local Variables: |
927 |
c-file-style: "gnu" |
c-file-style: "gnu" |