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