Re: srfi-18 requirements

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

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

Hi everyone,

Thanks for your comments and patience.  I've attached a new version of
my SRFI-18 patch which I hope addresses the stuff that Ludovic raised.
 Sorry it's taken so long!  In real life, I've been hung up on freeing
myself from the entanglements of one full-time job and getting wrapped
up in those of another.  At any rate:


> My comments below are mostly cosmetic.  Once you're done with them,
> could you please provide a ChangeLog entry?

Of course.  Please find relevant updates included in the revised patch.


> Then we'll need to update the doc of the core API, and also add
> documentation of the SRFI module itself (the custom has been to somewhat
> duplicate SRFIs in the manual so that we have all documentation in one
> place).

Sure, I'll do that -- I just wanted to make sure the scope of the
patch was well-established before I wrote anything.


> `threads.test' doesn't need to be updated because threads don't throw
> exceptions, right?

Right, sort of: doing 'join-thread' on a thread that has been canceled
via the SRFI-18 'terminate-thread!' function will throw a
thread-terminated-exception (terminate-thread! installs a special
cleanup handler right before exiting that does this). But everything
related to cancellation in threads.test uses cancel-thread, which does
not cause an exception to be thrown, and none of the other tests
involve exception handling.


> I don't quite get this one.  Could you illustrate the problem
> step-by-step with a simple scenario?
>
> The value of HANDLER in `scm_spawn_thread ()' doesn't seem to affect
> critical-section locking.

Maybe I should have said the problem lies in really_spawn() -- if
data->handler is non-NULL, then really_spawn() enters the thread's
body via scm_internal_catch() instead of directly.
scm_internal_catch() calls scm_c_catch(), which calls make_jmpbuf(),
which enters a critical section, leading to the deadlock. Here's the
sequence of events that I was experiencing (surprisingly often):

Thread 1, in guile-mode (heap mutex locked) launches Thread 2
Thread 2 enters a critical section, locking the critical section mutex
Thread 1, as part of expression evaluation in eval.i.c, attempts to
lock the critical section and blocks
Thread 2, as part of make_jmpbuf, calls SCM_NEWSMOB2, leading to a
call to scm_double_cell, which causes a GC. Thread 2 attempts to lock
the heap mutex of all executing threads, but Thread 1's heap mutex
will never be unlocked


I've subsequently discovered and fixed a separate (quasi-) deadlock,
also-preexisting, this time related to a lack of thread safety
surrounding the usage of scm_thread_go_to_sleep -- in short, there can
be a race on the value of scm_thread_go_to_sleep such that a thread
can continue to enter and leave guile-mode even while
scm_i_thread_put_to_sleep is trying to put it to sleep for GC.  The
fix is to require that threads hold the thread_admin_mutex while
locking their heap_mutexes in scm_enter_guile, so that they don't
inadvertantly re-enter guile-mode during a GC attempt.  I can give you
an example if you'd like.


> Don't do that, we must keep all years.

Fixed.


> In `block_self ()':
>
>> @@ -239,6 +265,7 @@
>>  	err = EINTR;
>>        t->block_asyncs--;
>>        scm_i_reset_sleep (t);
>> +      scm_i_pthread_cleanup_pop (0);
>>      }
>
> Why is it needed?

I'm not sure what you mean. In a literal sense, I pop the cleanup
handler because I installed it a few lines earlier. More generally,
the reason I added the handler was because scm_i_pthread_cond_wait is
a cancellation point, and scm_i_setup_sleep has just been called -- if
the thread is canceled while in cond_wait, the sleep state will never
be reset. This may not be a critical issue (or it may be -- I added
this code while I was chasing down an unrelated deadlock), but it
makes for better thread bookkeeping.


>> +extern scm_i_thread *scm_i_signal_delivery_thread;
>
> Could it go in one of `{threads,scmsigs}.h'?

Yes -- I'd meant to include that in the original patch.  Sorry!  It's
in scmsigs.h now.


