Re: srfi-18 requirements

["Julian Graham" <joolean@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 5349 bytes --]

Hi Guilers,

  Find attached a first draft of a patch to add SRFI-18 support to
Guile.  The patch contains the necessary modifications to Guile's C
code to support SRFI-18, which is provided as a Scheme module (also
attached). I don't believe any breaking changes to the API are
introduced by this code, and, in general, the only behavior that is
significantly different is that which was previously "unspecified" or
of dubious correctness -- e.g., unlocking mutexes from outside the
threads that originally locked them, or leaving abandoned mutexes
locked forever.

  I realize this is kind of a big patch, so I've included some, uh,
commentary to help you guys sift through it.  I'm working on updating
the Texinfo documentation, but didn't want to wait to submit, as the
scope and content of this patch could conceivably change. I'm also
attaching some test code that might be helpful in illustrating some of
the concepts involved in SRFI-18. Of course, I also encourage everyone
to take a look at the SRFI itself, which is available at
http://srfi.schemers.org/srfi-18/srfi-18.html.

  Please let me know if you have any questions / comments!


Best Regards,
Julian


SIGNIFICANT CHANGES TO THREADS.H
================================

* Three members have been added to the thread data structure:

** admin_mutex, which is a lighter-weight version of the
thread_admin_mutex, which should be used instead of thread_admin_mutex
in situations requiring synchronous access to thread-specific
information, such as checking whether a thread has been marked exited,
that do not require access to the global list of threads

** mutexes, a SCM list of mutexes owned by a thread.  This is
necessary so that threads waiting on mutexes that an exiting thread is
abandoning can be notified

** exception, a SCM holding any uncaught exceptions thrown by the
thread or its cleanup handler.  We need this so we can deliver
uncaught exceptions to threads that join on a terminated thread


NEW C FUNCTIONS
===============

* scm_join_thread_timed (t, timeout, timeout_val): An overload of
scm_join_thread featuring extended timeout semantics from SRFI-18
* scm_thread_p (obj): A type predicate for threads
* scm_lock_mutex_timed (m, abstime, thread): An overload of
scm_lock_mutex featuring extended timeout and ownership semantics from
SRFI-18
* scm_unlock_mutex_timed (m, cond, abstime): An overload of
scm_unlock_mutex featuring extended timeout semantics from SRFI-18
* scm_mutex_state (m): Mutex state reporting from SRFI-18
* scm_mutex_p (obj): A type predicate for mutexes
* scm_condition_variable_p (obj): A type predicate for condition variables


NEW SCHEME FUNCTIONS (without loading SRFI-18)
==============================================

* join-thread thread -> join-thread thread [timeout [timeoutval]]
* thread? obj
* lock-mutex mutex -> lock-mutex mutex [timeout [owner]]
* unlock-mutex mutex -> unlock-mutex mutex [cond [timeout]]
* mutex-state mutex
* mutex? obj
* condition-variable? obj


SIGNIFICANT CHANGES TO THREADS.C
================================

* A static function, scm_to_timespec, has been added to thread.c that
converts SCM timeouts -- either in numerical form or as (secs . usecs)
-- to an scm_t_timespec

* Because the owner of a locked mutex can be #f, unblock_from_queue
now returns SCM_UNDEFINED when a queue is empty, in order to avoid
ambiguity.  This is purely for consistency -- #f cannot actually be
added to a queue

* The catch calls in do_thread_exit and really_launch now include a
handler (if the caller does not specify one already),
exception_preserve_catch_handler, which saves exception data in the
thread's exception field

* scm_join_thread, which now calls scm_join_thread_timed, will rethrow
any uncaught exceptions thrown by the terminated thread

* fat_mutex_lock and fat_mutex_unlock now add and remove mutexes from
a thread's list of locked mutexes. As part of thread exit, other
threads waiting on mutexes in this list are woken up

* An unlocked fat_mutex now has its owner set to SCM_UNDEFINED, not SCM_BOOL_F

* fat_mutex_lock has been largely rewritten (although the behavior is
almost exactly the same for calls that do not specify a timeout) in
order to deal with SRFI-18's concept of mutex states. It is now a loop
that synchronously inspects the current state of the mutex to
determine whether it can be locked, sleeping on the mutex's condition
variable if it cannot be. As per SRFI-18, an attempt to lock an
abandoned mutex will succeed, although an abandoned-mutex-exception
will be thrown. fat_mutex_lock now returns an exception instead of a
char *, indicating the success of the lock via a passed-in int
pointer.

* fat_mutex_unlock now allows a mutex to be unlocked from any thread,
as per SRFI-18


SIGNIFICANT CHANGES TO SCMSIGS.C
================================

* The scm_spawn_thread call that launches the signal delivery thread
no longer specifies a handler. No one should call scm_spawn_thread
with a handler, because of an already-present deadlock in 1.8.x -- in
a multithreaded context, a guile mode thread (i.e., one that has
locked its heap mutex) may attempt to enter a critical section in
eval.i.c at the same time a non-guile mode thread created by
scm_spawn_thread is within a critical section in make_jmpbuf while
setting up a catch handler and attempts to do a GC

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: srfi-18.HEAD.patch --]
[-- Type: text/x-patch; name=srfi-18.HEAD.patch, Size: 29391 bytes --]

Index: scmsigs.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/scmsigs.c,v
retrieving revision 1.98
diff -a -u -r1.98 scmsigs.c
--- scmsigs.c	20 Oct 2007 11:09:58 -0000	1.98
+++ scmsigs.c	29 Oct 2007 13:15:31 -0000
@@ -212,9 +212,7 @@
 
   if (pipe (signal_pipe) != 0)
     scm_syserror (NULL);
-  signal_thread = scm_spawn_thread (signal_delivery_thread, NULL,
-				    scm_handle_by_message,
-				    "signal delivery thread");
+  signal_thread = scm_spawn_thread (signal_delivery_thread, NULL, NULL, NULL);
   scm_i_signal_delivery_thread = SCM_I_THREAD_DATA (signal_thread);
 
   scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
Index: threads.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.90
diff -a -u -r1.90 threads.c
--- threads.c	20 Oct 2007 11:09:58 -0000	1.90
+++ threads.c	29 Oct 2007 13:15:34 -0000
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2007 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
@@ -15,7 +15,6 @@
  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  */
 
-
 \f
 
 #define _GNU_SOURCE
@@ -49,6 +48,8 @@
 #include "libguile/gc.h"
 #include "libguile/init.h"
 #include "libguile/scmsigs.h"
+#include "libguile/strings.h"
+#include "libguile/list.h"
 
 #ifdef __MINGW32__
 #ifndef ETIMEDOUT
@@ -59,6 +60,26 @@
 # define pipe(fd) _pipe (fd, 256, O_BINARY)
 #endif /* __MINGW32__ */
 
