1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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
);
144 /* Reset pending_asyncs even when asyncs are blocked and not really
148 scm_root
->pending_asyncs
= 0;
149 if (scm_root
->block_asyncs
== 0)
152 while (!SCM_NULLP(asyncs
= scm_root
->active_asyncs
))
154 scm_root
->active_asyncs
= SCM_EOL
;
157 scm_call_0 (SCM_CAR (asyncs
));
158 asyncs
= SCM_CDR (asyncs
);
160 while (!SCM_NULLP(asyncs
));
162 for (asyncs
= scm_root
->signal_asyncs
; !SCM_NULLP(asyncs
);
163 asyncs
= SCM_CDR (asyncs
))
165 if (scm_is_true (SCM_CAR (asyncs
)))
167 SCM proc
= SCM_CAR (asyncs
);
168 SCM_SETCAR (asyncs
, SCM_BOOL_F
);
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_root_state
*root
)
195 SCM p
= root
->active_asyncs
;
196 SCM_SETCDR (c
, SCM_EOL
);
198 root
->active_asyncs
= c
;
202 while ((pp
= SCM_CDR(p
)) != SCM_EOL
)
204 if (SCM_CAR (p
) == SCM_CAR (c
))
210 root
->pending_asyncs
= 1;
213 SCM_DEFINE (scm_system_async_mark_for_thread
, "system-async-mark", 1, 1, 0,
214 (SCM proc
, SCM thread
),
215 "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
216 "in @var{thread}. If @var{proc} has already been marked for\n"
217 "@var{thread} but has not been executed yet, this call has no effect.\n"
218 "If @var{thread} is omitted, the thread that called\n"
219 "@code{system-async-mark} is used.\n\n"
220 "This procedure is not safe to be called from C signal handlers. Use\n"
221 "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
223 #define FUNC_NAME s_scm_system_async_mark_for_thread
225 if (SCM_UNBNDP (thread
))
226 thread
= scm_current_thread ();
229 SCM_VALIDATE_THREAD (2, thread
);
230 if (scm_c_thread_exited_p (thread
))
231 SCM_MISC_ERROR ("thread has already exited", SCM_EOL
);
233 scm_i_queue_async_cell (scm_cons (proc
, SCM_BOOL_F
),
234 scm_i_thread_root (thread
));
235 return SCM_UNSPECIFIED
;
240 scm_system_async_mark (SCM proc
)
241 #define FUNC_NAME s_scm_system_async_mark_for_thread
243 return scm_system_async_mark_for_thread (proc
, SCM_UNDEFINED
);
250 SCM_DEFINE (scm_noop
, "noop", 0, 0, 1,
252 "Do nothing. When called without arguments, return @code{#f},\n"
253 "otherwise return the first argument.")
254 #define FUNC_NAME s_scm_noop
256 SCM_VALIDATE_REST_ARGUMENT (args
);
257 return (SCM_NULL_OR_NIL_P (args
) ? SCM_BOOL_F
: SCM_CAR (args
));
264 #if (SCM_ENABLE_DEPRECATED == 1)
266 SCM_DEFINE (scm_unmask_signals
, "unmask-signals", 0, 0, 0,
268 "Unmask signals. The returned value is not specified.")
269 #define FUNC_NAME s_scm_unmask_signals
271 scm_c_issue_deprecation_warning
272 ("'unmask-signals' is deprecated. "
273 "Use 'call-with-blocked-asyncs' instead.");
275 if (scm_root
->block_asyncs
== 0)
276 SCM_MISC_ERROR ("signals already unmasked", SCM_EOL
);
277 scm_root
->block_asyncs
= 0;
279 return SCM_UNSPECIFIED
;
284 SCM_DEFINE (scm_mask_signals
, "mask-signals", 0, 0, 0,
286 "Mask signals. The returned value is not specified.")
287 #define FUNC_NAME s_scm_mask_signals
289 scm_c_issue_deprecation_warning
290 ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
292 if (scm_root
->block_asyncs
> 0)
293 SCM_MISC_ERROR ("signals already masked", SCM_EOL
);
294 scm_root
->block_asyncs
= 1;
295 return SCM_UNSPECIFIED
;
299 #endif /* SCM_ENABLE_DEPRECATED == 1 */
302 increase_block (void *unused
)
304 scm_root
->block_asyncs
++;
308 decrease_block (void *unused
)
310 scm_root
->block_asyncs
--;
311 if (scm_root
->block_asyncs
== 0)
315 SCM_DEFINE (scm_call_with_blocked_asyncs
, "call-with-blocked-asyncs", 1, 0, 0,
317 "Call @var{proc} with no arguments and block the execution\n"
318 "of system asyncs by one level for the current thread while\n"
319 "it is running. Return the value returned by @var{proc}.\n")
320 #define FUNC_NAME s_scm_call_with_blocked_asyncs
322 return scm_internal_dynamic_wind (increase_block
,
323 (scm_t_inner
) scm_call_0
,
330 scm_c_call_with_blocked_asyncs (void *(*proc
) (void *data
), void *data
)
332 return (void *)scm_internal_dynamic_wind (increase_block
,
339 SCM_DEFINE (scm_call_with_unblocked_asyncs
, "call-with-unblocked-asyncs", 1, 0, 0,
341 "Call @var{proc} with no arguments and unblock the execution\n"
342 "of system asyncs by one level for the current thread while\n"
343 "it is running. Return the value returned by @var{proc}.\n")
344 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
346 if (scm_root
->block_asyncs
== 0)
347 SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL
);
348 return scm_internal_dynamic_wind (decrease_block
,
349 (scm_t_inner
) scm_call_0
,
356 scm_c_call_with_unblocked_asyncs (void *(*proc
) (void *data
), void *data
)
358 if (scm_root
->block_asyncs
== 0)
359 scm_misc_error ("scm_c_call_with_unblocked_asyncs",
360 "asyncs already unblocked", SCM_EOL
);
361 return (void *)scm_internal_dynamic_wind (decrease_block
,
368 scm_frame_block_asyncs ()
370 scm_frame_rewind_handler (increase_block
, NULL
, SCM_F_WIND_EXPLICITLY
);
371 scm_frame_unwind_handler (decrease_block
, NULL
, SCM_F_WIND_EXPLICITLY
);
375 scm_frame_unblock_asyncs ()
377 if (scm_root
->block_asyncs
== 0)
378 scm_misc_error ("scm_with_unblocked_asyncs",
379 "asyncs already unblocked", SCM_EOL
);
380 scm_frame_rewind_handler (decrease_block
, NULL
, SCM_F_WIND_EXPLICITLY
);
381 scm_frame_unwind_handler (increase_block
, NULL
, SCM_F_WIND_EXPLICITLY
);
390 scm_asyncs
= SCM_EOL
;
391 tc16_async
= scm_make_smob_type ("async", 0);
392 scm_set_smob_mark (tc16_async
, async_gc_mark
);
394 #include "libguile/async.x"