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