+static scm_t_timespec
+scm_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) * 1000000);
+    }
+  return waittime;
+}
+
 /*** Queues */
 
 /* Make an empty queue data structure.
@@ -131,7 +152,9 @@
 thread_mark (SCM obj)
 {
   scm_i_thread *t = SCM_I_THREAD_DATA (obj);
+  scm_gc_mark (t->mutexes);
   scm_gc_mark (t->result);
+  scm_gc_mark (t->exception);
   scm_gc_mark (t->cleanup_handler);
   scm_gc_mark (t->join_queue);
   scm_gc_mark (t->dynwinds);
@@ -212,6 +235,7 @@
 
    The system asyncs themselves are not executed by block_self.
 */
+
 static int
 block_self (SCM queue, SCM sleep_object, scm_i_pthread_mutex_t *mutex,
 	    const scm_t_timespec *waittime)
@@ -224,8 +248,10 @@
     err = EINTR;
   else
     {
+      scm_i_pthread_cleanup_push ((void (*)(void *)) scm_i_reset_sleep, t);
       t->block_asyncs++;
       q_handle = enqueue (queue, t->handle);
+
       if (waittime == NULL)
 	err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex);
       else
@@ -239,6 +265,7 @@
 	err = EINTR;
       t->block_asyncs--;
       scm_i_reset_sleep (t);
+      scm_i_pthread_cleanup_pop (0);
     }
 
   return err;
@@ -246,15 +273,20 @@
 
 /* Wake up the first thread on QUEUE, if any.  The caller must hold
    the mutex that protects QUEUE.  The awoken thread is returned, or
-   #f when the queue was empty.
+   SCM_UNDEFINED when the queue was empty.
  */
 static SCM
 unblock_from_queue (SCM queue)
 {
   SCM thread = dequeue (queue);
+
   if (scm_is_true (thread))
-    scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread)->sleep_cond);
-  return thread;
+    {
+      scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread)->sleep_cond);
+      return thread;
+    }
+
+  return SCM_UNDEFINED;
 }
 
 /* Getting into and out of guile mode.
@@ -407,6 +439,8 @@
 
 static SCM scm_i_default_dynamic_state;
 
+extern scm_i_thread *scm_i_signal_delivery_thread;
+
 /* Perform first stage of thread initialisation, in non-guile mode.
  */
 static void
@@ -417,7 +451,9 @@
   t->pthread = scm_i_pthread_self ();
   t->handle = SCM_BOOL_F;
   t->result = SCM_BOOL_F;
+  t->exception = 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;
@@ -435,6 +471,7 @@
   /* 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->canceled = 0;
@@ -477,6 +514,25 @@
   t->block_asyncs = 0;
 }
 
+static SCM
+exception_preserve_catch_handler (void *data, SCM tag, SCM throw_args)
+{
+  scm_i_thread *t = (scm_i_thread *) data;
+  t->exception = scm_cons (tag, throw_args);
+  return SCM_BOOL_F;
+}
+
+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))
+
 /* Perform thread tear-down, in guile mode.
  */
 static void *
@@ -487,22 +543,31 @@
   if (!scm_is_false (t->cleanup_handler))
     {
       SCM ptr = t->cleanup_handler;
-
       t->cleanup_handler = SCM_BOOL_F;
-      t->result = scm_internal_catch (SCM_BOOL_T,
+      t->result = scm_internal_catch (SCM_BOOL_T, 
 				      (scm_t_catch_body) scm_call_0, ptr,
-				      scm_handle_by_message_noexit, NULL);
+				      exception_preserve_catch_handler, t);
     }
 
-  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  scm_i_pthread_mutex_lock (&t->admin_mutex);
 
   t->exited = 1;
   close (t->sleep_pipe[0]);
   close (t->sleep_pipe[1]);
-  while (scm_is_true (unblock_from_queue (t->join_queue)))
+  while (unblock_from_queue (t->join_queue) != SCM_UNDEFINED)
     ;
 
-  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;
 }
@@ -515,14 +580,14 @@
 
   scm_i_pthread_setspecific (scm_i_thread_key, v);
 
-  /* Ensure the signal handling thread has been launched, because we might be
-     shutting it down.  */
-  scm_i_ensure_signal_delivery_thread ();
-
   /* Unblocking the joining threads needs to happen in guile mode
      since the queue is a SCM data structure.  */
   scm_with_guile (do_thread_exit, v);
 
+  /* Ensure the signal handling thread has been launched, because we might be
+     shutting it down.  */
+  scm_i_ensure_signal_delivery_thread ();
+
   /* Removing ourself from the list of all threads needs to happen in
      non-guile mode since all SCM values on our stack become
      unprotected once we are no longer in the list.  */
@@ -749,6 +814,13 @@
   return res;
 }
 
+SCM_GLOBAL_SYMBOL (scm_uncaught_exception_key, "uncaught-exception");
+SCM_GLOBAL_SYMBOL (scm_join_timeout_exception_key, "join-timeout-exception");
+SCM_GLOBAL_SYMBOL (scm_abandoned_mutex_exception_key, 
+		   "abandoned-mutex-exception");
+SCM_GLOBAL_SYMBOL (scm_terminated_thread_exception_key, 
+		   "terminated-thread-exception");
+
 /*** Thread creation */
 
 typedef struct {
@@ -775,7 +847,9 @@
   scm_i_pthread_mutex_unlock (&data->mutex);
 
   if (SCM_UNBNDP (handler))
-    t->result = scm_call_0 (thunk);
+    t->result = scm_internal_catch (scm_uncaught_exception_key, 
+				    (scm_t_catch_body) scm_call_0, thunk,
+				    exception_preserve_catch_handler, t);
   else
     t->result = scm_catch (SCM_BOOL_T, thunk, handler);
 
@@ -931,15 +1005,13 @@
 
   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_cancel (t->pthread);
     }
-  else
-    scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return SCM_UNSPECIFIED;
 }
@@ -957,13 +1029,12 @@
   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;
 }
@@ -978,12 +1049,10 @@
   SCM ret;
 
   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
@@ -994,33 +1063,82 @@
 "terminates, unless the target @var{thread} has already terminated. ")
 #define FUNC_NAME s_scm_join_thread
 {
+  return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+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 or until @var{timeout} has elapsed, unless the target "
+"@var{thread} has already terminated. If @var{timeout_val} is specified and "
+"@var{timeout} elapses before @{thread} terminates, it will be returned as "
+"the value of this function; if @var{timeout_val} is not specified, "
+"@var{join-thread} will throw a @var{join-timeout-exception} exception.")
+#define FUNC_NAME s_scm_join_thread_timed
+{
+  int timed_out = 0;
   scm_i_thread *t;
-  SCM res;
+  scm_t_timespec ctimeout, *timeout_ptr = NULL;
+  SCM res = SCM_BOOL_F, ex = SCM_BOOL_F;
 
   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);