>> +typedef struct {
>
> Make sure to follow the GCS, i.e., put the opening brace on a line of
> its own.

Fixed for all occurences.


>> -  /* 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 ();
>> +
>
> Why does that need to be moved?

It doesn't -- thanks for catching that.  I was trying to resolve a
deadlock related to the one described above that I ultimately fixed by
removing the catch handler for the signal delivery thread.


> +SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0,
>
> Scheme/C name mismatch.  I believe it effectively hides the first
> `join-thread', right?

Yes, I put it there to override the binding of join-thread.  Is that a
problem? I do it several other places, too.  I wasn't sure how else to
maintain binary compatibility for users of scm_join_thread while
extending the functionality of the Scheme 'join-thread' function.
Would it be better if I removed the first SCM_DEFINE (the one that
refers to scm_join_thread()) and replaced it with a normal function
declaration for scm_join_thread()?


>> +"Suspend execution of the calling thread until the target @var{thread} "
>
> Indenting would be nicer.

You mean indenting the doc strings so that they line up with the
parentheses?  None of the other functions do this.  (And is this
documentation actually used to generate anything?)


> Remember spaces after periods.  :-)

Fixed for all occurences.


> Open bracket right after `block_self'.

Fixed for all occurences.


> Too bad we have yet another time API...
> ... and another exception API, too.

Yeah... such is the nature of SRFIs, though.  Anything you want me to
change here -- other than the exception handling described below?


> We have `*unspecified*' in core Guile, which is better because it
> doesn't have any side-effect, so better use it.

Ah, excellent -- didn't know that was there!  Fixed.  (Can we put that
in the manual index?)


> I'd use pairs or records for exception objects rather than just symbols
> since symbols can always be forged.  So we'd have, e.g.:

I hadn't thought of that!  Done, though it took a while.  SRFI-18
exception throwing and handling are now pass-thrus to SRFI-34.  There
was a bit of difficulty in that Guile's implementation of SRFI-34
causes exceptions to get rethrown at the end of the handler, whereas
SRFI-18 requires that the handler re-enter the continuation of the
called primitive afterwards.  I've resolved that by wrapping any
installed user handlers such that they store and then apply their
caller's continuation.


> Type-checking overhead may become a concern if we are to convert values
> often, e.g., once after every timed-join trial.  OTOH, it's good to have
> good error reporting.

So... do you have a ruling, one way or the other?  For what it's
worth, my opinion is that API exposed to the user must always feature
input-checking, but I defer to your maintainer wisdom.


Regards,
Julian

[-- Attachment #2: srfi-18.HEAD.patch-20071217 --]
[-- Type: application/octet-stream, Size: 36772 bytes --]

Index: libguile/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2420
diff -a -u -r1.2420 ChangeLog
--- libguile/ChangeLog	8 Dec 2007 16:00:56 -0000	1.2420
+++ libguile/ChangeLog	18 Dec 2007 04:18:50 -0000
@@ -1,3 +1,53 @@
+2007-12-17  Julian Graham  <joolean@mail.com>
+
+	Add support for SRFI-18.
+	
+	* scmsigs.c (start_signal_delivery_thread): Don't call scm_spawn_thread
+	with a handler; it can lead to deadlock.
+	* threads.c (scm_to_timespec, scm_join_thread_timed, scm_thread_p, 
+	scm_lock_mutex_timed, scm_unlock_mutex_timed, scm_mutex_state, 
+	scm_mutex_p, scm_condition_variable_p, fat_mutex_state): New functions.
+	(thread_mark): Updated to mark new struct fields `mutexes' and
+	`exception'.
+	(block_self): `Use scm_i_thread_cleanup_push' to call 
+	`scm_i_reset_sleep' if the thread is canceled during 
+	`scm_i_scm_cond_wait'.
+	(unblock_from_queue): Return `SCM_UNDEFINED' when the queue is empty,
+	instead of of `SCM_BOOL_F'.
+	(fat_cond_broadcast): Likewise.
+	(scm_enter_guile): Lock `thread_admin_mutex' when entering guile mode
+	to prevent a race during GC.
+	(scm_srfi_34_exception_key, scm_uncaught_exception_key, 
+	scm_join_timeout_exception_key, scm_abandoned_mutex_exception_key, 
+	scm_terminated_thread_exception_key): Bindings for unique SRFI-18
+	exception objects.
+	(exception_preserve_catch_handler): New function, to be used in place 
+	of existing exception handlers to handle exceptions at the base of a
+	thread's stack.
+	(do_thread_exit, really_launch): Likewise.
+	(do_thread_exit, scm_cancel_thread, scm_set_thread_cleanup_x, 
+	scm_thread_cleanup, fat_mutex_unlock): Lock on thread-specific admin 
+	mutex instead of `thread_admin_mutex'.
+	(do_thread_exit): Notify threads waiting on mutexes locked by exiting 
+	thread.
+	(scm_join_thread, scm_mutex_lock, scm_mutex_unlock): Reimplement in
+	terms of their new, timed counterparts.
+	(scm_mutex_state_not_owned, scm_mutex_state_abandoned, 
+	scm_mutex_state_not_abandoned): Bindings for SRFI-18 mutex states.
+	(make_fat_mutex): Use `SCM_UNDEFINED' instead of `SCM_BOOL_F' to 
+	indicate an unlocked mutex.
+	(fat_mutex_lock): Reimplement in terms of SRFI-18 mutex states.
+	(fat_mutex_unlock): Allow unlocking from other threads as per SRFI-18.
+	(fat_cond_timedwait): Updated to match fat_mutex_unlock return
+	signature.
+	(scm_timed_wait_condition_variable): Updated to use scm_to_timespec.
+	(scm_init_threads): Added initialization for new global symbols.
+	* threads.h (scm_i_thread)[admin_mutex, mutexes, exception]: New 
+	fields.
+	(scm_join_thread_timed, scm_thread_p, scm_lock_mutex_timed,
+	scm_unlock_mutex_timed, scm_mutex_state, scm_mutex_p, 
+	scm_condition_variable_p): Prototypes for new functions.
+	
 2007-12-08  Ludovic Courtès  <ludo@gnu.org>
 
 	* __scm.h (SCM_EXPECT, SCM_LIKELY, SCM_UNLIKELY): New macros.
Index: libguile/scmsigs.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/scmsigs.c,v
retrieving revision 1.98
diff -a -u -r1.98 scmsigs.c
--- libguile/scmsigs.c	20 Oct 2007 11:09:58 -0000	1.98
+++ libguile/scmsigs.c	18 Dec 2007 04:18:56 -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: libguile/threads.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.90
diff -a -u -r1.90 threads.c
--- libguile/threads.c	20 Oct 2007 11:09:58 -0000	1.90
+++ libguile/threads.c	18 Dec 2007 04:18:58 -0000
@@ -49,6 +49,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 +61,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 +153,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 +236,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 +249,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 +266,7 @@
 	err = EINTR;
       t->block_asyncs--;
       scm_i_reset_sleep (t);
+      scm_i_pthread_cleanup_pop (0);
     }
 
   return err;
@@ -246,15 +274,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.
@@ -368,15 +401,22 @@
 }
 
 typedef void* scm_t_guile_ticket;
+static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 static void
 scm_enter_guile (scm_t_guile_ticket ticket)
 {
-  scm_i_thread *t = (scm_i_thread *)ticket;
+  scm_i_thread *t = (scm_i_thread *) ticket;
   if (t)
     {
+      /* The admin mutex must be locked here to prevent the thread from
+	 entering guile-mode after scm_thread_go_to_sleep has been set to 1 in
+	 scm_i_thread_go_to_sleep. */
+
+      scm_i_pthread_mutex_lock (&thread_admin_mutex);
       scm_i_pthread_mutex_lock (&t->heap_mutex);
       resume (t);
+      scm_i_pthread_mutex_unlock (&thread_admin_mutex);
     }
 }
 
