1
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc.
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.
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.
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
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"
34
#include "libguile/validate.h"
35
#include "libguile/async.h"
45
/* {Asynchronous Events}
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.
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
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.
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.)
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
78
static scm_t_bits tc16_async;
80
/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
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")
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)
90
async_gc_mark (SCM obj)
92
return ASYNC_THUNK (obj);
95
SCM_DEFINE (scm_async, "async", 1, 0, 0,
97
"Create a new async for the procedure @var{thunk}.")
98
#define FUNC_NAME s_scm_async
100
SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
104
SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
106
"Mark the async @var{a} for future execution.")
107
#define FUNC_NAME s_scm_async_mark
109
VALIDATE_ASYNC (1, a);
110
SET_ASYNC_GOT_IT (a, 1);
111
return SCM_UNSPECIFIED;
115
SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
117
"Execute all thunks from the asyncs of the list @var{list_of_a}.")
118
#define FUNC_NAME s_scm_run_asyncs
120
while (! SCM_NULL_OR_NIL_P (list_of_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))
128
SET_ASYNC_GOT_IT (a, 0);
129
scm_call_0 (ASYNC_THUNK (a));
131
list_of_a = SCM_CDR (list_of_a);
139
static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
146
scm_i_thread *t = SCM_I_CURRENT_THREAD;
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.
155
scm_i_scm_pthread_mutex_lock (&async_mutex);
156
t->pending_asyncs = 0;
157
if (t->block_asyncs == 0)
159
asyncs = t->active_asyncs;
160
t->active_asyncs = SCM_EOL;
164
scm_i_pthread_mutex_unlock (&async_mutex);
166
while (scm_is_pair (asyncs))
168
SCM next = SCM_CDR (asyncs);
169
SCM_SETCDR (asyncs, SCM_BOOL_F);
170
scm_call_0 (SCM_CAR (asyncs));
175
#if (SCM_ENABLE_DEPRECATED == 1)
177
SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
179
"This function is deprecated. You can use @var{thunk} directly\n"
180
"instead of explicitely creating an async object.\n")
181
#define FUNC_NAME s_scm_system_async
183
scm_c_issue_deprecation_warning
184
("'system-async' is deprecated. "
185
"Use the procedure directly with 'system-async-mark'.");
190
#endif /* SCM_ENABLE_DEPRECATED == 1 */
193
scm_i_queue_async_cell (SCM c, scm_i_thread *t)
196
scm_i_pthread_mutex_t *sleep_mutex;
200
scm_i_scm_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;
208
while (scm_is_pair (pp = SCM_CDR (p)))
210
if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
212
scm_i_pthread_mutex_unlock (&async_mutex);
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);
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.
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.
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);
244
/* Likewise, T might already been done with sleeping here, but
245
interrupting it once too often does no harm. T might also
246
not yet have started sleeping, but this is no problem either
247
since the data written to a pipe will not be lost, unlike a
248
condition variable signal.
250
write (sleep_fd, &dummy, 1);
253
/* This is needed to protect sleep_mutex.
255
scm_remember_upto_here_1 (sleep_object);
259
scm_i_setup_sleep (scm_i_thread *t,
260
SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
265
scm_i_scm_pthread_mutex_lock (&async_mutex);
266
pending = t->pending_asyncs;
269
t->sleep_object = sleep_object;
270
t->sleep_mutex = sleep_mutex;
271
t->sleep_fd = sleep_fd;
273
scm_i_pthread_mutex_unlock (&async_mutex);
278
scm_i_reset_sleep (scm_i_thread *t)
280
scm_i_scm_pthread_mutex_lock (&async_mutex);
281
t->sleep_object = SCM_BOOL_F;
282
t->sleep_mutex = NULL;
284
scm_i_pthread_mutex_unlock (&async_mutex);
287
SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
288
(SCM proc, SCM thread),
289
"Mark @var{proc} (a procedure with zero arguments) for future execution\n"
290
"in @var{thread}. If @var{proc} has already been marked for\n"
291
"@var{thread} but has not been executed yet, this call has no effect.\n"
292
"If @var{thread} is omitted, the thread that called\n"
293
"@code{system-async-mark} is used.\n\n"
294
"This procedure is not safe to be called from C signal handlers. Use\n"
295
"@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
297
#define FUNC_NAME s_scm_system_async_mark_for_thread
299
/* The current thread might not have a handle yet. This can happen
300
when the GC runs immediately before allocating the handle. At
301
the end of that GC, a system async might be marked. Thus, we can
302
not use scm_current_thread here.
307
if (SCM_UNBNDP (thread))
308
t = SCM_I_CURRENT_THREAD;
311
SCM_VALIDATE_THREAD (2, thread);
312
if (scm_c_thread_exited_p (thread))
313
SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
314
t = SCM_I_THREAD_DATA (thread);
316
scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
317
return SCM_UNSPECIFIED;
322
scm_system_async_mark (SCM proc)
323
#define FUNC_NAME s_scm_system_async_mark_for_thread
325
return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
332
SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
334
"Do nothing. When called without arguments, return @code{#f},\n"
335
"otherwise return the first argument.")
336
#define FUNC_NAME s_scm_noop
338
SCM_VALIDATE_REST_ARGUMENT (args);
339
return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
346
#if (SCM_ENABLE_DEPRECATED == 1)
348
SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
350
"Unmask signals. The returned value is not specified.")
351
#define FUNC_NAME s_scm_unmask_signals
353
scm_i_thread *t = SCM_I_CURRENT_THREAD;
355
scm_c_issue_deprecation_warning
356
("'unmask-signals' is deprecated. "
357
"Use 'call-with-blocked-asyncs' instead.");
359
if (t->block_asyncs == 0)
360
SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
363
return SCM_UNSPECIFIED;
368
SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
370
"Mask signals. The returned value is not specified.")
371
#define FUNC_NAME s_scm_mask_signals
373
scm_i_thread *t = SCM_I_CURRENT_THREAD;
375
scm_c_issue_deprecation_warning
376
("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
378
if (t->block_asyncs > 0)
379
SCM_MISC_ERROR ("signals already masked", SCM_EOL);
381
return SCM_UNSPECIFIED;
385
#endif /* SCM_ENABLE_DEPRECATED == 1 */
388
increase_block (void *data)
390
((scm_i_thread *)data)->block_asyncs++;
394
decrease_block (void *data)
396
if (--((scm_i_thread *)data)->block_asyncs == 0)
400
SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
402
"Call @var{proc} with no arguments and block the execution\n"
403
"of system asyncs by one level for the current thread while\n"
404
"it is running. Return the value returned by @var{proc}.\n")
405
#define FUNC_NAME s_scm_call_with_blocked_asyncs
407
return scm_internal_dynamic_wind (increase_block,
408
(scm_t_inner) scm_call_0,
411
SCM_I_CURRENT_THREAD);
416
scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
418
return (void *)scm_internal_dynamic_wind (increase_block,
422
SCM_I_CURRENT_THREAD);
426
SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
428
"Call @var{proc} with no arguments and unblock the execution\n"
429
"of system asyncs by one level for the current thread while\n"
430
"it is running. Return the value returned by @var{proc}.\n")
431
#define FUNC_NAME s_scm_call_with_unblocked_asyncs
433
if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
434
SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
435
return scm_internal_dynamic_wind (decrease_block,
436
(scm_t_inner) scm_call_0,
439
SCM_I_CURRENT_THREAD);
444
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
446
if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
447
scm_misc_error ("scm_c_call_with_unblocked_asyncs",
448
"asyncs already unblocked", SCM_EOL);
449
return (void *)scm_internal_dynamic_wind (decrease_block,
453
SCM_I_CURRENT_THREAD);
457
scm_dynwind_block_asyncs ()
459
scm_i_thread *t = SCM_I_CURRENT_THREAD;
460
scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
461
scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
465
scm_dynwind_unblock_asyncs ()
467
scm_i_thread *t = SCM_I_CURRENT_THREAD;
468
if (t->block_asyncs == 0)
469
scm_misc_error ("scm_with_unblocked_asyncs",
470
"asyncs already unblocked", SCM_EOL);
471
scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
472
scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
481
scm_asyncs = SCM_EOL;
482
tc16_async = scm_make_smob_type ("async", 0);
483
scm_set_smob_mark (tc16_async, async_gc_mark);
485
#include "libguile/async.x"
added
removed
libguile/async.c
