Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc. |
d97eb496 | 2 | * |
73be1d9e MV |
3 | * This library is free software; you can redistribute it and/or |
4 | * modify it under the terms of the GNU Lesser General Public | |
5 | * License as published by the Free Software Foundation; either | |
6 | * version 2.1 of the License, or (at your option) any later version. | |
d97eb496 | 7 | * |
73be1d9e MV |
8 | * This library is distributed in the hope that it will be useful, |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | * Lesser General Public License for more details. | |
d97eb496 | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
d97eb496 MV |
17 | |
18 | ||
19 | \f | |
20 | ||
2295d4da RB |
21 | #include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */ |
22 | ||
d97eb496 MV |
23 | #include <unistd.h> |
24 | #include <stdio.h> | |
0019d6a1 MV |
25 | #include <assert.h> |
26 | #include <sys/time.h> | |
d97eb496 MV |
27 | |
28 | #include "libguile/validate.h" | |
29 | #include "libguile/coop-pthreads.h" | |
30 | #include "libguile/root.h" | |
31 | #include "libguile/eval.h" | |
32 | #include "libguile/async.h" | |
33 | #include "libguile/ports.h" | |
73e6fc23 | 34 | #include "libguile/smob.h" |
d97eb496 MV |
35 | |
36 | #undef DEBUG | |
37 | ||
0019d6a1 | 38 | /*** Queues */ |
cf8ea1a3 | 39 | |
0019d6a1 MV |
40 | static SCM |
41 | make_queue () | |
42 | { | |
43 | return scm_cons (SCM_EOL, SCM_EOL); | |
44 | } | |
cf8ea1a3 | 45 | |
0019d6a1 MV |
46 | static void |
47 | enqueue (SCM q, SCM t) | |
48 | { | |
49 | SCM c = scm_cons (t, SCM_EOL); | |
d2e53ed6 | 50 | if (scm_is_null (SCM_CAR (q))) |
0019d6a1 MV |
51 | SCM_SETCAR (q, c); |
52 | else | |
53 | SCM_SETCDR (SCM_CDR (q), c); | |
54 | SCM_SETCDR (q, c); | |
55 | } | |
56 | ||
57 | static SCM | |
58 | dequeue (SCM q) | |
59 | { | |
60 | SCM c = SCM_CAR (q); | |
d2e53ed6 | 61 | if (scm_is_null (c)) |
0019d6a1 MV |
62 | return SCM_BOOL_F; |
63 | else | |
64 | { | |
65 | SCM_SETCAR (q, SCM_CDR (c)); | |
d2e53ed6 | 66 | if (scm_is_null (SCM_CAR (q))) |
0019d6a1 MV |
67 | SCM_SETCDR (q, SCM_EOL); |
68 | return SCM_CAR (c); | |
69 | } | |
70 | } | |
cf8ea1a3 | 71 | |
d97eb496 | 72 | |
cf8ea1a3 MV |
73 | /*** Threads */ |
74 | ||
75 | typedef struct scm_copt_thread { | |
76 | ||
77 | /* A condition variable for sleeping on. | |
78 | */ | |
79 | pthread_cond_t sleep_cond; | |
d97eb496 | 80 | |
0019d6a1 | 81 | /* A link for waiting queues. |
cf8ea1a3 | 82 | */ |
0019d6a1 | 83 | struct scm_copt_thread *next_waiting; |
d97eb496 | 84 | |
cf8ea1a3 MV |
85 | scm_root_state *root; |
86 | SCM handle; | |
87 | pthread_t pthread; | |
88 | SCM result; | |
d97eb496 | 89 | |
0019d6a1 MV |
90 | SCM joining_threads; |
91 | ||
cf8ea1a3 | 92 | /* For keeping track of the stack and registers. */ |
d97eb496 MV |
93 | SCM_STACKITEM *base; |
94 | SCM_STACKITEM *top; | |
95 | jmp_buf regs; | |
d97eb496 | 96 | |
cf8ea1a3 | 97 | } scm_copt_thread; |
d97eb496 | 98 | |
cf8ea1a3 | 99 | static SCM |
05166e1a | 100 | make_thread (SCM creation_protects) |
d97eb496 | 101 | { |
cf8ea1a3 MV |
102 | SCM z; |
103 | scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); | |
73e6fc23 LC |
104 | |
105 | SCM_NEWSMOB (z, t); | |
cf8ea1a3 | 106 | t->handle = z; |
05166e1a | 107 | t->result = creation_protects; |
0019d6a1 MV |
108 | t->base = NULL; |
109 | t->joining_threads = make_queue (); | |
110 | pthread_cond_init (&t->sleep_cond, NULL); | |
cf8ea1a3 MV |
111 | return z; |
112 | } | |
d97eb496 | 113 | |
cf8ea1a3 MV |
114 | static void |
115 | init_thread_creator (SCM thread, pthread_t th, scm_root_state *r) | |
116 | { | |
117 | scm_copt_thread *t = SCM_THREAD_DATA(thread); | |
118 | t->root = r; | |
119 | t->pthread = th; | |
0019d6a1 MV |
120 | #ifdef DEBUG |
121 | // fprintf (stderr, "%ld created %ld\n", pthread_self (), th); | |
c28b0ba2 | 122 | #endif |
cf8ea1a3 | 123 | } |
d97eb496 | 124 | |
cf8ea1a3 MV |
125 | static void |
126 | init_thread_creatant (SCM thread, SCM_STACKITEM *base) | |
127 | { | |
128 | scm_copt_thread *t = SCM_THREAD_DATA(thread); | |
d97eb496 MV |
129 | t->base = base; |
130 | t->top = NULL; | |
cf8ea1a3 MV |
131 | } |
132 | ||
cf8ea1a3 MV |
133 | static int |
134 | thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) | |
135 | { | |
136 | scm_copt_thread *t = SCM_THREAD_DATA (exp); | |
137 | scm_puts ("#<thread ", port); | |
0345e278 | 138 | scm_uintprint ((scm_t_bits)t, 16, port); |
cf8ea1a3 MV |
139 | if (t->pthread != -1) |
140 | { | |
141 | scm_putc (' ', port); | |
142 | scm_intprint (t->pthread, 10, port); | |
143 | } | |
144 | else | |
145 | scm_puts (" (exited)", port); | |
146 | scm_putc ('>', port); | |
147 | return 1; | |
d97eb496 MV |
148 | } |
149 | ||
cf8ea1a3 MV |
150 | static size_t |
151 | thread_free (SCM obj) | |
d97eb496 | 152 | { |
cf8ea1a3 MV |
153 | scm_copt_thread *t = SCM_THREAD_DATA (obj); |
154 | if (t->pthread != -1) | |
155 | abort (); | |
156 | scm_gc_free (t, sizeof (*t), "thread"); | |
157 | return 0; | |
158 | } | |
d97eb496 | 159 | |
0019d6a1 | 160 | /*** Fair mutexes */ |
d97eb496 | 161 | |
0019d6a1 MV |
162 | /* POSIX mutexes are not necessarily fair but since we'd like to use a |
163 | mutex for scheduling, we build a fair one on top of POSIX. | |
164 | */ | |
165 | ||
166 | typedef struct fair_mutex { | |
167 | pthread_mutex_t lock; | |
168 | scm_copt_thread *owner; | |
169 | scm_copt_thread *next_waiting, *last_waiting; | |
170 | } fair_mutex; | |
171 | ||
172 | static void | |
173 | fair_mutex_init (fair_mutex *m) | |
cf8ea1a3 | 174 | { |
0019d6a1 MV |
175 | pthread_mutex_init (&m->lock, NULL); |
176 | m->owner = NULL; | |
177 | m->next_waiting = NULL; | |
178 | m->last_waiting = NULL; | |
d97eb496 MV |
179 | } |
180 | ||
cf8ea1a3 | 181 | static void |
0019d6a1 | 182 | fair_mutex_lock_1 (fair_mutex *m, scm_copt_thread *t) |
cf8ea1a3 | 183 | { |
0019d6a1 MV |
184 | if (m->owner == NULL) |
185 | m->owner = t; | |
cf8ea1a3 | 186 | else |
0019d6a1 MV |
187 | { |
188 | t->next_waiting = NULL; | |
189 | if (m->last_waiting) | |
190 | m->last_waiting->next_waiting = t; | |
191 | else | |
192 | m->next_waiting = t; | |
193 | m->last_waiting = t; | |
194 | do | |
195 | { | |
196 | pthread_cond_wait (&t->sleep_cond, &m->lock); | |
197 | } | |
198 | while (m->owner != t); | |
199 | assert (m->next_waiting == t); | |
200 | m->next_waiting = t->next_waiting; | |
201 | if (m->next_waiting == NULL) | |
202 | m->last_waiting = NULL; | |
203 | } | |
204 | pthread_mutex_unlock (&m->lock); | |
cf8ea1a3 MV |
205 | } |
206 | ||
0019d6a1 MV |
207 | static void |
208 | fair_mutex_lock (fair_mutex *m, scm_copt_thread *t) | |
cf8ea1a3 | 209 | { |
0019d6a1 MV |
210 | pthread_mutex_lock (&m->lock); |
211 | fair_mutex_lock_1 (m, t); | |
212 | } | |
213 | ||
214 | static void | |
215 | fair_mutex_unlock_1 (fair_mutex *m) | |
216 | { | |
217 | scm_copt_thread *t; | |
218 | pthread_mutex_lock (&m->lock); | |
219 | // fprintf (stderr, "%ld unlocking\n", m->owner->pthread); | |
220 | if ((t = m->next_waiting) != NULL) | |
cf8ea1a3 | 221 | { |
0019d6a1 MV |
222 | m->owner = t; |
223 | pthread_cond_signal (&t->sleep_cond); | |
cf8ea1a3 | 224 | } |
0019d6a1 MV |
225 | else |
226 | m->owner = NULL; | |
227 | // fprintf (stderr, "%ld unlocked\n", pthread_self ()); | |
cf8ea1a3 MV |
228 | } |
229 | ||
0019d6a1 MV |
230 | static void |
231 | fair_mutex_unlock (fair_mutex *m) | |
232 | { | |
233 | fair_mutex_unlock_1 (m); | |
234 | pthread_mutex_unlock (&m->lock); | |
235 | } | |
c28b0ba2 | 236 | |
0019d6a1 MV |
237 | /* Temporarily give up the mutex. This function makes sure that we |
238 | are on the wait queue before starting the next thread. Otherwise | |
239 | the next thread might preempt us and we will have a hard time | |
240 | getting on the wait queue. | |
241 | */ | |
242 | #if 0 | |
243 | static void | |
244 | fair_mutex_yield (fair_mutex *m) | |
245 | { | |
246 | scm_copt_thread *self, *next; | |
c28b0ba2 | 247 | |
0019d6a1 | 248 | pthread_mutex_lock (&m->lock); |
c28b0ba2 | 249 | |
0019d6a1 MV |
250 | /* get next thread |
251 | */ | |
252 | if ((next = m->next_waiting) == NULL) | |
253 | { | |
254 | /* No use giving it up. */ | |
255 | pthread_mutex_unlock (&m->lock); | |
256 | return; | |
257 | } | |
cf8ea1a3 | 258 | |
0019d6a1 MV |
259 | /* put us on queue |
260 | */ | |
261 | self = m->owner; | |
262 | self->next_waiting = NULL; | |
263 | if (m->last_waiting) | |
264 | m->last_waiting->next_waiting = self; | |
265 | else | |
266 | m->next_waiting = self; | |
267 | m->last_waiting = self; | |
cf8ea1a3 | 268 | |
0019d6a1 MV |
269 | /* wake up next thread |
270 | */ | |
c28b0ba2 | 271 | |
0019d6a1 MV |
272 | m->owner = next; |
273 | pthread_cond_signal (&next->sleep_cond); | |
cf8ea1a3 | 274 | |
0019d6a1 MV |
275 | /* wait for mutex |
276 | */ | |
277 | do | |
c28b0ba2 | 278 | { |
0019d6a1 | 279 | pthread_cond_wait (&self->sleep_cond, &m->lock); |
c28b0ba2 | 280 | } |
0019d6a1 MV |
281 | while (m->owner != self); |
282 | assert (m->next_waiting == self); | |
283 | m->next_waiting = self->next_waiting; | |
284 | if (m->next_waiting == NULL) | |
285 | m->last_waiting = NULL; | |
c28b0ba2 | 286 | |
0019d6a1 | 287 | pthread_mutex_unlock (&m->lock); |
cf8ea1a3 | 288 | } |
0019d6a1 | 289 | #else |
c28b0ba2 | 290 | static void |
0019d6a1 | 291 | fair_mutex_yield (fair_mutex *m) |
d97eb496 | 292 | { |
0019d6a1 MV |
293 | scm_copt_thread *self = m->owner; |
294 | fair_mutex_unlock_1 (m); | |
295 | fair_mutex_lock_1 (m, self); | |
cf8ea1a3 | 296 | } |
0019d6a1 | 297 | #endif |
d97eb496 | 298 | |
cf8ea1a3 | 299 | static void |
0019d6a1 | 300 | fair_cond_wait (pthread_cond_t *c, fair_mutex *m) |
cf8ea1a3 | 301 | { |
0019d6a1 MV |
302 | scm_copt_thread *t = m->owner; |
303 | fair_mutex_unlock_1 (m); | |
304 | pthread_cond_wait (c, &m->lock); | |
305 | fair_mutex_lock_1 (m, t); | |
cf8ea1a3 | 306 | } |
c28b0ba2 | 307 | |
0019d6a1 MV |
308 | /* Return 1 when the mutex was signalled and 0 when not. */ |
309 | static int | |
2295d4da | 310 | fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at) |
cf8ea1a3 | 311 | { |
0019d6a1 MV |
312 | int res; |
313 | scm_copt_thread *t = m->owner; | |
314 | fair_mutex_unlock_1 (m); | |
315 | res = pthread_cond_timedwait (c, &m->lock, at); /* XXX - signals? */ | |
316 | fair_mutex_lock_1 (m, t); | |
317 | return res == 0; | |
318 | } | |
d97eb496 | 319 | |
0019d6a1 | 320 | /*** Scheduling */ |
d97eb496 | 321 | |
0019d6a1 MV |
322 | /* When a thread wants to execute Guile functions, it locks the |
323 | guile_mutex. | |
324 | */ | |
c28b0ba2 | 325 | |
0019d6a1 | 326 | static fair_mutex guile_mutex; |
d97eb496 | 327 | |
0019d6a1 MV |
328 | static SCM cur_thread; |
329 | void *scm_i_copt_thread_data; | |
d97eb496 | 330 | |
0019d6a1 MV |
331 | void |
332 | scm_i_copt_set_thread_data (void *data) | |
333 | { | |
334 | scm_copt_thread *t = SCM_THREAD_DATA (cur_thread); | |
335 | scm_i_copt_thread_data = data; | |
336 | t->root = (scm_root_state *)data; | |
337 | } | |
338 | ||
339 | static void | |
340 | resume (scm_copt_thread *t) | |
341 | { | |
342 | cur_thread = t->handle; | |
343 | scm_i_copt_thread_data = t->root; | |
344 | t->top = NULL; | |
d97eb496 MV |
345 | } |
346 | ||
d97eb496 | 347 | static void |
0019d6a1 MV |
348 | enter_guile (scm_copt_thread *t) |
349 | { | |
350 | fair_mutex_lock (&guile_mutex, t); | |
351 | resume (t); | |
352 | } | |
353 | ||
354 | static scm_copt_thread * | |
355 | suspend () | |
d97eb496 | 356 | { |
c28b0ba2 | 357 | SCM cur = cur_thread; |
cf8ea1a3 | 358 | scm_copt_thread *c = SCM_THREAD_DATA (cur); |
c28b0ba2 MV |
359 | |
360 | /* record top of stack for the GC */ | |
361 | c->top = (SCM_STACKITEM *)&c; | |
362 | /* save registers. */ | |
363 | SCM_FLUSH_REGISTER_WINDOWS; | |
364 | setjmp (c->regs); | |
365 | ||
0019d6a1 MV |
366 | return c; |
367 | } | |
c28b0ba2 | 368 | |
0019d6a1 MV |
369 | static scm_copt_thread * |
370 | leave_guile () | |
371 | { | |
372 | scm_copt_thread *c = suspend (); | |
373 | fair_mutex_unlock (&guile_mutex); | |
374 | return c; | |
d97eb496 MV |
375 | } |
376 | ||
0019d6a1 | 377 | int scm_i_switch_counter; |
d97eb496 | 378 | |
cf8ea1a3 MV |
379 | SCM |
380 | scm_yield () | |
d97eb496 | 381 | { |
05166e1a MV |
382 | /* Testing guile_mutex.next_waiting without locking guile_mutex.lock |
383 | is OK since the outcome is not critical. Even when it changes | |
384 | after the test, we do the right thing. | |
0019d6a1 MV |
385 | */ |
386 | if (guile_mutex.next_waiting) | |
d97eb496 | 387 | { |
0019d6a1 MV |
388 | scm_copt_thread *t = suspend (); |
389 | fair_mutex_yield (&guile_mutex); | |
390 | resume (t); | |
d97eb496 | 391 | } |
cf8ea1a3 | 392 | return SCM_BOOL_T; |
d97eb496 MV |
393 | } |
394 | ||
0019d6a1 MV |
395 | /* Put the current thread to sleep until it is explicitely unblocked. |
396 | */ | |
397 | static void | |
398 | block () | |
399 | { | |
400 | scm_copt_thread *t = suspend (); | |
401 | fair_cond_wait (&t->sleep_cond, &guile_mutex); | |
402 | resume (t); | |
403 | } | |
404 | ||
405 | /* Put the current thread to sleep until it is explicitely unblocked | |
406 | or until a signal arrives or until time AT (absolute time) is | |
407 | reached. Return 1 when it has been unblocked; 0 otherwise. | |
408 | */ | |
409 | static int | |
2295d4da | 410 | timed_block (scm_t_timespec *at) |
0019d6a1 MV |
411 | { |
412 | int res; | |
413 | scm_copt_thread *t = suspend (); | |
414 | res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at); | |
415 | resume (t); | |
416 | return res; | |
417 | } | |
418 | ||
419 | /* Unblock a sleeping thread. | |
420 | */ | |
421 | static void | |
422 | unblock (scm_copt_thread *t) | |
423 | { | |
424 | pthread_cond_signal (&t->sleep_cond); | |
425 | } | |
cf8ea1a3 MV |
426 | |
427 | /*** Thread creation */ | |
428 | ||
429 | static SCM all_threads; | |
430 | static int thread_count; | |
431 | ||
05166e1a MV |
432 | typedef struct launch_data { |
433 | SCM thread; | |
cf8ea1a3 | 434 | SCM rootcont; |
05166e1a MV |
435 | scm_t_catch_body body; |
436 | void *body_data; | |
437 | scm_t_catch_handler handler; | |
438 | void *handler_data; | |
439 | } launch_data; | |
cf8ea1a3 | 440 | |
d97eb496 | 441 | static SCM |
05166e1a | 442 | body_bootstrip (launch_data* data) |
d97eb496 | 443 | { |
cf8ea1a3 MV |
444 | /* First save the new root continuation */ |
445 | data->rootcont = scm_root->rootcont; | |
05166e1a MV |
446 | return (data->body) (data->body_data); |
447 | // return scm_call_0 (data->body); | |
d97eb496 MV |
448 | } |
449 | ||
cf8ea1a3 | 450 | static SCM |
05166e1a | 451 | handler_bootstrip (launch_data* data, SCM tag, SCM throw_args) |
d97eb496 | 452 | { |
cf8ea1a3 | 453 | scm_root->rootcont = data->rootcont; |
05166e1a MV |
454 | return (data->handler) (data->handler_data, tag, throw_args); |
455 | // return scm_apply_1 (data->handler, tag, throw_args); | |
d97eb496 MV |
456 | } |
457 | ||
458 | static void | |
05166e1a | 459 | really_launch (SCM_STACKITEM *base, launch_data *data) |
d97eb496 | 460 | { |
05166e1a | 461 | SCM thread = data->thread; |
cf8ea1a3 | 462 | scm_copt_thread *t = SCM_THREAD_DATA (thread); |
cf8ea1a3 | 463 | init_thread_creatant (thread, base); |
0019d6a1 | 464 | enter_guile (t); |
cf8ea1a3 | 465 | |
05166e1a | 466 | data->rootcont = SCM_BOOL_F; |
cf8ea1a3 | 467 | t->result = |
05166e1a MV |
468 | scm_internal_cwdr ((scm_t_catch_body) body_bootstrip, |
469 | data, | |
470 | (scm_t_catch_handler) handler_bootstrip, | |
471 | data, base); | |
472 | free (data); | |
cf8ea1a3 | 473 | |
0019d6a1 | 474 | pthread_detach (t->pthread); |
cf8ea1a3 MV |
475 | all_threads = scm_delq (thread, all_threads); |
476 | t->pthread = -1; | |
477 | thread_count--; | |
c28b0ba2 | 478 | leave_guile (); |
cf8ea1a3 MV |
479 | } |
480 | ||
481 | static void * | |
05166e1a | 482 | launch_thread (void *p) |
cf8ea1a3 | 483 | { |
05166e1a | 484 | really_launch ((SCM_STACKITEM *)&p, (launch_data *)p); |
cf8ea1a3 | 485 | return NULL; |
d97eb496 MV |
486 | } |
487 | ||
05166e1a MV |
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) | |
cf8ea1a3 MV |
492 | { |
493 | SCM thread; | |
494 | ||
cf8ea1a3 MV |
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 | pthread_t th; | |
503 | SCM root, old_winds; | |
05166e1a MV |
504 | launch_data *data; |
505 | ||
cf8ea1a3 MV |
506 | /* Unwind wind chain. */ |
507 | old_winds = scm_dynwinds; | |
508 | scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); | |
509 | ||
510 | /* Allocate thread locals. */ | |
511 | root = scm_make_root (scm_root->handle); | |
a4a141f6 | 512 | data = scm_gc_malloc (sizeof (launch_data)); |
05166e1a | 513 | |
cf8ea1a3 | 514 | /* Make thread. */ |
05166e1a MV |
515 | thread = make_thread (protects); |
516 | data->thread = thread; | |
517 | data->body = body; | |
518 | data->body_data = body_data; | |
519 | data->handler = handler; | |
520 | data->handler_data = handler_data; | |
521 | pthread_create (&th, NULL, launch_thread, (void *) data); | |
cf8ea1a3 MV |
522 | init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
523 | all_threads = scm_cons (thread, all_threads); | |
524 | thread_count++; | |
cf8ea1a3 MV |
525 | |
526 | /* Return to old dynamic context. */ | |
527 | scm_dowinds (old_winds, - scm_ilength (old_winds)); | |
528 | } | |
0019d6a1 | 529 | |
cf8ea1a3 MV |
530 | return thread; |
531 | } | |
05166e1a MV |
532 | |
533 | SCM | |
534 | scm_call_with_new_thread (SCM argl) | |
535 | #define FUNC_NAME s_call_with_new_thread | |
536 | { | |
537 | SCM thunk, handler; | |
538 | ||
539 | /* Check arguments. */ | |
540 | { | |
541 | register SCM args = argl; | |
d2e53ed6 | 542 | if (!scm_is_pair (args)) |
05166e1a MV |
543 | SCM_WRONG_NUM_ARGS (); |
544 | thunk = SCM_CAR (args); | |
7888309b | 545 | SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), |
05166e1a MV |
546 | thunk, |
547 | SCM_ARG1, | |
548 | s_call_with_new_thread); | |
549 | args = SCM_CDR (args); | |
d2e53ed6 | 550 | if (!scm_is_pair (args)) |
05166e1a MV |
551 | SCM_WRONG_NUM_ARGS (); |
552 | handler = SCM_CAR (args); | |
7888309b | 553 | SCM_ASSERT (scm_is_true (scm_procedure_p (handler)), |
05166e1a MV |
554 | handler, |
555 | SCM_ARG2, | |
556 | s_call_with_new_thread); | |
d2e53ed6 | 557 | if (!scm_is_null (SCM_CDR (args))) |
05166e1a MV |
558 | SCM_WRONG_NUM_ARGS (); |
559 | } | |
560 | ||
561 | return create_thread ((scm_t_catch_body) scm_call_0, thunk, | |
562 | (scm_t_catch_handler) scm_apply_1, handler, | |
563 | argl); | |
564 | } | |
cf8ea1a3 MV |
565 | #undef FUNC_NAME |
566 | ||
05166e1a MV |
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 | ||
cf8ea1a3 MV |
574 | /*** Mutexes */ |
575 | ||
0019d6a1 MV |
576 | /* We implement our own mutex type since we want them to be 'fair', we |
577 | want to do fancy things while waiting for them (like running | |
cf8ea1a3 | 578 | asyncs) and we want to support waiting on many things at once. |
0019d6a1 | 579 | Also, we might add things that are nice for debugging. |
cf8ea1a3 MV |
580 | */ |
581 | ||
582 | typedef struct scm_copt_mutex { | |
583 | /* the thread currently owning the mutex, or SCM_BOOL_F. */ | |
584 | SCM owner; | |
585 | /* how much the owner owns us. */ | |
586 | int level; | |
587 | /* the threads waiting for this mutex. */ | |
588 | SCM waiting; | |
589 | } scm_copt_mutex; | |
590 | ||
d97eb496 | 591 | |
cf8ea1a3 MV |
592 | SCM |
593 | scm_make_mutex () | |
d97eb496 | 594 | { |
cf8ea1a3 MV |
595 | SCM mx = scm_make_smob (scm_tc16_mutex); |
596 | scm_copt_mutex *m = SCM_MUTEX_DATA (mx); | |
597 | m->owner = SCM_BOOL_F; | |
598 | m->level = 0; | |
599 | m->waiting = make_queue (); | |
600 | return mx; | |
601 | } | |
602 | ||
603 | SCM | |
604 | scm_lock_mutex (SCM mx) | |
605 | #define FUNC_NAME s_lock_mutex | |
606 | { | |
607 | scm_copt_mutex *m; | |
608 | SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); | |
609 | m = SCM_MUTEX_DATA (mx); | |
610 | ||
611 | if (m->owner == SCM_BOOL_F) | |
612 | m->owner = cur_thread; | |
613 | else if (m->owner == cur_thread) | |
614 | m->level++; | |
615 | else | |
d97eb496 | 616 | { |
cf8ea1a3 MV |
617 | while (m->owner != cur_thread) |
618 | { | |
619 | enqueue (m->waiting, cur_thread); | |
cf8ea1a3 MV |
620 | block (); |
621 | SCM_ASYNC_TICK; | |
622 | } | |
d97eb496 | 623 | } |
cf8ea1a3 | 624 | return SCM_BOOL_T; |
d97eb496 | 625 | } |
cf8ea1a3 | 626 | #undef FUNC_NAME |
d97eb496 | 627 | |
0019d6a1 MV |
628 | SCM |
629 | scm_try_mutex (SCM mx) | |
630 | #define FUNC_NAME s_try_mutex | |
631 | { | |
632 | scm_copt_mutex *m; | |
633 | SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); | |
634 | m = SCM_MUTEX_DATA (mx); | |
635 | ||
636 | if (m->owner == SCM_BOOL_F) | |
637 | m->owner = cur_thread; | |
638 | else if (m->owner == cur_thread) | |
639 | m->level++; | |
640 | else | |
641 | return SCM_BOOL_F; | |
642 | return SCM_BOOL_T; | |
643 | } | |
644 | #undef FUNC_NAME | |
645 | ||
cf8ea1a3 MV |
646 | SCM |
647 | scm_unlock_mutex (SCM mx) | |
76734914 | 648 | #define FUNC_NAME s_unlock_mutex |
d97eb496 | 649 | { |
cf8ea1a3 MV |
650 | scm_copt_mutex *m; |
651 | SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); | |
652 | m = SCM_MUTEX_DATA (mx); | |
653 | ||
654 | if (m->owner != cur_thread) | |
655 | { | |
656 | if (m->owner == SCM_BOOL_F) | |
657 | SCM_MISC_ERROR ("mutex not locked", SCM_EOL); | |
658 | else | |
659 | SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL); | |
660 | } | |
661 | else if (m->level > 0) | |
662 | m->level--; | |
663 | else | |
664 | { | |
665 | SCM next = dequeue (m->waiting); | |
7888309b | 666 | if (scm_is_true (next)) |
cf8ea1a3 MV |
667 | { |
668 | m->owner = next; | |
0019d6a1 | 669 | unblock (SCM_THREAD_DATA (next)); |
cf8ea1a3 MV |
670 | scm_yield (); |
671 | } | |
672 | else | |
673 | m->owner = SCM_BOOL_F; | |
674 | } | |
675 | return SCM_BOOL_T; | |
d97eb496 | 676 | } |
cf8ea1a3 | 677 | #undef FUNC_NAME |
d97eb496 | 678 | |
0019d6a1 MV |
679 | /*** Condition variables */ |
680 | ||
681 | /* Like mutexes, we implement our own condition variables using the | |
682 | primitives above. | |
683 | */ | |
684 | ||
685 | /* yeah, we don't need a structure for this, but more things (like a | |
686 | name) will likely follow... */ | |
687 | ||
688 | typedef struct scm_copt_cond { | |
689 | /* the threads waiting for this condition. */ | |
690 | SCM waiting; | |
691 | } scm_copt_cond; | |
692 | ||
693 | static SCM | |
694 | cond_mark (SCM cv) | |
695 | { | |
696 | scm_copt_cond *c = SCM_CONDVAR_DATA (cv); | |
697 | return c->waiting; | |
698 | } | |
699 | ||
700 | SCM | |
701 | scm_make_condition_variable (void) | |
702 | { | |
703 | SCM cv = scm_make_smob (scm_tc16_condvar); | |
704 | scm_copt_cond *c = SCM_CONDVAR_DATA (cv); | |
705 | c->waiting = make_queue (); | |
706 | return cv; | |
707 | } | |
708 | ||
709 | SCM | |
710 | scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t) | |
711 | #define FUNC_NAME s_wait_condition_variable | |
712 | { | |
713 | scm_copt_cond *c; | |
2295d4da | 714 | scm_t_timespec waittime; |
0019d6a1 MV |
715 | int res; |
716 | ||
717 | SCM_ASSERT (SCM_CONDVARP (cv), | |
718 | cv, | |
719 | SCM_ARG1, | |
720 | s_wait_condition_variable); | |
721 | SCM_ASSERT (SCM_MUTEXP (mx), | |
722 | mx, | |
723 | SCM_ARG2, | |
724 | s_wait_condition_variable); | |
725 | if (!SCM_UNBNDP (t)) | |
726 | { | |
d2e53ed6 | 727 | if (scm_is_pair (t)) |
0019d6a1 MV |
728 | { |
729 | SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec); | |
730 | SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec); | |
731 | waittime.tv_nsec *= 1000; | |
732 | } | |
733 | else | |
734 | { | |
735 | SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec); | |
736 | waittime.tv_nsec = 0; | |
737 | } | |
738 | } | |
739 | ||
740 | c = SCM_CONDVAR_DATA (cv); | |
741 | ||
742 | enqueue (c->waiting, cur_thread); | |
743 | scm_unlock_mutex (mx); | |
744 | if (SCM_UNBNDP (t)) | |
745 | { | |
746 | block (); | |
747 | res = 1; | |
748 | } | |
749 | else | |
750 | res = timed_block (&waittime); | |
751 | scm_lock_mutex (mx); | |
7888309b | 752 | return scm_from_bool (res); |
0019d6a1 MV |
753 | } |
754 | #undef FUNC_NAME | |
755 | ||
756 | SCM | |
757 | scm_signal_condition_variable (SCM cv) | |
758 | #define FUNC_NAME s_signal_condition_variable | |
759 | { | |
760 | SCM th; | |
761 | scm_copt_cond *c; | |
762 | SCM_ASSERT (SCM_CONDVARP (cv), | |
763 | cv, | |
764 | SCM_ARG1, | |
765 | s_signal_condition_variable); | |
766 | c = SCM_CONDVAR_DATA (cv); | |
7888309b | 767 | if (scm_is_true (th = dequeue (c->waiting))) |
0019d6a1 MV |
768 | unblock (SCM_THREAD_DATA (th)); |
769 | return SCM_BOOL_T; | |
770 | } | |
771 | #undef FUNC_NAME | |
772 | ||
773 | SCM | |
774 | scm_broadcast_condition_variable (SCM cv) | |
775 | #define FUNC_NAME s_broadcast_condition_variable | |
776 | { | |
777 | SCM th; | |
778 | scm_copt_cond *c; | |
779 | SCM_ASSERT (SCM_CONDVARP (cv), | |
780 | cv, | |
781 | SCM_ARG1, | |
782 | s_signal_condition_variable); | |
783 | c = SCM_CONDVAR_DATA (cv); | |
7888309b | 784 | while (scm_is_true (th = dequeue (c->waiting))) |
0019d6a1 MV |
785 | unblock (SCM_THREAD_DATA (th)); |
786 | return SCM_BOOL_T; | |
787 | } | |
788 | #undef FUNC_NAME | |
789 | ||
cf8ea1a3 | 790 | /*** Initialization */ |
d97eb496 MV |
791 | |
792 | void | |
793 | scm_threads_init (SCM_STACKITEM *base) | |
794 | { | |
cf8ea1a3 MV |
795 | scm_tc16_thread = scm_make_smob_type ("thread", 0); |
796 | scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex)); | |
0019d6a1 MV |
797 | scm_tc16_condvar = scm_make_smob_type ("condition-variable", |
798 | sizeof (scm_copt_cond)); | |
cf8ea1a3 | 799 | |
0019d6a1 MV |
800 | scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; |
801 | ||
802 | fair_mutex_init (&guile_mutex); | |
cf8ea1a3 | 803 | |
cf8ea1a3 | 804 | cur_thread = make_thread (SCM_BOOL_F); |
c28b0ba2 | 805 | enter_guile (SCM_THREAD_DATA (cur_thread)); |
d97eb496 | 806 | /* root is set later from init.c */ |
cf8ea1a3 MV |
807 | init_thread_creator (cur_thread, pthread_self(), NULL); |
808 | init_thread_creatant (cur_thread, base); | |
c28b0ba2 | 809 | |
d97eb496 | 810 | thread_count = 1; |
cf8ea1a3 MV |
811 | scm_gc_register_root (&all_threads); |
812 | all_threads = scm_cons (cur_thread, SCM_EOL); | |
813 | ||
d97eb496 | 814 | scm_set_smob_print (scm_tc16_thread, thread_print); |
d97eb496 MV |
815 | } |
816 | ||
cf8ea1a3 MV |
817 | /*** Marking stacks */ |
818 | ||
d97eb496 MV |
819 | /* XXX - what to do with this? Do we need to handle this for blocked |
820 | threads as well? | |
821 | */ | |
822 | #ifdef __ia64__ | |
823 | # define SCM_MARK_BACKING_STORE() do { \ | |
824 | ucontext_t ctx; \ | |
825 | SCM_STACKITEM * top, * bot; \ | |
826 | getcontext (&ctx); \ | |
827 | scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ | |
828 | ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ | |
829 | / sizeof (SCM_STACKITEM))); \ | |
9a5fa6e9 NJ |
830 | bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \ |
831 | top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ | |
d97eb496 MV |
832 | scm_mark_locations (bot, top - bot); } while (0) |
833 | #else | |
834 | # define SCM_MARK_BACKING_STORE() | |
835 | #endif | |
836 | ||
6bad09ba | 837 | |
d97eb496 | 838 | |
cf8ea1a3 | 839 | /*** Select */ |
d97eb496 | 840 | |
cf8ea1a3 MV |
841 | int |
842 | scm_internal_select (int nfds, | |
843 | SELECT_TYPE *readfds, | |
844 | SELECT_TYPE *writefds, | |
845 | SELECT_TYPE *exceptfds, | |
846 | struct timeval *timeout) | |
847 | { | |
0019d6a1 | 848 | int res, eno; |
c28b0ba2 | 849 | scm_copt_thread *c = leave_guile (); |
cf8ea1a3 | 850 | res = select (nfds, readfds, writefds, exceptfds, timeout); |
0019d6a1 | 851 | eno = errno; |
c28b0ba2 | 852 | enter_guile (c); |
cf8ea1a3 | 853 | SCM_ASYNC_TICK; |
0019d6a1 | 854 | errno = eno; |
cf8ea1a3 MV |
855 | return res; |
856 | } | |
d97eb496 | 857 | |
cf8ea1a3 MV |
858 | void |
859 | scm_init_iselect () | |
d97eb496 | 860 | { |
d97eb496 MV |
861 | } |
862 | ||
0019d6a1 MV |
863 | unsigned long |
864 | scm_thread_usleep (unsigned long usec) | |
865 | { | |
866 | scm_copt_thread *c = leave_guile (); | |
867 | usleep (usec); | |
868 | enter_guile (c); | |
869 | return 0; | |
870 | } | |
871 | ||
872 | unsigned long | |
873 | scm_thread_sleep (unsigned long sec) | |
874 | { | |
875 | unsigned long res; | |
876 | scm_copt_thread *c = leave_guile (); | |
877 | res = sleep (sec); | |
878 | enter_guile (c); | |
879 | return res; | |
880 | } | |
881 | ||
cf8ea1a3 MV |
882 | /*** Misc */ |
883 | ||
884 | SCM | |
885 | scm_current_thread (void) | |
d97eb496 | 886 | { |
cf8ea1a3 | 887 | return cur_thread; |
d97eb496 MV |
888 | } |
889 | ||
cf8ea1a3 MV |
890 | SCM |
891 | scm_all_threads (void) | |
d97eb496 | 892 | { |
cf8ea1a3 | 893 | return all_threads; |
d97eb496 MV |
894 | } |
895 | ||
cf8ea1a3 MV |
896 | scm_root_state * |
897 | scm_i_thread_root (SCM thread) | |
d97eb496 | 898 | { |
0019d6a1 MV |
899 | if (thread == cur_thread) |
900 | return scm_i_copt_thread_data; | |
901 | else | |
902 | return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root; | |
d97eb496 MV |
903 | } |
904 | ||
0019d6a1 MV |
905 | SCM |
906 | scm_join_thread (SCM thread) | |
907 | #define FUNC_NAME s_join_thread | |
cf8ea1a3 | 908 | { |
0019d6a1 MV |
909 | scm_copt_thread *t; |
910 | SCM res; | |
911 | ||
912 | SCM_VALIDATE_THREAD (1, thread); | |
913 | ||
914 | t = SCM_THREAD_DATA (thread); | |
915 | if (t->pthread != -1) | |
916 | { | |
917 | scm_copt_thread *c = leave_guile (); | |
918 | pthread_join (t->pthread, NULL); | |
919 | enter_guile (c); | |
920 | } | |
921 | res = t->result; | |
922 | t->result = SCM_BOOL_F; | |
923 | return res; | |
cf8ea1a3 | 924 | } |
0019d6a1 | 925 | #undef FUNC_NAME |
d97eb496 | 926 | |
0019d6a1 MV |
927 | int |
928 | scm_c_thread_exited_p (SCM thread) | |
929 | #define FUNC_NAME s_scm_thread_exited_p | |
d97eb496 | 930 | { |
0019d6a1 MV |
931 | scm_copt_thread *t; |
932 | SCM_VALIDATE_THREAD (1, thread); | |
933 | t = SCM_THREAD_DATA (thread); | |
934 | return t->pthread == -1; | |
cf8ea1a3 | 935 | } |
0019d6a1 MV |
936 | #undef FUNC_NAME |
937 | ||
d97eb496 MV |
938 | /* |
939 | Local Variables: | |
940 | c-file-style: "gnu" | |
941 | End: | |
942 | */ | |
943 |