1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
25 #define SCM_BUILDING_DEPRECATED_CODE
28 #include "libguile/_scm.h"
29 #include "libguile/eval.h"
30 #include "libguile/throw.h"
31 #include "libguile/root.h"
32 #include "libguile/smob.h"
33 #include "libguile/lang.h"
34 #include "libguile/dynwind.h"
35 #include "libguile/deprecation.h"
37 #include "libguile/validate.h"
38 #include "libguile/async.h"
47 #include <full-write.h>
50 /* {Asynchronous Events}
52 * There are two kinds of asyncs: system asyncs and user asyncs. The
53 * two kinds have some concepts in commen but work slightly
54 * differently and are not interchangeable.
56 * System asyncs are used to run arbitrary code at the next safe point
57 * in a specified thread. You can use them to trigger execution of
58 * Scheme code from signal handlers or to interrupt a thread, for
61 * Each thread has a list of 'activated asyncs', which is a normal
62 * Scheme list of procedures with zero arguments. When a thread
63 * executes a SCM_ASYNC_TICK statement (which is included in
64 * SCM_TICK), it will call all procedures on this list.
66 * Also, a thread will wake up when a procedure is added to its list
67 * of active asyncs and call them. After that, it will go to sleep
68 * again. (Not implemented yet.)
71 * User asyncs are a little data structure that consists of a
72 * procedure of zero arguments and a mark. There are functions for
73 * setting the mark of a user async and for calling all procedures of
74 * marked asyncs in a given list. Nothing you couldn't quickly
83 static scm_t_bits tc16_async
;
85 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
87 #define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
88 #define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
90 #define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
91 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
92 #define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
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 explicitly 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
);
245 /* Likewise, T might already been done with sleeping here, but
246 interrupting it once too often does no harm. T might also
247 not yet have started sleeping, but this is no problem either
248 since the data written to a pipe will not be lost, unlike a
249 condition variable signal. */
250 full_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
);
476 /* These are function variants of the same-named macros (uppercase) for use
477 outside of libguile. This is so that `SCM_I_CURRENT_THREAD', which may
478 reside in TLS, is not accessed from outside of libguile. It thus allows
479 libguile to be built with the "local-dynamic" TLS model. */
482 scm_critical_section_start (void)
484 SCM_CRITICAL_SECTION_START
;
488 scm_critical_section_end (void)
490 SCM_CRITICAL_SECTION_END
;
494 scm_async_tick (void)
504 scm_asyncs
= SCM_EOL
;
505 tc16_async
= scm_make_smob_type ("async", 0);
507 #include "libguile/async.x"