+  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
+
+  if (! SCM_UNBNDP (timeout))
+    {
+      ctimeout = scm_to_timespec (timeout);
+      timeout_ptr = &ctimeout;
+    }
+
   if (!t->exited)
     {
       while (1)
 	{
-	  block_self (t->join_queue, thread, &thread_admin_mutex, NULL);
+	  int err = block_self 
+	    (t->join_queue, thread, &t->admin_mutex, timeout_ptr);
+	  if (err == ETIMEDOUT)
+	    {
+	      timed_out = 1;
+	      if (SCM_UNBNDP (timeoutval))
+		ex = scm_cons (scm_join_timeout_exception_key, SCM_EOL);
+	      else 
+		res = timeoutval;
+	      break;
+	    }
 	  if (t->exited)
 	    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;
+  
+  if (!timed_out)
+    {
+      res = t->result;
+      ex = t->exception;
+    }
 
-  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
-  return res;
+  if (!scm_is_false (ex))
+    scm_ithrow (SCM_CAR (ex), SCM_CDR (ex), 1);
+
+  return res;  
+}
+#undef FUNC_NAME
+
+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
 
@@ -1034,16 +1152,36 @@
    debugging.
 */
 
+#define MUTEX_STATE_UNLOCKED_NOT_ABANDONED 0
+#define MUTEX_STATE_UNLOCKED_ABANDONED     1
+#define MUTEX_STATE_LOCKED_OWNED           2
+#define MUTEX_STATE_LOCKED_UNOWNED         3
+
+SCM_GLOBAL_SYMBOL (scm_mutex_state_not_owned, "not-owned");
+SCM_GLOBAL_SYMBOL (scm_mutex_state_abandoned, "abandoned");
+SCM_GLOBAL_SYMBOL (scm_mutex_state_not_abandoned, "not-abandoned");
+
+/*** Fat condition variables */
+ 
 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;
+  SCM waiting;               /* the threads waiting for this condition. */
+} fat_cond;
 
-#define SCM_MUTEXP(x)         SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
-#define SCM_MUTEX_DATA(x)     ((fat_mutex *) SCM_SMOB_DATA (x))
+#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_state (fat_mutex *m)
+{
+  if (m->owner == SCM_UNDEFINED)
+    return MUTEX_STATE_UNLOCKED_NOT_ABANDONED;
+  else if (scm_is_false (m->owner))
+    return MUTEX_STATE_LOCKED_UNOWNED;
+  else if (scm_c_thread_exited_p (m->owner))
+    return MUTEX_STATE_UNLOCKED_ABANDONED;
+  else return MUTEX_STATE_LOCKED_OWNED;
+}
 
 static SCM
 fat_mutex_mark (SCM mx)
@@ -1080,7 +1218,7 @@
 
   m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
   scm_i_pthread_mutex_init (&m->lock, NULL);
-  m->owner = SCM_BOOL_F;
+  m->owner = SCM_UNDEFINED;
   m->level = recursive? 0 : -1;
   m->waiting = SCM_EOL;
   SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m);
@@ -1106,55 +1244,150 @@
 }
 #undef FUNC_NAME
 
-static char *
-fat_mutex_lock (SCM mutex)
+static SCM
+fat_mutex_lock (SCM mutex, SCM thread, scm_t_timespec *timeout, int *ret)
 {
   fat_mutex *m = SCM_MUTEX_DATA (mutex);
-  SCM thread = scm_current_thread ();
-  char *msg = NULL;
+  SCM err = SCM_EOL;
+  int state = 0, try_lock = 1;
+
+  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))
+  state = fat_mutex_state (m);
+  while (try_lock)
     {
-      if (m->level >= 0)
-	m->level++;
-      else
-	msg = "mutex already locked by current thread";
-    }
-  else
-    {
-      while (1)
+      try_lock = 0;
+      switch (state)
 	{
-	  block_self (m->waiting, mutex, &m->lock, NULL);
+	case MUTEX_STATE_LOCKED_OWNED:
 	  if (scm_is_eq (m->owner, thread))
-	    break;
-	  scm_i_pthread_mutex_unlock (&m->lock);
-	  SCM_TICK;
-	  scm_i_scm_pthread_mutex_lock (&m->lock);
+	    {
+	      if (m->level >= 0) 
+		m->level++;
+	      else
+		{
+		  SCM msg = scm_from_locale_string
+		    ("mutex already locked by thread");
+		  err = scm_cons(scm_misc_error_key, msg);
+		}
+	      *ret = 0;
+	      break;
+	    }
+	case MUTEX_STATE_LOCKED_UNOWNED:
+	  while (1)
+	    {
+	      block_self (m->waiting, mutex, &m->lock, timeout);
+	      state = fat_mutex_state (m);
+	      if (state == MUTEX_STATE_UNLOCKED_ABANDONED ||
+		  state == MUTEX_STATE_UNLOCKED_NOT_ABANDONED)
+		{
+		  try_lock = 1;
+		  break;
+		}
+	      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;
+		    }
+		}
+	      scm_i_pthread_mutex_unlock (&m->lock);
+	      SCM_TICK;
+	      scm_i_scm_pthread_mutex_lock (&m->lock);	  
+	    }
+	  break;
+	case MUTEX_STATE_UNLOCKED_ABANDONED:
+	  err = scm_cons (scm_abandoned_mutex_exception_key, SCM_EOL);
+	case MUTEX_STATE_UNLOCKED_NOT_ABANDONED:
+	  if (SCM_I_IS_THREAD (thread))
+	    {
+	      scm_i_thread *t = SCM_I_THREAD_DATA (thread);
+	      
+	      /* The current thread can lock mutexes from within its cleanup
+		 handler, but we can't let other threads specify a canceled
+		 thread as the owner of a mutex because it may have passed the
+		 cleanup stage where it abandones its held mutexes. */
+	      
+	      scm_i_pthread_mutex_lock (&t->admin_mutex);
+	      if (t != SCM_I_CURRENT_THREAD && (t->exited || t->canceled))
+		err = scm_cons (scm_misc_error_key, SCM_EOL);
+	      else if (scm_is_null (t->mutexes))
+		t->mutexes = scm_list_1 (mutex);
+	      else
+		t->mutexes = scm_cons (mutex, t->mutexes);
+	      scm_i_pthread_mutex_unlock (&t->admin_mutex);
+	    }
+	  m->owner = thread;
+	  *ret = 1;
+	  break;
 	}
+      if (!try_lock)
+	break;
     }
   scm_i_pthread_mutex_unlock (&m->lock);
-  return msg;
+  return err;
 }
 
 SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
-	    (SCM mx),
-"Lock @var{mutex}. If the mutex is already locked, the calling thread "
+	    (SCM m),
+"Lock @var{m}. 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 "
+"the calling thread owns the lock on @var{m}.  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
 {
-  char *msg;
+  return scm_lock_mutex_timed (m, SCM_BOOL_F, SCM_I_CURRENT_THREAD->handle);
+}
+#undef FUNC_NAME
 
