1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
2 *
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.
7 *
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.
12 *
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
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16 */
17
18
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include <signal.h>
25 #include "libguile/_scm.h"
26 #include "libguile/eval.h"
27 #include "libguile/throw.h"
28 #include "libguile/root.h"
29 #include "libguile/smob.h"
30 #include "libguile/lang.h"
31 #include "libguile/dynwind.h"
32 #include "libguile/deprecation.h"
33
34 #include "libguile/validate.h"
35 #include "libguile/async.h"
36
37 #ifdef HAVE_STRING_H
38 #include <string.h>
39 #endif
40 #ifdef HAVE_UNISTD_H
41 #include <unistd.h>
42 #endif
43
44
45 /* {Asynchronous Events}
46 *
47 * There are two kinds of asyncs: system asyncs and user asyncs. The
48 * two kinds have some concepts in commen but work slightly
49 * differently and are not interchangeable.
50 *
51 * System asyncs are used to run arbitrary code at the next safe point
52 * in a specified thread. You can use them to trigger execution of
53 * Scheme code from signal handlers or to interrupt a thread, for
54 * example.
55 *
56 * Each thread has a list of 'activated asyncs', which is a normal
57 * Scheme list of procedures with zero arguments. When a thread
58 * executes a SCM_ASYNC_TICK statement (which is included in
59 * SCM_TICK), it will call all procedures on this list.
60 *
61 * Also, a thread will wake up when a procedure is added to its list
62 * of active asyncs and call them. After that, it will go to sleep
63 * again. (Not implemented yet.)
64 *
65 *
66 * User asyncs are a little data structure that consists of a
67 * procedure of zero arguments and a mark. There are functions for
68 * setting the mark of a user async and for calling all procedures of
69 * marked asyncs in a given list. Nothing you couldn't quickly
70 * implement yourself.
71 */
72
73
74
75
76 /* User asyncs. */
77
78 static scm_t_bits tc16_async;
79
80 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
81 this is ugly. */
82 #define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
83 #define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
84
85 #define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
86 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
87 #define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
88
89 static SCM
async_gc_mark(SCM obj)90 async_gc_mark (SCM obj)
91 {
92 return ASYNC_THUNK (obj);
93 }
94
95 SCM_DEFINE (scm_async, "async", 1, 0, 0,
96 (SCM thunk),
97 "Create a new async for the procedure @var{thunk}.")
98 #define FUNC_NAME s_scm_async
99 {
100 SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
101 }
102 #undef FUNC_NAME
103
104 SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
105 (SCM a),
106 "Mark the async @var{a} for future execution.")
107 #define FUNC_NAME s_scm_async_mark
108 {
109 VALIDATE_ASYNC (1, a);
110 SET_ASYNC_GOT_IT (a, 1);
111 return SCM_UNSPECIFIED;
112 }
113 #undef FUNC_NAME
114
115 SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
116 (SCM list_of_a),
117 "Execute all thunks from the asyncs of the list @var{list_of_a}.")
118 #define FUNC_NAME s_scm_run_asyncs
119 {
120 while (! SCM_NULL_OR_NIL_P (list_of_a))
121 {
122 SCM a;
123 SCM_VALIDATE_CONS (1, list_of_a);
124 a = SCM_CAR (list_of_a);
125 VALIDATE_ASYNC (SCM_ARG1, a);
126 if (ASYNC_GOT_IT (a))
127 {
128 SET_ASYNC_GOT_IT (a, 0);
129 scm_call_0 (ASYNC_THUNK (a));
130 }
131 list_of_a = SCM_CDR (list_of_a);
132 }
133 return SCM_BOOL_T;
134 }
135 #undef FUNC_NAME
136
137
138
139 static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
140
141 /* System asyncs. */
142
143 void
scm_async_click()144 scm_async_click ()
145 {
146 scm_i_thread *t = SCM_I_CURRENT_THREAD;
147 SCM asyncs;
148
149 /* Reset pending_asyncs even when asyncs are blocked and not really
150 executed since this will avoid future futile calls to this
151 function. When asyncs are unblocked again, this function is
152 invoked even when pending_asyncs is zero.
153 */
154
155 scm_i_pthread_mutex_lock (&async_mutex);
156 t->pending_asyncs = 0;
157 if (t->block_asyncs == 0)
158 {
159 asyncs = t->active_asyncs;
160 t->active_asyncs = SCM_EOL;
161 }
162 else
163 asyncs = SCM_EOL;
164 scm_i_pthread_mutex_unlock (&async_mutex);
165
166 while (scm_is_pair (asyncs))
167 {
168 SCM next = SCM_CDR (asyncs);
169 SCM_SETCDR (asyncs, SCM_BOOL_F);
170 scm_call_0 (SCM_CAR (asyncs));
171 asyncs = next;
172 }
173 }
174
175 #if (SCM_ENABLE_DEPRECATED == 1)
176
177 SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
178 (SCM thunk),
179 "This function is deprecated. You can use @var{thunk} directly\n"
180 "instead of explicitly creating an async object.\n")
181 #define FUNC_NAME s_scm_system_async
182 {
183 scm_c_issue_deprecation_warning
184 ("'system-async' is deprecated. "
185 "Use the procedure directly with 'system-async-mark'.");
186 return thunk;
187 }
188 #undef FUNC_NAME
189
190 #endif /* SCM_ENABLE_DEPRECATED == 1 */
191
192 void
scm_i_queue_async_cell(SCM c,scm_i_thread * t)193 scm_i_queue_async_cell (SCM c, scm_i_thread *t)
194 {
195 SCM sleep_object;
196 scm_i_pthread_mutex_t *sleep_mutex;
197 int sleep_fd;
198 SCM p;
199
200 scm_i_pthread_mutex_lock (&async_mutex);
201 p = t->active_asyncs;
202 SCM_SETCDR (c, SCM_EOL);
203 if (!scm_is_pair (p))
204 t->active_asyncs = c;
205 else
206 {
207 SCM pp;
208 while (scm_is_pair (pp = SCM_CDR (p)))
209 {
210 if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
211 {
212 scm_i_pthread_mutex_unlock (&async_mutex);
213 return;
214 }
215 p = pp;
216 }
217 SCM_SETCDR (p, c);
218 }
219 t->pending_asyncs = 1;
220 sleep_object = t->sleep_object;
221 sleep_mutex = t->sleep_mutex;
222 sleep_fd = t->sleep_fd;
223 scm_i_pthread_mutex_unlock (&async_mutex);
224
225 if (sleep_mutex)
226 {
227 /* By now, the thread T might be out of its sleep already, or
228 might even be in the next, unrelated sleep. Interrupting it
229 anyway does no harm, however.
230
231 The important thing to prevent here is to signal sleep_cond
232 before T waits on it. This can not happen since T has
233 sleep_mutex locked while setting t->sleep_mutex and will only
234 unlock it again while waiting on sleep_cond.
235 */
236 scm_i_scm_pthread_mutex_lock (sleep_mutex);
237 scm_i_pthread_cond_signal (&t->sleep_cond);
238 scm_i_pthread_mutex_unlock (sleep_mutex);
239 }
240
241 if (sleep_fd >= 0)
242 {
243 size_t count;
244 char dummy = 0;
245
246 /* Likewise, T might already been done with sleeping here, but
247 interrupting it once too often does no harm. T might also
248 not yet have started sleeping, but this is no problem either
249 since the data written to a pipe will not be lost, unlike a
250 condition variable signal. */
251 count = write (sleep_fd, &dummy, 1);
252 }
253
254 /* This is needed to protect sleep_mutex.
255 */
256 scm_remember_upto_here_1 (sleep_object);
257 }
258
259 int
scm_i_setup_sleep(scm_i_thread * t,SCM sleep_object,scm_i_pthread_mutex_t * sleep_mutex,int sleep_fd)260 scm_i_setup_sleep (scm_i_thread *t,
261 SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
262 int sleep_fd)
263 {
264 int pending;
265
266 scm_i_pthread_mutex_lock (&async_mutex);
267 pending = t->pending_asyncs;
268 if (!pending)
269 {
270 t->sleep_object = sleep_object;
271 t->sleep_mutex = sleep_mutex;
272 t->sleep_fd = sleep_fd;
273 }
274 scm_i_pthread_mutex_unlock (&async_mutex);
275 return pending;
276 }
277
278 void
scm_i_reset_sleep(scm_i_thread * t)279 scm_i_reset_sleep (scm_i_thread *t)
280 {
281 scm_i_pthread_mutex_lock (&async_mutex);
282 t->sleep_object = SCM_BOOL_F;
283 t->sleep_mutex = NULL;
284 t->sleep_fd = -1;
285 scm_i_pthread_mutex_unlock (&async_mutex);
286 }
287
288 SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
289 (SCM proc, SCM thread),
290 "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
291 "in @var{thread}. If @var{proc} has already been marked for\n"
292 "@var{thread} but has not been executed yet, this call has no effect.\n"
293 "If @var{thread} is omitted, the thread that called\n"
294 "@code{system-async-mark} is used.\n\n"
295 "This procedure is not safe to be called from C signal handlers. Use\n"
296 "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
297 "signal handlers.")
298 #define FUNC_NAME s_scm_system_async_mark_for_thread
299 {
300 /* The current thread might not have a handle yet. This can happen
301 when the GC runs immediately before allocating the handle. At
302 the end of that GC, a system async might be marked. Thus, we can
303 not use scm_current_thread here.
304 */
305
306 scm_i_thread *t;
307
308 if (SCM_UNBNDP (thread))
309 t = SCM_I_CURRENT_THREAD;
310 else
311 {
312 SCM_VALIDATE_THREAD (2, thread);
313 if (scm_c_thread_exited_p (thread))
314 SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
315 t = SCM_I_THREAD_DATA (thread);
316 }
317 scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
318 return SCM_UNSPECIFIED;
319 }
320 #undef FUNC_NAME
321
322 SCM
scm_system_async_mark(SCM proc)323 scm_system_async_mark (SCM proc)
324 #define FUNC_NAME s_scm_system_async_mark_for_thread
325 {
326 return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
327 }
328 #undef FUNC_NAME
329
330
331
332
333 SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
334 (SCM args),
335 "Do nothing. When called without arguments, return @code{#f},\n"
336 "otherwise return the first argument.")
337 #define FUNC_NAME s_scm_noop
338 {
339 SCM_VALIDATE_REST_ARGUMENT (args);
340 return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
341 }
342 #undef FUNC_NAME
343
344
345
346
347 #if (SCM_ENABLE_DEPRECATED == 1)
348
349 SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
350 (),
351 "Unmask signals. The returned value is not specified.")
352 #define FUNC_NAME s_scm_unmask_signals
353 {
354 scm_i_thread *t = SCM_I_CURRENT_THREAD;
355
356 scm_c_issue_deprecation_warning
357 ("'unmask-signals' is deprecated. "
358 "Use 'call-with-blocked-asyncs' instead.");
359
360 if (t->block_asyncs == 0)
361 SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
362 t->block_asyncs = 0;
363 scm_async_click ();
364 return SCM_UNSPECIFIED;
365 }
366 #undef FUNC_NAME
367
368
369 SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
370 (),
371 "Mask signals. The returned value is not specified.")
372 #define FUNC_NAME s_scm_mask_signals
373 {
374 scm_i_thread *t = SCM_I_CURRENT_THREAD;
375
376 scm_c_issue_deprecation_warning
377 ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
378
379 if (t->block_asyncs > 0)
380 SCM_MISC_ERROR ("signals already masked", SCM_EOL);
381 t->block_asyncs = 1;
382 return SCM_UNSPECIFIED;
383 }
384 #undef FUNC_NAME
385
386 #endif /* SCM_ENABLE_DEPRECATED == 1 */
387
388 static void
increase_block(void * data)389 increase_block (void *data)
390 {
391 ((scm_i_thread *)data)->block_asyncs++;
392 }
393
394 static void
decrease_block(void * data)395 decrease_block (void *data)
396 {
397 if (--((scm_i_thread *)data)->block_asyncs == 0)
398 scm_async_click ();
399 }
400
401 SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
402 (SCM proc),
403 "Call @var{proc} with no arguments and block the execution\n"
404 "of system asyncs by one level for the current thread while\n"
405 "it is running. Return the value returned by @var{proc}.\n")
406 #define FUNC_NAME s_scm_call_with_blocked_asyncs
407 {
408 return scm_internal_dynamic_wind (increase_block,
409 (scm_t_inner) scm_call_0,
410 decrease_block,
411 (void *)proc,
412 SCM_I_CURRENT_THREAD);
413 }
414 #undef FUNC_NAME
415
416 void *
scm_c_call_with_blocked_asyncs(void * (* proc)(void * data),void * data)417 scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
418 {
419 return (void *)scm_internal_dynamic_wind (increase_block,
420 (scm_t_inner) proc,
421 decrease_block,
422 data,
423 SCM_I_CURRENT_THREAD);
424 }
425
426
427 SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
428 (SCM proc),
429 "Call @var{proc} with no arguments and unblock the execution\n"
430 "of system asyncs by one level for the current thread while\n"
431 "it is running. Return the value returned by @var{proc}.\n")
432 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
433 {
434 if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
435 SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
436 return scm_internal_dynamic_wind (decrease_block,
437 (scm_t_inner) scm_call_0,
438 increase_block,
439 (void *)proc,
440 SCM_I_CURRENT_THREAD);
441 }
442 #undef FUNC_NAME
443
444 void *
scm_c_call_with_unblocked_asyncs(void * (* proc)(void * data),void * data)445 scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
446 {
447 if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
448 scm_misc_error ("scm_c_call_with_unblocked_asyncs",
449 "asyncs already unblocked", SCM_EOL);
450 return (void *)scm_internal_dynamic_wind (decrease_block,
451 (scm_t_inner) proc,
452 increase_block,
453 data,
454 SCM_I_CURRENT_THREAD);
455 }
456
457 void
scm_dynwind_block_asyncs()458 scm_dynwind_block_asyncs ()
459 {
460 scm_i_thread *t = SCM_I_CURRENT_THREAD;
461 scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
462 scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
463 }
464
465 void
scm_dynwind_unblock_asyncs()466 scm_dynwind_unblock_asyncs ()
467 {
468 scm_i_thread *t = SCM_I_CURRENT_THREAD;
469 if (t->block_asyncs == 0)
470 scm_misc_error ("scm_with_unblocked_asyncs",
471 "asyncs already unblocked", SCM_EOL);
472 scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
473 scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
474 }
475
476
477
478
479 void
scm_init_async()480 scm_init_async ()
481 {
482 scm_asyncs = SCM_EOL;
483 tc16_async = scm_make_smob_type ("async", 0);
484 scm_set_smob_mark (tc16_async, async_gc_mark);
485
486 #include "libguile/async.x"
487 }
488
489 /*
490 Local Variables:
491 c-file-style: "gnu"
492 End:
493 */
494