mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

* __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS): New definitions.

Browse source 
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.
This commit is contained in:
Mikael Djurfeldt 2002-12-15 14:24:34 +00:00
parent 2ff4f18159
commit 28d52ebb19
10 changed files with 305 additions and 133 deletions
Download patch file Download diff file Expand all files Collapse all files

39
libguile/ChangeLog
View file

@ -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.

61
libguile/__scm.h
View file

@ -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

75
libguile/eval.c
View file

@ -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. */

16
libguile/eval.h
View file

@ -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);

1
libguile/print.c
View file

@ -117,6 +117,7 @@ char *scm_isymnames[] =
"#@bind",
"#@delay",
"#@future",
"#@call-with-values",
"#<unbound>",

24
libguile/pthread-threads.h
View file

@ -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 */
/*

36
libguile/snarf.h
View file

@ -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

9
libguile/tags.h
View file

@ -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)

123
libguile/threads.c
View file

@ -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"
}

54
libguile/threads.h
View file

@ -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);