-  SCM_VALIDATE_MUTEX (1, mx);
-  msg = fat_mutex_lock (mx);
-  if (msg)
-    scm_misc_error (NULL, msg, SCM_EOL);
-  return SCM_BOOL_T;
+SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
+	    (SCM m, SCM timeout, SCM thread),
+"Lock @var{m}. If the mutex is already locked, the calling thread "
+"blocks until the mutex becomes available or until @var{timeout} elapses, if "
+"it is specified. When the function returns, the calling thread, or "
+"@var{thread}, if specified, will own the lock on @var{m}. If @var{thread} is "
+"@code{#f}, the mutex's state (as reported by @var{mutex-state}) will be "
+"@code{locked/unowned}; otherwise, the state will be @code{locked/owned}. If "
+"@{m} was previously held by a thread that terminated before unlocking it, a "
+"call to this function will change the owner of the mutex, but a "
+"@code{abadoned-mutex-exception} will be thrown. 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}. @var{lock-mutex} "
+"returns @code{#t} if @var{m} was successfully locked, @code{#f} otherwise.")
+#define FUNC_NAME s_scm_lock_mutex_timed
+{
+  SCM exception;
+  int ret = 0;
+  scm_t_timespec cwaittime, *waittime = NULL;
+
+  SCM_VALIDATE_MUTEX (1, m);
+
+  if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout))
+    {
+      cwaittime = scm_to_timespec (timeout);
+      waittime = &cwaittime;
+    }
+
+  if (SCM_UNBNDP (thread))
+    thread = SCM_I_CURRENT_THREAD->handle;
+  else if (! SCM_I_IS_THREAD (thread) && ! scm_is_false (thread))
+    SCM_MISC_ERROR ("thread must be a thread or false", SCM_EOL);
+
+  exception = fat_mutex_lock (m, thread, waittime, &ret);
+  if (scm_is_pair (exception))
+    {
+      SCM key = SCM_CAR (exception);
+      SCM scm_msg = SCM_CDR (exception);
+      char *msg = scm_msg == SCM_EOL ? NULL : scm_to_locale_string (scm_msg);
+      scm_error (key, NULL, msg, SCM_EOL, SCM_BOOL_F);
+    }
+  return ret ? SCM_BOOL_T : SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -1175,7 +1408,7 @@
 
   *resp = 1;
   scm_i_pthread_mutex_lock (&m->lock);
-  if (scm_is_false (m->owner))
+  if (m->owner == SCM_UNDEFINED)
     m->owner = thread;
   else if (scm_is_eq (m->owner, thread))
     {
@@ -1208,46 +1441,109 @@
 }
 #undef FUNC_NAME
 
-static char *
-fat_mutex_unlock (fat_mutex *m)
+static void
+fat_mutex_unlock (SCM mutex)
 {
-  char *msg = NULL;
-
+  fat_mutex *m = SCM_MUTEX_DATA (mutex);
   scm_i_scm_pthread_mutex_lock (&m->lock);
-  if (!scm_is_eq (m->owner, scm_current_thread ()))
+  if (SCM_I_IS_THREAD (m->owner))
     {
-      if (scm_is_false (m->owner))
-	msg = "mutex not locked";
-      else
-	msg = "mutex not locked by current thread";
+      scm_i_thread *t = SCM_I_THREAD_DATA (m->owner);
+      scm_i_pthread_mutex_lock (&t->admin_mutex);
+      scm_delete_x (t->mutexes, mutex);
+      scm_i_pthread_mutex_unlock (&t->admin_mutex);
     }
-  else if (m->level > 0)
+  if (m->level > 0)
     m->level--;
   else
-    m->owner = unblock_from_queue (m->waiting);
+    {
+      unblock_from_queue (m->waiting);
+      m->owner = SCM_UNDEFINED;
+    }
   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. ")
+	    (SCM m),
+"Unlocks @var{m}. Once a mutex has been unlocked, one thread blocked on "
+"@var{m} is awakened and grabs the mutex lock. For recursive mutexes, every "
+"call to @code{lock-mutex} for a particular owner 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;
+  return scm_unlock_mutex_timed (m, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+static int fat_cond_timedwait(SCM, SCM, const scm_t_timespec *);
+
+SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0,
+	    (SCM mx, SCM cond, SCM timeout),
+"Unlocks @var{mx}. Once a mutex has been unlocked, one thread blocked on "
+"@var{mx} is awakened and grabs the mutex lock. If a condition variable "
+"@var{cond} is specified, the current thread will block on @var{cond} until "
+"awoken by a call to @var{signal-condition-variable} or "
+"@var{broadcast-condition-variable}. (This behavior is very similar to that "
+"of @var{wait-condition-variable}, except that @var{mx} is not re-locked when "
+"the thread is woken up.) If @var{timeout} is specified and elapses before "
+"@var{cond} is signalled, @code{unlock-mutex} returns @code{#f}; otherwise it "
+"returns @code{#t}. For recursive mutexes, every call to @code{lock-mutex} "
+"for a particular owner 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 ret = SCM_BOOL_T;
+
   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;
+  if (! (SCM_UNBNDP (cond)))
+    {
+      SCM_VALIDATE_CONDVAR (2, cond);
+      scm_t_timespec cwaittime, *waittime = NULL;
+      
+      if (! (SCM_UNBNDP (timeout)))
+	{
+	  cwaittime = scm_to_timespec (timeout);
+	  waittime = &cwaittime;
+	}
+      if (! fat_cond_timedwait (cond, mx, waittime))
+	ret = SCM_BOOL_F;
+    }
+
+  fat_mutex_unlock (mx);
+  return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_mutex_state, "mutex-state", 1, 0, 0,
+	    (SCM mx),
+"Return the current state of the mutex @var{mx}, which is defined as follows: "
+"If @var{mx} is owned by a thread, its state is @code{locked/owned}, and that "
+"thread will be returned by this function; if @var{mx} has been locked but "
+"the owner is @code{#f}, the state is @code{locked/unowned}, and the symbol "
+"@code{not-owned} will be returned; if @var{mx} was owned by a thread that "
+"terminated before unlocking it, the symbol @code{abandoned} will be "
+"returned; otherwise this function returns the symbol @code{not-abandoned}.")
+#define FUNC_NAME s_scm_mutex_state
+{
+  SCM_VALIDATE_MUTEX (1, mx);
+  fat_mutex *fm = SCM_MUTEX_DATA (mx);
+  switch (fat_mutex_state (fm))
+    {
+    case MUTEX_STATE_LOCKED_OWNED: return fm->owner;
+    case MUTEX_STATE_LOCKED_UNOWNED: return scm_mutex_state_not_owned;
+    case MUTEX_STATE_UNLOCKED_ABANDONED: return scm_mutex_state_abandoned;
+    default: return scm_mutex_state_not_abandoned;
+    }
+}
+#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
 
@@ -1276,16 +1572,6 @@
 
 #endif
 
-/*** Fat condition variables */
-
-typedef struct {
-  scm_i_pthread_mutex_t lock;
-  SCM waiting;               /* the threads waiting for this condition. */
-} fat_cond;
-
-#define SCM_CONDVARP(x)       SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
-#define SCM_CONDVAR_DATA(x)   ((fat_cond *) SCM_SMOB_DATA (x))
-
 static SCM
 fat_cond_mark (SCM cv)
 {
@@ -1334,30 +1620,29 @@
 		    const scm_t_timespec *waittime)
 {
   scm_i_thread *t = SCM_I_CURRENT_THREAD;
+  SCM old_owner = SCM_UNDEFINED;
+
   fat_cond *c = SCM_CONDVAR_DATA (cond);
   fat_mutex *m = SCM_MUTEX_DATA (mutex);
-  const char *msg;
-  int err = 0;
+  int err = 0, ret = 0;
 
   while (1)
     {
+      old_owner = m->owner;
+      
       scm_i_scm_pthread_mutex_lock (&c->lock);
-      msg = fat_mutex_unlock (m);
+      fat_mutex_unlock (mutex);
+
       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);
+      
+      err = block_self (c->waiting, cond, &c->lock, waittime);
+
+      scm_i_pthread_mutex_unlock (&c->lock);
+      fat_mutex_lock (mutex, old_owner, NULL, &ret);
+
       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)
@@ -1392,16 +1677,7 @@
   
   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;
-	}
+      waittime = scm_to_timespec (t);
       waitptr = &waittime;
     }
 
