From 28d52ebb1945223db0df88cc33e4a88d860dafbb Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Sun, 15 Dec 2002 14:24:34 +0000 Subject: [PATCH] * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS): New definitions. Simply lock a thread C API recursive mutex. (SCM_NONREC_CRITICAL_SECTION_START, SCM_NONREC_CRITICAL_SECTION_END, SCM_REC_CRITICAL_SECTION_START, SCM_REC_CRITICAL_SECTION_END): Removed. * eval.c: Replaced SOURCE_SECTION_START / SOURCE_SECTION_END with direct calls to scm_rec_mutex_lock / unlock around the three calls to scm_m_expand_body. * eval.c, eval.h (promise_free): New function. (scm_force): Rewritten; Now thread-safe; Removed SCM_DEFER/ALLOW_INTS. * pthread-threads.h: Added partially implemented plugin interface for recursive mutexes. These are, for now, only intended to be used internally within the Guile implementation. * pthread-threads.c: New file. * threads.c: Conditionally #include "pthread-threads.c". * eval.c, eval.h (scm_makprom, scm_force): Rewritten to be thread-safe; * snarf.h (SCM_MUTEX, SCM_GLOBAL_MUTEX, SCM_REC_MUTEX, SCM_GLOBAL_REC_MUTEX): New macros. * eval.c, threads.c, threads.h, snarf.h: Rewrote critical section macros---use mutexes instead. * tags.h (SCM_IM_FUTURE): New tag. * eval.c (scm_m_future): New primitive macro. (SCM_CEVAL): Support futures. (unmemocopy): Support unmemoization of futures. * print.c (scm_isymnames): Name of future isym. --- libguile/ChangeLog | 39 ++++++++++++ libguile/__scm.h | 61 +----------------- libguile/eval.c | 75 +++++++++++++++------- libguile/eval.h | 16 +++++ libguile/print.c | 1 + libguile/pthread-threads.h | 24 ++++++++ libguile/snarf.h | 36 ++++------- libguile/tags.h | 9 +-- libguile/threads.c | 123 ++++++++++++++++++++++++++++++++----- libguile/threads.h | 54 ++++++++++++++-- 10 files changed, 305 insertions(+), 133 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 29de35ad5..907d12826 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,44 @@ 2002-12-15 Mikael Djurfeldt + * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS): New definitions. + Simply lock a thread C API recursive mutex. + (SCM_NONREC_CRITICAL_SECTION_START, + SCM_NONREC_CRITICAL_SECTION_END, SCM_REC_CRITICAL_SECTION_START, + SCM_REC_CRITICAL_SECTION_END): Removed. + + * eval.c: Replaced SOURCE_SECTION_START / SOURCE_SECTION_END with + direct calls to scm_rec_mutex_lock / unlock around the three calls + to scm_m_expand_body. + + * eval.c, eval.h (promise_free): New function. + (scm_force): Rewritten; Now thread-safe; Removed + SCM_DEFER/ALLOW_INTS. + + * pthread-threads.h: Added partially implemented plugin interface + for recursive mutexes. These are, for now, only intended to be + used internally within the Guile implementation. + + * pthread-threads.c: New file. + + * threads.c: Conditionally #include "pthread-threads.c". + + * eval.c, eval.h (scm_makprom, scm_force): Rewritten to be + thread-safe; + + * snarf.h (SCM_MUTEX, SCM_GLOBAL_MUTEX, SCM_REC_MUTEX, + SCM_GLOBAL_REC_MUTEX): New macros. + + * eval.c, threads.c, threads.h, snarf.h: Rewrote critical section + macros---use mutexes instead. + + * tags.h (SCM_IM_FUTURE): New tag. + + * eval.c (scm_m_future): New primitive macro. + (SCM_CEVAL): Support futures. + (unmemocopy): Support unmemoization of futures. + + * print.c (scm_isymnames): Name of future isym. + * version.c: Unmade some changes to my private copy that got committed by mistake. diff --git a/libguile/__scm.h b/libguile/__scm.h index 187ada5a0..0ce844ad5 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -425,9 +425,9 @@ do { \ #define SCM_FENCE #endif -#define SCM_DEFER_INTS SCM_REC_CRITICAL_SECTION_START (scm_i_defer) +#define SCM_DEFER_INTS scm_rec_mutex_lock (&scm_i_defer_mutex); -#define SCM_ALLOW_INTS SCM_REC_CRITICAL_SECTION_END (scm_i_defer) +#define SCM_ALLOW_INTS scm_rec_mutex_unlock (&scm_i_defer_mutex); #define SCM_REDEFER_INTS SCM_DEFER_INTS @@ -441,63 +441,6 @@ do { \ -/* Critical sections */ - -#define SCM_DECLARE_NONREC_CRITICAL_SECTION(prefix) \ - extern scm_t_mutex prefix ## _mutex - -#define SCM_NONREC_CRITICAL_SECTION_START(prefix) \ - do { scm_thread *t = scm_i_leave_guile (); \ - scm_i_plugin_mutex_lock (&prefix ## _mutex); \ - scm_i_enter_guile (t); \ - } while (0) - -#define SCM_NONREC_CRITICAL_SECTION_END(prefix) \ - do { scm_i_plugin_mutex_unlock (&prefix ## _mutex); \ - } while (0) - -/* This could be replaced by a single call to scm_i_plugin_mutex_lock - on systems which support recursive mutecis (like LinuxThreads). - We should test for the presence of recursive mutecis in - configure.in. - - Also, it is probably possible to replace recursive sections with - non-recursive ones, so don't worry about the complexity. - */ - -#define SCM_DECLARE_REC_CRITICAL_SECTION(prefix) \ - extern scm_t_mutex prefix ## _mutex; \ - extern int prefix ## _count; \ - extern scm_thread *prefix ## _owner - -#define SCM_REC_CRITICAL_SECTION_START(prefix) \ - do { scm_i_plugin_mutex_lock (&scm_i_section_mutex); \ - if (prefix ## _count && prefix ## _owner == SCM_CURRENT_THREAD) \ - { \ - ++prefix ## _count; \ - scm_i_plugin_mutex_unlock (&scm_i_section_mutex); \ - } \ - else \ - { \ - scm_thread *t = scm_i_leave_guile (); \ - scm_i_plugin_mutex_unlock (&scm_i_section_mutex); \ - scm_i_plugin_mutex_lock (&prefix ## _mutex); \ - prefix ## _count = 1; \ - prefix ## _owner = t; \ - scm_i_enter_guile (t); \ - } \ - } while (0) - -#define SCM_REC_CRITICAL_SECTION_END(prefix) \ - do { scm_i_plugin_mutex_lock (&scm_i_section_mutex); \ - if (!--prefix ## _count) \ - { \ - prefix ## _owner = 0; \ - scm_i_plugin_mutex_unlock (&prefix ## _mutex); \ - } \ - scm_i_plugin_mutex_unlock (&scm_i_section_mutex); \ - } while (0) - /* Note: The following needs updating. */ /* Classification of critical sections diff --git a/libguile/eval.c b/libguile/eval.c index 8ba26f293..ac3877e3a 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -152,9 +152,7 @@ char *alloca (); #define EXTEND_ENV SCM_EXTEND_ENV -SCM_REC_CRITICAL_SECTION (source); -#define SOURCE_SECTION_START SCM_REC_CRITICAL_SECTION_START (source); -#define SOURCE_SECTION_END SCM_REC_CRITICAL_SECTION_END (source); +SCM_REC_MUTEX (source_mutex); SCM * scm_ilookup (SCM iloc, SCM env) @@ -820,6 +818,22 @@ scm_m_delay (SCM xorig, SCM env SCM_UNUSED) } +SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future); +SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); + +/* Like promises, futures are implemented as closures with an empty + * parameter list. Thus, (future ) is transformed into + * (#@future '() ), where the empty list represents the + * empty parameter list. This representation allows for easy creation + * of the closure during evaluation. */ +SCM +scm_m_future (SCM xorig, SCM env SCM_UNUSED) +{ + SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future); + return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig)); +} + + SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); @@ -1476,6 +1490,10 @@ unmemocopy (SCM x, SCM env) ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); x = SCM_CDR (x); goto loop; + case (SCM_ISYMNUM (SCM_IM_FUTURE)): + ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); + x = SCM_CDR (x); + goto loop; case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); goto loop; @@ -1584,11 +1602,11 @@ scm_eval_body (SCM code, SCM env) { if (SCM_ISYMP (SCM_CAR (code))) { - SOURCE_SECTION_START; + scm_rec_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (code))) code = scm_m_expand_body (code, env); - SOURCE_SECTION_END; + scm_rec_mutex_unlock (&source_mutex); goto again; } } @@ -1987,11 +2005,11 @@ dispatch: { if (SCM_ISYMP (form)) { - SOURCE_SECTION_START; + scm_rec_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (x))) x = scm_m_expand_body (x, env); - SOURCE_SECTION_END; + scm_rec_mutex_unlock (&source_mutex); goto nontoplevel_begin; } else @@ -2373,6 +2391,10 @@ dispatch: RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); + case (SCM_ISYMNUM (SCM_IM_FUTURE)): + RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); + + case (SCM_ISYMNUM (SCM_IM_DISPATCH)): { /* If not done yet, evaluate the operand forms. The result is a @@ -3646,11 +3668,11 @@ tail: { if (SCM_ISYMP (SCM_CAR (proc))) { - SOURCE_SECTION_START; + scm_rec_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (proc))) proc = scm_m_expand_body (proc, args); - SOURCE_SECTION_END; + scm_rec_mutex_unlock (&source_mutex); goto again; } else @@ -4139,10 +4161,17 @@ scm_t_bits scm_tc16_promise; SCM scm_makprom (SCM code) { - SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code)); + SCM_RETURN_NEWSMOB2 (scm_tc16_promise, + SCM_UNPACK (code), + scm_make_rec_mutex ()); } - +static size_t +promise_free (SCM promise) +{ + scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise)); + return 0; +} static int promise_print (SCM exp, SCM port, scm_print_state *pstate) @@ -4150,33 +4179,32 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; } - SCM_DEFINE (scm_force, "force", 1, 0, 0, - (SCM x), + (SCM promise), "If the promise @var{x} has not been computed yet, compute and\n" "return @var{x}, otherwise just return the previously computed\n" "value.") #define FUNC_NAME s_scm_force { - SCM_VALIDATE_SMOB (1, x, promise); - if (!((1L << 16) & SCM_CELL_WORD_0 (x))) + SCM_VALIDATE_SMOB (1, promise, promise); + scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise)); + if (!SCM_PROMISE_COMPUTED_P (promise)) { - SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x)); - if (!((1L << 16) & SCM_CELL_WORD_0 (x))) + SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); + if (!SCM_PROMISE_COMPUTED_P (promise)) { - SCM_DEFER_INTS; - SCM_SET_CELL_OBJECT_1 (x, ans); - SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16)); - SCM_ALLOW_INTS; + SCM_SET_PROMISE_DATA (promise, ans); + SCM_SET_PROMISE_COMPUTED (promise); } } - return SCM_CELL_OBJECT_1 (x); + scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise)); + return SCM_PROMISE_DATA (promise); } #undef FUNC_NAME @@ -4413,6 +4441,7 @@ scm_init_eval () scm_tc16_promise = scm_make_smob_type ("promise", 0); scm_set_smob_mark (scm_tc16_promise, scm_markcdr); + scm_set_smob_free (scm_tc16_promise, promise_free); scm_set_smob_print (scm_tc16_promise, promise_print); /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */ diff --git a/libguile/eval.h b/libguile/eval.h index ec4dc476f..8e2fbee84 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -101,6 +101,21 @@ SCM_API SCM scm_eval_options_interface (SCM setting); +/* {Promises} + */ + +#define SCM_F_PROMISE_COMPUTED (1L << 16) +#define SCM_PROMISE_COMPUTED_P(promise) \ + (SCM_F_PROMISE_COMPUTED & SCM_CELL_WORD_0 (promise)) +#define SCM_SET_PROMISE_COMPUTED(promise) \ + SCM_SET_CELL_WORD_0 (promise, scm_tc16_promise | SCM_F_PROMISE_COMPUTED) +#define SCM_PROMISE_MUTEX(promise) \ + ((scm_t_rec_mutex *) SCM_CELL_WORD_2 (promise)) +#define SCM_PROMISE_DATA SCM_CELL_OBJECT_1 +#define SCM_SET_PROMISE_DATA SCM_SET_CELL_OBJECT_1 +SCM_API scm_t_bits scm_tc16_promise; + + /* {Evaluator} * @@ -204,6 +219,7 @@ SCM_API SCM scm_m_letstar (SCM xorig, SCM env); SCM_API SCM scm_m_do (SCM xorig, SCM env); SCM_API SCM scm_m_quasiquote (SCM xorig, SCM env); SCM_API SCM scm_m_delay (SCM xorig, SCM env); +SCM_API SCM scm_m_future (SCM xorig, SCM env); SCM_API SCM scm_m_define (SCM x, SCM env); SCM_API SCM scm_m_letrec (SCM xorig, SCM env); SCM_API SCM scm_m_let (SCM xorig, SCM env); diff --git a/libguile/print.c b/libguile/print.c index cf1ba134d..20332e0b4 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -117,6 +117,7 @@ char *scm_isymnames[] = "#@bind", "#@delay", + "#@future", "#@call-with-values", "#", diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 6e7e1d678..1dd7e5bc4 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -68,6 +68,9 @@ #define scm_i_plugin_thread_self pthread_self #define scm_t_mutex pthread_mutex_t +#define scm_t_mutexattr pthread_mutexattr_t + +extern scm_t_mutexattr scm_i_plugin_mutex; /* The "fast" mutex. */ #define scm_i_plugin_mutex_init pthread_mutex_init #define scm_i_plugin_mutex_destroy pthread_mutex_destroy @@ -75,6 +78,25 @@ #define scm_i_plugin_mutex_trylock pthread_mutex_trylock #define scm_i_plugin_mutex_unlock pthread_mutex_unlock +#define SCM_REC_MUTEX_MAXSIZE (8 * sizeof (long)) +typedef struct { char _[SCM_REC_MUTEX_MAXSIZE]; } scm_t_rec_mutex; + +extern scm_t_mutexattr scm_i_plugin_rec_mutex; + +#ifdef PTHREAD_MUTEX_RECURSIVE /* pthreads has recursive mutexes! */ +#define scm_i_plugin_rec_mutex_init pthread_mutex_init +#define scm_i_plugin_rec_mutex_destroy pthread_mutex_destroy +#define scm_i_plugin_rec_mutex_lock pthread_mutex_lock +#define scm_i_plugin_rec_mutex_trylock pthread_mutex_trylock +#define scm_i_plugin_rec_mutex_unlock pthread_mutex_unlock +#else +int scm_i_plugin_rec_mutex_init (scm_t_rec_mutex *, const scm_t_mutexattr *); +#define scm_i_plugin_rec_mutex_destroy(mx) do { (void) (mx); } while (0) +int scm_i_plugin_rec_mutex_lock (scm_t_rec_mutex *); +int scm_i_plugin_rec_mutex_trylock (scm_t_rec_mutex *); +int scm_i_plugin_rec_mutex_unlock (scm_t_rec_mutex *); +#endif + #define scm_t_cond pthread_cond_t #define scm_i_plugin_cond_init pthread_cond_init @@ -93,6 +115,8 @@ #define scm_i_plugin_select select +void scm_init_pthread_threads (void); + #endif /* SCM_THREADS_NULL_H */ /* diff --git a/libguile/snarf.h b/libguile/snarf.h index 3b7f1e77f..7d6902eb1 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -203,33 +203,21 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_va SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) -#define SCM_NONREC_CRITICAL_SECTION(prefix) \ -SCM_SNARF_HERE(static scm_t_mutex prefix ## _mutex) \ -SCM_SNARF_INIT(scm_i_plugin_mutex_init (&prefix ## _mutex, 0)) +#define SCM_MUTEX(c_name) \ +SCM_SNARF_HERE(static scm_t_mutex c_name) \ +SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex)) -#define SCM_GLOBAL_NONREC_CRITICAL_SECTION(prefix) \ -SCM_SNARF_HERE(scm_t_mutex prefix ## _mutex) \ -SCM_SNARF_INIT(scm_i_plugin_mutex_init (&prefix ## _mutex, 0)) +#define SCM_GLOBAL_MUTEX(c_name) \ +SCM_SNARF_HERE(scm_t_mutex c_name) \ +SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex)) -#define SCM_REC_CRITICAL_SECTION(prefix) \ -SCM_SNARF_HERE(\ -static scm_t_mutex prefix ## _mutex; \ -static int prefix ## _count; \ -static scm_thread *prefix ## _owner\ -)SCM_SNARF_INIT(\ -scm_i_plugin_mutex_init (&prefix ## _mutex, 0)\ -) +#define SCM_REC_MUTEX(c_name) \ +SCM_SNARF_HERE(static scm_t_rec_mutex c_name) \ +SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex)) -#define SCM_GLOBAL_REC_CRITICAL_SECTION(prefix) \ -SCM_SNARF_HERE(\ -scm_t_mutex prefix ## _mutex; \ -int prefix ## _count; \ -scm_thread *prefix ## _owner\ -)SCM_SNARF_INIT(\ -scm_i_plugin_mutex_init (&prefix ## _mutex, 0); \ -prefix ## _count = 0; \ -prefix ## _owner = 0\ -) +#define SCM_GLOBAL_REC_MUTEX(c_name) \ +SCM_SNARF_HERE(scm_t_rec_mutex c_name) \ +SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_rec_mutex)) #ifdef SCM_MAGIC_SNARF_DOCS #undef SCM_ASSERT diff --git a/libguile/tags.h b/libguile/tags.h index 3235b7705..e8f6d117f 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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 @@ -459,7 +459,8 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ #define SCM_IM_BIND SCM_MAKISYM (26) #define SCM_IM_DELAY SCM_MAKISYM (27) -#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (28) +#define SCM_IM_FUTURE SCM_MAKISYM (28) +#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (29) /* When a variable is unbound this is marked by the SCM_UNDEFINED * value. The following is an unbound value which can be handled on @@ -470,12 +471,12 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ * used instead. It is not ideal to let this kind of unique and * strange values loose on the Scheme level. */ -#define SCM_UNBOUND SCM_MAKIFLAG (29) +#define SCM_UNBOUND SCM_MAKIFLAG (30) #define SCM_UNBNDP(x) (SCM_EQ_P ((x), SCM_UNDEFINED)) /* The Elisp nil value. */ -#define SCM_ELISP_NIL SCM_MAKIFLAG (30) +#define SCM_ELISP_NIL SCM_MAKIFLAG (31) diff --git a/libguile/threads.c b/libguile/threads.c index 33f092768..1fdf77f5e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -490,6 +490,63 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, } #undef FUNC_NAME +SCM *scm_loc_sys_thread_handler; + +SCM +scm_i_make_future (SCM thunk) +{ + SCM_RETURN_NEWSMOB2 (scm_tc16_future, + create_thread ((scm_t_catch_body) scm_call_0, + thunk, + (scm_t_catch_handler) scm_apply_1, + *scm_loc_sys_thread_handler, + scm_cons (thunk, + *scm_loc_sys_thread_handler)), + scm_make_rec_mutex ()); +} + +static size_t +future_free (SCM future) +{ + scm_rec_mutex_free (SCM_FUTURE_MUTEX (future)); + return 0; +} + +static int +future_print (SCM exp, SCM port, scm_print_state *pstate) +{ + int writingp = SCM_WRITINGP (pstate); + scm_puts ("#', port); + return !0; +} + +SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0, + (SCM future), + "If the future @var{x} has not been computed yet, compute and\n" + "return @var{x}, otherwise just return the previously computed\n" + "value.") +#define FUNC_NAME s_scm_future_ref +{ + SCM_VALIDATE_FUTURE (1, future); + scm_rec_mutex_lock (SCM_FUTURE_MUTEX (future)); + if (!SCM_FUTURE_COMPUTED_P (future)) + { + SCM value = scm_join_thread (SCM_FUTURE_DATA (future)); + if (!SCM_FUTURE_COMPUTED_P (future)) + { + SCM_SET_FUTURE_DATA (future, value); + SCM_SET_FUTURE_COMPUTED (future); + } + } + scm_rec_mutex_unlock (SCM_FUTURE_MUTEX (future)); + return SCM_FUTURE_DATA (future); +} +#undef FUNC_NAME + /*** Fair mutexes */ /* We implement our own mutex type since we want them to be 'fair', we @@ -1068,6 +1125,30 @@ scm_mutex_lock (scm_t_mutex *m) return res; } +scm_t_rec_mutex * +scm_make_rec_mutex () +{ + scm_t_rec_mutex *m = scm_malloc (sizeof (scm_t_rec_mutex)); + scm_i_plugin_rec_mutex_init (m, &scm_i_plugin_rec_mutex); + return m; +} + +void +scm_rec_mutex_free (scm_t_rec_mutex *m) +{ + scm_i_plugin_rec_mutex_destroy (m); + free (m); +} + +int +scm_rec_mutex_lock (scm_t_rec_mutex *m) +{ + scm_thread *t = scm_i_leave_guile (); + int res = scm_i_plugin_rec_mutex_lock (m); + scm_i_enter_guile (t); + return res; +} + int scm_cond_wait (scm_t_cond *c, scm_t_mutex *m) { @@ -1166,16 +1247,15 @@ scm_c_thread_exited_p (SCM thread) static scm_t_cond wake_up_cond; int scm_i_thread_go_to_sleep; -static scm_t_mutex gc_section_mutex; -static scm_thread *gc_section_owner; +static scm_t_rec_mutex gc_section_mutex; static int gc_section_count = 0; static int threads_initialized_p = 0; void scm_i_thread_put_to_sleep () { - SCM_REC_CRITICAL_SECTION_START (gc_section); - if (threads_initialized_p && gc_section_count == 1) + scm_rec_mutex_lock (&gc_section_mutex); + if (threads_initialized_p && !gc_section_count++) { SCM threads; scm_i_plugin_mutex_lock (&thread_admin_mutex); @@ -1209,7 +1289,7 @@ scm_i_thread_invalidate_freelists () void scm_i_thread_wake_up () { - if (threads_initialized_p && gc_section_count == 1) + if (threads_initialized_p && !--gc_section_count) { SCM threads; /* Need to lock since woken threads can die and be deleted from list */ @@ -1224,7 +1304,7 @@ scm_i_thread_wake_up () } scm_i_plugin_mutex_unlock (&thread_admin_mutex); } - SCM_REC_CRITICAL_SECTION_END (gc_section); + scm_rec_mutex_unlock (&gc_section_mutex); } void @@ -1236,13 +1316,12 @@ scm_i_thread_sleep_for_gc () resume (t); } -/* The mother of all recursive critical sections */ -scm_t_mutex scm_i_section_mutex; - scm_t_mutex scm_i_critical_section_mutex; -scm_t_mutex scm_i_defer_mutex; -int scm_i_defer_count = 0; -scm_thread *scm_i_defer_owner = 0; +scm_t_rec_mutex scm_i_defer_mutex; + +#ifdef USE_PTHREAD_THREADS +#include "libguile/pthread-threads.c" +#endif /*** Initialization */ @@ -1250,23 +1329,26 @@ void scm_threads_prehistory () { scm_thread *t; - scm_i_plugin_mutex_init (&thread_admin_mutex, 0); - scm_i_plugin_mutex_init (&gc_section_mutex, 0); + scm_i_plugin_mutex_init (&thread_admin_mutex, &scm_i_plugin_mutex); + scm_i_plugin_rec_mutex_init (&gc_section_mutex, &scm_i_plugin_rec_mutex); scm_i_plugin_cond_init (&wake_up_cond, 0); - scm_i_plugin_mutex_init (&scm_i_critical_section_mutex, 0); + scm_i_plugin_mutex_init (&scm_i_critical_section_mutex, &scm_i_plugin_mutex); thread_count = 1; scm_i_plugin_key_create (&scm_i_thread_key, 0); scm_i_plugin_key_create (&scm_i_root_state_key, 0); - scm_i_plugin_mutex_init (&scm_i_defer_mutex, 0); - scm_i_plugin_mutex_init (&scm_i_section_mutex, 0); + scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex, &scm_i_plugin_rec_mutex); /* Allocate a fake thread object to be used during bootup. */ t = malloc (sizeof (scm_thread)); t->base = NULL; t->clear_freelists_p = 0; scm_setspecific (scm_i_thread_key, t); +#ifdef USE_PTHREAD_THREADS + scm_init_pthread_threads (); +#endif } scm_t_bits scm_tc16_thread; +scm_t_bits scm_tc16_future; scm_t_bits scm_tc16_mutex; scm_t_bits scm_tc16_fair_mutex; scm_t_bits scm_tc16_condvar; @@ -1305,12 +1387,19 @@ scm_init_threads (SCM_STACKITEM *base) scm_set_smob_mark (scm_tc16_fair_condvar, fair_cond_mark); + scm_tc16_future = scm_make_smob_type ("future", 0); + scm_set_smob_mark (scm_tc16_future, scm_markcdr); + scm_set_smob_free (scm_tc16_future, future_free); + scm_set_smob_print (scm_tc16_future, future_print); + threads_initialized_p = 1; } void scm_init_thread_procs () { + scm_loc_sys_thread_handler + = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F)); #include "libguile/threads.x" } diff --git a/libguile/threads.h b/libguile/threads.h index a438a9c33..63b70428d 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -82,6 +82,20 @@ SCM_API scm_t_bits scm_tc16_fair_condvar; SCM_ASSERT_TYPE (SCM_CONDVARP (a) || SCM_FAIR_CONDVAR_P (a), \ a, pos, FUNC_NAME, "condition variable"); +#define SCM_VALIDATE_FUTURE(pos, obj) \ + SCM_ASSERT_TYPE (SCM_TYP16_PREDICATE (scm_tc16_future, obj), \ + obj, pos, FUNC_NAME, "future"); +#define SCM_F_FUTURE_COMPUTED (1L << 16) +#define SCM_FUTURE_COMPUTED_P(future) \ + (SCM_F_FUTURE_COMPUTED & SCM_CELL_WORD_0 (future)) +#define SCM_SET_FUTURE_COMPUTED(future) \ + SCM_SET_CELL_WORD_0 (future, scm_tc16_future | SCM_F_FUTURE_COMPUTED) +#define SCM_FUTURE_MUTEX(future) \ + ((scm_t_rec_mutex *) SCM_CELL_WORD_2 (future)) +#define SCM_FUTURE_DATA SCM_CELL_OBJECT_1 +#define SCM_SET_FUTURE_DATA SCM_SET_CELL_OBJECT_1 +SCM_API scm_t_bits scm_tc16_future; + SCM_API void scm_threads_mark_stacks (void); SCM_API void scm_init_threads (SCM_STACKITEM *); SCM_API void scm_init_thread_procs (void); @@ -91,6 +105,9 @@ SCM_API void scm_init_thread_procs (void); /* The purpose of this API is seamless, simple and thread package independent interaction with Guile threads from the application. + + Note that Guile also uses it to implement itself, just like + with the rest of the application API. */ /* MDJ 021209 : @@ -116,6 +133,28 @@ SCM_API int scm_mutex_lock (scm_t_mutex *m); #define scm_mutex_trylock scm_i_plugin_mutex_trylock #define scm_mutex_unlock scm_i_plugin_mutex_unlock +/* Guile itself needs recursive mutexes. See for example the + implentation of scm_force in eval.c. + + Note that scm_rec_mutex_lock et al can be replaced by direct usage + of the corresponding pthread functions if we use the pthread + debugging API to access the stack top (in which case there is no + longer any need to save the top of the stack before blocking). + + It's therefore highly motivated to use these calls in situations + where Guile or the application needs recursive mutexes. + */ +#define scm_rec_mutex_init scm_i_plugin_rec_mutex_init +#define scm_rec_mutex_destroy scm_i_plugin_rec_mutex_destroy +/* It's a safer bet to use the following functions. + The future of the _init functions is uncertain. + */ +SCM_API scm_t_rec_mutex *scm_make_rec_mutex (void); +SCM_API void scm_rec_mutex_free (scm_t_rec_mutex *); +SCM_API int scm_rec_mutex_lock (scm_t_rec_mutex *m); +#define scm_rec_mutex_trylock scm_i_plugin_rec_mutex_trylock +#define scm_rec_mutex_unlock scm_i_plugin_rec_mutex_unlock + #define scm_cond_init scm_i_plugin_cond_init #define scm_cond_destroy scm_i_plugin_cond_destroy SCM_API int scm_cond_wait (scm_t_cond *c, scm_t_mutex *m); @@ -158,6 +197,8 @@ SCM_API unsigned long scm_thread_usleep (unsigned long); /* End of low-level C API */ /*----------------------------------------------------------------------*/ +extern SCM *scm_loc_sys_thread_handler; + typedef struct scm_thread scm_thread; SCM_API void scm_i_enter_guile (scm_thread *t); @@ -165,18 +206,17 @@ SCM_API scm_thread *scm_i_leave_guile (void); /* Critical sections */ -SCM_API scm_t_mutex scm_i_section_mutex; - /* This is the generic critical section for places where we are too lazy to allocate a specific mutex. */ -SCM_DECLARE_NONREC_CRITICAL_SECTION (scm_i_critical_section); +extern scm_t_mutex scm_i_critical_section_mutex; + #define SCM_CRITICAL_SECTION_START \ - SCM_NONREC_CRITICAL_SECTION_START (scm_i_critical_section) + scm_mutex_lock (&scm_i_critical_section_mutex) #define SCM_CRITICAL_SECTION_END \ - SCM_NONREC_CRITICAL_SECTION_END (scm_i_critical_section) + scm_mutex_unlock (&scm_i_critical_section_mutex) /* This is the temporary support for the old ALLOW/DEFER ints sections */ -SCM_DECLARE_REC_CRITICAL_SECTION (scm_i_defer); +extern scm_t_rec_mutex scm_i_defer_mutex; extern int scm_i_thread_go_to_sleep; @@ -196,6 +236,8 @@ do { \ /* The C versions of the Scheme-visible thread functions. */ SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler); SCM_API SCM scm_join_thread (SCM t); +SCM_API SCM scm_i_make_future (SCM thunk); +SCM_API SCM scm_future_ref (SCM future); SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_make_fair_mutex (void); SCM_API SCM scm_lock_mutex (SCM m); -- 2.20.1