@@ -401,7 +441,6 @@
   return (scm_t_guile_ticket) t;
 }
 
-static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 static scm_i_thread *all_threads = NULL;
 static int thread_count;
 
@@ -417,7 +456,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 +476,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 +519,47 @@
   t->block_asyncs = 0;
 }
 
+/*** Built-in SRFI-18 / SRFI-34 exception types */
+
+SCM scm_srfi_34_exception_key;
+SCM scm_uncaught_exception_key;
+SCM scm_join_timeout_exception_key;
+SCM scm_abandoned_mutex_exception_key;
+SCM scm_terminated_thread_exception_key;
+
+static SCM
+exception_preserve_catch_handler (void *data, SCM tag, SCM throw_args)
+{
+  scm_i_thread *t = (scm_i_thread *) data;
+
+  /* This code is mainly for SRFI-18 support: An exception that makes it to 
+     this level of the handler stack should be preserved for joining threads if
+     it is a terminated thread exception (resulting from SRFI-18 
+     thread-terminate!) or if it is wrapped in a SRFI-18 uncaught exception 
+     wrapper. */
+
+  if (scm_is_pair (throw_args) &&
+      (scm_is_eq (SCM_CAR (throw_args), scm_terminated_thread_exception_key) ||
+       (scm_is_pair (SCM_CAR (throw_args)) && 
+	scm_is_eq (SCM_CAAR (throw_args), scm_uncaught_exception_key)))) 
+    {
+      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 +570,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;
 }
@@ -751,7 +843,8 @@
 
 /*** Thread creation */
 
-typedef struct {
+typedef struct 
+{
   SCM parent;
   SCM thunk;
   SCM handler;
@@ -775,7 +868,9 @@
   scm_i_pthread_mutex_unlock (&data->mutex);
 
   if (SCM_UNBNDP (handler))
-    t->result = scm_call_0 (thunk);
+    t->result = scm_internal_catch (SCM_BOOL_T, 
+				    (scm_t_catch_body) scm_call_0, thunk,
+				    exception_preserve_catch_handler, t);
   else
     t->result = scm_catch (SCM_BOOL_T, thunk, handler);
 
@@ -835,7 +930,8 @@
 }
 #undef FUNC_NAME
 
-typedef struct {
+typedef struct 
+{
   SCM parent;
   scm_t_catch_body body;
   void *body_data;
@@ -922,7 +1018,7 @@
 
 SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0,
 	    (SCM thread),
-"Asynchronously force the target @var{thread} to terminate. @var{thread} "
+"Asynchronously force the target @var{thread} to terminate.  @var{thread} "
 "cannot be the current thread, and if @var{thread} has already terminated or "
 "been signaled to terminate, this function is a no-op.")
 #define FUNC_NAME s_scm_cancel_thread
@@ -931,15 +1027,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 +1051,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 +1071,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 +1085,83 @@
 "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_list_2 (scm_srfi_34_exception_key,
+				 scm_join_timeout_exception_key);
+	      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 +1175,37 @@
    debugging.
 */
 
-typedef struct {
+#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 +1242,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 +1268,146 @@
 }
 #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_BOOL_F;
+  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))
-    {
-      if (m->level >= 0)
-	m->level++;
-      else
-	msg = "mutex already locked by current thread";
-    }
-  else
+  state = fat_mutex_state (m);
+  while (try_lock)
     {
-      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
+		err = scm_cons (scm_misc_error_key,
+				scm_from_locale_string ("mutex already locked "
+							"by thread"));
+	      *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_srfi_34_exception_key,
+			 scm_abandoned_mutex_exception_key);
+	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_from_locale_string ("specified thread is "
+							"no longer active"));
+	      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 "
-"blocks until the mutex becomes available. The function returns when "
-"the calling thread owns the lock on @var{mutex}.  Locking a mutex that "
+	    (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{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_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
 
@@ -1175,7 +1428,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))
     {
@@ -1192,7 +1445,7 @@
 
 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 "
+"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
 {
@@ -1208,46 +1461,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 +1592,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 +1640,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 +1697,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 +1728,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 +1744,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
@@ -1789,6 +2094,32 @@
 void
 scm_init_threads ()
 {
+  /* Unique value definitions for SRFI-18 and SRFI-34 exception types. */
+
+  scm_srfi_34_exception_key = scm_from_locale_symbol ("srfi-34");
+  scm_permanent_object (scm_srfi_34_exception_key);
+  scm_uncaught_exception_key = 
+    scm_cons (scm_from_locale_symbol ("uncaught-exception"), SCM_BOOL_F);
+  scm_permanent_object (scm_uncaught_exception_key);
+  scm_join_timeout_exception_key = 
+    scm_cons (scm_from_locale_symbol ("join-timeout-exception"), SCM_BOOL_F);
+  scm_permanent_object (scm_join_timeout_exception_key);
+  scm_abandoned_mutex_exception_key =
+    scm_cons (scm_from_locale_symbol ("abandoned-mutex-exception"), 
+	      SCM_BOOL_F);
+  scm_permanent_object (scm_abandoned_mutex_exception_key);
+  scm_terminated_thread_exception_key =
+    scm_cons (scm_from_locale_symbol ("terminated-thread-exception"),
+	      SCM_BOOL_F);
+  scm_permanent_object (scm_terminated_thread_exception_key);
+  
+  scm_c_define ("uncaught-exception", scm_uncaught_exception_key);
+  scm_c_define ("join-timeout-exception", scm_join_timeout_exception_key);
+  scm_c_define ("abandoned-mutex-exception", 
+		scm_abandoned_mutex_exception_key);
+  scm_c_define ("terminated-thread-exception",
+		scm_terminated_thread_exception_key);
+
   scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread));
   scm_set_smob_mark (scm_tc16_thread, thread_mark);
   scm_set_smob_print (scm_tc16_thread, thread_print);
@@ -1806,6 +2137,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: libguile/threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v
retrieving revision 1.49
diff -a -u -r1.49 threads.h
--- libguile/threads.h	20 Oct 2007 11:09:58 -0000	1.49
+++ libguile/threads.h	18 Dec 2007 04:18:58 -0000
@@ -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);
Index: srfi/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/srfi/ChangeLog,v
retrieving revision 1.200
diff -a -u -r1.200 ChangeLog
--- srfi/ChangeLog	13 Dec 2007 12:27:37 -0000	1.200
+++ srfi/ChangeLog	18 Dec 2007 04:19:00 -0000
@@ -1,3 +1,8 @@
+2007-12-17  Julian Graham  <joolean@gmail.com>
+
+	* srfi-18.scm: New file.
+	* Makefile.am (srfi_DATA): Added `srfi-18.scm'.
+
 2007-12-13  Stephen Compall  <s11@member.fsf.org>
 
 	* srfi-69.scm (without-keyword-args): Use `cdr' instead of
