1 |
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2002 Free Software Foundation, Inc. |
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc. |
2 |
* |
* |
3 |
* This program is free software; you can redistribute it and/or modify |
* This program is free software; you can redistribute it and/or modify |
4 |
* it under the terms of the GNU General Public License as published by |
* it under the terms of the GNU General Public License as published by |
42 |
|
|
43 |
|
|
44 |
|
|
45 |
/* This file does some pretty hairy #inclusion. It probably seemed |
/* This file implements nice Scheme level threads on top of the gastly |
46 |
like a good idea at the time, but it doesn't now. Here's the |
C level threads. |
|
structure, edited for relevance (!), last I checked: |
|
|
|
|
|
threads.c: |
|
|
threads.h |
|
|
coop-defs.h |
|
|
iselect.h |
|
|
coop-threads.c |
|
|
coop-threads.h |
|
|
coop-defs.h* |
|
|
../qt/qt.h |
|
|
coop.c |
|
|
<qt.h> |
|
|
|
|
|
* second #inclusion |
|
47 |
*/ |
*/ |
48 |
|
|
49 |
#include <errno.h> |
#include <unistd.h> |
50 |
|
#include <stdio.h> |
51 |
|
#include <assert.h> |
52 |
|
#include <sys/time.h> |
53 |
|
|
54 |
#include "libguile/_scm.h" |
#include "libguile/_scm.h" |
55 |
|
#include "libguile/validate.h" |
56 |
|
#include "libguile/root.h" |
57 |
|
#include "libguile/eval.h" |
58 |
|
#include "libguile/async.h" |
59 |
|
#include "libguile/ports.h" |
60 |
|
#include "libguile/threads.h" |
61 |
#include "libguile/dynwind.h" |
#include "libguile/dynwind.h" |
62 |
#include "libguile/smob.h" |
#include "libguile/iselect.h" |
63 |
|
|
64 |
#include "libguile/threads.h" |
/*** Queues */ |
65 |
|
|
66 |
|
static SCM |
67 |
|
make_queue () |
68 |
|
{ |
69 |
|
return scm_cons (SCM_EOL, SCM_EOL); |
70 |
|
} |
71 |
|
|
72 |
scm_t_bits scm_tc16_thread; |
static SCM |
73 |
scm_t_bits scm_tc16_mutex; |
enqueue (SCM q, SCM t) |
74 |
scm_t_bits scm_tc16_condvar; |
{ |
75 |
|
SCM c = scm_cons (t, SCM_EOL); |
76 |
|
if (SCM_NULLP (SCM_CDR (q))) |
77 |
|
SCM_SETCDR (q, c); |
78 |
|
else |
79 |
|
SCM_SETCDR (SCM_CAR (q), c); |
80 |
|
SCM_SETCAR (q, c); |
81 |
|
return c; |
82 |
|
} |
83 |
|
|
84 |
|
static void |
85 |
/* Scheme-visible thread functions. */ |
remqueue (SCM q, SCM c) |
86 |
|
{ |
87 |
|
SCM p, prev = q; |
88 |
|
for (p = SCM_CDR (q); !SCM_NULLP (p); p = SCM_CDR (p)) |
89 |
|
{ |
90 |
|
if (SCM_EQ_P (p, c)) |
91 |
|
{ |
92 |
|
if (SCM_EQ_P (c, SCM_CAR (q))) |
93 |
|
SCM_SETCAR (q, SCM_CDR (c)); |
94 |
|
SCM_SETCDR (prev, SCM_CDR (c)); |
95 |
|
return; |
96 |
|
} |
97 |
|
prev = p; |
98 |
|
} |
99 |
|
abort (); |
100 |
|
} |
101 |
|
|
102 |
#ifdef USE_COOP_THREADS |
static SCM |
103 |
SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p); |
dequeue (SCM q) |
104 |
|
{ |
105 |
|
SCM c = SCM_CDR (q); |
106 |
|
if (SCM_NULLP (c)) |
107 |
|
return SCM_BOOL_F; |
108 |
|
else |
109 |
|
{ |
110 |
|
SCM_SETCDR (q, SCM_CDR (c)); |
111 |
|
if (SCM_NULLP (SCM_CDR (q))) |
112 |
|
SCM_SETCAR (q, SCM_EOL); |
113 |
|
return SCM_CAR (c); |
114 |
|
} |
115 |
|
} |
116 |
|
|
117 |
|
|
118 |
|
/*** Threads */ |
119 |
|
|
120 |
|
typedef struct scm_thread { |
121 |
|
|
122 |
|
/* Blocking. |
123 |
|
*/ |
124 |
|
scm_t_cond sleep_cond; |
125 |
|
struct scm_thread *next_waiting; |
126 |
|
|
127 |
|
scm_root_state *root; |
128 |
|
SCM handle; |
129 |
|
scm_t_thread thread; |
130 |
|
SCM result; |
131 |
|
int exited; |
132 |
|
|
133 |
|
SCM joining_threads; |
134 |
|
|
135 |
|
/* For keeping track of the stack and registers. */ |
136 |
|
SCM_STACKITEM *base; |
137 |
|
SCM_STACKITEM *top; |
138 |
|
jmp_buf regs; |
139 |
|
|
140 |
|
} scm_thread; |
141 |
|
|
142 |
|
static SCM |
143 |
|
make_thread (SCM creation_protects) |
144 |
|
{ |
145 |
|
SCM z; |
146 |
|
scm_thread *t; |
147 |
|
z = scm_make_smob (scm_tc16_thread); |
148 |
|
t = SCM_THREAD_DATA (z); |
149 |
|
t->handle = z; |
150 |
|
t->result = creation_protects; |
151 |
|
t->base = NULL; |
152 |
|
t->joining_threads = make_queue (); |
153 |
|
scm_cond_init (&t->sleep_cond); |
154 |
|
t->exited = 0; |
155 |
|
return z; |
156 |
|
} |
157 |
|
|
158 |
|
static void |
159 |
|
init_thread_creator (SCM thread, scm_t_thread th, scm_root_state *r) |
160 |
|
{ |
161 |
|
scm_thread *t = SCM_THREAD_DATA(thread); |
162 |
|
t->root = r; |
163 |
|
t->thread = th; |
164 |
|
#ifdef DEBUG |
165 |
|
// fprintf (stderr, "%ld created %ld\n", pthread_self (), th); |
166 |
#endif |
#endif |
167 |
|
} |
168 |
|
|
169 |
|
static void |
170 |
|
init_thread_creatant (SCM thread, SCM_STACKITEM *base) |
171 |
|
{ |
172 |
|
scm_thread *t = SCM_THREAD_DATA(thread); |
173 |
|
t->base = base; |
174 |
|
t->top = NULL; |
175 |
|
} |
176 |
|
|
177 |
/* GJB:FIXME:DOC: SCM_REGISTER_PROC needs to permit a docstring, |
static SCM |
178 |
or these need to move into the file where the proc is defined. */ |
thread_mark (SCM obj) |
179 |
|
{ |
180 |
|
scm_thread *t = SCM_THREAD_DATA (obj); |
181 |
|
scm_gc_mark (t->result); |
182 |
|
scm_gc_mark (t->joining_threads); |
183 |
|
return t->root->handle; |
184 |
|
} |
185 |
|
|
186 |
|
static int |
187 |
|
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) |
188 |
|
{ |
189 |
|
scm_thread *t = SCM_THREAD_DATA (exp); |
190 |
|
scm_puts ("#<thread ", port); |
191 |
|
scm_intprint ((unsigned long)t, 16, port); |
192 |
|
scm_putc ('>', port); |
193 |
|
return 1; |
194 |
|
} |
195 |
|
|
196 |
SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield); |
static size_t |
197 |
/* If one or more threads are waiting to execute, calling yield forces an |
thread_free (SCM obj) |
198 |
immediate context switch to one of them. Otherwise, yield has no effect. |
{ |
199 |
|
scm_thread *t = SCM_THREAD_DATA (obj); |
200 |
|
if (!t->exited) |
201 |
|
abort (); |
202 |
|
scm_gc_free (t, sizeof (*t), "thread"); |
203 |
|
return 0; |
204 |
|
} |
205 |
|
|
206 |
|
/*** Fair mutexes */ |
207 |
|
|
208 |
|
/* C level mutexes (such as POSIX mutexes) are not necessarily fair |
209 |
|
but since we'd like to use a mutex for scheduling, we build a fair |
210 |
|
one on top of the C one. |
211 |
*/ |
*/ |
212 |
|
|
213 |
SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread); |
typedef struct fair_mutex { |
214 |
/* Evaluate @var{(thunk)} in a new thread, and new dynamic context, |
scm_t_mutex lock; |
215 |
returning a new thread object representing the thread. |
scm_thread *owner; |
216 |
|
scm_thread *next_waiting, *last_waiting; |
217 |
If an error occurs during evaluation, call error-thunk, passing it an |
} fair_mutex; |
|
error code describing the condition. [Error codes are currently |
|
|
meaningless integers. In the future, real values will be specified.] |
|
|
If this happens, the error-thunk is called outside the scope of the new |
|
|
root -- it is called in the same dynamic context in which |
|
|
with-new-thread was evaluated, but not in the callers thread. |
|
218 |
|
|
219 |
All the evaluation rules for dynamic roots apply to threads. |
static void |
220 |
|
fair_mutex_init (fair_mutex *m) |
221 |
|
{ |
222 |
|
scm_mutex_init (&m->lock); |
223 |
|
m->owner = NULL; |
224 |
|
m->next_waiting = NULL; |
225 |
|
m->last_waiting = NULL; |
226 |
|
} |
227 |
|
|
228 |
|
static void |
229 |
|
fair_mutex_lock_1 (fair_mutex *m, scm_thread *t) |
230 |
|
{ |
231 |
|
if (m->owner == NULL) |
232 |
|
m->owner = t; |
233 |
|
else |
234 |
|
{ |
235 |
|
t->next_waiting = NULL; |
236 |
|
if (m->last_waiting) |
237 |
|
m->last_waiting->next_waiting = t; |
238 |
|
else |
239 |
|
m->next_waiting = t; |
240 |
|
m->last_waiting = t; |
241 |
|
do |
242 |
|
{ |
243 |
|
int err; |
244 |
|
err = scm_cond_wait (&t->sleep_cond, &m->lock); |
245 |
|
assert (err == 0); |
246 |
|
} |
247 |
|
while (m->owner != t); |
248 |
|
assert (m->next_waiting == t); |
249 |
|
m->next_waiting = t->next_waiting; |
250 |
|
if (m->next_waiting == NULL) |
251 |
|
m->last_waiting = NULL; |
252 |
|
} |
253 |
|
scm_mutex_unlock (&m->lock); |
254 |
|
} |
255 |
|
|
256 |
|
static void |
257 |
|
fair_mutex_lock (fair_mutex *m, scm_thread *t) |
258 |
|
{ |
259 |
|
scm_mutex_lock (&m->lock); |
260 |
|
fair_mutex_lock_1 (m, t); |
261 |
|
} |
262 |
|
|
263 |
|
static void |
264 |
|
fair_mutex_unlock_1 (fair_mutex *m) |
265 |
|
{ |
266 |
|
scm_thread *t; |
267 |
|
scm_mutex_lock (&m->lock); |
268 |
|
// fprintf (stderr, "%ld unlocking\n", m->owner->pthread); |
269 |
|
if ((t = m->next_waiting) != NULL) |
270 |
|
{ |
271 |
|
m->owner = t; |
272 |
|
scm_cond_signal (&t->sleep_cond); |
273 |
|
} |
274 |
|
else |
275 |
|
m->owner = NULL; |
276 |
|
// fprintf (stderr, "%ld unlocked\n", pthread_self ()); |
277 |
|
} |
278 |
|
|
279 |
|
static void |
280 |
|
fair_mutex_unlock (fair_mutex *m) |
281 |
|
{ |
282 |
|
fair_mutex_unlock_1 (m); |
283 |
|
scm_mutex_unlock (&m->lock); |
284 |
|
} |
285 |
|
|
286 |
|
/* Temporarily give up the mutex. This function makes sure that we |
287 |
|
are on the wait queue before starting the next thread. Otherwise |
288 |
|
the next thread might preempt us and we will have a hard time |
289 |
|
getting on the wait queue. |
290 |
*/ |
*/ |
291 |
|
static void |
292 |
|
fair_mutex_yield (fair_mutex *m) |
293 |
|
{ |
294 |
|
scm_thread *self = m->owner; |
295 |
|
fair_mutex_unlock_1 (m); |
296 |
|
fair_mutex_lock_1 (m, self); |
297 |
|
} |
298 |
|
|
299 |
SCM_REGISTER_PROC(s_current_thread, "current-thread", 0, 0, 0, scm_current_thread); |
static int |
300 |
SCM_REGISTER_PROC(s_all_thread, "all-threads", 0, 0, 0, scm_all_threads); |
fair_cond_wait (scm_t_cond *c, fair_mutex *m) |
301 |
|
{ |
302 |
|
scm_thread *t = m->owner; |
303 |
|
int err; |
304 |
|
fair_mutex_unlock_1 (m); |
305 |
|
err = scm_cond_wait (c, &m->lock); |
306 |
|
fair_mutex_lock_1 (m, t); |
307 |
|
return err; |
308 |
|
} |
309 |
|
|
310 |
SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread); |
static int |
311 |
/* Suspend execution of the calling thread until the target @var{thread} |
fair_cond_timedwait (scm_t_cond *c, fair_mutex *m, struct timespec *at) |
312 |
terminates, unless the target @var{thread} has already terminated. |
{ |
313 |
|
int err; |
314 |
|
scm_thread *t = m->owner; |
315 |
|
fair_mutex_unlock_1 (m); |
316 |
|
err = scm_cond_timedwait (c, &m->lock, at); /* XXX - signals? */ |
317 |
|
fair_mutex_lock_1 (m, t); |
318 |
|
return err; |
319 |
|
} |
320 |
|
|
321 |
|
/*** Scheduling */ |
322 |
|
|
323 |
|
/* When a thread wants to execute Guile functions, it locks the |
324 |
|
guile_mutex. |
325 |
*/ |
*/ |
326 |
|
|
327 |
SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0, |
static fair_mutex guile_mutex; |
328 |
|
|
329 |
|
static SCM cur_thread; |
330 |
|
void *scm_i_thread_data; |
331 |
|
|
332 |
|
void |
333 |
|
scm_i_set_thread_data (void *data) |
334 |
|
{ |
335 |
|
scm_thread *t = SCM_THREAD_DATA (cur_thread); |
336 |
|
scm_i_thread_data = data; |
337 |
|
t->root = (scm_root_state *)data; |
338 |
|
} |
339 |
|
|
340 |
|
static void |
341 |
|
resume (scm_thread *t) |
342 |
|
{ |
343 |
|
cur_thread = t->handle; |
344 |
|
scm_i_thread_data = t->root; |
345 |
|
t->top = NULL; |
346 |
|
} |
347 |
|
|
348 |
|
static void |
349 |
|
enter_guile (scm_thread *t) |
350 |
|
{ |
351 |
|
fair_mutex_lock (&guile_mutex, t); |
352 |
|
resume (t); |
353 |
|
} |
354 |
|
|
355 |
|
static scm_thread * |
356 |
|
suspend () |
357 |
|
{ |
358 |
|
SCM cur = cur_thread; |
359 |
|
scm_thread *c = SCM_THREAD_DATA (cur); |
360 |
|
|
361 |
|
/* record top of stack for the GC */ |
362 |
|
c->top = (SCM_STACKITEM *)&c; |
363 |
|
/* save registers. */ |
364 |
|
SCM_FLUSH_REGISTER_WINDOWS; |
365 |
|
setjmp (c->regs); |
366 |
|
|
367 |
|
return c; |
368 |
|
} |
369 |
|
|
370 |
|
static scm_thread * |
371 |
|
leave_guile () |
372 |
|
{ |
373 |
|
scm_thread *c = suspend (); |
374 |
|
fair_mutex_unlock (&guile_mutex); |
375 |
|
return c; |
376 |
|
} |
377 |
|
|
378 |
|
int scm_i_switch_counter; |
379 |
|
|
380 |
|
SCM |
381 |
|
scm_yield () |
382 |
|
{ |
383 |
|
/* Testing guile_mutex.next_waiting without locking guile_mutex.lock |
384 |
|
is OK since the outcome is not critical. Even when it changes |
385 |
|
after the test, we do the right thing. |
386 |
|
*/ |
387 |
|
if (guile_mutex.next_waiting) |
388 |
|
{ |
389 |
|
scm_thread *t = suspend (); |
390 |
|
fair_mutex_yield (&guile_mutex); |
391 |
|
resume (t); |
392 |
|
} |
393 |
|
return SCM_BOOL_T; |
394 |
|
} |
395 |
|
|
396 |
|
/* Put the current thread to sleep until it is explicitely unblocked. |
397 |
|
*/ |
398 |
|
static int |
399 |
|
block () |
400 |
|
{ |
401 |
|
int err; |
402 |
|
scm_thread *t = suspend (); |
403 |
|
err = fair_cond_wait (&t->sleep_cond, &guile_mutex); |
404 |
|
resume (t); |
405 |
|
return err; |
406 |
|
} |
407 |
|
|
408 |
|
/* Put the current thread to sleep until it is explicitely unblocked |
409 |
|
or until a signal arrives or until time AT (absolute time) is |
410 |
|
reached. Return 0 when it has been unblocked; errno otherwise. |
411 |
|
*/ |
412 |
|
static int |
413 |
|
timed_block (struct timespec *at) |
414 |
|
{ |
415 |
|
int err; |
416 |
|
scm_thread *t = suspend (); |
417 |
|
err = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at); |
418 |
|
resume (t); |
419 |
|
return err; |
420 |
|
} |
421 |
|
|
422 |
|
/* Unblock a sleeping thread. |
423 |
|
*/ |
424 |
|
static void |
425 |
|
unblock (scm_thread *t) |
426 |
|
{ |
427 |
|
scm_cond_signal (&t->sleep_cond); |
428 |
|
} |
429 |
|
|
430 |
|
/*** Thread creation */ |
431 |
|
|
432 |
|
static SCM all_threads; |
433 |
|
static int thread_count; |
434 |
|
|
435 |
|
typedef struct launch_data { |
436 |
|
SCM thread; |
437 |
|
SCM rootcont; |
438 |
|
scm_t_catch_body body; |
439 |
|
void *body_data; |
440 |
|
scm_t_catch_handler handler; |
441 |
|
void *handler_data; |
442 |
|
} launch_data; |
443 |
|
|
444 |
|
static SCM |
445 |
|
body_bootstrip (launch_data* data) |
446 |
|
{ |
447 |
|
/* First save the new root continuation */ |
448 |
|
data->rootcont = scm_root->rootcont; |
449 |
|
return (data->body) (data->body_data); |
450 |
|
} |
451 |
|
|
452 |
|
static SCM |
453 |
|
handler_bootstrip (launch_data* data, SCM tag, SCM throw_args) |
454 |
|
{ |
455 |
|
scm_root->rootcont = data->rootcont; |
456 |
|
return (data->handler) (data->handler_data, tag, throw_args); |
457 |
|
} |
458 |
|
|
459 |
|
static void |
460 |
|
really_launch (SCM_STACKITEM *base, launch_data *data) |
461 |
|
{ |
462 |
|
SCM thread = data->thread; |
463 |
|
scm_thread *t = SCM_THREAD_DATA (thread); |
464 |
|
init_thread_creatant (thread, base); |
465 |
|
enter_guile (t); |
466 |
|
|
467 |
|
data->rootcont = SCM_BOOL_F; |
468 |
|
t->result = |
469 |
|
scm_internal_cwdr ((scm_t_catch_body) body_bootstrip, |
470 |
|
data, |
471 |
|
(scm_t_catch_handler) handler_bootstrip, |
472 |
|
data, base); |
473 |
|
free (data); |
474 |
|
|
475 |
|
scm_thread_detach (t->thread); |
476 |
|
all_threads = scm_delq (thread, all_threads); |
477 |
|
t->exited = 1; |
478 |
|
thread_count--; |
479 |
|
leave_guile (); |
480 |
|
} |
481 |
|
|
482 |
|
static void |
483 |
|
launch_thread (void *p) |
484 |
|
{ |
485 |
|
really_launch ((SCM_STACKITEM *)&p, (launch_data *)p); |
486 |
|
} |
487 |
|
|
488 |
|
static SCM |
489 |
|
create_thread (scm_t_catch_body body, void *body_data, |
490 |
|
scm_t_catch_handler handler, void *handler_data, |
491 |
|
SCM protects) |
492 |
|
{ |
493 |
|
SCM thread; |
494 |
|
|
495 |
|
/* Make new thread. The first thing the new thread will do is to |
496 |
|
lock guile_mutex. Thus, we can safely complete its |
497 |
|
initialization after creating it. While the new thread starts, |
498 |
|
all its data is protected via all_threads. |
499 |
|
*/ |
500 |
|
|
501 |
|
{ |
502 |
|
scm_t_thread th; |
503 |
|
SCM root, old_winds; |
504 |
|
launch_data *data; |
505 |
|
int err; |
506 |
|
|
507 |
|
/* Unwind wind chain. */ |
508 |
|
old_winds = scm_dynwinds; |
509 |
|
scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); |
510 |
|
|
511 |
|
/* Allocate thread locals. */ |
512 |
|
root = scm_make_root (scm_root->handle); |
513 |
|
data = scm_malloc (sizeof (launch_data)); |
514 |
|
|
515 |
|
/* Make thread. */ |
516 |
|
thread = make_thread (protects); |
517 |
|
data->thread = thread; |
518 |
|
data->body = body; |
519 |
|
data->body_data = body_data; |
520 |
|
data->handler = handler; |
521 |
|
data->handler_data = handler_data; |
522 |
|
err = scm_thread_create (&th, launch_thread, (void *) data); |
523 |
|
if (err == 0) |
524 |
|
{ |
525 |
|
init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
526 |
|
all_threads = scm_cons (thread, all_threads); |
527 |
|
thread_count++; |
528 |
|
} |
529 |
|
else |
530 |
|
((scm_thread *)SCM_THREAD_DATA(thread))->exited = 1; |
531 |
|
|
532 |
|
/* Return to old dynamic context. */ |
533 |
|
scm_dowinds (old_winds, - scm_ilength (old_winds)); |
534 |
|
|
535 |
|
if (err) |
536 |
|
{ |
537 |
|
errno = err; |
538 |
|
scm_syserror ("create-thread"); |
539 |
|
} |
540 |
|
} |
541 |
|
|
542 |
|
return thread; |
543 |
|
} |
544 |
|
|
545 |
|
SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0, |
546 |
|
(SCM thunk, SCM handler), |
547 |
|
"Evaluate @var{(thunk)} in a new thread, and new dynamic context, " |
548 |
|
"returning a new thread object representing the thread. " |
549 |
|
"If an error occurs during evaluation, call error-thunk, passing it an " |
550 |
|
"error code describing the condition. " |
551 |
|
"If this happens, the error-thunk is called outside the scope of the new " |
552 |
|
"root -- it is called in the same dynamic context in which " |
553 |
|
"with-new-thread was evaluated, but not in the callers thread. " |
554 |
|
"All the evaluation rules for dynamic roots apply to threads.") |
555 |
|
#define FUNC_NAME s_scm_call_with_new_thread |
556 |
|
{ |
557 |
|
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME); |
558 |
|
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), handler, SCM_ARG2, |
559 |
|
FUNC_NAME); |
560 |
|
|
561 |
|
return create_thread ((scm_t_catch_body) scm_call_0, thunk, |
562 |
|
(scm_t_catch_handler) scm_apply_1, handler, |
563 |
|
scm_cons (thunk, handler)); |
564 |
|
} |
565 |
|
#undef FUNC_NAME |
566 |
|
|
567 |
|
SCM |
568 |
|
scm_spawn_thread (scm_t_catch_body body, void *body_data, |
569 |
|
scm_t_catch_handler handler, void *handler_data) |
570 |
|
{ |
571 |
|
return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F); |
572 |
|
} |
573 |
|
|
574 |
|
SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, |
575 |
(SCM thread), |
(SCM thread), |
576 |
"Return @code{#t} iff @var{thread} has exited.\n") |
"Suspend execution of the calling thread until the target @var{thread} " |
577 |
#define FUNC_NAME s_scm_thread_exited_p |
"terminates, unless the target @var{thread} has already terminated. ") |
578 |
|
#define FUNC_NAME s_scm_join_thread |
579 |
{ |
{ |
580 |
return SCM_BOOL (scm_c_thread_exited_p (thread)); |
scm_thread *t; |
581 |
|
SCM res; |
582 |
|
|
583 |
|
SCM_VALIDATE_THREAD (1, thread); |
584 |
|
if (SCM_EQ_P (cur_thread, thread)) |
585 |
|
SCM_MISC_ERROR ("can not join the current thread", SCM_EOL); |
586 |
|
|
587 |
|
t = SCM_THREAD_DATA (thread); |
588 |
|
if (!t->exited) |
589 |
|
{ |
590 |
|
scm_thread *c = leave_guile (); |
591 |
|
scm_thread_join (t->thread); |
592 |
|
enter_guile (c); |
593 |
|
} |
594 |
|
res = t->result; |
595 |
|
t->result = SCM_BOOL_F; |
596 |
|
return res; |
597 |
} |
} |
598 |
#undef FUNC_NAME |
#undef FUNC_NAME |
599 |
|
|
600 |
SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex); |
/*** Mutexes */ |
|
/* Create a new mutex object. */ |
|
601 |
|
|
602 |
SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex); |
/* We implement our own mutex type since we want them to be 'fair', we |
603 |
/* Lock @var{mutex}. If the mutex is already locked, the calling thread |
want to do fancy things while waiting for them (like running |
604 |
blocks until the mutex becomes available. The function returns when |
asyncs) and we want to support waiting on many things at once. |
605 |
the calling thread owns the lock on @var{mutex}. */ |
Also, we might add things that are nice for debugging. |
606 |
|
*/ |
607 |
|
|
608 |
SCM_REGISTER_PROC(s_try_mutex, "try-mutex", 1, 0, 0, scm_try_mutex); |
typedef struct scm_mutex { |
609 |
/* Try to lock @var{mutex}. If the mutex is already locked by someone |
/* the thread currently owning the mutex, or SCM_BOOL_F. */ |
610 |
else, return @code{#f}. Else lock the mutex and return @code{#t}. */ |
SCM owner; |
611 |
|
/* how much the owner owns us. */ |
612 |
|
int level; |
613 |
|
/* the threads waiting for this mutex. */ |
614 |
|
SCM waiting; |
615 |
|
} scm_mutex; |
616 |
|
|
617 |
SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex); |
static SCM |
618 |
/* Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. |
mutex_mark (SCM mx) |
619 |
Calling unlock-mutex on a mutex not owned by the current thread results |
{ |
620 |
in undefined behaviour. Once a mutex has been unlocked, one thread |
scm_mutex *m = SCM_MUTEX_DATA (mx); |
621 |
blocked on @var{mutex} is awakened and grabs the mutex lock. */ |
scm_gc_mark (m->owner); |
622 |
|
return m->waiting; |
623 |
|
} |
624 |
|
|
625 |
SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable); |
SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0, |
626 |
|
(void), |
627 |
|
"Create a new mutex object. ") |
628 |
|
#define FUNC_NAME s_scm_make_mutex |
629 |
|
{ |
630 |
|
SCM mx = scm_make_smob (scm_tc16_mutex); |
631 |
|
scm_mutex *m = SCM_MUTEX_DATA (mx); |
632 |
|
m->owner = SCM_BOOL_F; |
633 |
|
m->level = 0; |
634 |
|
m->waiting = make_queue (); |
635 |
|
return mx; |
636 |
|
} |
637 |
|
#undef FUNC_NAME |
638 |
|
|
639 |
|
SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0, |
640 |
|
(SCM mx), |
641 |
|
"Lock @var{mutex}. If the mutex is already locked, the calling thread " |
642 |
|
"blocks until the mutex becomes available. The function returns when " |
643 |
|
"the calling thread owns the lock on @var{mutex}. Locking a mutex that " |
644 |
|
"a thread already owns will succeed right away and will not block the " |
645 |
|
"thread. That is, Guile's mutexes are @emph{recursive}. ") |
646 |
|
#define FUNC_NAME s_scm_lock_mutex |
647 |
|
{ |
648 |
|
scm_mutex *m; |
649 |
|
SCM_VALIDATE_MUTEX (1, mx); |
650 |
|
m = SCM_MUTEX_DATA (mx); |
651 |
|
|
652 |
|
if (m->owner == SCM_BOOL_F) |
653 |
|
m->owner = cur_thread; |
654 |
|
else if (m->owner == cur_thread) |
655 |
|
m->level++; |
656 |
|
else |
657 |
|
{ |
658 |
|
while (1) |
659 |
|
{ |
660 |
|
SCM c = enqueue (m->waiting, cur_thread); |
661 |
|
int err = block (); |
662 |
|
if (m->owner == cur_thread) |
663 |
|
return SCM_BOOL_T; |
664 |
|
remqueue (m->waiting, c); |
665 |
|
if (err) |
666 |
|
{ |
667 |
|
errno = err; |
668 |
|
scm_syserror (FUNC_NAME); |
669 |
|
} |
670 |
|
SCM_ASYNC_TICK; |
671 |
|
} |
672 |
|
} |
673 |
|
return SCM_BOOL_T; |
674 |
|
} |
675 |
|
#undef FUNC_NAME |
676 |
|
|
677 |
SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 1, 0, scm_timed_wait_condition_variable); |
SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0, |
678 |
|
(SCM mx), |
679 |
|
"Try to lock @var{mutex}. If the mutex is already locked by someone " |
680 |
|
"else, return @code{#f}. Else lock the mutex and return @code{#t}. ") |
681 |
|
#define FUNC_NAME s_scm_try_mutex |
682 |
|
{ |
683 |
|
scm_mutex *m; |
684 |
|
SCM_VALIDATE_MUTEX (1, mx); |
685 |
|
m = SCM_MUTEX_DATA (mx); |
686 |
|
|
687 |
|
if (m->owner == SCM_BOOL_F) |
688 |
|
m->owner = cur_thread; |
689 |
|
else if (m->owner == cur_thread) |
690 |
|
m->level++; |
691 |
|
else |
692 |
|
return SCM_BOOL_F; |
693 |
|
return SCM_BOOL_T; |
694 |
|
} |
695 |
|
#undef FUNC_NAME |
696 |
|
|
697 |
SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable); |
SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, |
698 |
|
(SCM mx), |
699 |
|
"Unlocks @var{mutex} if the calling thread owns the lock on " |
700 |
|
"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current " |
701 |
|
"thread results in undefined behaviour. Once a mutex has been unlocked, " |
702 |
|
"one thread blocked on @var{mutex} is awakened and grabs the mutex " |
703 |
|
"lock. Every call to @code{lock-mutex} by this thread must be matched " |
704 |
|
"with a call to @code{unlock-mutex}. Only the last call to " |
705 |
|
"@code{unlock-mutex} will actually unlock the mutex. ") |
706 |
|
#define FUNC_NAME s_scm_unlock_mutex |
707 |
|
{ |
708 |
|
scm_mutex *m; |
709 |
|
SCM_VALIDATE_MUTEX (1, mx); |
710 |
|
m = SCM_MUTEX_DATA (mx); |
711 |
|
|
712 |
|
if (m->owner != cur_thread) |
713 |
|
{ |
714 |
|
if (m->owner == SCM_BOOL_F) |
715 |
|
SCM_MISC_ERROR ("mutex not locked", SCM_EOL); |
716 |
|
else |
717 |
|
SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL); |
718 |
|
} |
719 |
|
else if (m->level > 0) |
720 |
|
m->level--; |
721 |
|
else |
722 |
|
{ |
723 |
|
SCM next = dequeue (m->waiting); |
724 |
|
if (!SCM_FALSEP (next)) |
725 |
|
{ |
726 |
|
m->owner = next; |
727 |
|
unblock (SCM_THREAD_DATA (next)); |
728 |
|
scm_yield (); |
729 |
|
} |
730 |
|
else |
731 |
|
m->owner = SCM_BOOL_F; |
732 |
|
} |
733 |
|
return SCM_BOOL_T; |
734 |
|
} |
735 |
|
#undef FUNC_NAME |
736 |
|
|
737 |
SCM_REGISTER_PROC(s_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0, scm_broadcast_condition_variable); |
/*** Condition variables */ |
738 |
|
|
739 |
|
/* Like mutexes, we implement our own condition variables using the |
740 |
|
primitives above. |
741 |
|
*/ |
742 |
|
|
743 |
|
/* yeah, we don't need a structure for this, but more things (like a |
744 |
|
name) will likely follow... */ |
745 |
|
|
746 |
|
typedef struct scm_cond { |
747 |
|
/* the threads waiting for this condition. */ |
748 |
|
SCM waiting; |
749 |
|
} scm_cond; |
750 |
|
|
751 |
|
static SCM |
752 |
|
cond_mark (SCM cv) |
753 |
|
{ |
754 |
|
scm_cond *c = SCM_CONDVAR_DATA (cv); |
755 |
|
return c->waiting; |
756 |
|
} |
757 |
|
|
758 |
|
SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0, |
759 |
|
(void), |
760 |
|
"Make a new condition variable.") |
761 |
|
#define FUNC_NAME s_scm_make_condition_variable |
762 |
|
{ |
763 |
|
SCM cv = scm_make_smob (scm_tc16_condvar); |
764 |
|
scm_cond *c = SCM_CONDVAR_DATA (cv); |
765 |
|
c->waiting = make_queue (); |
766 |
|
return cv; |
767 |
|
} |
768 |
|
#undef FUNC_NAME |
769 |
|
|
770 |
|
SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0, |
771 |
|
(SCM cv, SCM mx, SCM t), |
772 |
|
"Wait until @var{cond-var} has been signalled. While waiting, " |
773 |
|
"@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and " |
774 |
|
"is locked again when this function returns. When @var{time} is given, " |
775 |
|
"it specifies a point in time where the waiting should be aborted. It " |
776 |
|
"can be either a integer as returned by @code{current-time} or a pair " |
777 |
|
"as returned by @code{gettimeofday}. When the waiting is aborted the " |
778 |
|
"mutex is locked and @code{#f} is returned. When the condition " |
779 |
|
"variable is in fact signalled, the mutex is also locked and @code{#t} " |
780 |
|
"is returned. ") |
781 |
|
#define FUNC_NAME s_scm_timed_wait_condition_variable |
782 |
|
{ |
783 |
|
scm_cond *c; |
784 |
|
struct timespec waittime; |
785 |
|
int err; |
786 |
|
|
787 |
|
SCM_VALIDATE_CONDVAR (1, cv); |
788 |
|
SCM_VALIDATE_MUTEX (2, mx); |
789 |
|
|
790 |
|
if (!SCM_UNBNDP (t)) |
791 |
|
{ |
792 |
|
if (SCM_CONSP (t)) |
793 |
|
{ |
794 |
|
SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec); |
795 |
|
SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec); |
796 |
|
waittime.tv_nsec *= 1000; |
797 |
|
} |
798 |
|
else |
799 |
|
{ |
800 |
|
SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec); |
801 |
|
waittime.tv_nsec = 0; |
802 |
|
} |
803 |
|
} |
804 |
|
|
805 |
|
c = SCM_CONDVAR_DATA (cv); |
806 |
|
|
807 |
|
while (1) |
808 |
|
{ |
809 |
|
enqueue (c->waiting, cur_thread); |
810 |
|
scm_unlock_mutex (mx); |
811 |
|
if (SCM_UNBNDP (t)) |
812 |
|
err = block (); |
813 |
|
else |
814 |
|
err = timed_block (&waittime); |
815 |
|
scm_lock_mutex (mx); |
816 |
|
if (err) |
817 |
|
{ |
818 |
|
errno = err; |
819 |
|
scm_syserror (FUNC_NAME); |
820 |
|
} |
821 |
|
/* XXX - check whether we have been signalled. */ |
822 |
|
break; |
823 |
|
} |
824 |
|
return SCM_BOOL (err == 0); |
825 |
|
} |
826 |
|
#undef FUNC_NAME |
827 |
|
|
828 |
SCM |
SCM |
829 |
scm_wait_condition_variable (SCM c, SCM m) |
scm_wait_condition_variable (SCM c, SCM m) |
831 |
return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED); |
return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED); |
832 |
} |
} |
833 |
|
|
834 |
|
SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0, |
835 |
|
(SCM cv), |
836 |
#ifdef USE_COOP_THREADS |
"Wake up one thread that is waiting for @var{cv}") |
837 |
#include "libguile/coop-threads.c" |
#define FUNC_NAME s_scm_signal_condition_variable |
838 |
#else |
{ |
839 |
#ifdef USE_COPT_THREADS |
SCM th; |
840 |
#include "libguile/coop-pthreads.c" |
scm_cond *c; |
|
#else |
|
|
#include "libguile/null-threads.c" |
|
|
#endif |
|
|
#endif |
|
|
|
|
|
|
|
841 |
|
|
842 |
#if (SCM_ENABLE_DEPRECATED == 1) |
SCM_VALIDATE_CONDVAR (1, cv); |
843 |
|
|
844 |
int |
c = SCM_CONDVAR_DATA (cv); |
845 |
scm_mutex_init (scm_t_mutex *m) |
if (!SCM_FALSEP (th = dequeue (c->waiting))) |
846 |
{ |
unblock (SCM_THREAD_DATA (th)); |
847 |
scm_gc_protect_object (m->m = scm_make_mutex ()); |
return SCM_BOOL_T; |
|
return 0; |
|
848 |
} |
} |
849 |
|
#undef FUNC_NAME |
850 |
|
|
851 |
int |
SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0, |
852 |
scm_mutex_lock (scm_t_mutex *m) |
(SCM cv), |
853 |
|
"Wake up all threads that are waiting for @var{cv}. ") |
854 |
|
#define FUNC_NAME s_scm_broadcast_condition_variable |
855 |
{ |
{ |
856 |
scm_lock_mutex (m->m); |
SCM th; |
857 |
return 0; |
scm_cond *c; |
858 |
|
|
859 |
|
SCM_VALIDATE_CONDVAR (1, cv); |
860 |
|
|
861 |
|
c = SCM_CONDVAR_DATA (cv); |
862 |
|
while (!SCM_FALSEP (th = dequeue (c->waiting))) |
863 |
|
unblock (SCM_THREAD_DATA (th)); |
864 |
|
return SCM_BOOL_T; |
865 |
} |
} |
866 |
|
#undef FUNC_NAME |
867 |
|
|
868 |
int |
/*** Marking stacks */ |
869 |
scm_mutex_trylock (scm_t_mutex *m) |
|
870 |
|
/* XXX - what to do with this? Do we need to handle this for blocked |
871 |
|
threads as well? |
872 |
|
*/ |
873 |
|
#ifdef __ia64__ |
874 |
|
# define SCM_MARK_BACKING_STORE() do { \ |
875 |
|
ucontext_t ctx; \ |
876 |
|
SCM_STACKITEM * top, * bot; \ |
877 |
|
getcontext (&ctx); \ |
878 |
|
scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ |
879 |
|
((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ |
880 |
|
/ sizeof (SCM_STACKITEM))); \ |
881 |
|
bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \ |
882 |
|
top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \ |
883 |
|
scm_mark_locations (bot, top - bot); } while (0) |
884 |
|
#else |
885 |
|
# define SCM_MARK_BACKING_STORE() |
886 |
|
#endif |
887 |
|
|
888 |
|
void |
889 |
|
scm_threads_mark_stacks (void) |
890 |
{ |
{ |
891 |
return SCM_FALSEP (scm_try_mutex (m->m))? EBUSY : 0; |
volatile SCM c; |
892 |
|
for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c)) |
893 |
|
{ |
894 |
|
scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c)); |
895 |
|
if (t->base == NULL) |
896 |
|
{ |
897 |
|
/* Not fully initialized yet. */ |
898 |
|
continue; |
899 |
|
} |
900 |
|
if (t->top == NULL) |
901 |
|
{ |
902 |
|
/* Active thread */ |
903 |
|
/* stack_len is long rather than sizet in order to guarantee |
904 |
|
that &stack_len is long aligned */ |
905 |
|
#ifdef STACK_GROWS_UP |
906 |
|
long stack_len = ((SCM_STACKITEM *) (&t) - |
907 |
|
(SCM_STACKITEM *) thread->base); |
908 |
|
|
909 |
|
/* Protect from the C stack. This must be the first marking |
910 |
|
* done because it provides information about what objects |
911 |
|
* are "in-use" by the C code. "in-use" objects are those |
912 |
|
* for which the information about length and base address must |
913 |
|
* remain usable. This requirement is stricter than a liveness |
914 |
|
* requirement -- in particular, it constrains the implementation |
915 |
|
* of scm_resizuve. |
916 |
|
*/ |
917 |
|
SCM_FLUSH_REGISTER_WINDOWS; |
918 |
|
/* This assumes that all registers are saved into the jmp_buf */ |
919 |
|
setjmp (scm_save_regs_gc_mark); |
920 |
|
scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, |
921 |
|
((size_t) sizeof scm_save_regs_gc_mark |
922 |
|
/ sizeof (SCM_STACKITEM))); |
923 |
|
|
924 |
|
scm_mark_locations (((size_t) t->base, |
925 |
|
(sizet) stack_len)); |
926 |
|
#else |
927 |
|
long stack_len = ((SCM_STACKITEM *) t->base - |
928 |
|
(SCM_STACKITEM *) (&t)); |
929 |
|
|
930 |
|
/* Protect from the C stack. This must be the first marking |
931 |
|
* done because it provides information about what objects |
932 |
|
* are "in-use" by the C code. "in-use" objects are those |
933 |
|
* for which the information about length and base address must |
934 |
|
* remain usable. This requirement is stricter than a liveness |
935 |
|
* requirement -- in particular, it constrains the implementation |
936 |
|
* of scm_resizuve. |
937 |
|
*/ |
938 |
|
SCM_FLUSH_REGISTER_WINDOWS; |
939 |
|
/* This assumes that all registers are saved into the jmp_buf */ |
940 |
|
setjmp (scm_save_regs_gc_mark); |
941 |
|
scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, |
942 |
|
((size_t) sizeof scm_save_regs_gc_mark |
943 |
|
/ sizeof (SCM_STACKITEM))); |
944 |
|
|
945 |
|
scm_mark_locations ((SCM_STACKITEM *) &t, |
946 |
|
stack_len); |
947 |
|
#endif |
948 |
|
} |
949 |
|
else |
950 |
|
{ |
951 |
|
/* Suspended thread */ |
952 |
|
#ifdef STACK_GROWS_UP |
953 |
|
long stack_len = t->top - t->base; |
954 |
|
scm_mark_locations (t->base, stack_len); |
955 |
|
#else |
956 |
|
long stack_len = t->base - t->top; |
957 |
|
scm_mark_locations (t->top, stack_len); |
958 |
|
#endif |
959 |
|
scm_mark_locations ((SCM_STACKITEM *) t->regs, |
960 |
|
((size_t) sizeof(t->regs) |
961 |
|
/ sizeof (SCM_STACKITEM))); |
962 |
|
} |
963 |
|
} |
964 |
} |
} |
965 |
|
|
966 |
|
/*** Select */ |
967 |
|
|
968 |
int |
int |
969 |
scm_mutex_unlock (scm_t_mutex *m) |
scm_internal_select (int nfds, |
970 |
|
SELECT_TYPE *readfds, |
971 |
|
SELECT_TYPE *writefds, |
972 |
|
SELECT_TYPE *exceptfds, |
973 |
|
struct timeval *timeout) |
974 |
{ |
{ |
975 |
scm_unlock_mutex (m->m); |
int res, eno; |
976 |
return 0; |
scm_thread *c = leave_guile (); |
977 |
|
res = scm_thread_select (nfds, readfds, writefds, exceptfds, timeout); |
978 |
|
eno = errno; |
979 |
|
enter_guile (c); |
980 |
|
SCM_ASYNC_TICK; |
981 |
|
errno = eno; |
982 |
|
return res; |
983 |
} |
} |
984 |
|
|
985 |
int |
unsigned long |
986 |
scm_mutex_destroy (scm_t_mutex *m) |
scm_thread_usleep (unsigned long usecs) |
987 |
{ |
{ |
988 |
scm_gc_unprotect_object (m->m); |
struct timeval tv; |
989 |
return 0; |
tv.tv_usec = usecs % 1000000; |
990 |
|
tv.tv_sec = usecs / 1000000; |
991 |
|
scm_internal_select (0, NULL, NULL, NULL, &tv); |
992 |
|
return tv.tv_usec + tv.tv_sec*1000000; |
993 |
} |
} |
994 |
|
|
995 |
SCM_API int |
unsigned long |
996 |
scm_cond_init (scm_t_cond *c, int *cattr) |
scm_thread_sleep (unsigned long secs) |
997 |
{ |
{ |
998 |
scm_gc_protect_object (c->c = scm_make_condition_variable ()); |
struct timeval tv; |
999 |
return 0; |
tv.tv_usec = 0; |
1000 |
|
tv.tv_sec = secs; |
1001 |
|
scm_internal_select (0, NULL, NULL, NULL, &tv); |
1002 |
|
return tv.tv_sec; |
1003 |
} |
} |
1004 |
|
|
1005 |
int |
/*** Misc */ |
1006 |
scm_cond_wait (scm_t_cond *c, scm_t_mutex *m) |
|
1007 |
|
SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0, |
1008 |
|
(void), |
1009 |
|
"Return the thread that called this function.") |
1010 |
|
#define FUNC_NAME s_scm_current_thread |
1011 |
{ |
{ |
1012 |
scm_wait_condition_variable (c->c, m->m); |
return cur_thread; |
|
return 0; |
|
1013 |
} |
} |
1014 |
|
#undef FUNC_NAME |
1015 |
|
|
1016 |
int |
SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0, |
1017 |
scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m, |
(void), |
1018 |
const struct timespec *t) |
"Return a list of all threads.") |
1019 |
|
#define FUNC_NAME s_all_threads |
1020 |
{ |
{ |
1021 |
return !SCM_FALSEP (scm_timed_wait_condition_variable ( |
return all_threads; |
|
c->c, m->m, scm_cons (scm_long2num (t->tv_sec), |
|
|
scm_long2num (t->tv_nsec/1000)))); |
|
1022 |
} |
} |
1023 |
|
#undef FUNC_NAME |
1024 |
|
|
1025 |
int |
scm_root_state * |
1026 |
scm_cond_signal (scm_t_cond *c) |
scm_i_thread_root (SCM thread) |
1027 |
{ |
{ |
1028 |
scm_signal_condition_variable (c->c); |
return ((scm_thread *)SCM_THREAD_DATA (thread))->root; |
|
return 0; |
|
1029 |
} |
} |
1030 |
|
|
1031 |
int |
SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0, |
1032 |
scm_cond_broadcast (scm_t_cond *c) |
(SCM thread), |
1033 |
|
"Return @code{#t} iff @var{thread} has exited.\n") |
1034 |
|
#define FUNC_NAME s_scm_thread_exited_p |
1035 |
{ |
{ |
1036 |
scm_broadcast_condition_variable (c->c); |
return SCM_BOOL (scm_c_thread_exited_p (thread)); |
|
return 0; |
|
1037 |
} |
} |
1038 |
|
#undef FUNC_NAME |
1039 |
|
|
1040 |
int |
int |
1041 |
scm_cond_destroy (scm_t_cond *c) |
scm_c_thread_exited_p (SCM thread) |
1042 |
|
#define FUNC_NAME s_scm_thread_exited_p |
1043 |
{ |
{ |
1044 |
scm_gc_unprotect_object (c->c); |
scm_thread *t; |
1045 |
return 0; |
SCM_VALIDATE_THREAD (1, thread); |
1046 |
|
t = SCM_THREAD_DATA (thread); |
1047 |
|
return t->exited; |
1048 |
} |
} |
1049 |
|
#undef FUNC_NAME |
1050 |
|
|
1051 |
#endif |
/*** Initialization */ |
1052 |
|
|
1053 |
|
scm_t_bits scm_tc16_thread; |
1054 |
|
scm_t_bits scm_tc16_mutex; |
1055 |
|
scm_t_bits scm_tc16_condvar; |
1056 |
|
|
1057 |
void |
void |
1058 |
scm_init_threads (SCM_STACKITEM *i) |
scm_init_threads (SCM_STACKITEM *base) |
1059 |
{ |
{ |
1060 |
/* Initialize implementation specific details of the threads support */ |
scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_thread)); |
1061 |
scm_threads_init (i); |
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_mutex)); |
1062 |
|
scm_tc16_condvar = scm_make_smob_type ("condition-variable", |
1063 |
|
sizeof (scm_cond)); |
1064 |
|
|
1065 |
|
scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; |
1066 |
|
|
1067 |
|
fair_mutex_init (&guile_mutex); |
1068 |
|
|
1069 |
|
cur_thread = make_thread (SCM_BOOL_F); |
1070 |
|
enter_guile (SCM_THREAD_DATA (cur_thread)); |
1071 |
|
/* root is set later from init.c */ |
1072 |
|
init_thread_creator (cur_thread, scm_thread_self(), NULL); |
1073 |
|
init_thread_creatant (cur_thread, base); |
1074 |
|
|
1075 |
|
thread_count = 1; |
1076 |
|
scm_gc_register_root (&all_threads); |
1077 |
|
all_threads = scm_cons (cur_thread, SCM_EOL); |
1078 |
|
|
1079 |
|
scm_set_smob_mark (scm_tc16_thread, thread_mark); |
1080 |
|
scm_set_smob_print (scm_tc16_thread, thread_print); |
1081 |
|
scm_set_smob_free (scm_tc16_thread, thread_free); |
1082 |
|
|
1083 |
|
scm_set_smob_mark (scm_tc16_mutex, mutex_mark); |
1084 |
|
|
1085 |
|
scm_set_smob_mark (scm_tc16_condvar, cond_mark); |
1086 |
} |
} |
1087 |
|
|
1088 |
void |
void |
1091 |
#include "libguile/threads.x" |
#include "libguile/threads.x" |
1092 |
} |
} |
1093 |
|
|
1094 |
|
/* XXX */ |
1095 |
|
|
1096 |
|
void |
1097 |
|
scm_init_iselect () |
1098 |
|
{ |
1099 |
|
} |
1100 |
|
|
1101 |
/* |
/* |
1102 |
Local Variables: |
Local Variables: |
1103 |
c-file-style: "gnu" |
c-file-style: "gnu" |
1104 |
End: |
End: |
1105 |
*/ |
*/ |
1106 |
|
|