X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/82892beda5c053715bc3ec7063af4a129f52c5f9..fbf0c8c7b194202e01338f8b5324126bf73af4c9:/libguile/async.c diff --git a/libguile/async.c b/libguile/async.c index 2e4960ab5..2728537b3 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,15 +1,15 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 96, 97, 98, 2000 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,22 @@ * 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. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #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 "async.h" +#include "libguile/validate.h" +#include "libguile/async.h" #ifdef HAVE_STRING_H #include @@ -65,7 +71,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 +94,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,58 +106,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 SCM system_signal_asyncs[SCM_NUM_SIGS]; -static SCM handler_var; -static SCM symbol_signal; - - -struct scm_async -{ - int got_it; /* needs to be delivered? */ - SCM thunk; /* the handler. */ -}; - - -static long scm_tc16_async; - -#define SCM_ASYNCP(X) (scm_tc16_async == SCM_GCTYP16 (X)) -#define SCM_ASYNC(X) ((struct scm_async *)SCM_CDR (X)) +static scm_bits_t tc16_async; + +/* 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 SCM_P ((void)); - -static int -asyncs_pending () +#ifdef GUILE_OLD_ASYNC_CLICK +int +scm_asyncs_pending () { SCM pos; pos = scm_asyncs; while (pos != SCM_EOL) { - 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 () @@ -196,7 +186,7 @@ scm_async_click () scm_async_clock = 1; return;; } - + if (!scm_tick_rate) { unsigned int r; @@ -229,11 +219,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) { @@ -256,7 +241,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; @@ -267,421 +252,222 @@ 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 } +#else - -static void scm_deliver_signal SCM_P ((int num)); - -static void -scm_deliver_signal (num) - int num; +void +scm_async_click () { - SCM handler; - handler = SCM_CDR (handler_var); - if (handler != SCM_BOOL_F) - scm_apply (handler, SCM_MAKINUM (num), scm_listofnull); - else - { - scm_mask_ints = 0; - scm_throw (symbol_signal, - scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED)); - } + if (!scm_mask_ints) + do + scm_run_asyncs (scm_asyncs); + while (scm_asyncs_pending_p); } - - - - -static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -print_async (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#', port); - return 1; -} +#endif -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; -} - - -static scm_sizet free_async SCM_P ((SCM obj)); - -static scm_sizet -free_async (obj) - SCM obj; +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), +"") +#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), +"") +#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; 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), +"") +#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), +"") +#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; +SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, + (SCM list_of_a), +"") +#define FUNC_NAME s_scm_run_asyncs { - SCM pos; - +#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_NULLP (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_apply (ASYNC_THUNK (a), SCM_EOL, SCM_EOL); } 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), +"") +#define FUNC_NAME s_scm_noop { - return (SCM_NULLP (args) - ? SCM_BOOL_F - : SCM_CAR (args)); + SCM_VALIDATE_REST_ARGUMENT (args); + return (SCM_NULLP (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), +"") +#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), +"") +#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 - - - -static SCM scm_sys_hup_async_thunk SCM_P ((void)); - -static SCM -scm_sys_hup_async_thunk () -{ - scm_deliver_signal (SCM_HUP_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_int_async_thunk SCM_P ((void)); - -static SCM -scm_sys_int_async_thunk () -{ - scm_deliver_signal (SCM_INT_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_fpe_async_thunk SCM_P ((void)); - -static SCM -scm_sys_fpe_async_thunk () -{ - scm_deliver_signal (SCM_FPE_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_bus_async_thunk SCM_P ((void)); - -static SCM -scm_sys_bus_async_thunk () -{ - scm_deliver_signal (SCM_BUS_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_segv_async_thunk SCM_P ((void)); - -static SCM -scm_sys_segv_async_thunk () -{ - scm_deliver_signal (SCM_SEGV_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_alrm_async_thunk SCM_P ((void)); - -static SCM -scm_sys_alrm_async_thunk () -{ - scm_deliver_signal (SCM_ALRM_SIGNAL); - return SCM_BOOL_F; -} - -/* 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; -} - - - -SCM -scm_take_signal (n) - int n; -{ - SCM ignored; - if (!scm_ints_disabled) - { - /* For reasons of speed, the SCM_NEWCELL macro doesn't defer - interrupts. Instead, it first sets its argument to point to - the first cell in the list, and then advances the freelist - pointer to the next cell. Now, if this procedure is - interrupted, the only anomalous state possible is to have - both SCM_NEWCELL's argument and scm_freelist pointing to the - same cell. To deal with this case, we always throw away the - first cell in scm_freelist here. - - At least, that's the theory. I'm not convinced that that's - the only anomalous path we need to worry about. */ - SCM_NEWCELL (ignored); - } - scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]); - return SCM_BOOL_F; -} +#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, + (), +"") +#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, + (), +"") +#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); - symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED)); - scm_permanent_object (symbol_signal); - - /* These are in the opposite order of delivery priortity. - * - * Error conditions are given low priority: - */ - a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk); - - 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); - - /* Clock and PC driven conditions are given highest priority. */ - /* - a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk); - */ - - a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk); - - handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED); - SCM_SETCDR (handler_var, SCM_BOOL_F); - scm_permanent_object (handler_var); -#include "async.x" + scm_asyncs = SCM_EOL; + tc16_async = scm_make_smob_type ("async", 0); + scm_set_smob_mark (tc16_async, async_mark); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/async.x" +#endif } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/