mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00
Code Activity

Merge branch 'master' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	libguile/Makefile.am
	libguile/coop-defs.h
	libguile/gc-card.c
	libguile/gc-freelist.c
	libguile/gc-malloc.c
	libguile/gc-mark.c
	libguile/gc-segment.c
	libguile/gc.c
	libguile/gc.h
	libguile/gc_os_dep.c
	libguile/hashtab.c
	libguile/hashtab.h
	libguile/inline.h
	libguile/private-gc.h
	libguile/struct.c
	libguile/struct.h
	libguile/threads.c
	libguile/threads.h
	libguile/vectors.h
	libguile/weaks.h
	test-suite/tests/gc.test
This commit is contained in:
Ludovic Courtès 2008-09-10 23:09:30 +02:00
commit 6f03035fe8
298 changed files with 15438 additions and 3275 deletions
Download patch file Download diff file Expand all files Collapse all files

714
libguile/threads.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
*
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
@ -18,8 +18,6 @@
#define _GNU_SOURCE
#include "libguile/boehm-gc.h"
#include "libguile/_scm.h"
@ -50,6 +48,7 @@
#include "libguile/gc.h"
#include "libguile/init.h"
#include "libguile/scmsigs.h"
#include "libguile/strings.h"
#ifdef __MINGW32__
#ifndef ETIMEDOUT
@ -60,6 +59,24 @@
# define pipe(fd) _pipe (fd, 256, O_BINARY)
#endif /* __MINGW32__ */
static void
to_timespec (SCM t, scm_t_timespec *waittime)
{
if (scm_is_pair (t))
{
waittime->tv_sec = scm_to_ulong (SCM_CAR (t));
waittime->tv_nsec = scm_to_ulong (SCM_CDR (t)) * 1000;
}
else
{
double time = scm_to_double (t);
double sec = scm_c_truncate (time);
waittime->tv_sec = (long) sec;
waittime->tv_nsec = (long) ((time - sec) * 1000000000);
}
}
/*** Queues */
/* Make an empty queue data structure.
@ -407,6 +424,7 @@ guilify_self_1 (SCM_STACKITEM *base)
t->handle = SCM_BOOL_F;
t->result = SCM_BOOL_F;
t->cleanup_handler = SCM_BOOL_F;
t->mutexes = SCM_EOL;
t->join_queue = SCM_EOL;
t->dynamic_state = SCM_BOOL_F;
t->dynwinds = SCM_EOL;
@ -415,6 +433,22 @@ guilify_self_1 (SCM_STACKITEM *base)
t->pending_asyncs = 1;
t->last_debug_frame = NULL;
t->base = base;
#ifdef __ia64__
/* Calculate and store off the base of this thread's register
backing store (RBS). Unfortunately our implementation(s) of
scm_ia64_register_backing_store_base are only reliable for the
main thread. For other threads, therefore, find out the current
top of the RBS, and use that as a maximum. */
t->register_backing_store_base = scm_ia64_register_backing_store_base ();
{
ucontext_t ctx;
void *bsp;
getcontext (&ctx);
bsp = scm_ia64_ar_bsp (&ctx);
if (t->register_backing_store_base > bsp)
t->register_backing_store_base = bsp;
}
#endif
t->continuation_root = SCM_EOL;
t->continuation_base = base;
scm_i_pthread_cond_init (&t->sleep_cond, NULL);
@ -424,6 +458,7 @@ guilify_self_1 (SCM_STACKITEM *base)
/* XXX - check for errors. */
pipe (t->sleep_pipe);
scm_i_pthread_mutex_init (&t->heap_mutex, NULL);
scm_i_pthread_mutex_init (&t->admin_mutex, NULL);
t->clear_freelists_p = 0;
t->gc_running_p = 0;
t->current_mark_stack_ptr = NULL;
@ -468,6 +503,31 @@ guilify_self_2 (SCM parent)
t->block_asyncs = 0;
}
/*** Fat mutexes */
/* We implement our own mutex type since we want them to be 'fair', we
want to do fancy things while waiting for them (like running
asyncs) and we might want to add things that are nice for
debugging.
*/
typedef struct {
scm_i_pthread_mutex_t lock;
SCM owner;
int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */
int recursive; /* allow recursive locking? */
int unchecked_unlock; /* is it an error to unlock an unlocked mutex? */
int allow_external_unlock; /* is it an error to unlock a mutex that is not
owned by the current thread? */
SCM waiting; /* the threads waiting for this mutex. */
} fat_mutex;
#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
/* Perform thread tear-down, in guile mode.
*/
static void *
@ -485,7 +545,7 @@ do_thread_exit (void *v)
scm_handle_by_message_noexit, NULL);
}
scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
t->exited = 1;
close (t->sleep_pipe[0]);
@ -493,7 +553,19 @@ do_thread_exit (void *v)
while (scm_is_true (unblock_from_queue (t->join_queue)))
;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
while (!scm_is_null (t->mutexes))
{
SCM mutex = SCM_CAR (t->mutexes);
fat_mutex *m = SCM_MUTEX_DATA (mutex);
scm_i_pthread_mutex_lock (&m->lock);
unblock_from_queue (m->waiting);
scm_i_pthread_mutex_unlock (&m->lock);
t->mutexes = SCM_CDR (t->mutexes);
}
scm_i_pthread_mutex_unlock (&t->admin_mutex);
return NULL;
}
@ -605,7 +677,7 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
{
/* This thread is already guilified but not in guile mode, just
resume it.
XXX - base might be lower than when this thread was first
guilified.
*/
@ -713,7 +785,7 @@ scm_with_guile (void *(*func)(void *), void *data)
scm_i_default_dynamic_state);
}
static void
SCM_UNUSED static void
scm_leave_guile_cleanup (void *x)
{
scm_leave_guile ();
@ -734,7 +806,7 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
scm_i_pthread_cleanup_pop (0);
scm_leave_guile ();
}
else
else
res = scm_c_with_continuation_barrier (func, data);
return res;
@ -832,7 +904,7 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0,
}
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
scm_i_pthread_mutex_unlock (&data.mutex);
return data.thread;
}
#undef FUNC_NAME
@ -909,7 +981,7 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data,
}
scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
scm_i_pthread_mutex_unlock (&data.mutex);
return data.thread;
}
@ -933,15 +1005,15 @@ SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
SCM_VALIDATE_THREAD (1, thread);
t = SCM_I_THREAD_DATA (thread);
scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
if (!t->canceled)
{
t->canceled = 1;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
scm_i_pthread_cancel (t->pthread);
}
else
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
return SCM_UNSPECIFIED;
}
@ -959,13 +1031,13 @@ SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0,
if (!scm_is_false (proc))
SCM_VALIDATE_THUNK (2, proc);
scm_i_pthread_mutex_lock (&thread_admin_mutex);
t = SCM_I_THREAD_DATA (thread);
scm_i_pthread_mutex_lock (&t->admin_mutex);
if (!(t->exited || t->canceled))
t->cleanup_handler = proc;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
return SCM_UNSPECIFIED;
}
@ -981,71 +1053,85 @@ SCM_DEFINE (scm_thread_cleanup, "thread-cleanup", 1, 0, 0,
SCM_VALIDATE_THREAD (1, thread);
scm_i_pthread_mutex_lock (&thread_admin_mutex);
t = SCM_I_THREAD_DATA (thread);
scm_i_pthread_mutex_lock (&t->admin_mutex);
ret = (t->exited || t->canceled) ? SCM_BOOL_F : t->cleanup_handler;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
return ret;
}
#undef FUNC_NAME
SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
(SCM thread),
SCM scm_join_thread (SCM thread)
{
return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED);
}
SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0,
(SCM thread, SCM timeout, SCM timeoutval),
"Suspend execution of the calling thread until the target @var{thread} "
"terminates, unless the target @var{thread} has already terminated. ")
#define FUNC_NAME s_scm_join_thread
#define FUNC_NAME s_scm_join_thread_timed
{
scm_i_thread *t;
SCM res;
scm_t_timespec ctimeout, *timeout_ptr = NULL;
SCM res = SCM_BOOL_F;
if (! (SCM_UNBNDP (timeoutval)))
res = timeoutval;
SCM_VALIDATE_THREAD (1, thread);
if (scm_is_eq (scm_current_thread (), thread))
SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL);
scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
t = SCM_I_THREAD_DATA (thread);
if (!t->exited)
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
if (! SCM_UNBNDP (timeout))
{
to_timespec (timeout, &ctimeout);
timeout_ptr = &ctimeout;
}
if (t->exited)
res = t->result;
else
{
while (1)
{
block_self (t->join_queue, thread, &thread_admin_mutex, NULL);
if (t->exited)
int err = block_self (t->join_queue, thread, &t->admin_mutex,
timeout_ptr);
if (err == 0)
{
if (t->exited)
{
res = t->result;
break;
}
}
else if (err == ETIMEDOUT)
break;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
SCM_TICK;
scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
}
}
res = t->result;
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
return res;
}
#undef FUNC_NAME
/*** Fat mutexes */
/* We implement our own mutex type since we want them to be 'fair', we
want to do fancy things while waiting for them (like running
asyncs) and we might want to add things that are nice for
debugging.
*/
typedef struct {
scm_i_pthread_mutex_t lock;
SCM owner;
int level; /* how much the owner owns us.
< 0 for non-recursive mutexes */
SCM waiting; /* the threads waiting for this mutex. */
} fat_mutex;
#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a thread.")
#define FUNC_NAME s_scm_thread_p
{
return SCM_I_IS_THREAD(obj) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
static size_t
@ -1068,7 +1154,7 @@ fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
}
static SCM
make_fat_mutex (int recursive)
make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock)
{
fat_mutex *m;
SCM mx;
@ -1076,19 +1162,49 @@ make_fat_mutex (int recursive)
m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
scm_i_pthread_mutex_init (&m->lock, NULL);
m->owner = SCM_BOOL_F;
m->level = recursive? 0 : -1;
m->level = 0;
m->recursive = recursive;
m->unchecked_unlock = unchecked_unlock;
m->allow_external_unlock = external_unlock;
m->waiting = SCM_EOL;
SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m);
m->waiting = make_queue ();
return mx;
}
SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
(void),
"Create a new mutex. ")
#define FUNC_NAME s_scm_make_mutex
SCM scm_make_mutex (void)
{
return make_fat_mutex (0);
return scm_make_mutex_with_flags (SCM_EOL);
}
SCM_SYMBOL (unchecked_unlock_sym, "unchecked-unlock");
SCM_SYMBOL (allow_external_unlock_sym, "allow-external-unlock");
SCM_SYMBOL (recursive_sym, "recursive");
SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1,
(SCM flags),
"Create a new mutex. ")
#define FUNC_NAME s_scm_make_mutex_with_flags
{
int unchecked_unlock = 0, external_unlock = 0, recursive = 0;
SCM ptr = flags;
while (! scm_is_null (ptr))
{
SCM flag = SCM_CAR (ptr);
if (scm_is_eq (flag, unchecked_unlock_sym))
unchecked_unlock = 1;
else if (scm_is_eq (flag, allow_external_unlock_sym))
external_unlock = 1;
else if (scm_is_eq (flag, recursive_sym))
recursive = 1;
else
SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag));
ptr = SCM_CDR (ptr);
}
return make_fat_mutex (recursive, unchecked_unlock, external_unlock);
}
#undef FUNC_NAME
@ -1097,59 +1213,119 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
"Create a new recursive mutex. ")
#define FUNC_NAME s_scm_make_recursive_mutex
{
return make_fat_mutex (1);
return make_fat_mutex (1, 0, 0);
}
#undef FUNC_NAME
static char *
fat_mutex_lock (SCM mutex)
SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error");
static SCM
fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
{
fat_mutex *m = SCM_MUTEX_DATA (mutex);
SCM thread = scm_current_thread ();
char *msg = NULL;
SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner;
SCM err = SCM_BOOL_F;
struct timeval current_time;
scm_i_scm_pthread_mutex_lock (&m->lock);
if (scm_is_false (m->owner))
m->owner = thread;
else if (scm_is_eq (m->owner, thread))
while (1)
{
if (m->level >= 0)
m->level++;
else
msg = "mutex already locked by current thread";
}
else
{
while (1)
if (m->level == 0)
{
block_self (m->waiting, mutex, &m->lock, NULL);
if (scm_is_eq (m->owner, thread))
break;
m->owner = new_owner;
m->level++;
if (SCM_I_IS_THREAD (new_owner))
{
scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
scm_i_pthread_mutex_lock (&t->admin_mutex);
t->mutexes = scm_cons (mutex, t->mutexes);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
}
*ret = 1;
break;
}
else if (SCM_I_IS_THREAD (m->owner) && scm_c_thread_exited_p (m->owner))
{
m->owner = new_owner;
err = scm_cons (scm_abandoned_mutex_error_key,
scm_from_locale_string ("lock obtained on abandoned "
"mutex"));
*ret = 1;
break;
}
else if (scm_is_eq (m->owner, new_owner))
{
if (m->recursive)
{
m->level++;
*ret = 1;
}
else
{
err = scm_cons (scm_misc_error_key,
scm_from_locale_string ("mutex already locked "
"by thread"));
*ret = 0;
}
break;
}
else
{
if (timeout != NULL)
{
gettimeofday (&current_time, NULL);
if (current_time.tv_sec > timeout->tv_sec ||
(current_time.tv_sec == timeout->tv_sec &&
current_time.tv_usec * 1000 > timeout->tv_nsec))
{
*ret = 0;
break;
}
}
block_self (m->waiting, mutex, &m->lock, timeout);
scm_i_pthread_mutex_unlock (&m->lock);
SCM_TICK;
scm_i_scm_pthread_mutex_lock (&m->lock);
}
}
scm_i_pthread_mutex_unlock (&m->lock);
return msg;
return err;
}
SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
(SCM mx),
SCM scm_lock_mutex (SCM mx)
{
return scm_lock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
}
SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
(SCM m, SCM timeout, SCM owner),
"Lock @var{mutex}. If the mutex is already locked, the calling thread "
"blocks until the mutex becomes available. The function returns when "
"the calling thread owns the lock on @var{mutex}. Locking a mutex that "
"a thread already owns will succeed right away and will not block the "
"thread. That is, Guile's mutexes are @emph{recursive}. ")
#define FUNC_NAME s_scm_lock_mutex
#define FUNC_NAME s_scm_lock_mutex_timed
{
char *msg;
SCM exception;
int ret = 0;
scm_t_timespec cwaittime, *waittime = NULL;
SCM_VALIDATE_MUTEX (1, mx);
msg = fat_mutex_lock (mx);
if (msg)
scm_misc_error (NULL, msg, SCM_EOL);
return SCM_BOOL_T;
SCM_VALIDATE_MUTEX (1, m);
if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout))
{
to_timespec (timeout, &cwaittime);
waittime = &cwaittime;
}
exception = fat_mutex_lock (m, waittime, owner, &ret);
if (!scm_is_false (exception))
scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
return ret ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
@ -1162,115 +1338,28 @@ scm_dynwind_lock_mutex (SCM mutex)
SCM_F_WIND_EXPLICITLY);
}
static char *
fat_mutex_trylock (fat_mutex *m, int *resp)
{
char *msg = NULL;
SCM thread = scm_current_thread ();
*resp = 1;
scm_i_pthread_mutex_lock (&m->lock);
if (scm_is_false (m->owner))
m->owner = thread;
else if (scm_is_eq (m->owner, thread))
{
if (m->level >= 0)
m->level++;
else
msg = "mutex already locked by current thread";
}
else
*resp = 0;
scm_i_pthread_mutex_unlock (&m->lock);
return msg;
}
SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
(SCM mutex),
"Try to lock @var{mutex}. If the mutex is already locked by someone "
"else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
#define FUNC_NAME s_scm_try_mutex
{
char *msg;
int res;
SCM exception;
int ret = 0;
scm_t_timespec cwaittime, *waittime = NULL;
SCM_VALIDATE_MUTEX (1, mutex);
msg = fat_mutex_trylock (SCM_MUTEX_DATA (mutex), &res);
if (msg)
scm_misc_error (NULL, msg, SCM_EOL);
return scm_from_bool (res);
to_timespec (scm_from_int(0), &cwaittime);
waittime = &cwaittime;
exception = fat_mutex_lock (mutex, waittime, SCM_UNDEFINED, &ret);
if (!scm_is_false (exception))
scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
return ret ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
static char *
fat_mutex_unlock (fat_mutex *m)
{
char *msg = NULL;
scm_i_scm_pthread_mutex_lock (&m->lock);
if (!scm_is_eq (m->owner, scm_current_thread ()))
{
if (scm_is_false (m->owner))
msg = "mutex not locked";
else
msg = "mutex not locked by current thread";
}
else if (m->level > 0)
m->level--;
else
m->owner = unblock_from_queue (m->waiting);
scm_i_pthread_mutex_unlock (&m->lock);
return msg;
}
SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
(SCM mx),
"Unlocks @var{mutex} if the calling thread owns the lock on "
"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
"thread results in undefined behaviour. Once a mutex has been unlocked, "
"one thread blocked on @var{mutex} is awakened and grabs the mutex "
"lock. Every call to @code{lock-mutex} by this thread must be matched "
"with a call to @code{unlock-mutex}. Only the last call to "
"@code{unlock-mutex} will actually unlock the mutex. ")
#define FUNC_NAME s_scm_unlock_mutex
{
char *msg;
SCM_VALIDATE_MUTEX (1, mx);
msg = fat_mutex_unlock (SCM_MUTEX_DATA (mx));
if (msg)
scm_misc_error (NULL, msg, SCM_EOL);
return SCM_BOOL_T;
}
#undef FUNC_NAME
#if 0
SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
(SCM mx),
"Return the thread owning @var{mx}, or @code{#f}.")
#define FUNC_NAME s_scm_mutex_owner
{
SCM_VALIDATE_MUTEX (1, mx);
return (SCM_MUTEX_DATA(mx))->owner;
}
#undef FUNC_NAME
SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
(SCM mx),
"Return the lock level of a recursive mutex, or -1\n"
"for a standard mutex.")
#define FUNC_NAME s_scm_mutex_level
{
SCM_VALIDATE_MUTEX (1, mx);
return scm_from_int (SCM_MUTEX_DATA(mx)->level);
}
#undef FUNC_NAME
#endif
/*** Fat condition variables */
typedef struct {
@ -1281,6 +1370,186 @@ typedef struct {
#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
static int
fat_mutex_unlock (SCM mutex, SCM cond,
const scm_t_timespec *waittime, int relock)
{
fat_mutex *m = SCM_MUTEX_DATA (mutex);
fat_cond *c = NULL;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
int err = 0, ret = 0;
scm_i_scm_pthread_mutex_lock (&m->lock);
SCM owner = m->owner;
if (!scm_is_eq (owner, scm_current_thread ()))
{
if (m->level == 0)
{
if (!m->unchecked_unlock)
{
scm_i_pthread_mutex_unlock (&m->lock);
scm_misc_error (NULL, "mutex not locked", SCM_EOL);
}
owner = scm_current_thread ();
}
else if (!m->allow_external_unlock)
{
scm_i_pthread_mutex_unlock (&m->lock);
scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL);
}
}
if (! (SCM_UNBNDP (cond)))
{
c = SCM_CONDVAR_DATA (cond);
while (1)
{
int brk = 0;
scm_i_scm_pthread_mutex_lock (&c->lock);
if (m->level > 0)
m->level--;
if (m->level == 0)
m->owner = unblock_from_queue (m->waiting);
scm_i_pthread_mutex_unlock (&m->lock);
t->block_asyncs++;
err = block_self (c->waiting, cond, &c->lock, waittime);
if (err == 0)
{
ret = 1;
brk = 1;
}
else if (err == ETIMEDOUT)
{
ret = 0;
brk = 1;
}
else if (err != EINTR)
{
errno = err;
scm_i_pthread_mutex_unlock (&c->lock);
scm_syserror (NULL);
}
if (brk)
{
if (relock)
scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
scm_i_pthread_mutex_unlock (&c->lock);
break;
}
scm_i_pthread_mutex_unlock (&c->lock);
t->block_asyncs--;
scm_async_click ();
scm_remember_upto_here_2 (cond, mutex);
scm_i_scm_pthread_mutex_lock (&m->lock);
}
}
else
{
if (m->level > 0)
m->level--;
if (m->level == 0)
m->owner = unblock_from_queue (m->waiting);
scm_i_pthread_mutex_unlock (&m->lock);
ret = 1;
}
return ret;
}
SCM scm_unlock_mutex (SCM mx)
{
return scm_unlock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
}
SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0,
(SCM mx, SCM cond, SCM timeout),
"Unlocks @var{mutex} if the calling thread owns the lock on "
"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
"thread results in undefined behaviour. Once a mutex has been unlocked, "
"one thread blocked on @var{mutex} is awakened and grabs the mutex "
"lock. Every call to @code{lock-mutex} by this thread must be matched "
"with a call to @code{unlock-mutex}. Only the last call to "
"@code{unlock-mutex} will actually unlock the mutex. ")
#define FUNC_NAME s_scm_unlock_mutex_timed
{
scm_t_timespec cwaittime, *waittime = NULL;
SCM_VALIDATE_MUTEX (1, mx);
if (! (SCM_UNBNDP (cond)))
{
SCM_VALIDATE_CONDVAR (2, cond);
if (! (SCM_UNBNDP (timeout)))
{
to_timespec (timeout, &cwaittime);
waittime = &cwaittime;
}
}
return fat_mutex_unlock (mx, cond, waittime, 0) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_mutex_p, "mutex?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a mutex.")
#define FUNC_NAME s_scm_mutex_p
{
return SCM_MUTEXP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
(SCM mx),
"Return the thread owning @var{mx}, or @code{#f}.")
#define FUNC_NAME s_scm_mutex_owner
{
SCM owner;
fat_mutex *m = NULL;
SCM_VALIDATE_MUTEX (1, mx);
m = SCM_MUTEX_DATA (mx);
scm_i_pthread_mutex_lock (&m->lock);
owner = m->owner;
scm_i_pthread_mutex_unlock (&m->lock);
return owner;
}
#undef FUNC_NAME
SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
(SCM mx),
"Return the lock level of mutex @var{mx}.")
#define FUNC_NAME s_scm_mutex_level
{
SCM_VALIDATE_MUTEX (1, mx);
return scm_from_int (SCM_MUTEX_DATA(mx)->level);
}
#undef FUNC_NAME
SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0,
(SCM mx),
"Returns @code{#t} if the mutex @var{mx} is locked.")
#define FUNC_NAME s_scm_mutex_locked_p
{
SCM_VALIDATE_MUTEX (1, mx);
return SCM_MUTEX_DATA (mx)->level > 0 ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
static size_t
fat_cond_free (SCM mx)
{
@ -1317,49 +1586,6 @@ SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0,
}
#undef FUNC_NAME
static int
fat_cond_timedwait (SCM cond, SCM mutex,
const scm_t_timespec *waittime)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
fat_cond *c = SCM_CONDVAR_DATA (cond);
fat_mutex *m = SCM_MUTEX_DATA (mutex);
const char *msg;
int err = 0;
while (1)
{
scm_i_scm_pthread_mutex_lock (&c->lock);
msg = fat_mutex_unlock (m);
t->block_asyncs++;
if (msg == NULL)
{
err = block_self (c->waiting, cond, &c->lock, waittime);
scm_i_pthread_mutex_unlock (&c->lock);
fat_mutex_lock (mutex);
}
else
scm_i_pthread_mutex_unlock (&c->lock);
t->block_asyncs--;
scm_async_click ();
if (msg)
scm_misc_error (NULL, msg, SCM_EOL);
scm_remember_upto_here_2 (cond, mutex);
if (err == 0)
return 1;
if (err == ETIMEDOUT)
return 0;
if (err != EINTR)
{
errno = err;
scm_syserror (NULL);
}
}
}
SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
(SCM cv, SCM mx, SCM t),
"Wait until @var{cond-var} has been signalled. While waiting, "
@ -1377,23 +1603,14 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1,
SCM_VALIDATE_CONDVAR (1, cv);
SCM_VALIDATE_MUTEX (2, mx);
if (!SCM_UNBNDP (t))
{
if (scm_is_pair (t))
{
waittime.tv_sec = scm_to_ulong (SCM_CAR (t));
waittime.tv_nsec = scm_to_ulong (SCM_CAR (t)) * 1000;
}
else
{
waittime.tv_sec = scm_to_ulong (t);
waittime.tv_nsec = 0;
}
to_timespec (t, &waittime);
waitptr = &waittime;
}
return scm_from_bool (fat_cond_timedwait (cv, mx, waitptr));
return fat_mutex_unlock (mx, cv, waitptr, 1) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
@ -1436,6 +1653,15 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1,
}
#undef FUNC_NAME
SCM_DEFINE (scm_condition_variable_p, "condition-variable?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a condition variable.")
#define FUNC_NAME s_scm_condition_variable_p
{
return SCM_CONDVARP(obj) ? SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
/*** Marking stacks */
/* XXX - what to do with this? Do we need to handle this for blocked
@ -1449,7 +1675,7 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1,
scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
/ sizeof (SCM_STACKITEM))); \
bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \
bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
scm_mark_locations (bot, top - bot); } while (0)
#else
@ -1660,7 +1886,7 @@ scm_i_thread_put_to_sleep ()
scm_leave_guile ();
scm_i_pthread_mutex_lock (&thread_admin_mutex);
/* Signal all threads to go to sleep
/* Signal all threads to go to sleep
*/
scm_i_thread_go_to_sleep = 1;
for (t = all_threads; t; t = t->next_thread)
@ -1743,7 +1969,7 @@ scm_threads_prehistory (SCM_STACKITEM *base)
scm_i_pthread_cond_init (&wake_up_cond, NULL);
scm_i_pthread_key_create (&scm_i_freelist, NULL);
scm_i_pthread_key_create (&scm_i_freelist2, NULL);
guilify_self_1 (base);
}