1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010, 2011 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 #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/dynwind.h"
31 #include "libguile/deprecation.h"
33 #include "libguile/validate.h"
34 #include "libguile/async.h"
43 #include <full-write.h>
46 /* {Asynchronous Events}
48 * There are two kinds of asyncs: system asyncs and user asyncs. The
49 * two kinds have some concepts in commen but work slightly
50 * differently and are not interchangeable.
52 * System asyncs are used to run arbitrary code at the next safe point
53 * in a specified thread. You can use them to trigger execution of
54 * Scheme code from signal handlers or to interrupt a thread, for
57 * Each thread has a list of 'activated asyncs', which is a normal
58 * Scheme list of procedures with zero arguments. When a thread
59 * executes a SCM_ASYNC_TICK statement (which is included in
60 * SCM_TICK), it will call all procedures on this list.
62 * Also, a thread will wake up when a procedure is added to its list
63 * of active asyncs and call them. After that, it will go to sleep
64 * again. (Not implemented yet.)
67 * User asyncs are a little data structure that consists of a
68 * procedure of zero arguments and a mark. There are functions for
69 * setting the mark of a user async and for calling all procedures of
70 * marked asyncs in a given list. Nothing you couldn't quickly
79 static scm_t_bits tc16_async
;
81 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
83 #define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
84 #define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
86 #define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X))
87 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
88 #define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X)
91 SCM_DEFINE (scm_async
, "async", 1, 0, 0,
93 "Create a new async for the procedure @var{thunk}.")
94 #define FUNC_NAME s_scm_async
96 SCM_RETURN_NEWSMOB (tc16_async
, SCM_UNPACK (thunk
));
100 SCM_DEFINE (scm_async_mark
, "async-mark", 1, 0, 0,
102 "Mark the async @var{a} for future execution.")
103 #define FUNC_NAME s_scm_async_mark
105 VALIDATE_ASYNC (1, a
);
106 SET_ASYNC_GOT_IT (a
, 1);
107 return SCM_UNSPECIFIED
;
111 SCM_DEFINE (scm_run_asyncs
, "run-asyncs", 1, 0, 0,
113 "Execute all thunks from the asyncs of the list @var{list_of_a}.")
114 #define FUNC_NAME s_scm_run_asyncs
116 while (! SCM_NULL_OR_NIL_P (list_of_a
))
119 SCM_VALIDATE_CONS (1, list_of_a
);
120 a
= SCM_CAR (list_of_a
);
121 VALIDATE_ASYNC (SCM_ARG1
, a
);
122 if (ASYNC_GOT_IT (a
))
124 SET_ASYNC_GOT_IT (a
, 0);
125 scm_call_0 (ASYNC_THUNK (a
));
127 list_of_a
= SCM_CDR (list_of_a
);
135 static scm_i_pthread_mutex_t async_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
140 scm_async_tick (void)
142 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
145 /* Reset pending_asyncs even when asyncs are blocked and not really
146 executed since this will avoid future futile calls to this
147 function. When asyncs are unblocked again, this function is
148 invoked even when pending_asyncs is zero.
151 scm_i_scm_pthread_mutex_lock (&async_mutex
);
152 t
->pending_asyncs
= 0;
153 if (t
->block_asyncs
== 0)
155 asyncs
= t
->active_asyncs
;
156 t
->active_asyncs
= SCM_EOL
;
160 scm_i_pthread_mutex_unlock (&async_mutex
);
162 while (scm_is_pair (asyncs
))
164 SCM next
= SCM_CDR (asyncs
);
165 SCM_SETCDR (asyncs
, SCM_BOOL_F
);
166 scm_call_0 (SCM_CAR (asyncs
));
172 scm_i_queue_async_cell (SCM c
, scm_i_thread
*t
)
175 scm_i_pthread_mutex_t
*sleep_mutex
;
179 scm_i_scm_pthread_mutex_lock (&async_mutex
);
180 p
= t
->active_asyncs
;
181 SCM_SETCDR (c
, SCM_EOL
);
182 if (!scm_is_pair (p
))
183 t
->active_asyncs
= c
;
187 while (scm_is_pair (pp
= SCM_CDR (p
)))
189 if (scm_is_eq (SCM_CAR (p
), SCM_CAR (c
)))
191 scm_i_pthread_mutex_unlock (&async_mutex
);
198 t
->pending_asyncs
= 1;
199 sleep_object
= t
->sleep_object
;
200 sleep_mutex
= t
->sleep_mutex
;
201 sleep_fd
= t
->sleep_fd
;
202 scm_i_pthread_mutex_unlock (&async_mutex
);
206 /* By now, the thread T might be out of its sleep already, or
207 might even be in the next, unrelated sleep. Interrupting it
208 anyway does no harm, however.
210 The important thing to prevent here is to signal sleep_cond
211 before T waits on it. This can not happen since T has
212 sleep_mutex locked while setting t->sleep_mutex and will only
213 unlock it again while waiting on sleep_cond.
215 scm_i_scm_pthread_mutex_lock (sleep_mutex
);
216 scm_i_pthread_cond_signal (&t
->sleep_cond
);
217 scm_i_pthread_mutex_unlock (sleep_mutex
);
224 /* Likewise, T might already been done with sleeping here, but
225 interrupting it once too often does no harm. T might also
226 not yet have started sleeping, but this is no problem either
227 since the data written to a pipe will not be lost, unlike a
228 condition variable signal. */
229 full_write (sleep_fd
, &dummy
, 1);
232 /* This is needed to protect sleep_mutex.
234 scm_remember_upto_here_1 (sleep_object
);
238 scm_i_setup_sleep (scm_i_thread
*t
,
239 SCM sleep_object
, scm_i_pthread_mutex_t
*sleep_mutex
,
244 scm_i_scm_pthread_mutex_lock (&async_mutex
);
245 pending
= t
->pending_asyncs
;
248 t
->sleep_object
= sleep_object
;
249 t
->sleep_mutex
= sleep_mutex
;
250 t
->sleep_fd
= sleep_fd
;
252 scm_i_pthread_mutex_unlock (&async_mutex
);
257 scm_i_reset_sleep (scm_i_thread
*t
)
259 scm_i_scm_pthread_mutex_lock (&async_mutex
);
260 t
->sleep_object
= SCM_BOOL_F
;
261 t
->sleep_mutex
= NULL
;
263 scm_i_pthread_mutex_unlock (&async_mutex
);
266 SCM_DEFINE (scm_system_async_mark_for_thread
, "system-async-mark", 1, 1, 0,
267 (SCM proc
, SCM thread
),
268 "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
269 "in @var{thread}. If @var{proc} has already been marked for\n"
270 "@var{thread} but has not been executed yet, this call has no effect.\n"
271 "If @var{thread} is omitted, the thread that called\n"
272 "@code{system-async-mark} is used.\n\n"
273 "This procedure is not safe to be called from C signal handlers. Use\n"
274 "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
276 #define FUNC_NAME s_scm_system_async_mark_for_thread
278 /* The current thread might not have a handle yet. This can happen
279 when the GC runs immediately before allocating the handle. At
280 the end of that GC, a system async might be marked. Thus, we can
281 not use scm_current_thread here.
286 if (SCM_UNBNDP (thread
))
287 t
= SCM_I_CURRENT_THREAD
;
290 SCM_VALIDATE_THREAD (2, thread
);
291 if (scm_c_thread_exited_p (thread
))
292 SCM_MISC_ERROR ("thread has already exited", SCM_EOL
);
293 t
= SCM_I_THREAD_DATA (thread
);
295 scm_i_queue_async_cell (scm_cons (proc
, SCM_BOOL_F
), t
);
296 return SCM_UNSPECIFIED
;
301 scm_system_async_mark (SCM proc
)
302 #define FUNC_NAME s_scm_system_async_mark_for_thread
304 return scm_system_async_mark_for_thread (proc
, SCM_UNDEFINED
);
311 SCM_DEFINE (scm_noop
, "noop", 0, 0, 1,
313 "Do nothing. When called without arguments, return @code{#f},\n"
314 "otherwise return the first argument.")
315 #define FUNC_NAME s_scm_noop
317 SCM_VALIDATE_REST_ARGUMENT (args
);
318 return (SCM_NULL_OR_NIL_P (args
) ? SCM_BOOL_F
: SCM_CAR (args
));
326 increase_block (void *data
)
328 scm_i_thread
*t
= data
;
333 decrease_block (void *data
)
335 scm_i_thread
*t
= data
;
336 if (--t
->block_asyncs
== 0)
341 scm_dynwind_block_asyncs (void)
343 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
344 scm_dynwind_rewind_handler (increase_block
, t
, SCM_F_WIND_EXPLICITLY
);
345 scm_dynwind_unwind_handler (decrease_block
, t
, SCM_F_WIND_EXPLICITLY
);
349 scm_dynwind_unblock_asyncs (void)
351 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
352 if (t
->block_asyncs
== 0)
353 scm_misc_error ("scm_with_unblocked_asyncs",
354 "asyncs already unblocked", SCM_EOL
);
355 scm_dynwind_rewind_handler (decrease_block
, t
, SCM_F_WIND_EXPLICITLY
);
356 scm_dynwind_unwind_handler (increase_block
, t
, SCM_F_WIND_EXPLICITLY
);
359 SCM_DEFINE (scm_call_with_blocked_asyncs
, "call-with-blocked-asyncs", 1, 0, 0,
361 "Call @var{proc} with no arguments and block the execution\n"
362 "of system asyncs by one level for the current thread while\n"
363 "it is running. Return the value returned by @var{proc}.\n")
364 #define FUNC_NAME s_scm_call_with_blocked_asyncs
368 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
369 scm_dynwind_block_asyncs ();
370 ans
= scm_call_0 (proc
);
378 scm_c_call_with_blocked_asyncs (void *(*proc
) (void *data
), void *data
)
382 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
383 scm_dynwind_block_asyncs ();
391 SCM_DEFINE (scm_call_with_unblocked_asyncs
, "call-with-unblocked-asyncs", 1, 0, 0,
393 "Call @var{proc} with no arguments and unblock the execution\n"
394 "of system asyncs by one level for the current thread while\n"
395 "it is running. Return the value returned by @var{proc}.\n")
396 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
400 if (SCM_I_CURRENT_THREAD
->block_asyncs
== 0)
401 SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL
);
403 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
404 scm_dynwind_unblock_asyncs ();
405 ans
= scm_call_0 (proc
);
413 scm_c_call_with_unblocked_asyncs (void *(*proc
) (void *data
), void *data
)
417 if (SCM_I_CURRENT_THREAD
->block_asyncs
== 0)
418 scm_misc_error ("scm_c_call_with_unblocked_asyncs",
419 "asyncs already unblocked", SCM_EOL
);
421 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
422 scm_dynwind_unblock_asyncs ();
430 /* These are function variants of the same-named macros (uppercase) for use
431 outside of libguile. This is so that `SCM_I_CURRENT_THREAD', which may
432 reside in TLS, is not accessed from outside of libguile. It thus allows
433 libguile to be built with the "local-dynamic" TLS model. */
436 scm_critical_section_start (void)
438 SCM_CRITICAL_SECTION_START
;
442 scm_critical_section_end (void)
444 SCM_CRITICAL_SECTION_END
;
452 tc16_async
= scm_make_smob_type ("async", 0);
454 #include "libguile/async.x"