summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog39
-rw-r--r--libguile/__scm.h61
-rw-r--r--libguile/eval.c75
-rw-r--r--libguile/eval.h16
-rw-r--r--libguile/print.c1
-rw-r--r--libguile/pthread-threads.h24
-rw-r--r--libguile/snarf.h36
-rw-r--r--libguile/tags.h9
-rw-r--r--libguile/threads.c123
-rw-r--r--libguile/threads.h54
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 <djurfeldt@nada.kth.se>
+ * __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 <expression>) is transformed into
+ * (#@future '() <expression>), 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 ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_CELL_OBJECT_1 (exp), port, pstate);
+ scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', 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",
"#<unbound>",
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 ("#<future ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_putc ('>', 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 <djurfeldt@nada.kth.se>:
@@ -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);