X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/b7f3516f99450ec2f0338ed1d17e28491c85de9e..c96d76b88dcb7805311d14e6e408d064211fde20:/libguile/async.c?ds=sidebyside diff --git a/libguile/async.c b/libguile/async.c index 72f23e2ef..e3b7d33f3 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,15 +1,15 @@ -/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. + * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -38,16 +38,20 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + + -#include #include -#include "_scm.h" -#include "eval.h" -#include "throw.h" -#include "smob.h" +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/throw.h" +#include "libguile/root.h" +#include "libguile/smob.h" +#include "libguile/lang.h" -#include "async.h" +#include "libguile/validate.h" +#include "libguile/async.h" #ifdef HAVE_STRING_H #include @@ -65,7 +69,7 @@ * * Setting the mark guarantees future execution of the thunk. More * than one set may be satisfied by a single execution. - * + * * scm_tick_clock decremented once per SCM_ALLOW_INTS. * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0. * Async execution prevented by scm_mask_ints != 0. @@ -88,10 +92,11 @@ * when the interpreter is not running at all. */ int scm_ints_disabled = 1; +unsigned int scm_mask_ints = 1; +#ifdef GUILE_OLD_ASYNC_CLICK unsigned int scm_async_clock = 20; static unsigned int scm_async_rate = 20; -unsigned int scm_mask_ints = 1; static unsigned int scm_tick_clock = 0; static unsigned int scm_tick_rate = 0; @@ -99,40 +104,41 @@ static unsigned int scm_desired_tick_rate = 0; static unsigned int scm_switch_clock = 0; static unsigned int scm_switch_rate = 0; static unsigned int scm_desired_switch_rate = 0; +#else +int scm_asyncs_pending_p = 0; +#endif -static long scm_tc16_async; +static scm_t_bits tc16_async; -static int asyncs_pending SCM_P ((void)); +/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it. + this is ugly. */ +#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X) +#define VALIDATE_ASYNC(pos,a) SCM_MAKE_VALIDATE(pos, a, ASYNCP) + +#define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16) +#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16))) +#define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X) -static int -asyncs_pending () + + +#ifdef GUILE_OLD_ASYNC_CLICK +int +scm_asyncs_pending () { SCM pos; pos = scm_asyncs; - while (pos != SCM_EOL) + while (!SCM_NULL_OR_NIL_P (pos)) { - SCM a; - struct scm_async * it; - a = SCM_CAR (pos); - it = SCM_ASYNC (a); - if (it->got_it) + SCM a = SCM_CAR (pos); + if (ASYNC_GOT_IT (a)) return 1; pos = SCM_CDR (pos); } return 0; } -#if 0 -static SCM scm_sys_tick_async_thunk SCM_P ((void)); -static SCM -scm_sys_tick_async_thunk () -{ - scm_deliver_signal (SCM_TICK_SIGNAL); - return SCM_BOOL_F; -} -#endif void scm_async_click () @@ -178,7 +184,7 @@ scm_async_click () scm_async_clock = 1; return;; } - + if (!scm_tick_rate) { unsigned int r; @@ -211,11 +217,6 @@ scm_async_click () } } - /* - if (owe_tick) - scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]); - */ - SCM_DEFER_INTS; if (scm_tick_rate && scm_switch_rate) { @@ -238,7 +239,7 @@ scm_async_click () scm_run_asyncs (scm_asyncs); SCM_DEFER_INTS; - if (asyncs_pending ()) + if (scm_asyncs_pending ()) { SCM_ALLOW_INTS_ONLY; goto tail; @@ -249,284 +250,225 @@ scm_async_click () scm_switch (); } - - - - void scm_switch () { #if 0 /* Thread switching code should probably reside here, but the async switching code doesn't seem to work, so it's put in the - SCM_ASYNC_TICK macro instead. /mdj */ + SCM_DEFER_INTS macro instead. /mdj */ SCM_THREAD_SWITCHING_CODE; #endif } - - -static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); +#else -static int -print_async (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +void +scm_async_click () { - scm_puts ("#', port); - return 1; + if (!scm_mask_ints) + do + scm_run_asyncs (scm_asyncs); + while (scm_asyncs_pending_p); } - -static SCM mark_async SCM_P ((SCM obj)); - -static SCM -mark_async (obj) - SCM obj; -{ - struct scm_async * it; - if (SCM_GC8MARKP (obj)) - return SCM_BOOL_F; - SCM_SETGC8MARK (obj); - it = SCM_ASYNC (obj); - return it->thunk; -} +#endif -static scm_sizet free_async SCM_P ((SCM obj)); + -static scm_sizet -free_async (obj) - SCM obj; +static SCM +async_mark (SCM obj) { - struct scm_async * it; - it = SCM_ASYNC (obj); - scm_must_free ((char *)it); - return (sizeof (*it)); + return ASYNC_THUNK (obj); } - -static scm_smobfuns async_smob = -{ - mark_async, - free_async, - print_async, - 0 -}; - - -SCM_PROC(s_async, "async", 1, 0, 0, scm_async); - -SCM -scm_async (thunk) - SCM thunk; +SCM_DEFINE (scm_async, "async", 1, 0, 0, + (SCM thunk), + "Create a new async for the procedure @var{thunk}.") +#define FUNC_NAME s_scm_async { - SCM it; - struct scm_async * async; - - SCM_NEWCELL (it); - SCM_DEFER_INTS; - SCM_SETCDR (it, SCM_EOL); - async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async); - async->got_it = 0; - async->thunk = thunk; - SCM_SETCDR (it, (SCM)async); - SCM_SETCAR (it, (SCM)scm_tc16_async); - SCM_ALLOW_INTS; - return it; + SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); } +#undef FUNC_NAME -SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async); - -SCM -scm_system_async (thunk) - SCM thunk; +SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, + (SCM thunk), + "Create a new async for the procedure @var{thunk}. Also\n" + "add it to the system's list of active async objects.") +#define FUNC_NAME s_scm_system_async { - SCM it; - SCM list; - - it = scm_async (thunk); - SCM_NEWCELL (list); - SCM_DEFER_INTS; - SCM_SETCAR (list, it); - SCM_SETCDR (list, scm_asyncs); - scm_asyncs = list; - SCM_ALLOW_INTS; + SCM it = scm_async (thunk); + scm_asyncs = scm_cons (it, scm_asyncs); return it; } +#undef FUNC_NAME -SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark); - -SCM -scm_async_mark (a) - SCM a; +SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, + (SCM a), + "Mark the async @var{a} for future execution.") +#define FUNC_NAME s_scm_async_mark { - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); - it->got_it = 1; + VALIDATE_ASYNC (1, a); +#ifdef GUILE_OLD_ASYNC_CLICK + SET_ASYNC_GOT_IT (a, 1); +#else + SET_ASYNC_GOT_IT (a, scm_asyncs_pending_p = 1); +#endif return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark); - -SCM -scm_system_async_mark (a) - SCM a; +SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0, + (SCM a), + "Mark the async @var{a} for future execution.") +#define FUNC_NAME s_scm_system_async_mark { - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); + VALIDATE_ASYNC (1, a); SCM_REDEFER_INTS; - it->got_it = 1; +#ifdef GUILE_OLD_ASYNC_CLICK + SET_ASYNC_GOT_IT (a, 1); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; +#else + SET_ASYNC_GOT_IT (a, scm_asyncs_pending_p = 1); +#endif SCM_REALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME - -SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs); - -SCM -scm_run_asyncs (list_of_a) - SCM list_of_a; +void +scm_system_async_mark_from_signal_handler (SCM a) { - SCM pos; + SET_ASYNC_GOT_IT (a, scm_asyncs_pending_p = 1); +} +SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, + (SCM list_of_a), + "Execute all thunks from the asyncs of the list @var{list_of_a}.") +#define FUNC_NAME s_scm_run_asyncs +{ +#ifdef GUILE_OLD_ASYNC_CLICK if (scm_mask_ints) return SCM_BOOL_F; - pos = list_of_a; - while (pos != SCM_EOL) +#else + scm_asyncs_pending_p = 0; +#endif + while (! SCM_NULL_OR_NIL_P (list_of_a)) { SCM a; - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs); - a = SCM_CAR (pos); - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs); - it = SCM_ASYNC (a); + SCM_VALIDATE_CONS (1, list_of_a); + a = SCM_CAR (list_of_a); + VALIDATE_ASYNC (SCM_ARG1, a); scm_mask_ints = 1; - if (it->got_it) + if (ASYNC_GOT_IT (a)) { - it->got_it = 0; - scm_apply (it->thunk, SCM_EOL, SCM_EOL); + SET_ASYNC_GOT_IT (a, 0); + scm_call_0 (ASYNC_THUNK (a)); } scm_mask_ints = 0; - pos = SCM_CDR (pos); + list_of_a = SCM_CDR (list_of_a); } return SCM_BOOL_T; } +#undef FUNC_NAME -SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop); - -SCM -scm_noop (args) - SCM args; +SCM_DEFINE (scm_noop, "noop", 0, 0, 1, + (SCM args), + "Do nothing. When called without arguments, return @code{#f},\n" + "otherwise return the first argument.") +#define FUNC_NAME s_scm_noop { - return (SCM_NULLP (args) - ? SCM_BOOL_F - : SCM_CAR (args)); + SCM_VALIDATE_REST_ARGUMENT (args); + return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args)); } +#undef FUNC_NAME -SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate); +#ifdef GUILE_OLD_ASYNC_CLICK -SCM -scm_set_tick_rate (n) - SCM n; +SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, + (SCM n), + "Set the rate of async ticks to @var{n}. Return the old rate\n" + "value.") +#define FUNC_NAME s_scm_set_tick_rate { - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate); - old_n = scm_tick_rate; + unsigned int old_n = scm_tick_rate; + SCM_VALIDATE_INUM (1, n); scm_desired_tick_rate = SCM_INUM (n); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); } +#undef FUNC_NAME -SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate); - -SCM -scm_set_switch_rate (n) - SCM n; +SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, + (SCM n), + "Set the async switch rate to @var{n}. Return the old value\n" + "of the switch rate.") +#define FUNC_NAME s_scm_set_switch_rate { - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate); - old_n = scm_switch_rate; + unsigned int old_n = scm_switch_rate; + SCM_VALIDATE_INUM (1, n); scm_desired_switch_rate = SCM_INUM (n); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); } +#undef FUNC_NAME - - -/* points to the GC system-async, so that scm_gc_end can find it. */ -SCM scm_gc_async; - -/* the vcell for gc-thunk. */ -static SCM scm_gc_vcell; - -/* the thunk installed in the GC system-async, which is marked at the - end of garbage collection. */ -static SCM -scm_sys_gc_async_thunk (void) -{ - if (SCM_NFALSEP (scm_gc_vcell)) - { - SCM proc = SCM_CDR (scm_gc_vcell); - - if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc)) - scm_apply (proc, SCM_EOL, SCM_EOL); - } - return SCM_UNSPECIFIED; -} +#endif -SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals); - -SCM -scm_unmask_signals () +SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0, + (), + "Unmask signals. The returned value is not specified.") +#define FUNC_NAME s_scm_unmask_signals { scm_mask_ints = 0; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals); - -SCM -scm_mask_signals () +SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0, + (), + "Mask signals. The returned value is not specified.") +#define FUNC_NAME s_scm_mask_signals { scm_mask_ints = 1; return SCM_UNSPECIFIED; } +#undef FUNC_NAME void scm_init_async () { - SCM a_thunk; - scm_tc16_async = scm_newsmob (&async_smob); - - scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); - a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); - scm_gc_async = scm_system_async (a_thunk); + scm_asyncs = SCM_EOL; + tc16_async = scm_make_smob_type ("async", 0); + scm_set_smob_mark (tc16_async, async_mark); -#include "async.x" +#ifndef SCM_MAGIC_SNARFER +#include "libguile/async.x" +#endif } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/