@@ -1432,7 +1708,7 @@
 fat_cond_broadcast (fat_cond *c)
 {
   scm_i_scm_pthread_mutex_lock (&c->lock);
-  while (scm_is_true (unblock_from_queue (c->waiting)))
+  while (unblock_from_queue (c->waiting) != SCM_UNDEFINED)
     ;
   scm_i_pthread_mutex_unlock (&c->lock);
 }
@@ -1448,6 +1724,15 @@
 }
 #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
@@ -1806,6 +2091,7 @@
   scm_set_smob_free (scm_tc16_condvar, fat_cond_free);
 
   scm_i_default_dynamic_state = SCM_BOOL_F;
+  scm_i_pthread_setspecific (scm_i_thread_key, SCM_I_CURRENT_THREAD);
   guilify_self_2 (SCM_BOOL_F);
   threads_initialized_p = 1;
 
Index: threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v
retrieving revision 1.49
diff -a -u -r1.49 threads.h
--- threads.h	20 Oct 2007 11:09:58 -0000	1.49
+++ threads.h	29 Oct 2007 13:15:34 -0000
@@ -3,7 +3,7 @@
 #ifndef SCM_THREADS_H
 #define SCM_THREADS_H
 
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2007 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
@@ -52,7 +52,12 @@
 
   SCM cleanup_handler;
   SCM join_queue;
+
+  scm_i_pthread_mutex_t admin_mutex;
+  SCM mutexes;
+
   SCM result;
+  SCM exception;
   int canceled;
   int exited;
 
@@ -159,13 +164,19 @@
 SCM_API SCM scm_set_thread_cleanup_x (SCM thread, SCM proc);
 SCM_API SCM scm_thread_cleanup (SCM thread);
 SCM_API SCM scm_join_thread (SCM t);
+SCM_API SCM scm_join_thread_timed (SCM t, SCM timeout, SCM timeout_val);
+SCM_API SCM scm_thread_p (SCM o);
 
 SCM_API SCM scm_make_mutex (void);
 SCM_API SCM scm_make_recursive_mutex (void);
 SCM_API SCM scm_lock_mutex (SCM m);
+SCM_API SCM scm_lock_mutex_timed (SCM m, SCM abstime, SCM thread);
 SCM_API void scm_dynwind_lock_mutex (SCM mutex);
 SCM_API SCM scm_try_mutex (SCM m);
 SCM_API SCM scm_unlock_mutex (SCM m);
+SCM_API SCM scm_unlock_mutex_timed (SCM m, SCM cond, SCM abstime);
+SCM_API SCM scm_mutex_state (SCM m);
+SCM_API SCM scm_mutex_p (SCM o);
 
 SCM_API SCM scm_make_condition_variable (void);
 SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex);
@@ -173,6 +184,7 @@
 					       SCM abstime);
 SCM_API SCM scm_signal_condition_variable (SCM cond);
 SCM_API SCM scm_broadcast_condition_variable (SCM cond);
+SCM_API SCM scm_condition_variable_p (SCM o);
 
 SCM_API SCM scm_current_thread (void);
 SCM_API SCM scm_all_threads (void);

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: srfi-18.scm --]
[-- Type: text/x-scheme; name=srfi-18.scm, Size: 8957 bytes --]

;;; srfi-18.scm --- Multithreading support

;; Copyright (C) 2007 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
;; version 2.1 of the License, or (at your option) any later version.
;; 
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Julian Graham <julian.graham@aya.yale.edu>
;;; Date: 2007-10-27

;;; Commentary:

;; This is an implementation of SRFI-18 (Multithreading support).
;;
;; All procedures defined in SRFI-18, which are not already defined in
;; the Guile core library, are exported.
;;
;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-18)
  :export (

;;; Threads
 ;; current-thread			<= in the core
 ;; thread?				<= in the core
 make-thread
 thread-name
 thread-specific
 thread-specific-set!
 thread-start!
 thread-yield!
 thread-sleep!
 thread-terminate!
 thread-join!

;;; Mutexes
 ;; mutex?				<= in the core
 make-mutex
 mutex-name
 mutex-specific
 mutex-specific-set!
 ;; mutex-state                         <= in the core
 mutex-lock!
 mutex-unlock!

;;; Condition variables
 ;; condition-variable?			<= in the core
 make-condition-variable
 condition-variable-name
 condition-variable-specific
 condition-variable-specific-set!
 condition-variable-signal!
 condition-variable-broadcast!
 condition-variable-wait!

;;; Time
 current-time
 time?
 time->seconds
 seconds->time
 
 current-exception-handler
 with-exception-handler
 raise
 join-timeout-exception?
 abandoned-mutex-exception?
 terminated-thread-exception?
 uncaught-exception?
 uncaught-exception-reason
 )
  :re-export (thread? mutex? condition-variable?)
  :replace (current-time 
	    raise 
	    make-thread 
	    make-mutex 
	    make-condition-variable)
  )