Index: srfi/Makefile.am
===================================================================
RCS file: /sources/guile/guile/guile-core/srfi/Makefile.am,v
retrieving revision 1.37
diff -a -u -r1.37 Makefile.am
--- srfi/Makefile.am	3 Dec 2007 12:36:12 -0000	1.37
+++ srfi/Makefile.am	18 Dec 2007 04:19:00 -0000
@@ -75,6 +75,7 @@
             srfi-14.scm \
 	    srfi-16.scm \
             srfi-17.scm \
+            srfi-18.scm \
             srfi-19.scm \
             srfi-26.scm \
             srfi-31.scm \
Index: test-suite/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/test-suite/ChangeLog,v
retrieving revision 1.411
diff -a -u -r1.411 ChangeLog
--- test-suite/ChangeLog	13 Dec 2007 12:27:37 -0000	1.411
+++ test-suite/ChangeLog	18 Dec 2007 04:19:03 -0000
@@ -1,3 +1,8 @@
+2007-12-17  Julian Graham  <joolean@gmail.com>
+
+	* tests/srfi-18.test: New file.
+	* Makefile.am (SCM_TESTS): Added `tests/srfi-18.test'.
+
 2007-12-13  Stephen Compall  <s11@member.fsf.org>
 
 	* tests/srfi-69.test (SRFI-69)[can use all arguments, including
Index: test-suite/Makefile.am
===================================================================
RCS file: /sources/guile/guile/guile-core/test-suite/Makefile.am,v
retrieving revision 1.43
diff -a -u -r1.43 Makefile.am
--- test-suite/Makefile.am	3 Dec 2007 12:36:12 -0000	1.43
+++ test-suite/Makefile.am	18 Dec 2007 04:19:03 -0000
@@ -72,6 +72,7 @@
 	    tests/srfi-11.test			\
 	    tests/srfi-13.test			\
 	    tests/srfi-14.test			\
+	    tests/srfi-18.test			\
 	    tests/srfi-19.test			\
 	    tests/srfi-26.test			\
 	    tests/srfi-31.test			\

[-- Attachment #3: srfi-18.test --]
[-- Type: application/octet-stream, Size: 14903 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)
      (with-exception-handler 
       (lambda (obj) (set! success (terminated-thread-exception? obj)))
       (lambda () (thread-join! 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)
      (with-exception-handler
       (lambda (obj) (set! success (terminated-thread-exception? obj)))
       (lambda () (thread-join! 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)
      (with-exception-handler
       (lambda (obj) (set! success (join-timeout-exception? obj)))
       (lambda () (thread-join! t (current-time))))
      (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)
      (with-exception-handler
       (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
       (lambda () (mutex-lock! m)))
      (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)
      (with-exception-handler
       (lambda (obj) (set! success (abandoned-mutex-exception? key)))
       (lambda () (wait-condition-variable c m)))
      (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 () (raise 'foo))))
	  (success #f))
      (thread-start! t)
      (with-exception-handler
       (lambda (obj)
	 (and (uncaught-exception? obj)
	      (eq? (uncaught-exception-reason obj) 'foo)
	      (set! success #t)))
       (lambda () (thread-join! t)))
      success)))

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: srfi-18.scm --]
[-- Type: text/x-scheme; name=srfi-18.scm, Size: 10427 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 
	    make-thread 
	    make-mutex 
	    make-condition-variable
	    raise)
  :use-module (srfi srfi-34)
  )

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

(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 raise (@ (srfi srfi-34) raise))

(define (initial-handler obj) (raise (cons uncaught-exception obj)))

(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))
    (apply (@ (srfi srfi-34) with-exception-handler) 
	   (list (lambda (obj)
		   (hashq-set! thread-exception-handlers ct hl) 
		   (handler obj))
		 (lambda () 
		   (let ((r (thunk)))
		     (hashq-set! thread-exception-handlers ct hl) r))))))

(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 (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")))
(define (terminated-thread-exception? obj) 
  (eq? obj terminated-thread-exception))

;; THREADS

;; Create a new thread and prevent it from starting using a condition variable.
;; Once started, install a top-level exception handler that rethrows any 
;; exceptions wrapped in an uncaught-exception wrapper. 

(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)
			       (with-exception-handler initial-handler
						       thunk)))))
    (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*))

;; A convenience function for installing exception handlers on SRFI-18 
;; primitives that resume the calling continuation after the handler is 
;; invoked -- this resolves a behavioral incompatibility with Guile's
;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
;; exceptions.  (SRFI-18, "Primitives and exceptions")

(define (wrap thunk)
  (lambda (continuation)
    (with-exception-handler (lambda (obj)
			      (apply (current-exception-handler) (list obj))
			      (apply continuation (list)))
			    thunk)))

;; A pass-thru to cancel-thread that first installs a handler that throws
;; terminated-thread exception, as per SRFI-18, 

(define (thread-terminate! thread)
  (define (thread-terminate-inner!)
    (let ((current-handler (thread-cleanup thread)))
      (if (thunk? current-handler)
	  (set-thread-cleanup! thread 
			       (lambda ()
				 (with-exception-handler initial-handler
							 current-handler) 
				 (raise terminated-thread-exception)))
	  (set-thread-cleanup! thread 
			       (lambda () 
				 (raise terminated-thread-exception))))
      (cancel-thread thread)
      *unspecified*))
  (thread-terminate-inner!))

(define (thread-join! thread . args) 
  (define thread-join-inner!
    (wrap (lambda () (apply join-thread (cons thread args)))))
  (call/cc thread-join-inner!))

;; MUTEXES
;; These functions are all pass-thrus to the existing Guile implementations.

(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) 
  (define mutex-lock-inner!
    (wrap (lambda () (apply lock-mutex (cons mutex args)))))
  (call/cc mutex-lock-inner!))
  
(define (mutex-unlock! mutex . args) (apply unlock-mutex (cons mutex args)))

;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.

(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 #5: Type: text/plain, Size: 143 bytes --]

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