(cond-expand-provide (current-module) '(srfi-18))

(define (unspecified) (display ""))

(define (check-arg-type pred arg caller)
  (if (pred arg)
      arg
      (scm-error 'wrong-type-arg caller
		 "Wrong type argument: ~S" (list arg) '())))

(define object-names (make-weak-key-hash-table))
(define object-specifics (make-weak-key-hash-table))
(define thread-start-conds (make-weak-key-hash-table))
(define thread-exception-handlers (make-weak-key-hash-table))

;; EXCEPTIONS

(define (initial-handler key . args) 
  (throw 'uncaught-exception key args))

(define (current-handler-stack)
  (let ((ct (current-thread)))
    (or (hashq-ref thread-exception-handlers ct)
	(hashq-set! thread-exception-handlers ct (list initial-handler)))))

(define (current-exception-handler)
  (car (current-handler-stack)))

(define (with-exception-handler handler thunk)
  (let ((ct (current-thread))
	(hl (current-handler-stack)))
    (check-arg-type procedure? handler "with-exception-handler") 
    (check-arg-type thunk? thunk "with-exception-handler")
    (hashq-set! thread-exception-handlers ct (cons handler hl))
    (catch #t 
	   (lambda () (let ((r (thunk)))
			(hashq-set! thread-exception-handlers ct hl) r))
	   (lambda (key . args)
	     (hashq-set! thread-exception-handlers ct hl)
	     (apply handler (cons key args))))))

(define raise throw)

(define (join-timeout-exception? obj) (eq? obj 'join-timeout-exception))
(define (abandoned-mutex-exception obj) (eq? obj 'abandoned-mutex-exception))
(define (uncaught-exception? obj) 
  (and (pair? obj) (eq? (car obj) 'uncaught-exception)))
(define (uncaught-exception-reason exc)
  (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))

;; THREADS

(define make-thread 
  (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
			     (lambda () 
			       (lock-mutex lmutex)
			       (signal-condition-variable lcond)
			       (lock-mutex smutex)
			       (unlock-mutex lmutex)
			       (wait-condition-variable scond smutex)
			       (unlock-mutex smutex)
			       (catch #t thunk initial-handler)))))
    (lambda (thunk . name)
      (let ((n (and (pair? name) (car name)))

	    (lm (make-mutex 'launch-mutex))
	    (lc (make-condition-variable 'launch-condition-variable))
	    (sm (make-mutex 'start-mutex))
	    (sc (make-condition-variable 'start-condition-variable)))
	
	(lock-mutex lm)
	(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm))))
	  (hashq-set! thread-start-conds t (cons sm sc))
	  (and n (hashq-set! object-names t n))
	  (wait-condition-variable lc lm)
	  (unlock-mutex lm)
	  t)))))

(define (thread-name thread)
  (hashq-ref object-names (check-arg-type thread? thread "thread-name")))

(define (thread-specific thread)
  (hashq-ref object-specifics 
	     (check-arg-type thread? thread "thread-specific")))

(define (thread-specific-set! thread obj)
  (hashq-set! object-specifics
	      (check-arg-type thread? thread "thread-specific-set!")
	      obj)
  (unspecified))

(define (thread-start! thread)
  (let ((x (hashq-ref thread-start-conds
		      (check-arg-type thread? thread "thread-start!"))))
    (and x (let ((smutex (car x))
		 (scond (cdr x)))
	     (hashq-remove! thread-start-conds thread)
	     (lock-mutex smutex)
	     (signal-condition-variable scond)
	     (unlock-mutex smutex)))
    thread))

(define (thread-yield!) (yield) (unspecified))

(define (thread-sleep! timeout)
  (let* ((ct (time->seconds (current-time)))
	 (t (cond ((time? timeout) (- (time->seconds timeout) ct))
		  ((number? timeout) (- timeout ct))
		  (else (scm-error 'wrong-type-arg caller
				   "Wrong type argument: ~S" 
				   (list timeout) 
				   '()))))
	 (secs (inexact->exact (truncate t)))
	 (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
    (and (> secs 0) (sleep secs))
    (and (> usecs 0) (usleep usecs))
    (unspecified)))

(define (thread-terminate! thread)
  (let ((current-handler (thread-cleanup thread)))
    (if (thunk? current-handler)
	(set-thread-cleanup! thread (lambda () 
				      (current-handler) 
				      (throw 'thread-terminated-exception)))
	(set-thread-cleanup! thread (lambda () 
				      (throw 'thread-terminated-exception))))
    (cancel-thread thread))
  (unspecified))

(define (thread-join! thread . args) (apply join-thread (cons thread args)))

;; MUTEXES

(define make-mutex
  (lambda name
    (let ((n (and (pair? name) (car name)))
	  (m ((@ (guile) make-mutex))))
      (and n (hashq-set! object-names m n)) m)))

(define (mutex-name mutex)
  (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))

(define (mutex-specific mutex)
  (hashq-ref object-specifics 
	     (check-arg-type mutex? mutex "mutex-specific")))

(define (mutex-specific-set! mutex obj)
  (hashq-set! object-specifics
	      (check-arg-type mutex? mutex "mutex-specific-set!")
	      obj)
  (unspecified))

(define (mutex-lock! mutex . args) (apply lock-mutex (cons mutex args)))
  
(define (mutex-unlock! mutex . args) (apply unlock-mutex (cons mutex args)))

;; CONDITION VARIABLES

(define make-condition-variable
  (lambda name
    (let ((n (and (pair? name) (car name)))
	  (m ((@ (guile) make-condition-variable))))
      (and n (hashq-set! object-names m n)) m)))

(define (condition-variable-name condition-variable)
  (hashq-ref object-names (check-arg-type condition-variable? 
					  condition-variable
					  "condition-variable-name")))

(define (condition-variable-specific condition-variable)
  (hashq-ref object-specifics (check-arg-type condition-variable? 
					      condition-variable 
					      "condition-variable-specific")))

(define (condition-variable-specific-set! condition-variable obj)
  (hashq-set! object-specifics
	      (check-arg-type condition-variable? 
			      condition-variable 
			      "condition-variable-specific-set!")
	      obj)
  (unspecified))

(define (condition-variable-signal! cond) 
  (signal-condition-variable cond) 
  (unspecified))

(define (condition-variable-broadcast! cond)
  (broadcast-condition-variable cond)
  (unspecified))

;; TIME

(define current-time gettimeofday)
(define (time? obj)
  (and (pair? obj)
       (let ((co (car obj))) (and (integer? co) (>= co 0)))
       (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))

(define (time->seconds time) 
  (and (check-arg-type time? time "time->seconds")
       (+ (car time) (/ (cdr time) 1000000))))

(define (seconds->time x)
  (and (check-arg-type number? x "seconds->time")
       (let ((fx (truncate x)))
	 (cons (inexact->exact fx)
	       (inexact->exact (truncate (* (- x fx) 1000000)))))))

;; srfi-18.scm ends here

[-- Attachment #4: srfi-18.test --]
[-- Type: application/octet-stream, Size: 14775 bytes --]

;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26
;;;;
;;;; Copyright (C) 2007 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-suite test-srfi-18)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-18))

(with-test-prefix "current-thread"

  (pass-if "current-thread eq current-thread"
    (eq? (current-thread) (current-thread))))

(with-test-prefix "thread?"

  (pass-if "current-thread is thread"
    (thread? (current-thread)))

  (pass-if "foo not thread"
    (not (thread? 'foo))))

(with-test-prefix "make-thread"

  (pass-if "make-thread creates new thread"
    (let* ((n (length (all-threads)))
	   (t (make-thread (lambda () 'foo) 'make-thread-1))
	   (r (> (length (all-threads)) n)))
      (thread-terminate! t) r)))

(with-test-prefix "thread-name"

  (pass-if "make-thread with name binds name"
    (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
	   (r (eq? (thread-name t) 'thread-name-1)))
      (thread-terminate! t) r))

  (pass-if "make-thread without name does not bind name"
    (let* ((t (make-thread (lambda () 'foo)))
	   (r (not (thread-name t))))
      (thread-terminate! t) r)))

(with-test-prefix "thread-specific"

  (pass-if "thread-specific is initially #f"
    (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
	   (r (not (thread-specific t))))
      (thread-terminate! t) r))

  (pass-if "thread-specific-set! can set value"
    (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
      (thread-specific-set! t "hello")
      (let ((r (equal? (thread-specific t) "hello")))
	(thread-terminate! t) r))))

(with-test-prefix "thread-start!"

  (pass-if "thread activates only after start" 
    (let* ((started #f)
	   (m (make-mutex 'thread-start-mutex))
	   (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
      (and (not started) (thread-start! t) (thread-join! t) started))))

(with-test-prefix "thread-yield!"

  (pass-if "thread yield suceeds"
    (thread-yield!) #t))

(with-test-prefix "thread-sleep!"

  (pass-if "thread sleep with time"
    (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
      (unspecified? (thread-sleep! future-time))))

  (pass-if "thread sleep with number"
    (let ((old-secs (car (current-time))))
      (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))

  (pass-if "thread does not sleep on past time"
    (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
      (unspecified? (thread-sleep! past-time)))))

(with-test-prefix "thread-terminate!"
  
  (pass-if "termination destroys non-started thread"
    (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
	  (num-threads (length (all-threads)))
	  (success #f))
      (thread-terminate! t)
      (catch 'thread-terminated-exception
	     (lambda () (thread-join! t))
	     (lambda args (set! success #t)))
      success))

  (pass-if "termination destroys started thread"
    (let ((t (make-thread (lambda () (sleep 100)) 'thread-terminate-2))
	  (num-threads (length (all-threads)))
	  (success #f))
      (thread-start! t)
      (thread-terminate! t)
      (catch 'thread-terminated-exception
	     (lambda () (thread-join! t))
	     (lambda args (set! success #t)))
      success)))

(with-test-prefix "thread-join!"

  (pass-if "join receives result of thread"
    (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
      (thread-start! t)
      (eq? (thread-join! t) 'foo)))

  (pass-if "join receives timeout val if timeout expires"
    (let ((t (make-thread (lambda () (sleep 100) 'foo) 'thread-join-2)))
      (thread-start! t)
      (let ((r (thread-join! t (current-time) 'bar)))
	(thread-terminate! t)
	(eq? r 'bar))))

  (pass-if "join throws exception on timeout without timeout val"
    (let ((t (make-thread (lambda () (sleep 100) 'foo) 'thread-join-3))
	  (success #f))
      (thread-start! t)
      (catch 'join-timeout-exception
	     (lambda () (thread-join! t (current-time)))
	     (lambda args (set! success #t)))
      (thread-terminate! t)
      success))

  (pass-if "join waits on timeout"
    (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
      (thread-start! t)
      (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))

(with-test-prefix "mutex?"

  (pass-if "make-mutex creates mutex"
    (mutex? (make-mutex)))

  (pass-if "symbol not mutex"
    (not (mutex? 'foo))))

(with-test-prefix "mutex-name"

  (pass-if "make-mutex with name binds name"
    (let* ((m (make-mutex 'mutex-name-1)))
      (eq? (mutex-name m) 'mutex-name-1)))

  (pass-if "make-mutex without name does not bind name"
    (let* ((m (make-mutex)))
      (not (mutex-name m)))))

(with-test-prefix "mutex-specific"

  (pass-if "mutex-specific is initially #f"
    (let ((m (make-mutex 'mutex-specific-1)))
      (not (mutex-specific m))))

  (pass-if "mutex-specific-set! can set value"
    (let ((m (make-mutex 'mutex-specific-2)))
      (mutex-specific-set! m "hello")
      (equal? (mutex-specific m) "hello"))))

(with-test-prefix "mutex-state"

  (pass-if "mutex state is initially not-abandoned"
    (let ((m (make-mutex 'mutex-state-1)))
      (eq? (mutex-state m) 'not-abandoned)))

  (pass-if "mutex state of locked, owned mutex is owner thread"
    (let ((m (make-mutex 'mutex-state-2)))
      (mutex-lock! m)
      (eq? (mutex-state m) (current-thread))))
	  
  (pass-if "mutex state of locked, unowned mutex is not-owned"
    (let ((m (make-mutex 'mutex-state-3)))
      (mutex-lock! m #f #f)
      (eq? (mutex-state m) 'not-owned)))

  (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
    (let* ((m (make-mutex 'mutex-state-4))
	   (t (make-thread (lambda () (mutex-lock! m)))))
      (thread-start! t)
      (thread-join! t)
      (eq? (mutex-state m) 'abandoned))))

(with-test-prefix "mutex-lock!"
  
  (pass-if "mutex-lock! returns true on successful lock"
    (let* ((m (make-mutex 'mutex-lock-1)))
      (mutex-lock! m)))

  (pass-if "mutex-lock! returns false on timeout"
    (let* ((m (make-mutex 'mutex-lock-2))
	   (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
      (mutex-lock! m)
      (thread-start! t)
      (not (thread-join! t))))

  (pass-if "mutex-lock! returns true when lock obtained within timeout"
    (let* ((m (make-mutex 'mutex-lock-3))
	   (t (make-thread (lambda () 
			     (mutex-lock! m (+ (time->seconds (current-time)) 
					       100) 
					  #f)))))
      (mutex-lock! m)
      (thread-start! t)
      (mutex-unlock! m)
      (thread-join! t)))

  (pass-if "can lock mutex for non-current thread"
    (let* ((m (make-mutex 'mutex-lock-4))
	   (t (make-thread #f (lambda () 'foo))))
      (mutex-lock! m #f t)
      (thread-terminate! t)
      (eq? (mutex-state m) t)))

  (pass-if "locking abandoned mutex throws exception"
    (let* ((m (make-mutex 'mutex-lock-5))
	   (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
	   (success #f))
      (thread-start! t)
      (thread-join! t)
      (catch 'abandoned-mutex-exception
	     (lambda () (mutex-lock! m))
	     (lambda args (set! success #t)))
      (and success (eq? (mutex-state m) (current-thread)))))

  (pass-if "sleeping threads notified of abandonment"
    (let* ((m (make-mutex 'mutex-lock-6))
	   (c (make-condition-variable 'mutex-lock-6))
	   (t (make-thread (lambda () 
			     (mutex-lock! m)
			     (condition-variable-signal! c))))
	   (success #f))
      (mutex-lock! m)
      (thread-start! t)
      (catch 'abandoned-mutex-exception
	     (lambda () (wait-condition-variable c m))
	     (lambda args (set! success #t)))
      (mutex-unlock! m))))

(with-test-prefix "mutex-unlock!"
   
  (pass-if "unlock changes mutex state"
    (let* ((m (make-mutex 'mutex-unlock-1)))
      (mutex-lock! m)
      (mutex-unlock! m)
      (eq? (mutex-state m) 'not-abandoned)))

  (pass-if "can unlock from any thread"
    (let* ((m (make-mutex 'mutex-unlock-2))
	   (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
      (mutex-lock! m)
      (thread-start! t)
      (thread-join! t)
      (eq? (mutex-state m) 'not-abandoned)))

  (pass-if "mutex unlock is true when condition is signalled"
    (let* ((m (make-mutex 'mutex-unlock-3))
	   (c (make-condition-variable 'mutex-unlock-3))
	   (t (make-thread (lambda () 
			     (mutex-lock! m) 
			     (condition-variable-signal! c) 
			     (mutex-unlock! m)))))
      (mutex-lock! m)
      (thread-start! t)
      (mutex-unlock! m c)))

  (pass-if "mutex unlock is false when condition times out"
    (let* ((m (make-mutex 'mutex-unlock-4))
	   (c (make-condition-variable 'mutex-unlock-4)))
      (mutex-lock! m)
      (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))

(with-test-prefix "condition-variable?"

  (pass-if "make-condition-variable creates condition variable"
    (condition-variable? (make-condition-variable)))

  (pass-if "symbol not condition variable"
    (not (condition-variable? 'foo))))

(with-test-prefix "condition-variable-name"

  (pass-if "make-condition-variable with name binds name"
    (let* ((c (make-condition-variable 'condition-variable-name-1)))
      (eq? (condition-variable-name c) 'condition-variable-name-1)))

  (pass-if "make-condition-variable without name does not bind name"
    (let* ((c (make-condition-variable)))
      (not (condition-variable-name c)))))

(with-test-prefix "condition-variable-specific"

  (pass-if "condition-variable-specific is initially #f"
    (let ((c (make-condition-variable 'condition-variable-specific-1)))
      (not (condition-variable-specific c))))

  (pass-if "condition-variable-specific-set! can set value"
    (let ((c (make-condition-variable 'condition-variable-specific-1)))
      (condition-variable-specific-set! c "hello")
      (equal? (condition-variable-specific c) "hello"))))

(with-test-prefix "condition-variable-signal!"
  
  (pass-if "condition-variable-signal! wakes up single thread"
    (let* ((m (make-mutex 'condition-variable-signal-1))
	   (c (make-condition-variable 'condition-variable-signal-1))
	   (t (make-thread (lambda () 
			     (mutex-lock! m) 
			     (condition-variable-signal! c) 
			     (mutex-unlock! m)))))
      (mutex-lock! m)
      (thread-start! t)
      (mutex-unlock! m c))))

(with-test-prefix "condition-variable-broadcast!"

  (pass-if "condition-variable-broadcast! wakes up multiple threads"
    (let* ((sem 0)
	   (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
	   (m1 (make-mutex 'condition-variable-broadcast-1-a))
	   (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
	   (m2 (make-mutex 'condition-variable-broadcast-1-b))
	   (inc-sem! (lambda () 
		       (mutex-lock! m1)
		       (set! sem (+ sem 1))
		       (condition-variable-broadcast! c1)
		       (mutex-unlock! m1)))
	   (dec-sem! (lambda ()
		       (mutex-lock! m1)
		       (while (eqv? sem 0) (wait-condition-variable c1 m1))
		       (set! sem (- sem 1))
		       (mutex-unlock! m1)))
	   (t1 (make-thread (lambda () 
			      (mutex-lock! m2)
			      (inc-sem!)
			      (mutex-unlock! m2 c2)
			      (inc-sem!))))
	   (t2 (make-thread (lambda () 
			      (mutex-lock! m2)
			      (inc-sem!)
			      (mutex-unlock! m2 c2)
			      (inc-sem!)))))
      (thread-start! t1)
      (thread-start! t2)
      (dec-sem!)
      (dec-sem!)
      (mutex-lock! m2)
      (condition-variable-broadcast! c2)
      (mutex-unlock! m2)
      (dec-sem!)
      (dec-sem!))))

(with-test-prefix "time?"

  (pass-if "current-time is time" (time? (current-time)))
  (pass-if "number is not time" (not (time? 123)))
  (pass-if "symbol not time" (not (time? 'foo))))

(with-test-prefix "time->seconds"

  (pass-if "time->seconds makes time into rational"
    (rational? (time->seconds (current-time))))

  (pass-if "time->seconds is reversible"
    (let ((t (current-time)))
      (equal? t (seconds->time (time->seconds t))))))

(with-test-prefix "seconds->time"

  (pass-if "seconds->time makes rational into time"
    (time? (seconds->time 123.456)))

  (pass-if "seconds->time is reversible"
    (let ((t (time->seconds (current-time))))
      (equal? t (time->seconds (seconds->time t))))))

(with-test-prefix "current-exception-handler"

  (pass-if "current handler returned at top level"
    (procedure? (current-exception-handler)))

  (pass-if "specified handler set under with-exception-handler"
    (let ((h (lambda (key . args) 'nothing)))
      (with-exception-handler h (lambda () (eq? (current-exception-handler) 
						h)))))

  (pass-if "multiple levels of handler nesting"
    (let ((h (lambda (key . args) 'nothing))
	  (i (current-exception-handler)))
      (and (with-exception-handler h (lambda () 
				       (eq? (current-exception-handler) h)))
	   (eq? (current-exception-handler) i))))

  (pass-if "exception handler installation is thread-safe"
    (let* ((h1 (current-exception-handler))
	   (h2 (lambda (key . args) 'nothing-2))
	   (m (make-mutex 'current-exception-handler-4))
	   (c (make-condition-variable 'current-exception-handler-4))
	   (t (make-thread (lambda () 
			     (with-exception-handler 
			      h2 (lambda () 
				   (mutex-lock! m) 
				   (condition-variable-signal! c) 
				   (wait-condition-variable c m)
				   (and (eq? (current-exception-handler) h2)
					(mutex-unlock! m)))))
			   'current-exception-handler-4)))
      (mutex-lock! m)
      (thread-start! t)
      (wait-condition-variable c m)
      (and (eq? (current-exception-handler) h1)
	   (condition-variable-signal! c)
	   (mutex-unlock! m)
	   (thread-join! t)))))

(with-test-prefix "uncaught-exception-reason"

  (pass-if "initial handler captures top level exception"
    (let ((t (make-thread (lambda () (throw 'foo))))
	  (success #f))
      (thread-start! t)
      (catch 'uncaught-exception
	     (lambda () (thread-join! t))
	     (lambda args 
	       (and (eq? (car (uncaught-exception-reason args)) 'foo)
		    (set! success #t))))
      success)))

(exit)

[-- Attachment #5: Type: text/plain, Size: 143 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel