srfi-18 requirements

srfi-18 requirements

[Julian Graham]

Hi guys,

While I was waiting to get my copyright assignment sorted out, I
started trying to figure out what it would take to add SRFI-18
(http://srfi.schemers.org/srfi-18/srfi-18.html) support to Guile.  I
think a lot of it can be safely done in Scheme (mostly by mapping the
SRFI's proposed API onto what's already in Guile), but there are a few
things that'd require further modification to the C core.
Specifically:

* Type predicates: thread?, mutex?, and condition-variable?.

* Mutex state: This kind of needs to happen in C, since we need to
hook the actual lock / unlock calls in order to record the state
changes.

* Mutex unlocking outside the owner thread: The existing
implementation claims the result of doing this is undefined, but what
it actually does is mark the mutex unlocked and then throw an
exception.  I don't really think there's a technical reason to
prohibit this, especially since Guile doesn't use the pthreads mutex
implementation directly.

* Mutex lock timeout: Not really sure how to do this -- maybe add a
pthreads condition variable to the definition of fat_mutex.
Supporting this with the existing lock-mutex code would also require a
breaking change to the C API, and I don't know what the conditions are
(if any) under which that's acceptable.

All this kind of presumes that SRFI-18 is something that the Guile
maintainers care about supporting.  Is it?  I'm afraid I don't know
the Guile project's attitude towards implementing SRFIs.


Regards,
Julian


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

Re: srfi-18 requirements

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

> All this kind of presumes that SRFI-18 is something that the Guile
> maintainers care about supporting.  Is it?  I'm afraid I don't know
> the Guile project's attitude towards implementing SRFIs.

I'm not sure there's an "official position" regarding this.  Personally,
I consider that it's always good to support more SRFIs, at least because
it makes Guile more directly usable by Scheme hackers.

I haven't looked in detail at SRFI-18.  Adding support for it should not
force us to introduce incompatible changes in the core API, though.
Specifying behavior that used to be unspecified might be acceptable, but
changing type predicates isn't, I guess.

Thus, you'd need to pinpoint what can be implemented without changing
the core API (e.g., do the SRFI-18 type predicates really require
changes in the core type predicates, or can they be implemented without
changing the core API?), what requires changes/additions in the core
API, etc.

Thanks,
Ludovic.

PS: BTW, I'll hopefully look at your patch sometime next week.


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

Re: srfi-18 requirements

[Julian Graham]

Hi Ludovic,

> Thus, you'd need to pinpoint what can be implemented without changing
> the core API (e.g., do the SRFI-18 type predicates really require
> changes in the core type predicates, or can they be implemented without
> changing the core API?), what requires changes/additions in the core
> API, etc.

The type predicates would be additions to the core API, not
modifications to it.  The addition of timeouts to the mutex and
condition variable functions could be done by creating new functions
(scm_lock_mutex_timed, scm_wait_condition_variable_timed) instead of
modifying the signatures of the existing ones.  Would that be okay?


Regards,
Julian


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

Re: srfi-18 requirements

[Julian Graham]

Alright, so I've completed the parts of SRFI-18 that absolutely needed
to be written in C.  I didn't modify the signatures of any existing
parts of the API, although I did add some new functions and change
behavior in a few places where I don't think it'll affect too many
people (and which I'll describe at length once I've got things rolled
up into a patch).

Now I'm working on the things that can be implemented in Scheme.
SRFI-18 defines a few functions whose names conflict with some of
Guile's built-in primitives -- e.g., make-mutex and
make-condition-variable -- and which have slightly different behavior
(SRFI-18 make-condition-variable takes an optional argument that you
can use to "name" the condition var).  To work around this, I was
going to create backup bindings of the original primitives and then
refer to them in my scheme reimplementations, a la:

(define guile:make-condition-variable make-condition-variable)
(define (make-condition-variable . foo)
  (let ((m (guile:make-condition-variable))) (do-something)))

...and even if the user noticed the slightly different behavior, that
would be okay, because she'd specifically requested it by loading
(srfi srfi-18).

Unfortunately, it doesn't seem possible to refer to a top-level
primitive function from within a module body.  I get "Unbound
variable: make-condition-variable."  What am I doing wrong?
(Strangely enough, this doesn't seem to be an issue for 'make-mutex'.)


Regards,
Julian


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

Re: srfi-18 requirements

[Stephen Compall]

Julian Graham wrote:
> (SRFI-18 make-condition-variable takes an optional argument that you
> can use to "name" the condition var).  To work around this, I was
> going to create backup bindings of the original primitives and then
> refer to them in my scheme reimplementations, a la:
> 
> (define guile:make-condition-variable make-condition-variable)
> (define (make-condition-variable . foo)
>   (let ((m (guile:make-condition-variable))) (do-something)))
> 
> ...and even if the user noticed the slightly different behavior, that
> would be okay, because she'd specifically requested it by loading
> (srfi srfi-18).

I can always get those if I want them with (@ (guile) 
make-condition-variable).

Also, unless there's a type conflict, I think other existing modules 
simply assume you can deal with more optional arguments than you expect. 
  For example, SRFI-1 adds a third optional argument to assoc, the `=' 
argument.  You can use `#:replace' in define-module to suppress the warning.

-- 
;;; Stephen Compall ** http://scompall.nocandysw.com/blog **
"Peta" is Greek for fifth; a petabyte is 10 to the fifth power, as
well as fifth in line after kilo, mega, giga, and tera.
   -- Lee Gomes, performing every Wednesday in his tech column
      "Portals" on page B1 of The Wall Street Journal


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

Re: srfi-18 requirements

[Julian Graham]

Works like a charm!  Thanks.


On 10/15/07, Stephen Compall <s11@member.fsf.org> wrote:
> Julian Graham wrote:
> > (SRFI-18 make-condition-variable takes an optional argument that you
> > can use to "name" the condition var).  To work around this, I was
> > going to create backup bindings of the original primitives and then
> > refer to them in my scheme reimplementations, a la:
> >
> > (define guile:make-condition-variable make-condition-variable)
> > (define (make-condition-variable . foo)
> >   (let ((m (guile:make-condition-variable))) (do-something)))
> >
> > ...and even if the user noticed the slightly different behavior, that
> > would be okay, because she'd specifically requested it by loading
> > (srfi srfi-18).
>
> I can always get those if I want them with (@ (guile)
> make-condition-variable).
>
> Also, unless there's a type conflict, I think other existing modules
> simply assume you can deal with more optional arguments than you expect.
>   For example, SRFI-1 adds a third optional argument to assoc, the `='
> argument.  You can use `#:replace' in define-module to suppress the warning.


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

Re: srfi-18 requirements

[Julian Graham]

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

Re: srfi-18 requirements

[Julian Graham]

Hi guys,

Just wanted to see if anyone had had a chance to take a look at the
patch I attached to the last message on this thread.  Once again, I
know it's big for a patch (I'd be glad to break it into a few smaller
patches), but about half of it is Scheme code.  I'd be happy to
explain / discuss any aspect of it!


Regards,
Julian


On Oct 29, 2007 9:37 AM, Julian Graham <joolean@gmail.com> wrote:
> 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
>


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

Re: srfi-18 requirements

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

> Just wanted to see if anyone had had a chance to take a look at the
> patch I attached to the last message on this thread.

Sorry, I've been busy over the last weeks, but it's really on my to-do
list for this week, trust me.  :-)

Thanks,
Ludovic.



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

Re: srfi-18 requirements

[Ludovic Courtès]

Hi Julian,

Overall, the patch looks good to me and your explanations were helpful.
The caveat is that I'm not familiar with SRFI-18 and not too comfortable
with these parts of the pthread API that you're wrapping, so I may well
overlook a few things here and there.  I think we'll have to stress-test
the thing on NetBSD since it's good a catching thread-related
programming errors.

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

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


"Julian Graham" <joolean@gmail.com> writes:

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

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

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

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.

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

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

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?

> +extern scm_i_thread *scm_i_signal_delivery_thread;

Could it go in one of `{threads,scmsigs}.h'?

> +typedef struct {

Make sure to follow the GCS, i.e., put the opening brace on a line of
its own.

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

> +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?

> +"Suspend execution of the calling thread until the target @var{thread} "

Indenting would be nicer.

> +"@var{thread} has already terminated. If @var{timeout_val} is specified and "

Remember spaces after periods.  :-)

> +	  int err = block_self 
> +	    (t->join_queue, thread, &t->admin_mutex, timeout_ptr);

Open bracket right after `block_self'.

> ;;; Time
>  current-time
>  time?
>  time->seconds
>  seconds->time

Too bad we have yet another time API...

>  current-exception-handler
>  with-exception-handler
>  raise

... and another exception API, too.

> (define (unspecified) (display ""))

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

> (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")))

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

  (define uncaught-exception?
    (let ((exception-type (cons 'uncaught-exception #f)))
      (lambda (obj)
        (and (pair? obj)
             (eq? (car obj) exception-type)))))

> (define (seconds->time x)
>   (and (check-arg-type number? x "seconds->time")

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.

Thanks,
Ludovic.



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

Re: srfi-18 requirements

[Julian Graham]

Hi Ludovic,

Thanks so much for your comments!  I'll try to address this stuff
tonight.  Stress-testing on NetBSD sounds good!


Thanks,
Julian


On Nov 28, 2007 1:23 PM, Ludovic Courtès <ludo@gnu.org> wrote:
> Hi Julian,
>
> Overall, the patch looks good to me and your explanations were helpful.
> The caveat is that I'm not familiar with SRFI-18 and not too comfortable
> with these parts of the pthread API that you're wrapping, so I may well
> overlook a few things here and there.  I think we'll have to stress-test
> the thing on NetBSD since it's good a catching thread-related
> programming errors.
>
> My comments below are mostly cosmetic.  Once you're done with them,
> could you please provide a ChangeLog entry?
>
> 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).


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

Re: srfi-18 requirements

[Julian Graham]

Hi Ludovic,

I'm almost finished making the changes -- in fact, I've got everything
fixed except for this one:

> 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.:
>
>   (define uncaught-exception?
>     (let ((exception-type (cons 'uncaught-exception #f)))
>       (lambda (obj)
>         (and (pair? obj)
>              (eq? (car obj) exception-type)))))

The thing is, I can't throw with a key that's not a symbol.  I've been
trying to rig up something using SRFI-34-style exceptions (key =
'srfi-34, args = anything) -- provided I can make that work, would
that be okay?


Regards,
Julian


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

Re: srfi-18 requirements

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

> The thing is, I can't throw with a key that's not a symbol.  I've been
> trying to rig up something using SRFI-34-style exceptions (key =
> 'srfi-34, args = anything) -- provided I can make that work, would
> that be okay?

Yes, I'd prefer, if that's not too much work (but in this case you may
want to really use SRFI-34 and SRFI-35 rather than hand-write things
like "(throw 'srfi-34 ...)").

Thanks!

Ludovic.


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

Re: srfi-18 requirements

[Julian Graham]

> Yes, I'd prefer, if that's not too much work (but in this case you may
> want to really use SRFI-34 and SRFI-35 rather than hand-write things
> like "(throw 'srfi-34 ...)").

Right, that's actually what I was trying to do, except that I've
discovered that SRFI-34 implements 'with-exception-handler' using
'lazy-catch', which rethrows caught exceptions after it calls the
handler.  What's the rationale for this behavior (SRFI-34's or
lazy-catch's)?


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

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

>> Yes, I'd prefer, if that's not too much work (but in this case you may
>> want to really use SRFI-34 and SRFI-35 rather than hand-write things
>> like "(throw 'srfi-34 ...)").
>
> Right, that's actually what I was trying to do, except that I've
> discovered that SRFI-34 implements 'with-exception-handler' using
> 'lazy-catch', which rethrows caught exceptions after it calls the
> handler.  What's the rationale for this behavior (SRFI-34's or
> lazy-catch's)?

lazy-catch rethrows because otherwise we can't provide a guarantee of
reasonable behaviour to someone who writes code that calls `error' or
`throw' somewhere.  In such situations, the coder should be able to
assume that execution won't just continue normally past that call.

If a lazy-catch handler returned normally, and libguile didn't do a
rethrow itself (as it does now), that (execution continuing normally)
is what would happen.

This was hardly ever a problem in practice, because the usage pattern
for lazy-catch was almost always that the lazy-catch handler would
rethrow to a non-lazy catch just outside the lazy-catch.  But we
(Marius and I) thought it would make sense to enforce the
non-returnability of the lazy-catch handler, by having libguile do the
rethrow itself if the handler doesn't do a non-local exit.  It also
gave a minor bonus of meaning that lazy-catch handler code no longer
has to do the rethrow itself.

The thing that actually triggered all this was me working on SRFI-34,
and then noticing an inconsistency in how lazy-catch works - i.e. that
all the dynamic context apart from the stack (e.g. fluids) is unwound
before the handler is called - and then adding `with-throw-handler',
to provide a mechanism to allow the handler _really_ to be called in
the full dynamic context of the error.  I'm not sure now if the
details of this strictly required libguile performing a rethrow, but
it made good sense at the time.

Moving on to SRFI 34, and how that relates to your question about
rethrowing...  The reference implementation calls `error' if a handler
returns normally, which is like rethrowing in that it forces a
non-local exit.  Also note that in all the examples, the handler uses
call/cc to do a jump, and so does not return normally.

Well, I'm afraid that ended up being a bit rambly.  Did it answer your
question though?

         Neil



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

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Ludovic,
>
> I'm almost finished making the changes -- in fact, I've got everything
> fixed except for this one:
>
>> I'd use pairs or records for exception objects rather than just symbols
>> since symbols can always be forged. 

They can't be forged if you use a non-interned symbol: (make-symbol
"srfi-18").  I had this in mind, for the same reason, for srfi-34.scm,
I'm not sure now why that didn't happen.  Possibly because I wasn't
completely sure whether it was the Right Thing to exclude someone
doing:

(catch 'srfi-34
       (lambda ()
         ...
         (raise obj)
         ...)
       (lambda (key obj)
         ...))

>> So we'd have, e.g.:
>>
>>   (define uncaught-exception?
>>     (let ((exception-type (cons 'uncaught-exception #f)))
>>       (lambda (obj)
>>         (and (pair? obj)
>>              (eq? (car obj) exception-type)))))
>
> The thing is, I can't throw with a key that's not a symbol.  I've been
> trying to rig up something using SRFI-34-style exceptions (key =
> 'srfi-34, args = anything) -- provided I can make that work, would
> that be okay?

It's a bit of pain that srfi-18 doesn't refer forward to srfi-34/35.
Obviously the exception system of srfi-18 is very _like_ that of
srfi-34/35, but srfi-18 doesn't say whether its exceptions have to be
implemented using srfi-34/35.

I guess that doesn't actually matter, though.  srfi-18 simply
requires its exception primitives to be implemented somehow.  If it
works semantically for them to be implemented using srfi-34/35, I
think it would make good sense for us to do that.

Regards,
        Neil



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

Re: srfi-18 requirements

[Julian Graham]

> It's a bit of pain that srfi-18 doesn't refer forward to srfi-34/35.
> Obviously the exception system of srfi-18 is very _like_ that of
> srfi-34/35, but srfi-18 doesn't say whether its exceptions have to be
> implemented using srfi-34/35.
>
> I guess that doesn't actually matter, though.  srfi-18 simply
> requires its exception primitives to be implemented somehow.  If it
> works semantically for them to be implemented using srfi-34/35, I
> think it would make good sense for us to do that.

Thanks for the explanation, Neil.  I've currently got something more
or less working with pass-thrus to SRFI-34 exceptions, using a stored
continuation to prevent the exceptions from being re-thrown (as per
SRFI-18, "Primitives and exceptions").

I'm hoping to have something for you guys soon -- I'm starting a new
day job right now, though, so it might be a little while.


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

Re: srfi-18 requirements

[Julian Graham]

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

Re: srfi-18 requirements

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

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

Due to several Important Events occurring in real life, I probably won't
have much time to take care of this by the end of January.  If someone
else wants to take it over, that'd be great, otherwise we'll have to
wait some more.  :-(

Sorry about that!

Thanks,
Ludovic.



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

Re: srfi-18 requirements

[Julian Graham]

Hi Ludovic,

> Due to several Important Events occurring in real life, I probably won't
> have much time to take care of this by the end of January.  If someone
> else wants to take it over, that'd be great, otherwise we'll have to
> wait some more.  :-(


No worries -- I understand.  I'm fine with waiting, but... any takers?


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

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Ludovic,
>
>> Due to several Important Events occurring in real life, I probably won't
>> have much time to take care of this by the end of January.  If someone
>> else wants to take it over, that'd be great, otherwise we'll have to
>> wait some more.  :-(
>
>
> No worries -- I understand.  I'm fine with waiting, but... any takers?

I'll try to take a look in the next week or so.

     Neil



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

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

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

I have some general comments.  I'm sorry for not coming up with these
earlier.

1. Some of your changes are bug fixes for the existing thread code,
   and not dependent on SRFI-18, so we should apply these to 1.8.x as
   well as to HEAD.  Can you pull these out into a separate patch?

2. I don't think it's clear what the overall effect of the SRFI-18
   enhancement will be.  Is it your intention that Guile will then
   implement SRFI-18 behaviour by default?  Or that it will be an
   option, alongside the existing thread behaviour?

   Based on the current patch, I think you intend the latter, and that
   the choice of existing/SRFI-18 behaviour is made by what procedures
   the calling code uses, which in turn depends on whether that code
   has done (use-modules (srfi srfi-18)).  Right?

   What then happens if a SRFI-18 procedure is called on a
   non-SRFI-18-created thread, or vice versa?

   (Is there already a list somewhere of differences between existing
   and SRFI-18 behaviour?  That would help my understanding, at
   least.)

3. I think it's important that existing thread behaviour continues to
   work exactly as it does before your enhancement (modulo bug fixes,
   of course), so I'd prefer if the code changes could be structured
   in such as way as to make it obvious that this will be the case.
   Perhaps this is impossible, in which case we have to rely on
   review, but if there is anything that could be done here, that
   would be good.

I haven't commented on the patch in detail, because it may change
depending on discussion of the above points.  I have a few points on
the text below though.

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

Why is Thread 2 still in the critical section when it calls
make_jmpbuf?  That strikes me as the problem here.

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

Nice fix.

>> +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()?

See e.g. handling of scm_srfi1_map in srfi/srfi-1.c.  Would that work
for the SRFI-18 extensions?

Note that this would imply a separate SRFI-18 library, which gets
loaded when the srfi-18 module is first used.  So clearly this is
related to the points above code structure and separating existing and
SRFI-18 behaviour.

>>> +"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?)

In theory, yes: see doc/maint/docstring.el.  I haven't actually done
this for years, but I believe it should still work.

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

I think the check-arg-type calls are messy, but I'm not that much
bothered.

     Neil



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

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,

Thanks for your comments.


> 1. Some of your changes are bug fixes for the existing thread code,
>    and not dependent on SRFI-18, so we should apply these to 1.8.x as
>    well as to HEAD.  Can you pull these out into a separate patch?

Sure.


> 2. I don't think it's clear what the overall effect of the SRFI-18
>    enhancement will be.  Is it your intention that Guile will then
>    implement SRFI-18 behaviour by default?  Or that it will be an
>    option, alongside the existing thread behaviour?
>
>    Based on the current patch, I think you intend the latter, and that
>    the choice of existing/SRFI-18 behaviour is made by what procedures
>    the calling code uses, which in turn depends on whether that code
>    has done (use-modules (srfi srfi-18)).  Right?

Yes, that's right.  The purpose of the C component of the patch is to
add to and extend Guile's core API in a way that is consistent with
the existing core code (in terms of function names and arguments) but
which allows the Scheme component of the patch to cleanly (i.e,
relying mainly on primitive functions) implement SRFI-18 on top of it.


>    What then happens if a SRFI-18 procedure is called on a
>    non-SRFI-18-created thread, or vice versa?

Nothing significantly different, in most cases.  The main differences
between threads created by core code and by SRFI-18's make-thread are
in the way they start up (SRFI-18 threads must be explicitly started)
and in the way exceptions are handled (SRFI-18 threads have a
top-level exception handler that marks exceptions for rethrow  in
joining threads).  As far as I can see, the worst case would be a lost
exception thrown from an SRFI-18 call in a non-SRFI-18 thread -- but
that's Guile's existing behavior.

>    (Is there already a list somewhere of differences between existing
>    and SRFI-18 behaviour?  That would help my understanding, at
>    least.)

I can prepare one.


> 3. I think it's important that existing thread behaviour continues to
>    work exactly as it does before your enhancement (modulo bug fixes,
>    of course), so I'd prefer if the code changes could be structured
>    in such as way as to make it obvious that this will be the case.
>    Perhaps this is impossible, in which case we have to rely on
>    review, but if there is anything that could be done here, that
>    would be good.

Agreed, except that in a few cases the patch introduces changes to
existing behaviors that were previously "undefined" -- for example,
unlocking a mutex from outside the thread that originally locked it.
SRFI-18 addresses this explicitly and describes the expected behavior.


> Why is Thread 2 still in the critical section when it calls
> make_jmpbuf?  That strikes me as the problem here.

I should've been clearer -- SCM_CRITICAL_SECTION_START occurs *within*
make_jmpbuf.  As to why this is necessary, I must confess I'm not well
enough versed in the particulars of Guile's jmp and async code... it
may indeed be anachronistic, but it'll take me some time to trace
through things to see if that's the case.  Anyone out there happen to
know?


> See e.g. handling of scm_srfi1_map in srfi/srfi-1.c.  Would that work
> for the SRFI-18 extensions?

I take it you're talking about "map" and "map-in-order" both using
scm_srfi1_map via SCM_GPROC and SCM_REGISTER_PROC, respectively?  Yes,
that looks feasible.


> Note that this would imply a separate SRFI-18 library, which gets
> loaded when the srfi-18 module is first used.  So clearly this is
> related to the points above code structure and separating existing and
> SRFI-18 behaviour.

Not necessarily, given how close the core behavior already is to
SRFI-18 (unless I'm misunderstanding) -- that is to say, loading the
SRFI-18 module doesn't change the behavior of any existing thread
functions in either Scheme or C.  Even in cases where new
SRFI-18-supporting functions have been added that have Scheme exposure
(e.g., scm_lock_mutex_timed -> "lock-mutex-timed"), SRFI-18 wraps them
in new names that don't conflict with existing bindings
("mutex-unlock!").


Shall I go ahead and prepare bugfix patches against 1.8.x and HEAD for
the non-SRFI-18 stuff?


Regards,
Julian


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

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Neil,
>
> Thanks for your comments.

No problem.  I feel like I'm being a bit awkward, so thanks for taking
these comments in good faith.

>> 1. Some of your changes are bug fixes for the existing thread code,
>>    and not dependent on SRFI-18, so we should apply these to 1.8.x as
>>    well as to HEAD.  Can you pull these out into a separate patch?
>
> Sure.
>
>
>> 2. I don't think it's clear what the overall effect of the SRFI-18
>>    enhancement will be.  Is it your intention that Guile will then
>>    implement SRFI-18 behaviour by default?  Or that it will be an
>>    option, alongside the existing thread behaviour?
>>
>>    Based on the current patch, I think you intend the latter, and that
>>    the choice of existing/SRFI-18 behaviour is made by what procedures
>>    the calling code uses, which in turn depends on whether that code
>>    has done (use-modules (srfi srfi-18)).  Right?
>
> Yes, that's right.  The purpose of the C component of the patch is to
> add to and extend Guile's core API in a way that is consistent with
> the existing core code (in terms of function names and arguments) but
> which allows the Scheme component of the patch to cleanly (i.e,
> relying mainly on primitive functions) implement SRFI-18 on top of it.

Thanks.  I still need to persuade myself that the dividing lines are
in the right places - am now doing a detailed review of the patch to
work that out.

>>    What then happens if a SRFI-18 procedure is called on a
>>    non-SRFI-18-created thread, or vice versa?
>
> Nothing significantly different, in most cases.  The main differences
> between threads created by core code and by SRFI-18's make-thread are
> in the way they start up (SRFI-18 threads must be explicitly started)
> and in the way exceptions are handled (SRFI-18 threads have a
> top-level exception handler that marks exceptions for rethrow  in
> joining threads).  As far as I can see, the worst case would be a lost
> exception thrown from an SRFI-18 call in a non-SRFI-18 thread -- but
> that's Guile's existing behavior.

Thanks.

>>    (Is there already a list somewhere of differences between existing
>>    and SRFI-18 behaviour?  That would help my understanding, at
>>    least.)
>
> I can prepare one.

Don't bother for now; let's see if all is sufficiently clear after
detailed review.

>> 3. I think it's important that existing thread behaviour continues to
>>    work exactly as it does before your enhancement (modulo bug fixes,
>>    of course), so I'd prefer if the code changes could be structured
>>    in such as way as to make it obvious that this will be the case.
>>    Perhaps this is impossible, in which case we have to rely on
>>    review, but if there is anything that could be done here, that
>>    would be good.
>
> Agreed, except that in a few cases the patch introduces changes to
> existing behaviors that were previously "undefined" -- for example,
> unlocking a mutex from outside the thread that originally locked it.
> SRFI-18 addresses this explicitly and describes the expected behavior.

But unfortunately it is possible for people to have inadvertently
depended on unspecified behaviour.  So we still need to consider those
cases in our analysis of back-compatibility implications.

>> Why is Thread 2 still in the critical section when it calls
>> make_jmpbuf?  That strikes me as the problem here.
>
> I should've been clearer -- SCM_CRITICAL_SECTION_START occurs *within*
> make_jmpbuf.  As to why this is necessary, I must confess I'm not well
> enough versed in the particulars of Guile's jmp and async code... it
> may indeed be anachronistic, but it'll take me some time to trace
> through things to see if that's the case.  Anyone out there happen to
> know?

I think the use of a critical section here is just nonsense, because
all the data being touched is local.  Here is the code; can anyone
else see a reason for a critical section here?

static SCM
make_jmpbuf (void)
{
  SCM answer;
  SCM_CRITICAL_SECTION_START;
  {
    SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
    SETJBJMPBUF(answer, (jmp_buf *)0);
    DEACTIVATEJB(answer);
  }
  SCM_CRITICAL_SECTION_END;
  return answer;
}

So I think the solution is just to remove the SCM_CRITICAL_SECTION_*
lines.

Would that also mean that you could revert the change to the spawning
of signal_delivery_thread()?  As this stands, I'm concerned that
you're introducing an observable difference.  For example: program
calls sigaction specifying a signal handler and a specific thread;
later that thread exits, then the signal is raised.  I believe this
will cause signal_delivery_thread/scm_system_async_mark_for_thread to
raise a "thread has already exited" exception, which is currently
reported.

(It's also nonsense to allow the signal delivery thread to exit in
such a case... but that's another matter.)

>> See e.g. handling of scm_srfi1_map in srfi/srfi-1.c.  Would that work
>> for the SRFI-18 extensions?
>
> I take it you're talking about "map" and "map-in-order" both using
> scm_srfi1_map via SCM_GPROC and SCM_REGISTER_PROC, respectively?  Yes,
> that looks feasible.

No, I meant how the srfi-1 map (defined by module (srfi srfi-1)) is
distinct from the core Guile map (defined by (guile)).

In other words, the suggestion is that the SRFI-18 implementation of
join-thread would not be a core binding, but would come from (srfi
srfi-18).

>> Note that this would imply a separate SRFI-18 library, which gets
>> loaded when the srfi-18 module is first used.  So clearly this is
>> related to the points above code structure and separating existing and
>> SRFI-18 behaviour.
>
> Not necessarily, given how close the core behavior already is to
> SRFI-18 (unless I'm misunderstanding) -- that is to say, loading the
> SRFI-18 module doesn't change the behavior of any existing thread
> functions in either Scheme or C.  Even in cases where new
> SRFI-18-supporting functions have been added that have Scheme exposure
> (e.g., scm_lock_mutex_timed -> "lock-mutex-timed"), SRFI-18 wraps them
> in new names that don't conflict with existing bindings
> ("mutex-unlock!").

I'll follow up on this after full review.

> Shall I go ahead and prepare bugfix patches against 1.8.x and HEAD for
> the non-SRFI-18 stuff?

Yes, please.  Can you include the make_jmpbuf fix discussed above,
assuming that it passes all your tests?

Thanks,
     Neil




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

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,


> Would that also mean that you could revert the change to the spawning
> of signal_delivery_thread()?

Of course.


> As this stands, I'm concerned that
> you're introducing an observable difference.  For example: program
> calls sigaction specifying a signal handler and a specific thread;
> later that thread exits, then the signal is raised.  I believe this
> will cause signal_delivery_thread/scm_system_async_mark_for_thread to
> raise a "thread has already exited" exception, which is currently
> reported.

Yeah, it's "reported," but you can't do anything about it
programmatically, so all you can really do is observe it.  But, yes,
point taken.


> No, I meant how the srfi-1 map (defined by module (srfi srfi-1)) is
> distinct from the core Guile map (defined by (guile)).
>
> In other words, the suggestion is that the SRFI-18 implementation of
> join-thread would not be a core binding, but would come from (srfi
> srfi-18).

Well, maybe.  Except that I don't really see the benefit to thread API
users who weren't depending on idiosyncratic threading behavior.  And
it seems to me that SRFI-1 had more behavioral conflict with Guile
primitives than does SRFI-18, so if SRFI-18 functionality can be
introduced by extending the core rather than providing a parallel
implementation, then there'll be fewer tears for everyone.  But I'm
arguing this as the guy who already wrote it like that, so a grain of
salt is probably in order.


> Yes, please.  Can you include the make_jmpbuf fix discussed above,
> assuming that it passes all your tests?

Will do, unless somebody has a sudden twinge regarding the utility of
CRITICAL_SECTION_START in that function.  I'll try to get that done
this weekend.


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Neil,
>
>
>> Would that also mean that you could revert the change to the spawning
>> of signal_delivery_thread()?
>
> Of course.

Good, thanks.

>> As this stands, I'm concerned that
>> you're introducing an observable difference.  For example: program
>> calls sigaction specifying a signal handler and a specific thread;
>> later that thread exits, then the signal is raised.  I believe this
>> will cause signal_delivery_thread/scm_system_async_mark_for_thread to
>> raise a "thread has already exited" exception, which is currently
>> reported.
>
> Yeah, it's "reported," but you can't do anything about it
> programmatically, so all you can really do is observe it.  But, yes,
> point taken.

Thanks.

>> No, I meant how the srfi-1 map (defined by module (srfi srfi-1)) is
>> distinct from the core Guile map (defined by (guile)).
>>
>> In other words, the suggestion is that the SRFI-18 implementation of
>> join-thread would not be a core binding, but would come from (srfi
>> srfi-18).
>
> Well, maybe.  Except that I don't really see the benefit to thread API
> users who weren't depending on idiosyncratic threading behavior.  And
> it seems to me that SRFI-1 had more behavioral conflict with Guile

(I don't want to go back to whatever we did for SRFI-1; let's look at
this patch and SRFI-18 on their own merits.)

> primitives than does SRFI-18, so if SRFI-18 functionality can be
> introduced by extending the core rather than providing a parallel
> implementation, then there'll be fewer tears for everyone.

I have what I think is a clearer view on this now, now that I
understand more about what's happening in this enhancement.

Logically speaking I think this patch is a combination of 3 things.

1. Bug fixes and improvements (like admin_mutex) to the existing
   thread code.

2. Enhancements to the set of core thread primitives, to allow
  - timed locking and unlocking of mutexes
  - timed joining
  - defined handling of abandoned mutexes
  - new predicates for threads, mutexes and condition variables.

3. SRFI-18 APIs and specific behaviour (notably with exceptions and
   joining).

We've already agreed to split out and apply (1) first; no change
there, except please also include improvements like the use of
admin_mutex, if you agree that that makes sense.  (I will filter the
latter out when applying to 1.8.x, as they aren't strictly needed
there.)

(2) and (3) are currently intertwined, and I think the key to
clarifying this patch is to imagine a clear boundary between them.  In
other words,

- first (2) we enhance the thread primitives - in ways that are useful
  for SRFI-18, but not _only_ for SRFI-18 thread code;

- then (3) we write the SRFI-18 API.

I've said more about the specific changes to achieve this below.  If
you agree with them, one of the advantages of this is that a lot of
the code that is currently part of the C patch can be moved into (srfi
srfi-18), in Scheme.  We end up with all of (3) being in Scheme -
which is great, because it then makes perfect sense to say that

- all of the C changes are generic enhancements, so should be in core
  Guile, so there is no argument or need for a separate SRFI-18 C
  library

- any issues about when the SRFI-18 API is used (as opposed to the
  core Guile API) are covered in the usual way by the module system.

So, to be precise about the things that are currently in the C patch,
but which I think should not be...

* thread exception, exception_preserve_catch_handler,
  join_thread_timed

The only enhancement needed in the core is for a join-thread proc that
takes a timeout arg, and which can report somehow whether it timed
out.

The SRFI-18 behaviour of throwing a timed-out exception can be
implemented in Scheme.

The storage and later retrieval of a thread exception can be
implemented in Scheme like this:

 (define thread->exception (make-object-property))

 (define (srfi-18-exception-preserver key . args)
   (if (or (srfi-18-terminated-thread-exception? key args)
           (srfi-18-uncaught-exception? key args))
       (set! (thread->exception (current-thread)) (cons key args))))

 When the SRFI-18 Scheme code creates a thread, it calls
 call-with-new-thread with srfi-18-exception-preserver as the
 thread-handler arg.

 The SRFI-18 version of join-thread can (i) call the core join-thread
 proc; (ii) if it returns successfully, access (thread->exception
 JOINED-THREAD), and behave accordingly.

That leaves one loose end in the C patch, namely the use of
exception_preserve_catch_handler() in do_thread_exit().  SRFI-18 has
no concept of thread cleanup proc, so I don't think the SRFI-18
exception preservation semantics should or need to apply to the thread
cleanup code.  So I think this change can simply be reverted.  (Any
thread cleanup proc is of course free to protect itself however it
wishes, and even use srfi-18-exception-preserver if that makes sense.)

Note that this also allows us to remove the SRFI-18/34 symbols from
the C code.

* mutex state

A confusing element here is the bizarre locked/not-owned state.

AFAICS, SRFI-18 specifies nothing at all (apart from mutex-state
itself) which depends on the difference between locked/owned and
locked/not-owned.  Therefore I don't think we should support this
state in the core.

It can be supported in (srfi srfi-18) like this:

(define mutex->not-owned? (make-object-property))

(define (srfi-18-mutex-lock mutex . optargs)
  (apply core-mutex-lock mutex optargs)
  (if (and (= (length optargs) 2)
           (eq? (cadr optargs) #f))
      ;; Support the locked/not-owned state.
      (set! (mutex->not-owned? mutex) #t)))

Then SRFI-18 mutex-state can be implemented in Scheme also:

(define (mutex-state m)
  (let ((thread (mutex-owner m)))
    (cond ((not thread) 'not-abandoned)
          ((thread-exited? thread) 'abandoned)
          ((mutex->not-owned? m) 'not-owned)
          (else thread))))

And the #f/SCM_UNDEFINED changes can be reverted.

That just leaves the uses of fat_mutex_state() in fat_mutex_lock().  I
personally find that these uses obfuscate what has changed, and would
prefer if the code went back to checking m->owner as it did before.
Is that feasible?

Note that this also allows us to remove the SRFI-18 state symbols from
the C code.

* (end of things to remove from the C patch)

Finally, there are quite a few spurious changes (or perhaps just that
I don't understand yet) in patch: whitespace, line break and docstring
changes.  Can you revert all these, as they only confuse the overall
picture?

To conclude...

I'm sorry that I'm asking for some significant changes here, but I
hope that you'll agree that they make the enhancement clearer, and in
particular that it is a good thing to reduce the changes that we need
to make to the C code.  Please let me know what you think.

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

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

Hi Neil,

> > Of course.
>
> Good, thanks.

Find attached a patch against HEAD that includes only the bug fix
stuff (2 deadlocks and use of thread-specific admin mutex) from the
original patch, modified to change make_jmpbuf instead of the signal
delivery code.

With regard to your comments about the rest of the patch, agreed, except:

Given the similarities between the existing Guile threading code and
SRFI-18, what level of comptability between these two domains will be
supported?  For example, SRFI-18 specifies that threads waiting on a
mutex held by a thread that exits should be notified of the exit and
that one of them will then be able to lock that mutex.  Given the
changes you describe below, will this behavior only work if all the
components in the user's code were created using the SRFI-18 API?

What about a thread that calls SRFI-18's thread-join function on a
non-SRFI-18 thread that died with an exception?  (Are you sure you
don't want thread exceptions in the core?  I feel like join-thread
isn't really "complete" without them...)


> Finally, there are quite a few spurious changes (or perhaps just that
> I don't understand yet) in patch: whitespace, line break and docstring
> changes.  Can you revert all these, as they only confuse the overall
> picture?

This may have just been stuff that Ludovic asked me to clean up (or
that I just cleaned up ad-hoc).  It can all go.


> I'm sorry that I'm asking for some significant changes here, but I
> hope that you'll agree that they make the enhancement clearer, and in
> particular that it is a good thing to reduce the changes that we need
> to make to the C code.  Please let me know what you think.

Not a problem.  Thank you for taking the time to all this analysis.
What's the next thing you'd like me to submit?  How about (2), the
enhancement patch for timed joins?


Regards,
Julian

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

Index: libguile/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2421
diff -a -u -r1.2421 ChangeLog
--- libguile/ChangeLog	29 Dec 2007 01:35:33 -0000	1.2421
+++ libguile/ChangeLog	6 Jan 2008 21:11:29 -0000
@@ -1,3 +1,15 @@
+2008-01-06  Julian Graham  <joolean@gmail.com>
+
+	* threads.c (scm_enter_guile): Lock `thread_admin_mutex' when entering 
+	guile mode to prevent a race during GC.
+	(do_thread_exit, scm_cancel_thread, scm_set_thread_cleanup_x, 
+	scm_thread_cleanup): Lock on thread-specific admin mutex instead of 
+	`thread_admin_mutex'.
+	* threads.h (scm_i_thread)[admin_mutex]: New field.
+	* throw.c (make_jmpbuf): Don't enter critical section during thread
+	spawn -- there is a possibility of deadlock if other threads are
+	exiting.
+	
 2007-12-29  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* gc.c (mark_gc_async): Change "func_data" to "fn_data", to avoid
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	6 Jan 2008 21:11:29 -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) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -369,14 +369,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;
   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 +409,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;
 
@@ -435,6 +442,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;
@@ -494,7 +502,7 @@
 				      scm_handle_by_message_noexit, NULL);
     }
 
-  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
 
   t->exited = 1;
   close (t->sleep_pipe[0]);
@@ -502,7 +510,7 @@
   while (scm_is_true (unblock_from_queue (t->join_queue)))
     ;
 
-  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return NULL;
 }
@@ -931,15 +939,15 @@
 
   SCM_VALIDATE_THREAD (1, thread);
   t = SCM_I_THREAD_DATA (thread);
-  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
   if (!t->canceled)
     {
       t->canceled = 1;
-      scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+      scm_i_pthread_mutex_unlock (&t->admin_mutex);
       scm_i_pthread_cancel (t->pthread);
     }
   else
-    scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+    scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return SCM_UNSPECIFIED;
 }
@@ -957,13 +965,13 @@
   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;
 }
@@ -979,10 +987,10 @@
 
   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;
 }
@@ -1001,24 +1009,24 @@
   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 (!t->exited)
     {
       while (1)
 	{
-	  block_self (t->join_queue, thread, &thread_admin_mutex, NULL);
+	  block_self (t->join_queue, thread, &t->admin_mutex, NULL);
 	  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;
 
-  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return res;
 }
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	6 Jan 2008 21:11:29 -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) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -52,6 +52,9 @@
 
   SCM cleanup_handler;
   SCM join_queue;
+
+  scm_i_pthread_mutex_t admin_mutex;
+
   SCM result;
   int canceled;
   int exited;
Index: libguile/throw.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/throw.c,v
retrieving revision 1.114
diff -a -u -r1.114 throw.c
--- libguile/throw.c	22 Jan 2007 15:14:40 -0000	1.114
+++ libguile/throw.c	6 Jan 2008 21:11:29 -0000
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -75,12 +75,8 @@
 make_jmpbuf (void)
 {
   SCM answer;
-  SCM_CRITICAL_SECTION_START;
-  {
-    SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
-    SETJBJMPBUF(answer, (jmp_buf *)0);
-    DEACTIVATEJB(answer);
-  }
-  SCM_CRITICAL_SECTION_END;
+  SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
+  SETJBJMPBUF(answer, (jmp_buf *)0);
+  DEACTIVATEJB(answer);
   return answer;
 }

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Neil,
>
>> > Of course.
>>
>> Good, thanks.
>
> Find attached a patch against HEAD that includes only the bug fix
> stuff (2 deadlocks and use of thread-specific admin mutex) from the
> original patch, modified to change make_jmpbuf instead of the signal
> delivery code.

Thanks.  Just a couple further points...

>  static void
>  scm_enter_guile (scm_t_guile_ticket 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);
>      }
>  }

1. Embarassingly - given that I already said "Nice fix" to this - I'm
afraid I can't now see exactly why this is needed.

I understand that if the line to lock thread_admin_mutex is absent, it
is possible for this thread (A, say) to lock its heap_mutex, and call
resume(), and return from scm_enter_guile(), even though
scm_i_thread_go_to_sleep is already 1.

I'm not sure why this is a problem, though.  It seems to me that what
will then ensue is that

- scm_i_thread_put_to_sleep() will block when it tries to lock thread
  A's heap_mutex

- after a short while, thread A will call SCM_TICK, which will call
  SCM_THREAD_SWITCHING_CODE, which will notice that
  scm_i_thread_go_to_sleep is 1 and so call
  scm_i_thread_sleep_for_gc()

- scm_i_thread_sleep_for_gc() will do the cond_wait, releasing the
  heap_mutex, and so allowing the GC thread to lock it.

So the worst that happens is that thread A manages to do a little more
guile mode execution before it goes to sleep.

Is that right?  I think you suggested in one of your previous emails
that it might be possible for thread A to enter and leave guile mode
multiple times, but I don't see how that is possible.

2. Should admin_mutex be locked in scm_c_thread_exited_p()?  I think
it should.  (This was equally wrong when using thread_admin_mutex, of
course; your patch doesn't make anything worse, but it's worth fixing
this in passing if you agree.)

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,

> 1. Embarassingly - given that I already said "Nice fix" to this - I'm
> afraid I can't now see exactly why this is needed.

Argh, you're right -- when I first noticed this behavior, I was so
astonished to see my logs showing threads entering and leaving guile
mode during GC that my first move was to try and prevent this.  When
my changes got rid of this behavior, I assumed everything was
hunky-dory.  However, when pressed to explain the details, I added
more logging, which showed that errant thread ultimately did go to
sleep at the proper time -- it just never woke up when the
wake_up_cond was broadcast on.

My current inclination is that the problem lies with sleeping on the
global wake_up_cond -- each thread calls pthread_cond_wait with its
own, thread-specific heap_mutex, the result of which is undefined, or
so say the glibc docs.  I'm testing a fix now that uses a mutex
reserved for this purpose instead.

So why hasn't this been reported before?  I'm not really sure, except
that based on  my logs, a GC involving more than two threads (one
thread stays awake, of course, to manage the collection) is kind of
rare.  It doesn't even necessarily happen during an entire run of my
SRFI-18 test suite, which lasts for several seconds and is fairly
multi-threaded.


> Is that right?  I think you suggested in one of your previous emails
> that it might be possible for thread A to enter and leave guile mode
> multiple times, but I don't see how that is possible.

It *is* possible, because a thread can enter and leave guile mode and
do a fair number of things without SCM_TICK getting called.  I don't
know if that's significant or not.


> 2. Should admin_mutex be locked in scm_c_thread_exited_p()?  I think
> it should.  (This was equally wrong when using thread_admin_mutex, of
> course; your patch doesn't make anything worse, but it's worth fixing
> this in passing if you agree.)

Sure -- wouldn't hurt.  I'll include that with whatever ends up in the
final "bug" patch.

Apologies that it takes me so long to reply to these emails.  Blame
the overhead of looping my test code all night?


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Neil,
>
>> 1. Embarassingly - given that I already said "Nice fix" to this - I'm
>> afraid I can't now see exactly why this is needed.
>
> Argh, you're right -- when I first noticed this behavior, I was so
> astonished to see my logs showing threads entering and leaving guile
> mode during GC that my first move was to try and prevent this.  When
> my changes got rid of this behavior, I assumed everything was
> hunky-dory.  However, when pressed to explain the details, I added
> more logging, which showed that errant thread ultimately did go to
> sleep at the proper time -- it just never woke up when the
> wake_up_cond was broadcast on.
>
> My current inclination is that the problem lies with sleeping on the
> global wake_up_cond -- each thread calls pthread_cond_wait with its
> own, thread-specific heap_mutex, the result of which is undefined, or
> so say the glibc docs.

Agreed.  All the examples I've seen have the same mutex for all
threads that wait on the cond var.

>  I'm testing a fix now that uses a mutex reserved for this purpose
> instead.

OK.  While looking through the docs, though, and playing with possible
solutions, I noted a couple of other pitfalls (which the current code
also appears to suffer from).

1. pthread_cond_wait() returning does not necessarily mean that the
   cond var was signalled.  Apparently pthread_cond_wait() can return
   early because of an interrupt.

2. If two threads are using pthread_cond_wait and pthread_cond_signal
   to communicate, and using the cond_var itself as a state
   indication, they have to be certain that the pthread_cond_wait
   starts before the pthread_cond_signal, otherwise it won't work.

The practical impact of these is that one shouldn't use the cond_var
itself as an indication of "reached so-and-so state".  Instead, one
can represent the state using an explicit variable, which is protected
by the associated mutex, and then interpret the cond_var as indicating
simply that the variable _might_ have changed.

In our case, I think the state variable could be
scm_i_thread_go_to_sleep, protected by thread_admin_mutex.  Here's a
possible solution based on this, but it isn't yet complete, because it
doesn't explain how num_guile_threads_awake is calculated.  (And I
have to go to bed!)

scm_i_thread_sleep_for_gc ()
{
  scm_i_thread *t = suspend ();

  pthread_mutex_lock (&thread_admin_mutex);
  if (scm_i_thread_go_to_sleep)
  {
    num_guile_threads_awake--;
    pthread_cond_signal (&going_to_sleep_cond);

    while (scm_i_thread_go_to_sleep)
    {
      pthread_cond_wait (&wake_up_cond, &thread_admin_mutex);
    }
    num_guile_threads_awake++;
  }
  pthread_mutex_unlock (&thread_admin_mutex);

  resume (t);
}

scm_i_thread_put_to_sleep ()
{
  pthread_mutex_lock (&thread_admin_mutex);
  scm_i_thread_go_to_sleep = 1;
  while (num_guile_threads_awake > 0)
  {
    pthread_cond_wait (&going_to_sleep_cond, &thread_admin_mutex);
  }
}

scm_i_thread_wake_up ()
{
  scm_i_thread_go_to_sleep = 0;
  pthread_mutex_unlock (&thread_admin_mutex);
  pthread_cond_broadcast (&wake_up_cond);
}

> So why hasn't this been reported before?  I'm not really sure, except
> that based on  my logs, a GC involving more than two threads (one
> thread stays awake, of course, to manage the collection) is kind of
> rare.  It doesn't even necessarily happen during an entire run of my
> SRFI-18 test suite, which lasts for several seconds and is fairly
> multi-threaded.

Not sure what you mean here.  Surely if there are >2 threads, they all
have to go to sleep before GC can proceed?

>> Is that right?  I think you suggested in one of your previous emails
>> that it might be possible for thread A to enter and leave guile mode
>> multiple times, but I don't see how that is possible.
>
> It *is* possible, because a thread can enter and leave guile mode and
> do a fair number of things without SCM_TICK getting called.  I don't
> know if that's significant or not.

That may mean that we need some more SCM_TICK calls.  What kind of
processing was the thread doing?

>> 2. Should admin_mutex be locked in scm_c_thread_exited_p()?  I think
>> it should.  (This was equally wrong when using thread_admin_mutex, of
>> course; your patch doesn't make anything worse, but it's worth fixing
>> this in passing if you agree.)
>
> Sure -- wouldn't hurt.  I'll include that with whatever ends up in the
> final "bug" patch.

Thanks.

> Apologies that it takes me so long to reply to these emails.  Blame
> the overhead of looping my test code all night?

No need to apologize there!  My time at the moment is pretty limited
too, so if you replied any quicker, you'd then just be waiting for me
(even more)!

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,

> OK.  While looking through the docs, though, and playing with possible
> solutions, I noted a couple of other pitfalls (which the current code
> also appears to suffer from).
>
> 1. pthread_cond_wait() returning does not necessarily mean that the
>    cond var was signalled.  Apparently pthread_cond_wait() can return
>    early because of an interrupt.

Yes, the pthreads docs refer to this as a "spurious wakeup."


> 2. If two threads are using pthread_cond_wait and pthread_cond_signal
>    to communicate, and using the cond_var itself as a state
>    indication, they have to be certain that the pthread_cond_wait
>    starts before the pthread_cond_signal, otherwise it won't work.

Right -- holding the right mutexes when you signal / broadcast is
pretty important.


> The practical impact of these is that one shouldn't use the cond_var
> itself as an indication of "reached so-and-so state".  Instead, one
> can represent the state using an explicit variable, which is protected
> by the associated mutex, and then interpret the cond_var as indicating
> simply that the variable _might_ have changed.
>
> In our case, I think the state variable could be
> scm_i_thread_go_to_sleep, protected by thread_admin_mutex.  Here's a
> possible solution based on this, but it isn't yet complete, because it
> doesn't explain how num_guile_threads_awake is calculated.  (And I
> have to go to bed!)

I've come up with something similar that seems to work decently and
seems a bit simple.  See what you think (apologies for the
formatting):

static scm_i_pthread_cond_t wake_up_cond;
static scm_i_pthread_mutex_t wake_up_mutex;
static int wake_up_flag = 0;
int scm_i_thread_go_to_sleep;

void
scm_i_thread_put_to_sleep ()
{
  if (threads_initialized_p)
    {
      scm_i_thread *t;

      scm_leave_guile ();
      scm_i_pthread_mutex_lock (&thread_admin_mutex);

      wake_up_flag = 0;
      scm_i_thread_go_to_sleep = 1;
      for (t = all_threads; t; t = t->next_thread)
        {
	   scm_i_pthread_mutex_lock (&t->heap_mutex);
        }
      scm_i_thread_go_to_sleep = 0;
    }
}

void
scm_i_thread_wake_up ()
{
  if (threads_initialized_p)
    {
      scm_i_thread *t;

      scm_i_pthread_mutex_lock (&wake_up_mutex);
      wake_up_flag = 1;
      scm_i_pthread_cond_broadcast (&wake_up_cond);
      scm_i_pthread_mutex_unlock (&wake_up_mutex);
      for (t = all_threads; t; t = t->next_thread)
        {
           scm_i_pthread_mutex_unlock (&t->heap_mutex);
        }
      scm_i_pthread_mutex_unlock (&thread_admin_mutex);
      scm_enter_guile ((scm_t_guile_ticket) SCM_I_CURRENT_THREAD);
    }
}

void
scm_i_thread_sleep_for_gc ()
{
  scm_i_thread *t = suspend ();

  scm_i_pthread_cleanup_push ((void (*)(void *)) scm_i_pthread_mutex_unlock,
			      &wake_up_mutex);
  scm_i_pthread_mutex_lock (&wake_up_mutex);
  scm_i_pthread_mutex_unlock (&t->heap_mutex);
  do
    {
      scm_i_pthread_cond_wait (&wake_up_cond, &wake_up_mutex);
    }
  while (!wake_up_flag);
  scm_i_pthread_mutex_lock (&t->heap_mutex);
  scm_i_pthread_mutex_unlock (&wake_up_mutex);
  scm_i_pthread_cleanup_pop (0);
  resume (t);
}


> > So why hasn't this been reported before?  I'm not really sure, except
> > that based on  my logs, a GC involving more than two threads (one
> > thread stays awake, of course, to manage the collection) is kind of
> > rare.  It doesn't even necessarily happen during an entire run of my
> > SRFI-18 test suite, which lasts for several seconds and is fairly
> > multi-threaded.
>
> Not sure what you mean here.  Surely if there are >2 threads, they all
> have to go to sleep before GC can proceed?

Of course -- all I meant by this was that in the existing thread tests
(and in much of the SRFI-18 test code I wrote) the lifespans of
threads besides the main thread (and the signal delivery thread) are
usually short enough that they don't end up participating in this
whole co-op GC process.  Maybe we need some test code for
longer-running, guile-mode threads.  (Perhaps developers with
multi-threaded Guile application development under their belts would
care to chime in here?)


> > It *is* possible, because a thread can enter and leave guile mode and
> > do a fair number of things without SCM_TICK getting called.  I don't
> > know if that's significant or not.
>
> That may mean that we need some more SCM_TICK calls.  What kind of
> processing was the thread doing?

I'm not totally sure -- I'll have to add some more logs and get back
to you.  I think are definitely some places where an extra SCM_TICK
might do some good (in fat_cond_timedwait, e.g.).


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Neil,

Hi Julian; sorry for taking so long to follow up on this!

>> 2. If two threads are using pthread_cond_wait and pthread_cond_signal
>>    to communicate, and using the cond_var itself as a state
>>    indication, they have to be certain that the pthread_cond_wait
>>    starts before the pthread_cond_signal, otherwise it won't work.
>
> Right -- holding the right mutexes when you signal / broadcast is
> pretty important.

I don't think holding a mutex when you signal/broadcast is enough.
It's still possible for the signal/broadcast to happen before the
other thread starts waiting.

> I've come up with something similar that seems to work decently and
> seems a bit simple.  See what you think (apologies for the
> formatting):
>
> static scm_i_pthread_cond_t wake_up_cond;
> static scm_i_pthread_mutex_t wake_up_mutex;
> static int wake_up_flag = 0;
> int scm_i_thread_go_to_sleep;
>
> void
> scm_i_thread_put_to_sleep ()
> {
>   if (threads_initialized_p)
>     {
>       scm_i_thread *t;
>
>       scm_leave_guile ();
>       scm_i_pthread_mutex_lock (&thread_admin_mutex);
>
>       wake_up_flag = 0;
>       scm_i_thread_go_to_sleep = 1;
>       for (t = all_threads; t; t = t->next_thread)

NB I have an orthogonal concern here (i.e. possibly yet another issue
with the current code!): If a thread that was running in Guile mode
called scm_leave_guile() to do non-guile stuff for a while, and is
still outside Guile mode, shouldn't it have been removed from the
all_threads list when it called scm_leave_guile()?

(But please feel free to ignore this one for now.  We already have
enough loose ends in the air!)

>         {
> 	   scm_i_pthread_mutex_lock (&t->heap_mutex);
>         }
>       scm_i_thread_go_to_sleep = 0;
>     }
> }
>
> void
> scm_i_thread_wake_up ()
> {
>   if (threads_initialized_p)
>     {
>       scm_i_thread *t;
>
[B]
>       scm_i_pthread_mutex_lock (&wake_up_mutex);
>       wake_up_flag = 1;
>       scm_i_pthread_cond_broadcast (&wake_up_cond);
>       scm_i_pthread_mutex_unlock (&wake_up_mutex);
>       for (t = all_threads; t; t = t->next_thread)
>         {
>            scm_i_pthread_mutex_unlock (&t->heap_mutex);
>         }
>       scm_i_pthread_mutex_unlock (&thread_admin_mutex);
>       scm_enter_guile ((scm_t_guile_ticket) SCM_I_CURRENT_THREAD);
>     }
> }
>
> void
> scm_i_thread_sleep_for_gc ()
> {
>   scm_i_thread *t = suspend ();
>
>   scm_i_pthread_cleanup_push ((void (*)(void *)) scm_i_pthread_mutex_unlock,
> 			      &wake_up_mutex);
>   scm_i_pthread_mutex_lock (&wake_up_mutex);
>   scm_i_pthread_mutex_unlock (&t->heap_mutex);
>   do

I think you need to check !wake_up_flag at the start of the loop.  I
think it is possible that when the loop starts, the GC thread has
already set wake_up_flag to 1 and signalled wake_up_cond.

>     {
>       scm_i_pthread_cond_wait (&wake_up_cond, &wake_up_mutex);
>     }
>   while (!wake_up_flag);
[A]
>   scm_i_pthread_mutex_lock (&t->heap_mutex);
>   scm_i_pthread_mutex_unlock (&wake_up_mutex);

Do the locks of t->heap_mutex and wake_up_mutex really need to overlap
like this?  I think this could lead to a deadlock: at [A] above, the
non-GC thread holds wake_up_mutex and tries to lock t->heap_mutex,
whereas at [B] above, the GC thread holds t->heap_mutex (for every
thread) and tries to lock wake_up_mutex.

If there isn't a hard reason for the overlapping, the two lock/unlock
pairs just above can be swapped, and that eliminates the deadlock
possibility.

Otherwise I think your code looks good.

> Of course -- all I meant by this was that in the existing thread tests
> (and in much of the SRFI-18 test code I wrote) the lifespans of
> threads besides the main thread (and the signal delivery thread) are
> usually short enough that they don't end up participating in this
> whole co-op GC process.  Maybe we need some test code for
> longer-running, guile-mode threads.  (Perhaps developers with
> multi-threaded Guile application development under their belts would
> care to chime in here?)

Yes, some longer-running threads would be good.  Does anyone have some
multi-threaded code that we could use for testing?

> I'm not totally sure -- I'll have to add some more logs and get back
> to you.  I think are definitely some places where an extra SCM_TICK
> might do some good (in fat_cond_timedwait, e.g.).

OK, no worries.  Let's handle this when we need to.

Regards,
      Neil

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,

> NB I have an orthogonal concern here (i.e. possibly yet another issue
> with the current code!): If a thread that was running in Guile mode
> called scm_leave_guile() to do non-guile stuff for a while, and is
> still outside Guile mode, shouldn't it have been removed from the
> all_threads list when it called scm_leave_guile()?
>
> (But please feel free to ignore this one for now.  We already have
> enough loose ends in the air!)

Ignoring... (but is that what all_threads is for?  My understanding
was that it was for ALL threads created by / initialized to use Guile
-- i.e., all threads that needed to be GC'd.)


> I think you need to check !wake_up_flag at the start of the loop.  I
> think it is possible that when the loop starts, the GC thread has
> already set wake_up_flag to 1 and signalled wake_up_cond.

I don't think this is possible -- the GC thread could never have
gotten to that point unless it had locked the non-GC thread's
heap_mutex.  By the time it sets wake_up_flag to 1, it must also be
holding the wake_up_mutex, which means that the non-GC thread had
already relinquished it via the cond_wait.


> Do the locks of t->heap_mutex and wake_up_mutex really need to overlap
> like this?  I think this could lead to a deadlock: at [A] above, the
> non-GC thread holds wake_up_mutex and tries to lock t->heap_mutex,
> whereas at [B] above, the GC thread holds t->heap_mutex (for every
> thread) and tries to lock wake_up_mutex.
>
> If there isn't a hard reason for the overlapping, the two lock/unlock
> pairs just above can be swapped, and that eliminates the deadlock
> possibility.

I think that they do (need to overlap).  And I'm having a hard time
seeing the potential for deadlock here (maybe I'm just sluggish from
the heat in my cubicle).  I think the order of locking is critical to
preventing deadlock, in fact, via a race on wake_up_flag.  In the
situation you describe, the non-GC thread will only be able to seize
wake_up_mutex once the wake_up_flag has been set and the GC thread has
permanently relinquished wake_up_mutex for that round of collection,
so there's no deadlock.  Am I missing something?


Regards.
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Hi Neil,

Hello again!  I've added some comments below, but I think that for the
last few emails we've rather lost sight of the ball - mostly my fault,
for pursuing details that didn't need pursuing.  So actually my
comments below are not really important.

Looking back, and clawing our way back towards SRFI-18 (remember that
:-), I suggest that

- I'll stop raising unproven issues in the threads code!

- we apply the generic / bug fix patch that you already posted, except
  without the extra thread_admin_mutex locking (which I think we
  concluded we can't justify) - that will be to HEAD

- I'll have a go at devising a test for the critical section in
  make_jmpbuf bug; if I succeed, I'll run the test on 1.8.x too, and
  port the fix over

- you continue on the C enhancements and Scheme code for SRFI-18, as
  already discussed and agreed

- once all of your code and tests are in (HEAD), we can see if there
  are any _actual_ generic thread code issues that we need to address,
  and address them.

What do you think?

> Ignoring... (but is that what all_threads is for?  My understanding
> was that it was for ALL threads created by / initialized to use Guile
> -- i.e., all threads that needed to be GC'd.)

(I'm not sure, but I think that (i) a thread that has left guile mode
ain't gonna call SCM_TICK, and (ii) the fact that all threads need to
be GC'd is handled by the thread saving its stack top and flushing its
registers in suspend().  But in any case, we should leave this until
someone writes a cunning test case to expose it.)

> I don't think this is possible -- the GC thread could never have
> gotten to that point unless it had locked the non-GC thread's
> heap_mutex.  By the time it sets wake_up_flag to 1, it must also be
> holding the wake_up_mutex, which means that the non-GC thread had
> already relinquished it via the cond_wait.

Yes, agreed now.  (Note that this does rely on the overlapping, and so
this is the "hard reason".)

> I think that they do (need to overlap).  And I'm having a hard time
> seeing the potential for deadlock here (maybe I'm just sluggish from
> the heat in my cubicle).  I think the order of locking is critical to
> preventing deadlock, in fact, via a race on wake_up_flag.  In the
> situation you describe, the non-GC thread will only be able to seize
> wake_up_mutex once the wake_up_flag has been set and the GC thread has
> permanently relinquished wake_up_mutex for that round of collection,
> so there's no deadlock.  Am I missing something?

No, you're very likely right.  I think from here on the onus should be
on me (or anyone else) to come up with an actual test, instead of
trying to argue theoretically.

(And for the same reason, I don't think we should apply your new code
to CVS yet, because I don't think we've yet demonstrated an actual
problem with the existing code - is that right?)

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

> - we apply the generic / bug fix patch that you already posted, except
>   without the extra thread_admin_mutex locking (which I think we
>   concluded we can't justify) - that will be to HEAD

Agreed, though see below...


> - I'll have a go at devising a test for the critical section in
>   make_jmpbuf bug; if I succeed, I'll run the test on 1.8.x too, and
>   port the fix over

Agreed (though you wanted to remove that critical section for HEAD, right?)


> - you continue on the C enhancements and Scheme code for SRFI-18, as
>   already discussed and agreed

Agreed.


> - once all of your code and tests are in (HEAD), we can see if there
>   are any _actual_ generic thread code issues that we need to address,
>   and address them.
>
> What do you think?

Agreed.  Sounds good!


> (And for the same reason, I don't think we should apply your new code
> to CVS yet, because I don't think we've yet demonstrated an actual
> problem with the existing code - is that right?)

Well, I think I *am* seeing a problem with existing code, most likely
related to the fact that the cond_wait while sleeping for GC is on
different mutexes but the same condition variable.  I believe the
manifestation of this, as I explained in an earlier email, is that
sometimes a thread will go to sleep for GC and never wake up.


Regards,
Julian

Re: srfi-18 requirements

[Julian Graham]

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

On Jan 24, 2008 8:38 PM, Julian Graham <joolean@gmail.com> wrote:
> > - we apply the generic / bug fix patch that you already posted, except
> >   without the extra thread_admin_mutex locking (which I think we
> >   concluded we can't justify) - that will be to HEAD
>
> Agreed, though see below...


Actually, in light of Neil's apt suggestion that we get this thing
back on track, I resolve to stop fussing about deadlocks for the time
being -- find attached the patch described above (1 deadlock -- the
jmpbuf critical section one -- and the thread-specific mutex).  Let me
know if I've missed anything.


Regards,
Julian

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

Index: libguile/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2421
diff -a -u -r1.2421 ChangeLog
--- libguile/ChangeLog	29 Dec 2007 01:35:33 -0000	1.2421
+++ libguile/ChangeLog	28 Jan 2008 01:54:49 -0000
@@ -1,3 +1,13 @@
+2008-01-27  Julian Graham  <joolean@gmail.com>
+
+	* threads.c (do_thread_exit, scm_cancel_thread, 
+	scm_set_thread_cleanup_x, scm_thread_cleanup): Lock on thread-specific 
+	admin mutex instead of `thread_admin_mutex'.
+	* threads.h (scm_i_thread)[admin_mutex]: New field.
+	* throw.c (make_jmpbuf): Don't enter critical section during thread
+	spawn -- there is a possibility of deadlock if other threads are
+	exiting.
+	
 2007-12-29  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* gc.c (mark_gc_async): Change "func_data" to "fn_data", to avoid
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	28 Jan 2008 01:54:51 -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) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -435,6 +435,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;
@@ -494,7 +495,7 @@
 				      scm_handle_by_message_noexit, NULL);
     }
 
-  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
 
   t->exited = 1;
   close (t->sleep_pipe[0]);
@@ -502,7 +503,7 @@
   while (scm_is_true (unblock_from_queue (t->join_queue)))
     ;
 
-  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return NULL;
 }
@@ -931,15 +932,15 @@
 
   SCM_VALIDATE_THREAD (1, thread);
   t = SCM_I_THREAD_DATA (thread);
-  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
   if (!t->canceled)
     {
       t->canceled = 1;
-      scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+      scm_i_pthread_mutex_unlock (&t->admin_mutex);
       scm_i_pthread_cancel (t->pthread);
     }
   else
-    scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+    scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return SCM_UNSPECIFIED;
 }
@@ -957,13 +958,13 @@
   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;
 }
@@ -979,10 +980,10 @@
 
   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;
 }
@@ -1001,24 +1002,24 @@
   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 (!t->exited)
     {
       while (1)
 	{
-	  block_self (t->join_queue, thread, &thread_admin_mutex, NULL);
+	  block_self (t->join_queue, thread, &t->admin_mutex, NULL);
 	  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;
 
-  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return res;
 }
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	28 Jan 2008 01:54:51 -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) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -52,6 +52,9 @@
 
   SCM cleanup_handler;
   SCM join_queue;
+
+  scm_i_pthread_mutex_t admin_mutex;
+
   SCM result;
   int canceled;
   int exited;
Index: libguile/throw.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/throw.c,v
retrieving revision 1.114
diff -a -u -r1.114 throw.c
--- libguile/throw.c	22 Jan 2007 15:14:40 -0000	1.114
+++ libguile/throw.c	28 Jan 2008 01:54:52 -0000
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -75,12 +75,8 @@
 make_jmpbuf (void)
 {
   SCM answer;
-  SCM_CRITICAL_SECTION_START;
-  {
-    SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
-    SETJBJMPBUF(answer, (jmp_buf *)0);
-    DEACTIVATEJB(answer);
-  }
-  SCM_CRITICAL_SECTION_END;
+  SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
+  SETJBJMPBUF(answer, (jmp_buf *)0);
+  DEACTIVATEJB(answer);
   return answer;
 }

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> On Jan 24, 2008 8:38 PM, Julian Graham <joolean@gmail.com> wrote:
>> > - we apply the generic / bug fix patch that you already posted, except
>> >   without the extra thread_admin_mutex locking (which I think we
>> >   concluded we can't justify) - that will be to HEAD
>>
>> Agreed, though see below...
>
>
> Actually, in light of Neil's apt suggestion that we get this thing
> back on track, I resolve to stop fussing about deadlocks for the time
> being -- find attached the patch described above (1 deadlock -- the
> jmpbuf critical section one -- and the thread-specific mutex).

Thanks.

> Let me know if I've missed anything.

I don't think so, and I plan to apply this very soon.  I've found a
reliable recipe for reproducing the critical section problem: if a
scm_i_gc call is added to make_jmpbuf (), like this:

static SCM
make_jmpbuf (void)
{
  SCM answer;
  SCM_CRITICAL_SECTION_START;
  {
    scm_i_gc ("test");
    SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
    SETJBJMPBUF(answer, (jmp_buf *)0);
    DEACTIVATEJB(answer);
  }
  SCM_CRITICAL_SECTION_END;
  return answer;
}

Then "make check" hangs every time, in the way you described, when
running the system* part of test-suite/standalone/test-system-cmds.

(It happens because scm_system_star calls scm_sigaction, which calls
ensure_signal_delivery_thread, which spawns a new thread; and then
immediately after that, scm_sigaction enters a critical section.)

So now I just want to find a way of making this happen regressibly,
without actually adding the scm_i_gc call to the checked in code.

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

> > Let me know if I've missed anything.
>
> I don't think so, and I plan to apply this very soon.  I've found a
> reliable recipe for reproducing the critical section problem: if a
> scm_i_gc call is added to make_jmpbuf (), like this:


Excellent -- I'll let you know if I can think of a deterministic way
to reproduce that from user code.


At any rate, let me pop a few frames off the stack.  The two remaining
changes for the core features patch were providing a join_thread that
could indicate a timeout without throwing an SRFI-18 exception; and
providing a well-defined fat_mutex_lock that doesn't rely on the
SRFI-18 notion of mutex state.  Two questions:

* What would be an appropriate way for join_thread to indicate a
timeout?  Given that it's a primitive that can be called from Guile, I
take it that the standard C approach of passing a pointer to a flag is
out of the question.  Would it be good enough to have it return #f on
timeout (even if that leaves some amiguity about whether there was a
timeout or just a lack of a thread return value)?  Is there a core
exception it could throw?

* What should be the behavior of fat_mutex_lock when attempting to
lock an abandoned mutex -- in your earlier email, you seemed amenable
to the parts of SRFI-18 that shore up some of the poorly-defined
threading behavior in core threads.  So should locking an abandoned
mutex be an error?  If so, what kind?  Or should locking an abandoned
mutex not be an error at all unless you do it using the SRFI-18 API?


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

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

"Julian Graham" <joolean@gmail.com> writes:

>> > Let me know if I've missed anything.
>>
>> I don't think so, and I plan to apply this very soon.  I've found a
>> reliable recipe for reproducing the critical section problem: if a
>> scm_i_gc call is added to make_jmpbuf (), like this:
>
>
> Excellent -- I'll let you know if I can think of a deterministic way
> to reproduce that from user code.

Thanks.  I've decided to give up on this for now, and just check in
the fix.

I was playing with code like the attached patch - which I think is
already more effort than it's worth spending to be able to regressibly
test this :-) - and then I found that even this doesn't work reliably.
To be precise, it hangs every time when run under GDB, but not when
run outside GDB.

So I think the wise course is to accept that there are some things we
can't write tests for.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: test-gc-deadlock.patch --]
[-- Type: text/x-diff, Size: 3387 bytes --]

Index: libguile/debug.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/debug.c,v
retrieving revision 1.120.2.1
diff -u -r1.120.2.1 debug.c
--- libguile/debug.c	12 Feb 2006 13:42:51 -0000	1.120.2.1
+++ libguile/debug.c	6 Feb 2008 23:52:02 -0000
@@ -523,6 +523,30 @@
 
 \f
 
+unsigned scm_forced_internals[1] = { 0 };
+
+SCM_GLOBAL_SYMBOL (scm_sym_gc_in_make_jmpbuf, "gc-in-make_jmpbuf");
+
+SCM_DEFINE (scm_force_internal, "force-internal", 1, 0, 0,
+	    (SCM op),
+	    "Force the next internal Guile operation @var{op} to occur (for test purposes only).")
+#define FUNC_NAME s_scm_force_internal
+{
+  int op_index;
+
+  if (scm_is_eq (op, scm_sym_gc_in_make_jmpbuf))
+    op_index = SCM_FI_GC_IN_MAKE_JMPBUF;
+  else
+    SCM_WRONG_TYPE_ARG(1, op);
+
+  scm_forced_internals[op_index] = 2;
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
 void
 scm_init_debug ()
 {
Index: libguile/debug.h
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/debug.h,v
retrieving revision 1.58
diff -u -r1.58 debug.h
--- libguile/debug.h	4 Nov 2005 21:20:24 -0000	1.58
+++ libguile/debug.h	6 Feb 2008 23:52:02 -0000
@@ -173,6 +173,12 @@
 SCM_API SCM scm_debug_hang (SCM obj);
 #endif /*GUILE_DEBUG*/
 
+#define SCM_FI_GC_IN_MAKE_JMPBUF 0
+extern unsigned scm_forced_internals[];
+#define SCM_FORCE_INTERNAL(OP) ((scm_forced_internals[OP]) && !(--scm_forced_internals[OP]))
+
+SCM_API SCM scm_force_internal (SCM op);
+
 #if SCM_ENABLE_DEPRECATED == 1
 
 #define CHECK_ENTRY      scm_check_entry_p
Index: libguile/throw.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/throw.c,v
retrieving revision 1.108.2.3
diff -u -r1.108.2.3 throw.c
--- libguile/throw.c	2 Jun 2006 23:39:12 -0000	1.108.2.3
+++ libguile/throw.c	6 Feb 2008 23:52:02 -0000
@@ -73,6 +73,8 @@
   SCM answer;
   SCM_CRITICAL_SECTION_START;
   {
+    if (SCM_FORCE_INTERNAL (SCM_FI_GC_IN_MAKE_JMPBUF))
+      scm_i_gc ("test");
     SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
     SETJBJMPBUF(answer, (jmp_buf *)0);
     DEACTIVATEJB(answer);
Index: test-suite/standalone/Makefile.am
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/standalone/Makefile.am,v
retrieving revision 1.13.2.7
diff -u -r1.13.2.7 Makefile.am
--- test-suite/standalone/Makefile.am	1 Feb 2008 22:47:51 -0000	1.13.2.7
+++ test-suite/standalone/Makefile.am	6 Feb 2008 23:52:03 -0000
@@ -55,6 +55,9 @@
 check_SCRIPTS += test-bad-identifiers
 TESTS += test-bad-identifiers
 
+check_SCRIPTS += test-gc-in-make-jmpbuf
+TESTS += test-gc-in-make-jmpbuf
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}
Index: test-suite/standalone/test-gc-in-make-jmpbuf
===================================================================
RCS file: test-suite/standalone/test-gc-in-make-jmpbuf
diff -N test-suite/standalone/test-gc-in-make-jmpbuf
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ test-suite/standalone/test-gc-in-make-jmpbuf	6 Feb 2008 23:52:03 -0000
@@ -0,0 +1,10 @@
+#!/bin/sh
+exec guile -s "$0" "$@"
+!#
+
+(force-internal 'gc-in-make_jmpbuf)
+(system* "sleep" "1")
+
+;; Local Variables:
+;; mode: scheme
+;; End:

[-- Attachment #3: Type: text/plain, Size: 1810 bytes --]


> At any rate, let me pop a few frames off the stack.  The two remaining
> changes for the core features patch were providing a join_thread that
> could indicate a timeout without throwing an SRFI-18 exception; and
> providing a well-defined fat_mutex_lock that doesn't rely on the
> SRFI-18 notion of mutex state.  Two questions:
>
> * What would be an appropriate way for join_thread to indicate a
> timeout?  Given that it's a primitive that can be called from Guile, I
> take it that the standard C approach of passing a pointer to a flag is
> out of the question.  Would it be good enough to have it return #f on
> timeout (even if that leaves some amiguity about whether there was a
> timeout or just a lack of a thread return value)?  Is there a core
> exception it could throw?

How about if the core join-thread takes an optional timeout-val
parameter, like SRFI-18 thread-join! ?  If no timeout-val was
supplied, and the join timed out, the core join-thread would return
#f.

The #f would indeed be ambiguous, but any given caller can eliminate
the ambiguity if they choose to by specifying a timeout-val.

Note that thread-join! can map onto this, in the case where _it_ gets
no timeout-val, by constructing a unique object such as (list
'timeout) and passing this as the timeout-val to the core join-thread.

> * What should be the behavior of fat_mutex_lock when attempting to
> lock an abandoned mutex -- in your earlier email, you seemed amenable
> to the parts of SRFI-18 that shore up some of the poorly-defined
> threading behavior in core threads.  So should locking an abandoned
> mutex be an error?  If so, what kind?  Or should locking an abandoned
> mutex not be an error at all unless you do it using the SRFI-18 API?

I'll get back to you on this one tomorrow!

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

I await your mutex wisdom; while I wait for tomorrow's post, though --


> How about if the core join-thread takes an optional timeout-val
> parameter, like SRFI-18 thread-join! ?  If no timeout-val was
> supplied, and the join timed out, the core join-thread would return
> #f.

For join-thread, sure.  What about scm_join_thread?  Sorry if I'm
being obtuse, but my understanding was that you didn't want anything
like scm_join_thread_timed and that changing the signature of
scm_join_thread was out of the question.  (Or should this enhancement
only be exposed in Scheme?)


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

>> How about if the core join-thread takes an optional timeout-val
>> parameter, like SRFI-18 thread-join! ?  If no timeout-val was
>> supplied, and the join timed out, the core join-thread would return
>> #f.
>
> For join-thread, sure.  What about scm_join_thread?  Sorry if I'm
> being obtuse, but my understanding was that you didn't want anything
> like scm_join_thread_timed and that changing the signature of
> scm_join_thread was out of the question.  (Or should this enhancement
> only be exposed in Scheme?)

Write scm_join_thread_timed(), which implements all the new behaviour.
Map that to join-thread in Scheme - then that's still back compatible,
because the added args are optional.  Then rewrite scm_join_thread()
as a trivial function that just calls scm_join_thread_timed().

See scm_catch_with_pre_unwind_handler() and scm_catch() in throw.c for
a similar example.

Does that sound OK to you?

Regards,
     Neil

Re: srfi-18 requirements

[Julian Graham]

> > For join-thread, sure.  What about scm_join_thread?  Sorry if I'm
> > being obtuse, but my understanding was that you didn't want anything
> > like scm_join_thread_timed and that changing the signature of
> > scm_join_thread was out of the question.  (Or should this enhancement
> > only be exposed in Scheme?)
>
> Write scm_join_thread_timed(), which implements all the new behaviour.
> Map that to join-thread in Scheme - then that's still back compatible,
> because the added args are optional.  Then rewrite scm_join_thread()
> as a trivial function that just calls scm_join_thread_timed().
>
> See scm_catch_with_pre_unwind_handler() and scm_catch() in throw.c for
> a similar example.
>
> Does that sound OK to you?


Quite!  Thanks.

Re: srfi-18 requirements

[Neil Jerram]

>> * What should be the behavior of fat_mutex_lock when attempting to
>> lock an abandoned mutex -- in your earlier email, you seemed amenable
>> to the parts of SRFI-18 that shore up some of the poorly-defined
>> threading behavior in core threads.  So should locking an abandoned
>> mutex be an error?  If so, what kind?  Or should locking an abandoned
>> mutex not be an error at all unless you do it using the SRFI-18 API?

As previously discussed, I think it's better for the core behavior to
be defined - i.e. by signaling some kind of error - than undefined as
it is now.

I suggest we introduce 'locking-abandoned-mutex-error as a new throw
key, and fat_mutex_lock() can throw that.  That's then trivial for the
SRFI-18 API to catch and reraise as a SRFI-34/35 exception.

OK?

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

> As previously discussed, I think it's better for the core behavior to
> be defined - i.e. by signaling some kind of error - than undefined as
> it is now.
>
> I suggest we introduce 'locking-abandoned-mutex-error as a new throw
> key, and fat_mutex_lock() can throw that.  That's then trivial for the
> SRFI-18 API to catch and reraise as a SRFI-34/35 exception.
>
> OK?


Works for me.  I'll try to have something to you this weekend.


Regards,
Julian

Re: srfi-18 requirements

[Julian Graham]

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

>
> Works for me.  I'll try to have something to you this weekend.
>


Okay, find attached a patch against HEAD containing the aforementioned
changes to the core for supporting SRFI-18.  I'm still looping my test
code, but I thought I should get something out to you guys this
evening.  In addition to the code changes, the patch includes relevant
Changelog, doc, and threads.test updates.  Let me know what you think.


Regards,
Julian

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

Index: doc/ref/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/doc/ref/ChangeLog,v
retrieving revision 1.357
diff -a -u -r1.357 ChangeLog
--- doc/ref/ChangeLog	1 Feb 2008 21:02:15 -0000	1.357
+++ doc/ref/ChangeLog	11 Feb 2008 02:36:49 -0000
@@ -1,3 +1,11 @@
+2008-02-10  Julian Graham  <joolean@gmail.com>
+
+	* api-scheduling.texi (Threads): Add documentation for new 
+	functions "scm_thread_p" and new "scm_join_thread_timed".
+	(Mutexes and Condition Variables): Add documentation for new 
+	functions "scm_mutex_p", "scm_lock_mutex_timed", 
+	"scm_unlock_mutex_timed", and "scm_condition_variable_p".
+
 2008-02-01  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* api-scheduling.texi (Threads): Add "C Function scm_join_thread"
Index: doc/ref/api-scheduling.texi
===================================================================
RCS file: /sources/guile/guile/guile-core/doc/ref/api-scheduling.texi,v
retrieving revision 1.19
diff -a -u -r1.19 api-scheduling.texi
--- doc/ref/api-scheduling.texi	1 Feb 2008 21:02:15 -0000	1.19
+++ doc/ref/api-scheduling.texi	11 Feb 2008 02:36:50 -0000
@@ -267,12 +267,23 @@
 @emph{exit value} of the thread and the thread is terminated.
 @end deftypefn
 
+@deffn {Scheme Procedure} thread? obj
+@deffnx {C Function} scm_thread_p (obj)
+Return @code{#t} iff @var{obj} is a thread; otherwise, return
+@code{#f}.
+@end deffn
+
 @c begin (texi-doc-string "guile" "join-thread")
-@deffn {Scheme Procedure} join-thread thread
+@deffn {Scheme Procedure} join-thread thread [timeout]
 @deffnx {C Function} scm_join_thread (thread)
+@deffnx {C Function} scm_join_thread_timed (thread, timeout)
 Wait for @var{thread} to terminate and return its exit value.  Threads
 that have not been created with @code{call-with-new-thread} or
-@code{scm_spawn_thread} have an exit value of @code{#f}.
+@code{scm_spawn_thread} have an exit value of @code{#f}.  When 
+@var{timeout} is given, it specifies a point in time where the waiting
+should be aborted.  It can be either an integer as returned by 
+@code{current-time} or a pair as returned by @code{gettimeofday}.  
+When the waiting is aborted, @code{#f} is returned.
 @end deffn
 
 @deffn {Scheme Procedure} thread-exited? thread
@@ -368,16 +379,28 @@
 Return a new standard mutex.  It is initially unlocked.
 @end deffn
 
+@deffn {Scheme Procedure} mutex? obj
+@deffnx {C Function} scm_mutex_p (obj)
+Return @code{#t} iff @var{obj} is a mutex; otherwise, return 
+@code{#f}.
+@end deffn
+
 @deffn {Scheme Procedure} make-recursive-mutex
 @deffnx {C Function} scm_make_recursive_mutex ()
 Create a new recursive mutex.  It is initialloy unlocked.
 @end deffn
 
-@deffn {Scheme Procedure} lock-mutex mutex
+@deffn {Scheme Procedure} lock-mutex mutex [timeout]
 @deffnx {C Function} scm_lock_mutex (mutex)
+@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout)
 Lock @var{mutex}.  If the mutex is already locked by another thread
 then block and return only when @var{mutex} has been acquired.
 
+When @var{timeout} is given, it specifies a point in time where the 
+waiting should be aborted.  It can be either an integer as returned 
+by @code{current-time} or a pair as returned by @code{gettimeofday}.  
+When the waiting is aborted, @code{#f} is returned. 
+
 For standard mutexes (@code{make-mutex}), and error is signalled if
 the thread has itself already locked @var{mutex}.
 
@@ -386,6 +409,10 @@
 call increments the lock count.  An additional @code{unlock-mutex}
 will be required to finally release.
 
+If @var{mutex} was locked by a thread that exited before unlocking it,
+the next attempt to lock @var{mutex} will succeed, but 
+@code{locking-abandoned-mutex-error} will be signalled.
+
 When a system async (@pxref{System asyncs}) is activated for a thread
 blocked in @code{lock-mutex}, the wait is interrupted and the async is
 executed.  When the async returns, the wait resumes.
@@ -404,10 +431,23 @@
 the return is @code{#f}.
 @end deffn
 
-@deffn {Scheme Procedure} unlock-mutex mutex
+@deffn {Scheme Procedure} unlock-mutex mutex [condvar [timeout]]
 @deffnx {C Function} scm_unlock_mutex (mutex)
+@deffnx {C Function} scm_unlock_mutex_timed (mutex, condvar, timeout)
 Unlock @var{mutex}.  An error is signalled if @var{mutex} is not
 locked by the calling thread.
+
+If @var{condvar} is given, it specifies a condition variable upon
+which the calling thread will wait to be signalled before unlocking
+@var{mutex}.  (This behavior is very similar to that of 
+@code{wait-condition-variable}, except that the mutex is left in an 
+unlocked state when the function returns.)
+
+When @var{timeout} is also given, it specifies a point in time where 
+the waiting should be aborted.  It can be either an integer as 
+returned by @code{current-time} or a pair as returned by 
+@code{gettimeofday}.  When the waiting is aborted, @code{#f} is 
+returned. 
 @end deffn
 
 @deffn {Scheme Procedure} make-condition-variable
@@ -415,6 +455,12 @@
 Return a new condition variable.
 @end deffn
 
+@deffn {Scheme Procedure} condition-variable? obj
+@deffnx {C Function} scm_condition_variable_p (obj)
+Return @code{#t} iff @var{obj} is a condition variable; otherwise, 
+return @code{#f}.
+@end deffn
+
 @deffn {Scheme Procedure} wait-condition-variable condvar mutex [time]
 @deffnx {C Function} scm_wait_condition_variable (condvar, mutex, time)
 Wait until @var{condvar} has been signalled.  While waiting,
Index: libguile/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2430
diff -a -u -r1.2430 ChangeLog
--- libguile/ChangeLog	7 Feb 2008 09:54:46 -0000	1.2430
+++ libguile/ChangeLog	11 Feb 2008 02:37:10 -0000
@@ -1,3 +1,24 @@
+2008-02-10  Julian Graham  <joolean@gmail.com>
+
+	* threads.c (scm_to_timespec, scm_join_thread_timed, scm_thread_p, 
+	scm_lock_mutex_timed, scm_unlock_mutex_timed, scm_mutex_p, 
+	scm_condition_variable_p): New functions.
+	(thread_mark): Updated to mark new struct field `mutexes'.
+	(do_thread_exit): Notify threads waiting on mutexes locked by exiting 
+	thread.
+	(scm_join_thread, scm_mutex_lock): Reimplement in terms of their new, 
+	timed counterparts.
+	(scm_abandoned_mutex_error_key): New symbol.
+	(fat_mutex_lock): Reimplement to support timeouts and abandonment.
+	(fat_mutex_trylock, scm_try_mutex): Remove fat_mutex_trylock and
+	reimplement scm_try_mutex as a lock attempt with a timeout of zero.
+	(fat_mutex_unlock): Allow unlocking from other threads.
+	(scm_timed_wait_condition_variable): Updated to use scm_to_timespec.
+	* threads.h (scm_i_thread)[mutexes]: New field.
+	(scm_join_thread_timed, scm_thread_p, scm_lock_mutex_timed,
+	scm_unlock_mutex_timed, scm_mutex_p, scm_condition_variable_p): 
+	Prototypes for new functions.
+
 2008-02-07  Ludovic Courtès  <ludo@gnu.org>
 
 	Fix bug #21378.
Index: libguile/threads.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.91
diff -a -u -r1.91 threads.c
--- libguile/threads.c	7 Feb 2008 01:24:31 -0000	1.91
+++ libguile/threads.c	11 Feb 2008 02:37:16 -0000
@@ -49,6 +49,7 @@
 #include "libguile/gc.h"
 #include "libguile/init.h"
 #include "libguile/scmsigs.h"
+#include "libguile/strings.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.
@@ -134,6 +155,7 @@
   scm_gc_mark (t->result);
   scm_gc_mark (t->cleanup_handler);
   scm_gc_mark (t->join_queue);
+  scm_gc_mark (t->mutexes);
   scm_gc_mark (t->dynwinds);
   scm_gc_mark (t->active_asyncs);
   scm_gc_mark (t->continuation_root);
@@ -418,6 +440,7 @@
   t->handle = SCM_BOOL_F;
   t->result = SCM_BOOL_F;
   t->cleanup_handler = SCM_BOOL_F;
+  t->mutexes = SCM_EOL;
   t->join_queue = SCM_EOL;
   t->dynamic_state = SCM_BOOL_F;
   t->dynwinds = SCM_EOL;
@@ -478,6 +501,26 @@
   t->block_asyncs = 0;
 }
 
+\f
+/*** Fat mutexes */
+
+/* We implement our own mutex type since we want them to be 'fair', we
+   want to do fancy things while waiting for them (like running
+   asyncs) and we might want to add things that are nice for
+   debugging.
+*/
+
+typedef struct {
+  scm_i_pthread_mutex_t lock;
+  SCM owner;
+  int level;      /* how much the owner owns us.  
+		     < 0 for non-recursive mutexes */
+  SCM waiting;    /* the threads waiting for this mutex. */
+} fat_mutex;
+
+#define SCM_MUTEXP(x)         SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
+#define SCM_MUTEX_DATA(x)     ((fat_mutex *) SCM_SMOB_DATA (x))
+
 /* Perform thread tear-down, in guile mode.
  */
 static void *
@@ -503,6 +546,18 @@
   while (scm_is_true (unblock_from_queue (t->join_queue)))
     ;
 
+  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;
@@ -989,14 +1044,22 @@
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
-	    (SCM thread),
+SCM scm_join_thread (SCM thread)
+{
+  return scm_join_thread_timed (thread, SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 1, 0,
+	    (SCM thread, SCM timeout),
 "Suspend execution of the calling thread until the target @var{thread} "
 "terminates, unless the target @var{thread} has already terminated. ")
-#define FUNC_NAME s_scm_join_thread
+#define FUNC_NAME s_scm_join_thread_timed
 {
+  int timed_out = 0;
   scm_i_thread *t;
-  SCM res;
+  scm_t_timespec ctimeout, *timeout_ptr = NULL;
+  SCM res = SCM_BOOL_F;
 
   SCM_VALIDATE_THREAD (1, thread);
   if (scm_is_eq (scm_current_thread (), thread))
@@ -1005,11 +1068,23 @@
   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, &t->admin_mutex, NULL);
+	  int err = block_self (t->join_queue, thread, &t->admin_mutex, 
+				timeout_ptr);
+	  if (err == ETIMEDOUT)
+	    {
+	      timed_out = 1;
+	      break;
+	    }
 	  if (t->exited)
 	    break;
 	  scm_i_pthread_mutex_unlock (&t->admin_mutex);
@@ -1017,7 +1092,11 @@
 	  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
 	}
     }
-  res = t->result;
+
+  if (!timed_out)
+    {
+      res = t->result;
+    }
 
   scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
@@ -1025,26 +1104,14 @@
 }
 #undef FUNC_NAME
 
-
-\f
-/*** Fat mutexes */
-
-/* We implement our own mutex type since we want them to be 'fair', we
-   want to do fancy things while waiting for them (like running
-   asyncs) and we might want to add things that are nice for
-   debugging.
-*/
-
-typedef struct {
-  scm_i_pthread_mutex_t lock;
-  SCM owner;
-  int level;      /* how much the owner owns us.  
-		     < 0 for non-recursive mutexes */
-  SCM waiting;    /* the threads waiting for this mutex. */
-} fat_mutex;
-
-#define SCM_MUTEXP(x)         SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
-#define SCM_MUTEX_DATA(x)     ((fat_mutex *) SCM_SMOB_DATA (x))
+SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0,
+	    (SCM obj),
+	    "Return @code{#t} if @var{obj} is a thread.")
+#define FUNC_NAME s_scm_thread_p
+{
+  return SCM_I_IS_THREAD(obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
 
 static SCM
 fat_mutex_mark (SCM mx)
@@ -1107,55 +1174,121 @@
 }
 #undef FUNC_NAME
 
-static char *
-fat_mutex_lock (SCM mutex)
+SCM_SYMBOL (scm_abandoned_mutex_error_key, "locking-abandoned-mutex-error");
+
+static SCM
+fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
 {
   fat_mutex *m = SCM_MUTEX_DATA (mutex);
+
   SCM thread = scm_current_thread ();
-  char *msg = NULL;
+  scm_i_thread *t = SCM_I_THREAD_DATA (thread);
+
+  SCM err = SCM_BOOL_F;
+
+  struct timeval current_time;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
   if (scm_is_false (m->owner))
-    m->owner = thread;
+    {
+      m->owner = thread;
+      scm_i_pthread_mutex_lock (&t->admin_mutex);
+      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);
+      *ret = 1;
+    }
   else if (scm_is_eq (m->owner, thread))
     {
       if (m->level >= 0)
 	m->level++;
       else
-	msg = "mutex already locked by current thread";
+	err = scm_cons (scm_misc_error_key,
+			scm_from_locale_string ("mutex already locked by "
+						"current thread"));
+      *ret = 0;
     }
   else
     {
+      int first_iteration = 1;
       while (1)
 	{
-	  block_self (m->waiting, mutex, &m->lock, NULL);
-	  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 (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner))
+	    {
+	      scm_i_pthread_mutex_lock (&t->admin_mutex);
+	      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);
+	      *ret = 1;
+	      if (scm_c_thread_exited_p (m->owner)) 
+		{
+		  m->owner = thread;
+		  err = scm_cons (scm_abandoned_mutex_error_key,
+				  scm_from_locale_string ("lock obtained on "
+							  "abandoned mutex"));
+		}
+	      break;
+	    }
+	  else if (!first_iteration)
+	    {
+	      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);
+	    }
+	  else
+	    first_iteration = 0;
+	  block_self (m->waiting, mutex, &m->lock, timeout);
 	}
     }
   scm_i_pthread_mutex_unlock (&m->lock);
-  return msg;
+  return err;
 }
 
-SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
-	    (SCM mx),
+SCM scm_lock_mutex (SCM mx)
+{
+  return scm_lock_mutex_timed (mx, SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0,
+	    (SCM m, SCM timeout),
 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
 "blocks until the mutex becomes available. The function returns when "
 "the calling thread owns the lock on @var{mutex}.  Locking a mutex that "
 "a thread already owns will succeed right away and will not block the "
 "thread.  That is, Guile's mutexes are @emph{recursive}. ")
-#define FUNC_NAME s_scm_lock_mutex
+#define FUNC_NAME s_scm_lock_mutex_timed
 {
-  char *msg;
+  SCM exception;
+  int ret = 0;
+  scm_t_timespec cwaittime, *waittime = NULL;
 
-  SCM_VALIDATE_MUTEX (1, mx);
-  msg = fat_mutex_lock (mx);
-  if (msg)
-    scm_misc_error (NULL, msg, SCM_EOL);
-  return SCM_BOOL_T;
+  SCM_VALIDATE_MUTEX (1, m);
+
+  if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout))
+    {
+      cwaittime = scm_to_timespec (timeout);
+      waittime = &cwaittime;
+    }
+
+  exception = fat_mutex_lock (m, 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
 
@@ -1168,71 +1301,56 @@
 				       SCM_F_WIND_EXPLICITLY);
 }
 
-static char *
-fat_mutex_trylock (fat_mutex *m, int *resp)
-{
-  char *msg = NULL;
-  SCM thread = scm_current_thread ();
-
-  *resp = 1;
-  scm_i_pthread_mutex_lock (&m->lock);
-  if (scm_is_false (m->owner))
-    m->owner = thread;
-  else if (scm_is_eq (m->owner, thread))
-    {
-      if (m->level >= 0)
-	m->level++;
-      else
-	msg = "mutex already locked by current thread";
-    }
-  else
-    *resp = 0;
-  scm_i_pthread_mutex_unlock (&m->lock);
-  return msg;
-}
-
 SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
 	    (SCM mutex),
 "Try to lock @var{mutex}. If the mutex is already locked by someone "
 "else, return @code{#f}.  Else lock the mutex and return @code{#t}. ")
 #define FUNC_NAME s_scm_try_mutex
 {
-  char *msg;
-  int res;
+  SCM exception;
+  int ret = 0;
+  scm_t_timespec cwaittime, *waittime = NULL;
 
   SCM_VALIDATE_MUTEX (1, mutex);
+
+  cwaittime = scm_to_timespec (scm_from_int(0));
+  waittime = &cwaittime;
   
-  msg = fat_mutex_trylock (SCM_MUTEX_DATA (mutex), &res);
-  if (msg)
-    scm_misc_error (NULL, msg, SCM_EOL);
-  return scm_from_bool (res);
+  exception = fat_mutex_lock (mutex, 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
 
-static char *
-fat_mutex_unlock (fat_mutex *m)
+static void
+fat_mutex_unlock (SCM mx)
 {
-  char *msg = NULL;
-
+  fat_mutex *m = SCM_MUTEX_DATA (mx);
   scm_i_scm_pthread_mutex_lock (&m->lock);
-  if (!scm_is_eq (m->owner, scm_current_thread ()))
+  if (m->level > 0)
+    m->level--;
+  else 
     {
-      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);
+      m->owner = unblock_from_queue (m->waiting);
+      scm_i_pthread_mutex_lock (&t->admin_mutex);
+      scm_delete_x (t->mutexes, mx);
+      scm_i_pthread_mutex_unlock (&t->admin_mutex);
     }
-  else if (m->level > 0)
-    m->level--;
-  else
-    m->owner = unblock_from_queue (m->waiting);
   scm_i_pthread_mutex_unlock (&m->lock);
+}
+
+static int
+fat_cond_timedwait (SCM, SCM, const scm_t_timespec *);
 
-  return msg;
+SCM scm_unlock_mutex (SCM mx)
+{
+  return scm_unlock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
 }
 
-SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
-	    (SCM mx),
+SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0,
+	    (SCM mx, SCM cond, SCM timeout),
 "Unlocks @var{mutex} if the calling thread owns the lock on "
 "@var{mutex}.  Calling unlock-mutex on a mutex not owned by the current "
 "thread results in undefined behaviour. Once a mutex has been unlocked, "
@@ -1240,18 +1358,39 @@
 "lock.  Every call to @code{lock-mutex} by this thread must be matched "
 "with a call to @code{unlock-mutex}.  Only the last call to "
 "@code{unlock-mutex} will actually unlock the mutex. ")
-#define FUNC_NAME s_scm_unlock_mutex
+#define FUNC_NAME s_scm_unlock_mutex_timed
 {
-  char *msg;
+  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_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 
+
 #if 0
 
 SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
@@ -1335,30 +1474,25 @@
 		    const scm_t_timespec *waittime)
 {
   scm_i_thread *t = SCM_I_CURRENT_THREAD;
+  
   fat_cond *c = SCM_CONDVAR_DATA (cond);
-  fat_mutex *m = SCM_MUTEX_DATA (mutex);
-  const char *msg;
-  int err = 0;
+  int err = 0, ret = 0;
 
   while (1)
     {
       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, 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)
@@ -1393,16 +1527,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;
     }
 
@@ -1449,6 +1574,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
Index: libguile/threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v
retrieving revision 1.50
diff -a -u -r1.50 threads.h
--- libguile/threads.h	7 Feb 2008 01:24:31 -0000	1.50
+++ libguile/threads.h	11 Feb 2008 02:37:17 -0000
@@ -54,6 +54,7 @@
   SCM join_queue;
 
   scm_i_pthread_mutex_t admin_mutex;
+  SCM mutexes;
 
   SCM result;
   int canceled;
@@ -162,13 +163,18 @@
 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_API SCM scm_thread_p (SCM t);
 
 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 timeout);
 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 timeout);
+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);
@@ -176,6 +182,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: test-suite/tests/threads.test
===================================================================
RCS file: /sources/guile/guile/guile-core/test-suite/tests/threads.test,v
retrieving revision 1.7
diff -a -u -r1.7 threads.test
--- test-suite/tests/threads.test	20 Oct 2007 11:09:58 -0000	1.7
+++ test-suite/tests/threads.test	11 Feb 2008 02:37:17 -0000
@@ -138,6 +138,85 @@
 	    (equal? result '(10 8 6 4 2 0)))))
 
       ;;
+      ;; timed mutex locking
+      ;;
+
+      (with-test-prefix "lock-mutex"
+
+	(pass-if "timed locking fails if timeout exceeded"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m)
+	    (let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
+	      (not (join-thread t)))))
+
+        (pass-if "timed locking succeeds if mutex unlocked within timeout"
+	  (let* ((m (make-mutex))
+		 (c (make-condition-variable))
+		 (cm (make-mutex)))
+	    (lock-mutex cm)
+	    (let ((t (begin-thread (begin (lock-mutex cm)
+					  (signal-condition-variable c)
+					  (unlock-mutex cm)
+					  (lock-mutex m
+						      (+ (current-time) 2))))))
+	      (lock-mutex m)
+	      (wait-condition-variable c cm)
+	      (unlock-mutex cm)
+	      (sleep 1)
+	      (unlock-mutex m)
+	      (join-thread t)))))
+
+      ;;
+      ;; timed mutex unlocking
+      ;;
+
+      (with-test-prefix "unlock-mutex"
+
+        (pass-if "timed unlocking returns #f if timeout exceeded"
+          (let ((m (make-mutex))
+		(c (make-condition-variable)))
+	    (lock-mutex m)
+	    (not (unlock-mutex m c 0))))
+
+        (pass-if "timed unlocking returns #t if condition signaled"
+	  (let ((m1 (make-mutex))
+		(m2 (make-mutex))
+		(c1 (make-condition-variable))
+		(c2 (make-condition-variable)))
+	    (lock-mutex m1)
+	    (let ((t (begin-thread (begin (lock-mutex m1)
+					  (signal-condition-variable c1)
+					  (lock-mutex m2)
+					  (unlock-mutex m1)
+					  (unlock-mutex m2 
+							c2 
+							(+ (current-time) 
+							   1))))))
+	      (wait-condition-variable c1 m1)
+	      (unlock-mutex m1)
+	      (lock-mutex m2)
+	      (signal-condition-variable c2)
+	      (unlock-mutex m2)
+	      (join-thread t)))))
+
+      ;;
+      ;; timed joining
+      ;;
+
+      (with-test-prefix "join-thread"
+
+	(pass-if "timed joining fails if timeout exceeded"
+	  (let* ((m (make-mutex))
+		 (c (make-condition-variable))
+		 (t (begin-thread (begin (lock-mutex m)
+					 (wait-condition-variable c m)))))
+	    (not (join-thread t (+ (current-time) 1)))))
+      
+	(pass-if "timed joining succeeds if thread exits within timeout"
+          (let ((t (begin-thread (begin (sleep 1) #t))))
+	    (join-thread t (+ (current-time) 2)))))
+
+      ;;
       ;; thread cancellation
       ;;
 
@@ -185,4 +264,20 @@
 	      (eq? (join-thread t) 'bar))))
 
 	(pass-if "initial handler is false"
-	  (not (thread-cleanup (current-thread)))))))
+	  (not (thread-cleanup (current-thread)))))
+
+      ;;
+      ;; mutex behavior
+      ;;
+
+      (with-test-prefix "mutex-behavior"
+
+	(pass-if "locking abandoned mutex throws exception"
+          (let* ((m (make-mutex))
+		 (t (begin-thread (lock-mutex m)))
+		 (success #f))
+	    (join-thread t)
+	    (catch 'locking-abandoned-mutex-error
+		   (lambda () (lock-mutex m))
+		   (lambda key (set! success #t)))
+	    success)))))

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Okay, find attached a patch against HEAD containing the aforementioned
> changes to the core for supporting SRFI-18.  I'm still looping my test
> code, but I thought I should get something out to you guys this
> evening.  In addition to the code changes, the patch includes relevant
> Changelog, doc, and threads.test updates.  Let me know what you think.

Looking good!  Many thanks for your continuing work on this, and sorry
for my delay (once again!) in reviewing.  I have a few comments, as
follows.

>  @c begin (texi-doc-string "guile" "join-thread")
> -@deffn {Scheme Procedure} join-thread thread
> +@deffn {Scheme Procedure} join-thread thread [timeout]
>  @deffnx {C Function} scm_join_thread (thread)
> +@deffnx {C Function} scm_join_thread_timed (thread, timeout)

Didn't we agree to add a timeout-val parameter here?

> +static scm_t_timespec
> +scm_to_timespec (SCM t)

For static functions it's nice to omit the scm_ prefix, because they
don't need it, and it makes it clearer to the casual reader that
they're not part of the API.

Also, can the signature be void to_timespec (SCM t, scm_t_timespec *),
to avoid relying on support for struct return?

> -SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
> -	    (SCM thread),
> +SCM scm_join_thread (SCM thread)
> +{
> +  return scm_join_thread_timed (thread, SCM_BOOL_F);

You should use SCM_UNDEFINED to indicate an absent parameter, rather
than SCM_BOOL_F.

> +}
> +#undef FUNC_NAME

Last #undef line is extraneous.

> +
> +SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 1, 0,
> +	    (SCM thread, SCM timeout),

What about the timeout_val parameter ...

>  "Suspend execution of the calling thread until the target @var{thread} "
>  "terminates, unless the target @var{thread} has already terminated. ")
> -#define FUNC_NAME s_scm_join_thread
> +#define FUNC_NAME s_scm_join_thread_timed
>  {
> +  int timed_out = 0;
>    scm_i_thread *t;
> -  SCM res;
> +  scm_t_timespec ctimeout, *timeout_ptr = NULL;
> +  SCM res = SCM_BOOL_F;
>  
>    SCM_VALIDATE_THREAD (1, thread);
>    if (scm_is_eq (scm_current_thread (), thread))
> @@ -1005,11 +1068,23 @@
>    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, &t->admin_mutex, NULL);
> +	  int err = block_self (t->join_queue, thread, &t->admin_mutex, 
> +				timeout_ptr);
> +	  if (err == ETIMEDOUT)
> +	    {
> +	      timed_out = 1;

... which I would expect to be assigned to res here.

> +	      break;
> +	    }
>  	  if (t->exited)

Do res = t->result here, rather than below, to make clear that it goes
with the t->exited case?

> +static SCM
> +fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
>  {
>    fat_mutex *m = SCM_MUTEX_DATA (mutex);
> +
>    SCM thread = scm_current_thread ();
> -  char *msg = NULL;
> +  scm_i_thread *t = SCM_I_THREAD_DATA (thread);
> +
> +  SCM err = SCM_BOOL_F;
> +
> +  struct timeval current_time;
>  
>    scm_i_scm_pthread_mutex_lock (&m->lock);
>    if (scm_is_false (m->owner))
> -    m->owner = thread;
> +    {
> +      m->owner = thread;
> +      scm_i_pthread_mutex_lock (&t->admin_mutex);
> +      if (scm_is_null (t->mutexes))
> +        t->mutexes = scm_list_1 (mutex);
> +      else
> +        t->mutexes = scm_cons (mutex, t->mutexes);

Just "t->mutexes = scm_cons (mutex, t->mutexes);" is sufficient for
both cases.

> +      scm_i_pthread_mutex_unlock (&t->admin_mutex);
> +      *ret = 1;
> +    }
>    else if (scm_is_eq (m->owner, thread))
>      {
>        if (m->level >= 0)
>  	m->level++;
>        else
> -	msg = "mutex already locked by current thread";
> +	err = scm_cons (scm_misc_error_key,
> +			scm_from_locale_string ("mutex already locked by "
> +						"current thread"));
> +      *ret = 0;
>      }
>    else
>      {
> +      int first_iteration = 1;
>        while (1)
>  	{
> -	  block_self (m->waiting, mutex, &m->lock, NULL);
> -	  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 (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner))
> +	    {
> +	      scm_i_pthread_mutex_lock (&t->admin_mutex);
> +	      if (scm_is_null (t->mutexes))
> +		t->mutexes = scm_list_1 (mutex);
> +	      else
> +		t->mutexes = scm_cons (mutex, t->mutexes);

Same again here.

> +	  else if (!first_iteration)
> +	    {
> +	      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;
> +		    }

Is timeout an absolute time, or relative to when join-thread was
called?  Before getting to this code, I thought it was relative - but
then I don't see how the code above can be correct, because it is
comparing against the absolute gettimeofday() ...?

> -SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
> -	    (SCM mx),
> +SCM scm_lock_mutex (SCM mx)
> +{
> +  return scm_lock_mutex_timed (mx, SCM_BOOL_F);

Should be SCM_UNDEFINED.

> -static char *
> -fat_mutex_unlock (fat_mutex *m)
> +static void
> +fat_mutex_unlock (SCM mx)
>  {
> -  char *msg = NULL;
> -
> +  fat_mutex *m = SCM_MUTEX_DATA (mx);
>    scm_i_scm_pthread_mutex_lock (&m->lock);
> -  if (!scm_is_eq (m->owner, scm_current_thread ()))
> +  if (m->level > 0)
> +    m->level--;
> +  else 

It looks like there is a significant change to the semantics here: any
thread can unlock a mutex, not just the thread that locked it.  Is
that the intention, or am I misunderstanding?

> +static int
> +fat_cond_timedwait (SCM, SCM, const scm_t_timespec *);
>  
> -  return msg;
> +SCM scm_unlock_mutex (SCM mx)
> +{
> +  return scm_unlock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
>  }
>  
> -SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
> -	    (SCM mx),
> +SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0,
> +	    (SCM mx, SCM cond, SCM timeout),
>  "Unlocks @var{mutex} if the calling thread owns the lock on "
>  "@var{mutex}.  Calling unlock-mutex on a mutex not owned by the current "
>  "thread results in undefined behaviour. Once a mutex has been unlocked, "
> @@ -1240,18 +1358,39 @@
>  "lock.  Every call to @code{lock-mutex} by this thread must be matched "
>  "with a call to @code{unlock-mutex}.  Only the last call to "
>  "@code{unlock-mutex} will actually unlock the mutex. ")
> -#define FUNC_NAME s_scm_unlock_mutex
> +#define FUNC_NAME s_scm_unlock_mutex_timed
>  {
> -  char *msg;
> +  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;
> +    }

Call scm_timed_wait_condition_variable() here, instead of duplicating
the code?

Actually, that strongly says to me that we don't need the `cond' part
of this API to be implemented in C.  Can we move that to the SRFI-18
Scheme code, and leave the C API as a plain unlock-mutex operation?

Regards,
       Neil

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,

> Looking good!  Many thanks for your continuing work on this, and sorry
> for my delay (once again!) in reviewing.  I have a few comments, as
> follows.

No worries.  Find my responses below.


> >  @c begin (texi-doc-string "guile" "join-thread")
> > -@deffn {Scheme Procedure} join-thread thread
> > +@deffn {Scheme Procedure} join-thread thread [timeout]
> >  @deffnx {C Function} scm_join_thread (thread)
> > +@deffnx {C Function} scm_join_thread_timed (thread, timeout)
>
> Didn't we agree to add a timeout-val parameter here?

No, we didn't, although I agree such a parameter would be pretty
useful.  I'll add that in the next revision I send you.


> > +static scm_t_timespec
> > +scm_to_timespec (SCM t)
>
> For static functions it's nice to omit the scm_ prefix, because they
> don't need it, and it makes it clearer to the casual reader that
> they're not part of the API.
>
> Also, can the signature be void to_timespec (SCM t, scm_t_timespec *),
> to avoid relying on support for struct return?

Yes and yes.


> > +       else if (!first_iteration)
> > +         {
> > +           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;
> > +                 }
>
> Is timeout an absolute time, or relative to when join-thread was
> called?  Before getting to this code, I thought it was relative - but
> then I don't see how the code above can be correct, because it is
> comparing against the absolute gettimeofday() ...?

It's absolute -- like the arguments for the existing timed
synchronization primitives (and like the timed parts of the SRFI-18
API).  (Unless I'm mistaken...)


> > -static char *
> > -fat_mutex_unlock (fat_mutex *m)
> > +static void
> > +fat_mutex_unlock (SCM mx)
> >  {
> > -  char *msg = NULL;
> > -
> > +  fat_mutex *m = SCM_MUTEX_DATA (mx);
> >    scm_i_scm_pthread_mutex_lock (&m->lock);
> > -  if (!scm_is_eq (m->owner, scm_current_thread ()))
> > +  if (m->level > 0)
> > +    m->level--;
> > +  else
>
> It looks like there is a significant change to the semantics here: any
> thread can unlock a mutex, not just the thread that locked it.  Is
> that the intention, or am I misunderstanding?

No, that's the intention (it's explicitly permitted by SRFI-18).  I
thought you were okay with that, since it was not on your list of
stuff that didn't belong in C.  If that's too big of a change, might I
suggest we add a function that forcibly unlocks a mutex, regardless of
the owner?


> Actually, that strongly says to me that we don't need the `cond' part
> of this API to be implemented in C.  Can we move that to the SRFI-18
> Scheme code, and leave the C API as a plain unlock-mutex operation?

Fine by me (again. left this one in because you didn't squawk about it
earlier), except that it might be harder to guarantee the safety of
mixing the mutex and cond passed to the SRFI-18 Scheme implementation
with non-SRFI-18 calls -- C generally provides a convenient protection
against deadlock for things like that.


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

>> >  @c begin (texi-doc-string "guile" "join-thread")
>> > -@deffn {Scheme Procedure} join-thread thread
>> > +@deffn {Scheme Procedure} join-thread thread [timeout]
>> >  @deffnx {C Function} scm_join_thread (thread)
>> > +@deffnx {C Function} scm_join_thread_timed (thread, timeout)
>>
>> Didn't we agree to add a timeout-val parameter here?
>
> No, we didn't, although I agree such a parameter would be pretty
> useful.

Well we discussed it a bit here:
http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00004.html
http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00005.html

>  I'll add that in the next revision I send you.

Cool, thanks.

>> > +       else if (!first_iteration)
>> > +         {
>> > +           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;
>> > +                 }
>>
>> Is timeout an absolute time, or relative to when join-thread was
>> called?  Before getting to this code, I thought it was relative - but
>> then I don't see how the code above can be correct, because it is
>> comparing against the absolute gettimeofday() ...?
>
> It's absolute -- like the arguments for the existing timed
> synchronization primitives

OK, yes, I see now.  The code is fine as it stands, then.

> (and like the timed parts of the SRFI-18 API).  (Unless I'm
> mistaken...)

But that's not completely right.  SRFI-18 says that timeout-val can be
one of the following:

    * a time object represents an absolute point in time
    * an exact or inexact real number represents a relative time in seconds from the moment the primitive was called
    * #f means that there is no timeout 

So for the SRFI-18 API, timeout-val is sometimes absolute and
sometimes relative!  I guess that just means that the SRFI-18 Scheme
code will have to add (current-time), when an integer or float is
given to it.

>
>> > -static char *
>> > -fat_mutex_unlock (fat_mutex *m)
>> > +static void
>> > +fat_mutex_unlock (SCM mx)
>> >  {
>> > -  char *msg = NULL;
>> > -
>> > +  fat_mutex *m = SCM_MUTEX_DATA (mx);
>> >    scm_i_scm_pthread_mutex_lock (&m->lock);
>> > -  if (!scm_is_eq (m->owner, scm_current_thread ()))
>> > +  if (m->level > 0)
>> > +    m->level--;
>> > +  else
>>
>> It looks like there is a significant change to the semantics here: any
>> thread can unlock a mutex, not just the thread that locked it.  Is
>> that the intention, or am I misunderstanding?
>
> No, that's the intention (it's explicitly permitted by SRFI-18).  I
> thought you were okay with that, since it was not on your list of
> stuff that didn't belong in C.  If that's too big of a change, might I
> suggest we add a function that forcibly unlocks a mutex, regardless of
> the owner?

Sorry for missing this before.  The SRFI-18 semantics are really
interesting, but I think we need to preserve the existing semantics
too for back-compatibility.  i.e. we need to preserve the two
conditions described by this existing code:

  if (!scm_is_eq (m->owner, scm_current_thread ()))
    {
      if (scm_is_false (m->owner))
	msg = "mutex not locked";
      else
	msg = "mutex not locked by current thread";
    }

I guess that means that scm_unlock_mutex_timed will need to take
another optional parameter (or two) indicating whether

- it is an error to unlock an unlocked mutex (default yes, but SRFI-18
  will pass "no")

- it is an error to unlock a mutex owned by another thread (default
  yes, SRFI-18 will pass "no").

Can you propose a representation for this?

>> Actually, that strongly says to me that we don't need the `cond' part
>> of this API to be implemented in C.  Can we move that to the SRFI-18
>> Scheme code, and leave the C API as a plain unlock-mutex operation?
>
> Fine by me (again. left this one in because you didn't squawk about it
> earlier), except that it might be harder to guarantee the safety of
> mixing the mutex and cond passed to the SRFI-18 Scheme implementation
> with non-SRFI-18 calls -- C generally provides a convenient protection
> against deadlock for things like that.

I'm not sure about that argument, but I think it's moot anyway -
because I think the current implementation, which equates to

  (begin
    (wait-condition-variable cond-var mutex)
    (unlock-mutex mutex))

does not always behave as SRFI-18 says.  Specifically, if there is
another thread trying to lock `mutex', `(wait-condition-variable
cond-var mutex)' may block, after the cond-var has been signalled,
because it is not able to reacquire the mutex.  Whereas SRFI-18 says
that the thread that calls mutex-unlock! "can unblock at any time, but
no later than when an appropriate call to condition-variable-signal!
or condition-variable-broadcast! is performed (see below), and no
later than the timeout (if timeout is supplied)".

Given the definitions of `wait-condition-variable' and SRFI-18's
`mutex-unlock!', and that we want Guile to provide both of these, it
seems to me now that `mutex-unlock!' is actually the more primitive
operation, and that `wait-condition-variable' could be written as

    scm_unlock_mutex_timed (mx, cv, 0);
    scm_lock_mutex (mx;)

Is it possible to reorganize the relevant code a bit, so that
scm_unlock_mutex_timed (mx, cv, 0) does not lock and immediately
unlock the mutex after the cond var has been signalled?

Regards,
     Neil

Re: srfi-18 requirements

[Julian Graham]

Hi Neil,


>  > No, we didn't, although I agree such a parameter would be pretty
>  > useful.
>
>  Well we discussed it a bit here:
>  http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00004.html
>  http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00005.html

Argh, don't know how I missed that.  Sorry!


>  So for the SRFI-18 API, timeout-val is sometimes absolute and
>  sometimes relative!  I guess that just means that the SRFI-18 Scheme
>  code will have to add (current-time), when an integer or float is
>  given to it.

Oops -- my mistaken again.  Yes, using `current-time' sounds like a good plan.


>  Sorry for missing this before.  The SRFI-18 semantics are really
>  interesting, but I think we need to preserve the existing semantics
>  too for back-compatibility.

Sure, fair enough.


>  I guess that means that scm_unlock_mutex_timed will need to take
>  another optional parameter (or two) indicating whether
>
>  - it is an error to unlock an unlocked mutex (default yes, but SRFI-18
>   will pass "no")
>
>  - it is an error to unlock a mutex owned by another thread (default
>   yes, SRFI-18 will pass "no").
>
>  Can you propose a representation for this?

Well, this could be down with an entirely separate primitive -- that
is, we could add something with a name like scm_make_permissive_mutex
that initializes the fat_mutex struct with a couple of new flags.
That wouldn't be strictly compatible with SRFI-18, since SRFI-18
`mutex-unlock!' accessing regular mutexes through Guile's primitives
could cause errors to be signaled, but it actually might make more
sense than passing flags to the unlock call, since I would think users
would want consistent behavior from their mutexes, no matter which
functions were used to manipulate them.

If this isn't acceptable, then I think one or two extra flags at the
end is okay.  We could justify one flag by using it to mean "unlock
the mutex, no matter who owns it, including no one."  Either way, the
syntax could be along the lines of unlock-mutex! mutex
[[[allow-unlocking-unowned]] [allow-unlocking-other-thread]].

Actually, I just remembered a fairly elegant approach that seems to be
used in other parts of the Guile API -- these optional arguments could
be specified as symbols: 'unlock-if-unowned and
'unlock-if-owned-by-other, say.  Let me know what you'd prefer.


>  Is it possible to reorganize the relevant code a bit, so that
>  scm_unlock_mutex_timed (mx, cv, 0) does not lock and immediately
>  unlock the mutex after the cond var has been signalled?

Certainly.  It'll be in the next version of the patch.


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

>>  Sorry for missing this before.  The SRFI-18 semantics are really
>>  interesting, but I think we need to preserve the existing semantics
>>  too for back-compatibility.
>
> Sure, fair enough.
>
>
>>  I guess that means that scm_unlock_mutex_timed will need to take
>>  another optional parameter (or two) indicating whether
>>
>>  - it is an error to unlock an unlocked mutex (default yes, but SRFI-18
>>   will pass "no")
>>
>>  - it is an error to unlock a mutex owned by another thread (default
>>   yes, SRFI-18 will pass "no").
>>
>>  Can you propose a representation for this?
>
> Well, this could be down with an entirely separate primitive -- that
> is, we could add something with a name like scm_make_permissive_mutex
> that initializes the fat_mutex struct with a couple of new flags.
> That wouldn't be strictly compatible with SRFI-18, since SRFI-18
> `mutex-unlock!' accessing regular mutexes through Guile's primitives
> could cause errors to be signaled, but it actually might make more
> sense than passing flags to the unlock call, since I would think users
> would want consistent behavior from their mutexes, no matter which
> functions were used to manipulate them.

Agreed, that's a nice solution.  The matter of whether a mutex can be
unlocked by another thread will depend on an application's design for
how it uses that mutex, and it feels right for the application to
declare this when the mutex is created, instead of on every unlock
call.

On the Scheme level, I think the call can still be `make-mutex', with
optional flag args - is that right?

> Actually, I just remembered a fairly elegant approach that seems to be
> used in other parts of the Guile API -- these optional arguments could
> be specified as symbols: 'unlock-if-unowned and
> 'unlock-if-owned-by-other, say.  Let me know what you'd prefer.

This is still an interesting question, but now for `make-mutex'
instead of for `unlock-mutex'.  Personally I like the symbol approach,
because (in comparison with a sequence of #t and #f) it will make the
code easier to understand at the point of the call, and also because
the #t/#f approach requires remembering the parameter ordering.

>>  Is it possible to reorganize the relevant code a bit, so that
>>  scm_unlock_mutex_timed (mx, cv, 0) does not lock and immediately
>>  unlock the mutex after the cond var has been signalled?
>
> Certainly.  It'll be in the next version of the patch.

Looking forward to it!

> Regards,
> Julian

Regards,
  Neil

Re: srfi-18 requirements

[Julian Graham]

>  Agreed, that's a nice solution.  The matter of whether a mutex can be
>  unlocked by another thread will depend on an application's design for
>  how it uses that mutex, and it feels right for the application to
>  declare this when the mutex is created, instead of on every unlock
>  call.
>
>  On the Scheme level, I think the call can still be `make-mutex', with
>  optional flag args - is that right?

Yes.  For C, though, how do you want to manage passing these flags?  I
imagine the primitive should be named something like
scm_make_mutex_with_options (or _with_flags), and we could either
require two arguments (each being a symbol option as described below
or SCM_UNDEFINED) or have it take a list containing an arbitrary
number of symbol options to allow us to extend its behavior as
necessary.  I didn't get a strong sense of established precedent
looking at Guile's C API; I'm kind of leaning towards the list
approach right now.


>  > Actually, I just remembered a fairly elegant approach that seems to be
>  > used in other parts of the Guile API -- these optional arguments could
>  > be specified as symbols: 'unlock-if-unowned and
>  > 'unlock-if-owned-by-other, say.  Let me know what you'd prefer.
>
>  This is still an interesting question, but now for `make-mutex'
>  instead of for `unlock-mutex'.  Personally I like the symbol approach,
>  because (in comparison with a sequence of #t and #f) it will make the
>  code easier to understand at the point of the call, and also because
>  the #t/#f approach requires remembering the parameter ordering.

Cool -- I'll set up make-mutex for Scheme, and for C as described
above.  Let me know if that's not okay.


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

>>  Agreed, that's a nice solution.  The matter of whether a mutex can be
>>  unlocked by another thread will depend on an application's design for
>>  how it uses that mutex, and it feels right for the application to
>>  declare this when the mutex is created, instead of on every unlock
>>  call.
>>
>>  On the Scheme level, I think the call can still be `make-mutex', with
>>  optional flag args - is that right?
>
> Yes.  For C, though, how do you want to manage passing these flags?  I
> imagine the primitive should be named something like
> scm_make_mutex_with_options (or _with_flags), and we could either
> require two arguments (each being a symbol option as described below
> or SCM_UNDEFINED) or have it take a list containing an arbitrary
> number of symbol options to allow us to extend its behavior as
> necessary.  I didn't get a strong sense of established precedent
> looking at Guile's C API; I'm kind of leaning towards the list
> approach right now.

That sounds great.

>>  > Actually, I just remembered a fairly elegant approach that seems to be
>>  > used in other parts of the Guile API -- these optional arguments could
>>  > be specified as symbols: 'unlock-if-unowned and
>>  > 'unlock-if-owned-by-other, say.  Let me know what you'd prefer.
>>
>>  This is still an interesting question, but now for `make-mutex'
>>  instead of for `unlock-mutex'.  Personally I like the symbol approach,
>>  because (in comparison with a sequence of #t and #f) it will make the
>>  code easier to understand at the point of the call, and also because
>>  the #t/#f approach requires remembering the parameter ordering.
>
> Cool -- I'll set up make-mutex for Scheme, and for C as described
> above.  Let me know if that's not okay.

All sounds perfect to me.

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

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

Hi Neil et al.,

>  > Cool -- I'll set up make-mutex for Scheme, and for C as described
>  > above.  Let me know if that's not okay.
>
>  All sounds perfect to me.


Find attached the latest revision of the core changes for SRFI-18
support.  Key changes between this revision and the last are:

* scm_to_timespec -> to_timespec
* "Timeout values" for timed joins
* The extension of make-mutex and addition of make_mutex_with_flags to
support additional configuration options that persist for the lifetime
of a mutex (unchecked unlocking and external unlocking)
* fat_mutex_unlock now takes a condition variable and a timeout to
support SRFI-18's condition-signal unlock semantics; mutex unlocking
and condition variable waiting are reimplemented in terms of
fat_mutex_unlock; unnecessary relocking / unlocking is no longer
performed
* The threads tests and scheduling documentation have been updated to
reflect the above.

Let me know what you think!


Regards,
Julian

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

Index: doc/ref/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/doc/ref/ChangeLog,v
retrieving revision 1.357
diff -a -u -r1.357 ChangeLog
--- doc/ref/ChangeLog	1 Feb 2008 21:02:15 -0000	1.357
+++ doc/ref/ChangeLog	1 Mar 2008 19:34:52 -0000
@@ -1,3 +1,12 @@
+2008-02-28  Julian Graham  <joolean@gmail.com>
+
+	* api-scheduling.texi (Threads): Add documentation for new 
+	functions "scm_thread_p" and new "scm_join_thread_timed".
+	(Mutexes and Condition Variables): Add documentation for new 
+	functions "scm_make_mutex_with_flags", "scm_mutex_p", 
+	"scm_lock_mutex_timed", "scm_unlock_mutex_timed", and 
+	"scm_condition_variable_p".
+
 2008-02-01  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* api-scheduling.texi (Threads): Add "C Function scm_join_thread"
Index: doc/ref/api-scheduling.texi
===================================================================
RCS file: /sources/guile/guile/guile-core/doc/ref/api-scheduling.texi,v
retrieving revision 1.19
diff -a -u -r1.19 api-scheduling.texi
--- doc/ref/api-scheduling.texi	1 Feb 2008 21:02:15 -0000	1.19
+++ doc/ref/api-scheduling.texi	1 Mar 2008 19:34:53 -0000
@@ -267,12 +267,24 @@
 @emph{exit value} of the thread and the thread is terminated.
 @end deftypefn
 
+@deffn {Scheme Procedure} thread? obj
+@deffnx {C Function} scm_thread_p (obj)
+Return @code{#t} iff @var{obj} is a thread; otherwise, return
+@code{#f}.
+@end deffn
+
 @c begin (texi-doc-string "guile" "join-thread")
-@deffn {Scheme Procedure} join-thread thread
+@deffn {Scheme Procedure} join-thread thread [timeout [timeoutval]]
 @deffnx {C Function} scm_join_thread (thread)
+@deffnx {C Function} scm_join_thread_timed (thread, timeout, timeoutval)
 Wait for @var{thread} to terminate and return its exit value.  Threads
 that have not been created with @code{call-with-new-thread} or
-@code{scm_spawn_thread} have an exit value of @code{#f}.
+@code{scm_spawn_thread} have an exit value of @code{#f}.  When 
+@var{timeout} is given, it specifies a point in time where the waiting
+should be aborted.  It can be either an integer as returned by 
+@code{current-time} or a pair as returned by @code{gettimeofday}.  
+When the waiting is aborted, @var{timeoutval} is returned (if it is 
+specified; @code{#f} is returned otherwise).
 @end deffn
 
 @deffn {Scheme Procedure} thread-exited? thread
@@ -363,21 +375,51 @@
 in all threads is one way to avoid such problems.
 
 @sp 1
-@deffn {Scheme Procedure} make-mutex
+@deffn {Scheme Procedure} make-mutex . flags
 @deffnx {C Function} scm_make_mutex ()
-Return a new standard mutex.  It is initially unlocked.
+@deffnx {C Function} scm_make_mutex_with_flags (SCM flag)
+Return a new mutex.  It is initially unlocked.  If @var{flags} is 
+specified, it must be a list of symbols specifying configuration flags
+for the newly-created mutex.  The supported flags are: 
+@table @code
+@item unchecked-unlock
+Unless this flag is present, a call to `unlock-mutex' on the returned
+mutex when it is already unlocked will cause an error to be signalled.
+
+@item allow-external-unlock
+Allow the returned mutex to be unlocked by the calling thread even if
+it was originally locked by a different thread.
+
+@item recursive
+The returned mutex will be recursive.
+
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} mutex? obj
+@deffnx {C Function} scm_mutex_p (obj)
+Return @code{#t} iff @var{obj} is a mutex; otherwise, return 
+@code{#f}.
 @end deffn
 
 @deffn {Scheme Procedure} make-recursive-mutex
 @deffnx {C Function} scm_make_recursive_mutex ()
-Create a new recursive mutex.  It is initialloy unlocked.
+Create a new recursive mutex.  It is initially unlocked.  Calling this
+function is equivalent to calling `make-mutex' and specifying the
+@code{recursive} flag.
 @end deffn
 
-@deffn {Scheme Procedure} lock-mutex mutex
+@deffn {Scheme Procedure} lock-mutex mutex [timeout]
 @deffnx {C Function} scm_lock_mutex (mutex)
+@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout)
 Lock @var{mutex}.  If the mutex is already locked by another thread
 then block and return only when @var{mutex} has been acquired.
 
+When @var{timeout} is given, it specifies a point in time where the 
+waiting should be aborted.  It can be either an integer as returned 
+by @code{current-time} or a pair as returned by @code{gettimeofday}.  
+When the waiting is aborted, @code{#f} is returned. 
+
 For standard mutexes (@code{make-mutex}), and error is signalled if
 the thread has itself already locked @var{mutex}.
 
@@ -386,6 +428,10 @@
 call increments the lock count.  An additional @code{unlock-mutex}
 will be required to finally release.
 
+If @var{mutex} was locked by a thread that exited before unlocking it,
+the next attempt to lock @var{mutex} will succeed, but 
+@code{abandoned-mutex-error} will be signalled.
+
 When a system async (@pxref{System asyncs}) is activated for a thread
 blocked in @code{lock-mutex}, the wait is interrupted and the async is
 executed.  When the async returns, the wait resumes.
@@ -395,7 +441,7 @@
 Arrange for @var{mutex} to be locked whenever the current dynwind
 context is entered and to be unlocked when it is exited.
 @end deftypefn
-
+ 
 @deffn {Scheme Procedure} try-mutex mx
 @deffnx {C Function} scm_try_mutex (mx)
 Try to lock @var{mutex} as per @code{lock-mutex}.  If @var{mutex} can
@@ -404,10 +450,25 @@
 the return is @code{#f}.
 @end deffn
 
-@deffn {Scheme Procedure} unlock-mutex mutex
+@deffn {Scheme Procedure} unlock-mutex mutex [condvar [timeout]]
 @deffnx {C Function} scm_unlock_mutex (mutex)
-Unlock @var{mutex}.  An error is signalled if @var{mutex} is not
-locked by the calling thread.
+@deffnx {C Function} scm_unlock_mutex_timed (mutex, condvar, timeout)
+Unlock @var{mutex}.  An error is signalled if @var{mutex} is not locked
+and was not created with the @code{unchecked-unlock} flag set, or if 
+@var{mutex} is locked by a thread other than the calling thread and was
+not created with the @code{allow-external-unlock} flag set.
+
+If @var{condvar} is given, it specifies a condition variable upon
+which the calling thread will wait to be signalled before returning.
+(This behavior is very similar to that of 
+@code{wait-condition-variable}, except that the mutex is left in an
+unlocked state when the function returns.)
+
+When @var{timeout} is also given, it specifies a point in time where 
+the waiting should be aborted.  It can be either an integer as 
+returned by @code{current-time} or a pair as returned by 
+@code{gettimeofday}.  When the waiting is aborted, @code{#f} is 
+returned.  Otherwise the function returns @code{#t}.
 @end deffn
 
 @deffn {Scheme Procedure} make-condition-variable
@@ -415,6 +476,12 @@
 Return a new condition variable.
 @end deffn
 
+@deffn {Scheme Procedure} condition-variable? obj
+@deffnx {C Function} scm_condition_variable_p (obj)
+Return @code{#t} iff @var{obj} is a condition variable; otherwise, 
+return @code{#f}.
+@end deffn
+
 @deffn {Scheme Procedure} wait-condition-variable condvar mutex [time]
 @deffnx {C Function} scm_wait_condition_variable (condvar, mutex, time)
 Wait until @var{condvar} has been signalled.  While waiting,
Index: libguile/ChangeLog
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2430
diff -a -u -r1.2430 ChangeLog
--- libguile/ChangeLog	7 Feb 2008 09:54:46 -0000	1.2430
+++ libguile/ChangeLog	1 Mar 2008 19:35:13 -0000
@@ -1,3 +1,29 @@
+2008-02-10  Julian Graham  <joolean@gmail.com>
+
+	* threads.c (scm_join_thread_timed, scm_thread_p, 
+	scm_make_mutex_with_flags, scm_lock_mutex_timed, 
+	scm_unlock_mutex_timed, scm_mutex_p, scm_condition_variable_p): New 
+	functions.
+	(thread_mark): Updated to mark new struct field `mutexes'.
+	(do_thread_exit): Notify threads waiting on mutexes locked by exiting 
+	thread.
+	(scm_join_thread, scm_make_mutex, scm_make_recursive_mutex, 
+	scm_mutex_lock): Reimplement in terms of their newer 
+	counterparts.
+	(scm_abandoned_mutex_error_key): New symbol.
+	(fat_mutex)[unchecked_unlock, allow_external_unlock]: New fields.
+	(fat_mutex_lock): Reimplement to support timeouts and abandonment.
+	(fat_mutex_trylock, scm_try_mutex): Remove fat_mutex_trylock and
+	reimplement scm_try_mutex as a lock attempt with a timeout of zero.
+	(fat_mutex_unlock): Allow unlocking from other threads and unchecked
+	unlocking; implement in terms of condition variable wait.
+	(scm_timed_wait_condition_variable): Reimplement in terms of 
+	fat_mutex_unlock.
+	* threads.h (scm_i_thread)[mutexes]: New field.
+	(scm_join_thread_timed, scm_thread_p, scm_lock_mutex_timed,
+	scm_unlock_mutex_timed, scm_mutex_p, scm_condition_variable_p): 
+	Prototypes for new functions.
+
 2008-02-07  Ludovic Courtès  <ludo@gnu.org>
 
 	Fix bug #21378.
Index: libguile/threads.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.91
diff -a -u -r1.91 threads.c
--- libguile/threads.c	7 Feb 2008 01:24:31 -0000	1.91
+++ libguile/threads.c	1 Mar 2008 19:35:20 -0000
@@ -49,6 +49,7 @@
 #include "libguile/gc.h"
 #include "libguile/init.h"
 #include "libguile/scmsigs.h"
+#include "libguile/strings.h"
 
 #ifdef __MINGW32__
 #ifndef ETIMEDOUT
@@ -59,6 +60,24 @@
 # define pipe(fd) _pipe (fd, 256, O_BINARY)
 #endif /* __MINGW32__ */
 
+static void
+to_timespec (SCM t, scm_t_timespec *waittime)
+{
+  if (scm_is_pair (t))
+    {
+      waittime->tv_sec = scm_to_ulong (SCM_CAR (t));
+      waittime->tv_nsec = scm_to_ulong (SCM_CDR (t)) * 1000;
+    }
+  else
+    {
+      double time = scm_to_double (t);
+      double sec = scm_c_truncate (time);
+
+      waittime->tv_sec = (long) sec;
+      waittime->tv_nsec = (long) ((time - sec) * 1000000);
+    }
+}
+
 /*** Queues */
 
 /* Make an empty queue data structure.
@@ -134,6 +153,7 @@
   scm_gc_mark (t->result);
   scm_gc_mark (t->cleanup_handler);
   scm_gc_mark (t->join_queue);
+  scm_gc_mark (t->mutexes);
   scm_gc_mark (t->dynwinds);
   scm_gc_mark (t->active_asyncs);
   scm_gc_mark (t->continuation_root);
@@ -418,6 +438,7 @@
   t->handle = SCM_BOOL_F;
   t->result = SCM_BOOL_F;
   t->cleanup_handler = SCM_BOOL_F;
+  t->mutexes = SCM_EOL;
   t->join_queue = SCM_EOL;
   t->dynamic_state = SCM_BOOL_F;
   t->dynwinds = SCM_EOL;
@@ -478,6 +499,31 @@
   t->block_asyncs = 0;
 }
 
+\f
+/*** Fat mutexes */
+
+/* We implement our own mutex type since we want them to be 'fair', we
+   want to do fancy things while waiting for them (like running
+   asyncs) and we might want to add things that are nice for
+   debugging.
+*/
+
+typedef struct {
+  scm_i_pthread_mutex_t lock;
+  SCM owner;
+  int level;      /* how much the owner owns us.  
+		     < 0 for non-recursive mutexes */
+
+  int unchecked_unlock; /* is it an error to unlock an unlocked mutex? */
+  int allow_external_unlock; /* is it an error to unlock a mutex that is not
+				owned by the current thread? */
+
+  SCM waiting;    /* the threads waiting for this mutex. */
+} fat_mutex;
+
+#define SCM_MUTEXP(x)         SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
+#define SCM_MUTEX_DATA(x)     ((fat_mutex *) SCM_SMOB_DATA (x))
+
 /* Perform thread tear-down, in guile mode.
  */
 static void *
@@ -503,6 +549,18 @@
   while (scm_is_true (unblock_from_queue (t->join_queue)))
     ;
 
+  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;
@@ -989,14 +1047,23 @@
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
-	    (SCM thread),
+SCM scm_join_thread (SCM thread)
+{
+  return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0,
+	    (SCM thread, SCM timeout, SCM timeoutval),
 "Suspend execution of the calling thread until the target @var{thread} "
 "terminates, unless the target @var{thread} has already terminated. ")
-#define FUNC_NAME s_scm_join_thread
+#define FUNC_NAME s_scm_join_thread_timed
 {
   scm_i_thread *t;
-  SCM res;
+  scm_t_timespec ctimeout, *timeout_ptr = NULL;
+  SCM res = SCM_BOOL_F;
+
+  if (! (SCM_UNBNDP (timeoutval)))
+    res = timeoutval;
 
   SCM_VALIDATE_THREAD (1, thread);
   if (scm_is_eq (scm_current_thread (), thread))
@@ -1005,19 +1072,36 @@
   t = SCM_I_THREAD_DATA (thread);
   scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
 
-  if (!t->exited)
+  if (! SCM_UNBNDP (timeout))
+    {
+      to_timespec (timeout, &ctimeout);
+      timeout_ptr = &ctimeout;
+    }
+
+  if (t->exited)
+    res = t->result;
+  else
     {
       while (1)
 	{
-	  block_self (t->join_queue, thread, &t->admin_mutex, NULL);
-	  if (t->exited)
+	  int err = block_self (t->join_queue, thread, &t->admin_mutex, 
+				timeout_ptr);
+	  if (err == 0)
+	    {
+	      if (t->exited)
+		{
+		  res = t->result;
+		  break;
+		}
+	    }
+	  else if (err == ETIMEDOUT)
 	    break;
+
 	  scm_i_pthread_mutex_unlock (&t->admin_mutex);
 	  SCM_TICK;
 	  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
 	}
     }
-  res = t->result;
 
   scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
@@ -1025,26 +1109,14 @@
 }
 #undef FUNC_NAME
 
-
-\f
-/*** Fat mutexes */
-
-/* We implement our own mutex type since we want them to be 'fair', we
-   want to do fancy things while waiting for them (like running
-   asyncs) and we might want to add things that are nice for
-   debugging.
-*/
-
-typedef struct {
-  scm_i_pthread_mutex_t lock;
-  SCM owner;
-  int level;      /* how much the owner owns us.  
-		     < 0 for non-recursive mutexes */
-  SCM waiting;    /* the threads waiting for this mutex. */
-} fat_mutex;
-
-#define SCM_MUTEXP(x)         SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
-#define SCM_MUTEX_DATA(x)     ((fat_mutex *) SCM_SMOB_DATA (x))
+SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0,
+	    (SCM obj),
+	    "Return @code{#t} if @var{obj} is a thread.")
+#define FUNC_NAME s_scm_thread_p
+{
+  return SCM_I_IS_THREAD(obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
 
 static SCM
 fat_mutex_mark (SCM mx)
@@ -1074,7 +1146,7 @@
 }
 
 static SCM
-make_fat_mutex (int recursive)
+make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock)
 {
   fat_mutex *m;
   SCM mx;
@@ -1083,18 +1155,47 @@
   scm_i_pthread_mutex_init (&m->lock, NULL);
   m->owner = SCM_BOOL_F;
   m->level = recursive? 0 : -1;
+
+  m->unchecked_unlock = unchecked_unlock;
+  m->allow_external_unlock = external_unlock;
+
   m->waiting = SCM_EOL;
   SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m);
   m->waiting = make_queue ();
   return mx;
 }
 
-SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
-	    (void),
+SCM scm_make_mutex (void)
+{
+  return scm_make_mutex_with_flags (SCM_EOL);
+}
+
+static SCM unchecked_unlock_sym;
+static SCM allow_external_unlock_sym;
+static SCM recursive_sym;
+
+SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1,
+	    (SCM flags),
 	    "Create a new mutex. ")
-#define FUNC_NAME s_scm_make_mutex
+#define FUNC_NAME s_scm_make_mutex_with_flags
 {
-  return make_fat_mutex (0);
+  int unchecked_unlock = 0, external_unlock = 0, recursive = 0;
+
+  SCM ptr = flags;
+  while (! scm_is_null (ptr))
+    {
+      SCM flag = SCM_CAR (ptr);
+      if (scm_is_eq (flag, unchecked_unlock_sym))
+	unchecked_unlock = 1;
+      else if (scm_is_eq (flag, allow_external_unlock_sym))
+	external_unlock = 1;
+      else if (scm_is_eq (flag, recursive_sym))
+	recursive = 1;
+      else 
+	SCM_MISC_ERROR ("unsupported mutex option", SCM_EOL);
+      ptr = SCM_CDR (ptr);
+    }
+  return make_fat_mutex (recursive, unchecked_unlock, external_unlock);
 }
 #undef FUNC_NAME
 
@@ -1103,59 +1204,121 @@
 	    "Create a new recursive mutex. ")
 #define FUNC_NAME s_scm_make_recursive_mutex
 {
-  return make_fat_mutex (1);
+  return make_fat_mutex (1, 0, 0);
 }
 #undef FUNC_NAME
 
-static char *
-fat_mutex_lock (SCM mutex)
+SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error");
+
+static SCM
+fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
 {
   fat_mutex *m = SCM_MUTEX_DATA (mutex);
+
   SCM thread = scm_current_thread ();
-  char *msg = NULL;
+  scm_i_thread *t = SCM_I_THREAD_DATA (thread);
+
+  SCM err = SCM_BOOL_F;
+
+  struct timeval current_time;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
   if (scm_is_false (m->owner))
-    m->owner = thread;
+    {
+      m->owner = thread;
+      scm_i_pthread_mutex_lock (&t->admin_mutex);
+      t->mutexes = scm_cons (mutex, t->mutexes);
+      scm_i_pthread_mutex_unlock (&t->admin_mutex);
+      *ret = 1;
+    }
   else if (scm_is_eq (m->owner, thread))
     {
       if (m->level >= 0)
-	m->level++;
+	{
+	  m->level++;
+	  *ret = 1;
+	}
       else
-	msg = "mutex already locked by current thread";
+	err = scm_cons (scm_misc_error_key,
+			scm_from_locale_string ("mutex already locked by "
+						"current thread"));
     }
   else
     {
+      int first_iteration = 1;
       while (1)
 	{
-	  block_self (m->waiting, mutex, &m->lock, NULL);
-	  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 (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner))
+	    {
+	      scm_i_pthread_mutex_lock (&t->admin_mutex);
+	      t->mutexes = scm_cons (mutex, t->mutexes);
+	      scm_i_pthread_mutex_unlock (&t->admin_mutex);
+	      *ret = 1;
+	      if (scm_c_thread_exited_p (m->owner)) 
+		{
+		  m->owner = thread;
+		  err = scm_cons (scm_abandoned_mutex_error_key,
+				  scm_from_locale_string ("lock obtained on "
+							  "abandoned mutex"));
+		}
+	      break;
+	    }
+	  else if (!first_iteration)
+	    {
+	      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);
+	    }
+	  else
+	    first_iteration = 0;
+	  block_self (m->waiting, mutex, &m->lock, timeout);
 	}
     }
   scm_i_pthread_mutex_unlock (&m->lock);
-  return msg;
+  return err;
 }
 
-SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
-	    (SCM mx),
+SCM scm_lock_mutex (SCM mx)
+{
+  return scm_lock_mutex_timed (mx, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0,
+	    (SCM m, SCM timeout),
 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
 "blocks until the mutex becomes available. The function returns when "
 "the calling thread owns the lock on @var{mutex}.  Locking a mutex that "
 "a thread already owns will succeed right away and will not block the "
 "thread.  That is, Guile's mutexes are @emph{recursive}. ")
-#define FUNC_NAME s_scm_lock_mutex
+#define FUNC_NAME s_scm_lock_mutex_timed
 {
-  char *msg;
+  SCM exception;
+  int ret = 0;
+  scm_t_timespec cwaittime, *waittime = NULL;
 
-  SCM_VALIDATE_MUTEX (1, mx);
-  msg = fat_mutex_lock (mx);
-  if (msg)
-    scm_misc_error (NULL, msg, SCM_EOL);
-  return SCM_BOOL_T;
+  SCM_VALIDATE_MUTEX (1, m);
+
+  if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout))
+    {
+      to_timespec (timeout, &cwaittime);
+      waittime = &cwaittime;
+    }
+
+  exception = fat_mutex_lock (m, waittime, &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
 
@@ -1168,71 +1331,134 @@
 				       SCM_F_WIND_EXPLICITLY);
 }
 
-static char *
-fat_mutex_trylock (fat_mutex *m, int *resp)
-{
-  char *msg = NULL;
-  SCM thread = scm_current_thread ();
-
-  *resp = 1;
-  scm_i_pthread_mutex_lock (&m->lock);
-  if (scm_is_false (m->owner))
-    m->owner = thread;
-  else if (scm_is_eq (m->owner, thread))
-    {
-      if (m->level >= 0)
-	m->level++;
-      else
-	msg = "mutex already locked by current thread";
-    }
-  else
-    *resp = 0;
-  scm_i_pthread_mutex_unlock (&m->lock);
-  return msg;
-}
-
 SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
 	    (SCM mutex),
 "Try to lock @var{mutex}. If the mutex is already locked by someone "
 "else, return @code{#f}.  Else lock the mutex and return @code{#t}. ")
 #define FUNC_NAME s_scm_try_mutex
 {
-  char *msg;
-  int res;
+  SCM exception;
+  int ret = 0;
+  scm_t_timespec cwaittime, *waittime = NULL;
 
   SCM_VALIDATE_MUTEX (1, mutex);
+
+  to_timespec (scm_from_int(0), &cwaittime);
+  waittime = &cwaittime;
   
-  msg = fat_mutex_trylock (SCM_MUTEX_DATA (mutex), &res);
-  if (msg)
-    scm_misc_error (NULL, msg, SCM_EOL);
-  return scm_from_bool (res);
+  exception = fat_mutex_lock (mutex, 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
 
-static char *
-fat_mutex_unlock (fat_mutex *m)
+/*** 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 int
+fat_mutex_unlock (SCM mutex, SCM cond,
+		  const scm_t_timespec *waittime, int relock)
 {
-  char *msg = NULL;
+  fat_mutex *m = SCM_MUTEX_DATA (mutex);
+  fat_cond *c = NULL;
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+  int err = 0, ret = 0;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
   if (!scm_is_eq (m->owner, scm_current_thread ()))
     {
       if (scm_is_false (m->owner))
-	msg = "mutex not locked";
-      else
-	msg = "mutex not locked by current thread";
+	{
+	  if (!m->unchecked_unlock)
+	    scm_misc_error (NULL, "mutex not locked", SCM_EOL);
+	}
+      else if (!m->allow_external_unlock)
+	scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL);
+    }
+
+  if (! (SCM_UNBNDP (cond)))
+    {
+      int lock_ret = 0;
+
+      c = SCM_CONDVAR_DATA (cond);
+      while (1)
+	{
+	  int brk = 0;
+
+	  scm_i_scm_pthread_mutex_lock (&c->lock);
+	  if (m->level > 0)
+	    m->level--;
+	  else
+	    m->owner = unblock_from_queue (m->waiting);
+	  scm_i_pthread_mutex_unlock (&m->lock);
+	  
+	  t->block_asyncs++;
+	  
+	  err = block_self (c->waiting, cond, &c->lock, waittime);
+
+	  if (err == 0)
+	    {
+	      ret = 1;
+	      brk = 1;
+	    }
+	  else if (err == ETIMEDOUT)
+	    {
+	      ret = 0;
+	      brk = 1;
+	    }
+	  else if (err != EINTR)
+	    {	      
+	      errno = err;
+	      scm_i_pthread_mutex_unlock (&c->lock);
+	      scm_syserror (NULL);
+	    }	  
+
+	  if (brk)
+	    {
+	      if (relock)
+		fat_mutex_lock (mutex, NULL, &lock_ret);
+	      scm_i_pthread_mutex_unlock (&c->lock);
+	      break;
+	    }
+	  
+	  scm_i_pthread_mutex_unlock (&c->lock);
+
+	  t->block_asyncs--;
+	  scm_async_click ();
+	  
+	  scm_remember_upto_here_2 (cond, mutex);
+
+	  scm_i_scm_pthread_mutex_lock (&m->lock);
+	}
     }
-  else if (m->level > 0)
-    m->level--;
   else
-    m->owner = unblock_from_queue (m->waiting);
-  scm_i_pthread_mutex_unlock (&m->lock);
+    {
+      if (m->level > 0)
+	m->level--;
+      else
+	m->owner = unblock_from_queue (m->waiting);
+      scm_i_pthread_mutex_unlock (&m->lock);
+      ret = 1;
+    }
+  
+  return ret;
+}
 
-  return msg;
+SCM scm_unlock_mutex (SCM mx)
+{
+  return scm_unlock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
 }
 
-SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
-	    (SCM mx),
+SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0,
+	    (SCM mx, SCM cond, SCM timeout),
 "Unlocks @var{mutex} if the calling thread owns the lock on "
 "@var{mutex}.  Calling unlock-mutex on a mutex not owned by the current "
 "thread results in undefined behaviour. Once a mutex has been unlocked, "
@@ -1240,18 +1466,35 @@
 "lock.  Every call to @code{lock-mutex} by this thread must be matched "
 "with a call to @code{unlock-mutex}.  Only the last call to "
 "@code{unlock-mutex} will actually unlock the mutex. ")
-#define FUNC_NAME s_scm_unlock_mutex
+#define FUNC_NAME s_scm_unlock_mutex_timed
 {
-  char *msg;
+  scm_t_timespec cwaittime, *waittime = NULL;
+
   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);
+
+      if (! (SCM_UNBNDP (timeout)))
+	{
+	  to_timespec (timeout, &cwaittime);
+	  waittime = &cwaittime;
+	}
+    }
+
+  return fat_mutex_unlock (mx, cond, waittime, 0) ? SCM_BOOL_T : SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_mutex_p, "mutex?", 1, 0, 0,
+	    (SCM obj),
+	    "Return @code{#t} if @var{obj} is a mutex.")
+#define FUNC_NAME s_scm_mutex_p
+{
+  return SCM_MUTEXP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME 
+
 #if 0
 
 SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
@@ -1277,16 +1520,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,43 +1567,7 @@
 fat_cond_timedwait (SCM cond, SCM mutex,
 		    const scm_t_timespec *waittime)
 {
-  scm_i_thread *t = SCM_I_CURRENT_THREAD;
-  fat_cond *c = SCM_CONDVAR_DATA (cond);
-  fat_mutex *m = SCM_MUTEX_DATA (mutex);
-  const char *msg;
-  int err = 0;
-
-  while (1)
-    {
-      scm_i_scm_pthread_mutex_lock (&c->lock);
-      msg = fat_mutex_unlock (m);
-      t->block_asyncs++;
-      if (msg == NULL)
-	{
-	  err = block_self (c->waiting, cond, &c->lock, waittime);
-	  scm_i_pthread_mutex_unlock (&c->lock);
-	  fat_mutex_lock (mutex);
-	}
-      else
-	scm_i_pthread_mutex_unlock (&c->lock);
-      t->block_asyncs--;
-      scm_async_click ();
-
-      if (msg)
-	scm_misc_error (NULL, msg, SCM_EOL);
-
-      scm_remember_upto_here_2 (cond, mutex);
-
-      if (err == 0)
-	return 1;
-      if (err == ETIMEDOUT)
-	return 0;
-      if (err != EINTR)
-	{
-	  errno = err;
-	  scm_syserror (NULL);
-	}
-    }
+  return fat_mutex_unlock (mutex, cond, waittime, 1);
 }
 
 SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
@@ -1393,20 +1590,11 @@
   
   if (!SCM_UNBNDP (t))
     {
-      if (scm_is_pair (t))
-	{
-	  waittime.tv_sec = scm_to_ulong (SCM_CAR (t));
-	  waittime.tv_nsec = scm_to_ulong (SCM_CAR (t)) * 1000;
-	}
-      else
-	{
-	  waittime.tv_sec = scm_to_ulong (t);
-	  waittime.tv_nsec = 0;
-	}
+      to_timespec (t, &waittime);
       waitptr = &waittime;
     }
 
-  return scm_from_bool (fat_cond_timedwait (cv, mx, waitptr));
+  return fat_cond_timedwait (cv, mx, waitptr) ? SCM_BOOL_T : SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -1449,6 +1637,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
@@ -1800,6 +1997,12 @@
   scm_set_smob_print (scm_tc16_mutex, fat_mutex_print);
   scm_set_smob_free (scm_tc16_mutex, fat_mutex_free);
 
+  unchecked_unlock_sym = 
+    scm_permanent_object (scm_from_locale_symbol ("unchecked-unlock"));
+  allow_external_unlock_sym = 
+    scm_permanent_object (scm_from_locale_symbol ("allow-external-unlock"));
+  recursive_sym = scm_permanent_object (scm_from_locale_symbol ("recursive"));
+
   scm_tc16_condvar = scm_make_smob_type ("condition-variable",
 					 sizeof (fat_cond));
   scm_set_smob_mark (scm_tc16_condvar, fat_cond_mark);
Index: libguile/threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v
retrieving revision 1.50
diff -a -u -r1.50 threads.h
--- libguile/threads.h	7 Feb 2008 01:24:31 -0000	1.50
+++ libguile/threads.h	1 Mar 2008 19:35:20 -0000
@@ -54,6 +54,7 @@
   SCM join_queue;
 
   scm_i_pthread_mutex_t admin_mutex;
+  SCM mutexes;
 
   SCM result;
   int canceled;
@@ -162,13 +163,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 timeoutval);
+SCM_API SCM scm_thread_p (SCM t);
 
 SCM_API SCM scm_make_mutex (void);
 SCM_API SCM scm_make_recursive_mutex (void);
+SCM_API SCM scm_make_mutex_with_flags (SCM flags);
 SCM_API SCM scm_lock_mutex (SCM m);
+SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout);
 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 timeout);
+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);
@@ -176,6 +183,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: test-suite/tests/threads.test
===================================================================
RCS file: /sources/guile/guile/guile-core/test-suite/tests/threads.test,v
retrieving revision 1.7
diff -a -u -r1.7 threads.test
--- test-suite/tests/threads.test	20 Oct 2007 11:09:58 -0000	1.7
+++ test-suite/tests/threads.test	1 Mar 2008 19:35:21 -0000
@@ -138,6 +138,97 @@
 	    (equal? result '(10 8 6 4 2 0)))))
 
       ;;
+      ;; timed mutex locking
+      ;;
+
+      (with-test-prefix "lock-mutex"
+
+	(pass-if "timed locking fails if timeout exceeded"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m)
+	    (let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
+	      (not (join-thread t)))))
+
+        (pass-if "timed locking succeeds if mutex unlocked within timeout"
+	  (let* ((m (make-mutex))
+		 (c (make-condition-variable))
+		 (cm (make-mutex)))
+	    (lock-mutex cm)
+	    (let ((t (begin-thread (begin (lock-mutex cm)
+					  (signal-condition-variable c)
+					  (unlock-mutex cm)
+					  (lock-mutex m
+						      (+ (current-time) 2))))))
+	      (lock-mutex m)
+	      (wait-condition-variable c cm)
+	      (unlock-mutex cm)
+	      (sleep 1)
+	      (unlock-mutex m)
+	      (join-thread t)))))
+
+      ;;
+      ;; timed mutex unlocking
+      ;;
+
+      (with-test-prefix "unlock-mutex"
+
+        (pass-if "timed unlocking returns #f if timeout exceeded"
+          (let ((m (make-mutex))
+		(c (make-condition-variable)))
+	    (lock-mutex m)
+	    (not (unlock-mutex m c (current-time)))))
+
+        (pass-if "timed unlocking returns #t if condition signaled"
+	  (let ((m1 (make-mutex))
+		(m2 (make-mutex))
+		(c1 (make-condition-variable))
+		(c2 (make-condition-variable)))
+	    (lock-mutex m1)
+	    (let ((t (begin-thread (begin (lock-mutex m1)
+					  (signal-condition-variable c1)
+					  (lock-mutex m2)
+					  (unlock-mutex m1)
+					  (unlock-mutex m2 
+							c2 
+							(+ (current-time) 
+							   2))))))
+	      (wait-condition-variable c1 m1)
+	      (unlock-mutex m1)
+	      (lock-mutex m2)
+	      (signal-condition-variable c2)
+	      (unlock-mutex m2)
+	      (join-thread t)))))
+
+      ;;
+      ;; timed joining
+      ;;
+
+      (with-test-prefix "join-thread"
+
+	(pass-if "timed joining fails if timeout exceeded"
+	  (let* ((m (make-mutex))
+		 (c (make-condition-variable))
+		 (t (begin-thread (begin (lock-mutex m)
+					 (wait-condition-variable c m))))
+		 (r (join-thread t (current-time))))
+	    (cancel-thread t)
+	    (not r)))
+      
+        (pass-if "join-thread returns timeoutval on timeout"
+          (let* ((m (make-mutex))
+		 (c (make-condition-variable))
+		 (t (begin-thread (begin (lock-mutex m)
+					 (wait-condition-variable c m))))
+		 (r (join-thread t (current-time) 'foo)))
+	    (cancel-thread t)
+	    (eq? r 'foo)))
+	    
+
+	(pass-if "timed joining succeeds if thread exits within timeout"
+          (let ((t (begin-thread (begin (sleep 1) #t))))
+	    (join-thread t (+ (current-time) 2)))))
+
+      ;;
       ;; thread cancellation
       ;;
 
@@ -185,4 +276,35 @@
 	      (eq? (join-thread t) 'bar))))
 
 	(pass-if "initial handler is false"
-	  (not (thread-cleanup (current-thread)))))))
+	  (not (thread-cleanup (current-thread)))))
+
+      ;;
+      ;; mutex behavior
+      ;;
+
+      (with-test-prefix "mutex-behavior"
+
+        (pass-if "unchecked unlock"
+          (let* ((m (make-mutex 'unchecked-unlock)))
+	    (unlock-mutex m)))
+
+	(pass-if "allow external unlock"
+	  (let* ((m (make-mutex 'allow-external-unlock))
+		 (t (begin-thread (lock-mutex m))))
+	    (join-thread t)
+	    (unlock-mutex m)))
+
+	(pass-if "recursive mutexes"
+	  (let* ((m (make-mutex 'recursive)))
+	    (lock-mutex m)
+	    (lock-mutex m)))		 
+
+	(pass-if "locking abandoned mutex throws exception"
+          (let* ((m (make-mutex))
+		 (t (begin-thread (lock-mutex m)))
+		 (success #f))
+	    (join-thread t)
+	    (catch 'abandoned-mutex-error
+		   (lambda () (lock-mutex m))
+		   (lambda key (set! success #t)))
+	    success)))))

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Find attached the latest revision of the core changes for SRFI-18
> support.  Key changes between this revision and the last are:
>
> * scm_to_timespec -> to_timespec
> * "Timeout values" for timed joins
> * The extension of make-mutex and addition of make_mutex_with_flags to
> support additional configuration options that persist for the lifetime
> of a mutex (unchecked unlocking and external unlocking)
> * fat_mutex_unlock now takes a condition variable and a timeout to
> support SRFI-18's condition-signal unlock semantics; mutex unlocking
> and condition variable waiting are reimplemented in terms of
> fat_mutex_unlock; unnecessary relocking / unlocking is no longer
> performed
> * The threads tests and scheduling documentation have been updated to
> reflect the above.
>
> Let me know what you think!

It looks great.  I still have a few minor queries, but it's close
enough now that I've committed this latest patch to CVS; it'll be much
more convenient to work on the few remaining queries incrementally,
rather than with respect to threads.c as it was prior to all these
changes.

> -@deffn {Scheme Procedure} make-mutex
> +@deffn {Scheme Procedure} make-mutex . flags
>  @deffnx {C Function} scm_make_mutex ()
> -Return a new standard mutex.  It is initially unlocked.
> +@deffnx {C Function} scm_make_mutex_with_flags (SCM flag)

flag -> flags here?

> +static void
> +to_timespec (SCM t, scm_t_timespec *waittime)
> +{
> +  if (scm_is_pair (t))
> +    {
> +      waittime->tv_sec = scm_to_ulong (SCM_CAR (t));
> +      waittime->tv_nsec = scm_to_ulong (SCM_CDR (t)) * 1000;
> +    }
> +  else
> +    {
> +      double time = scm_to_double (t);
> +      double sec = scm_c_truncate (time);
> +
> +      waittime->tv_sec = (long) sec;
> +      waittime->tv_nsec = (long) ((time - sec) * 1000000);

1000000 -> 1000000000 ?

> +static SCM unchecked_unlock_sym;
> +static SCM allow_external_unlock_sym;
> +static SCM recursive_sym;

Use SCM_SYMBOL here?  As the init code stands, this means that the
symbols will end up being created in scm_init_thread_procs(), but I
think that will be fine, as the symbols are only useful in procedure
calls.

> +
> +SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1,
> +	    (SCM flags),
>  	    "Create a new mutex. ")
> -#define FUNC_NAME s_scm_make_mutex
> +#define FUNC_NAME s_scm_make_mutex_with_flags
>  {
> -  return make_fat_mutex (0);
> +  int unchecked_unlock = 0, external_unlock = 0, recursive = 0;
> +
> +  SCM ptr = flags;
> +  while (! scm_is_null (ptr))
> +    {
> +      SCM flag = SCM_CAR (ptr);
> +      if (scm_is_eq (flag, unchecked_unlock_sym))
> +	unchecked_unlock = 1;
> +      else if (scm_is_eq (flag, allow_external_unlock_sym))
> +	external_unlock = 1;
> +      else if (scm_is_eq (flag, recursive_sym))
> +	recursive = 1;
> +      else 
> +	SCM_MISC_ERROR ("unsupported mutex option", SCM_EOL);

Perhaps we can generate a more explicit error here, indicating the
actual problem value?  See other calls to scm_misc_error() where the
3rd parameter is not SCM_EOL.

> +static int
> +fat_mutex_unlock (SCM mutex, SCM cond,
> +		  const scm_t_timespec *waittime, int relock)
>  {
> -  char *msg = NULL;
> +  fat_mutex *m = SCM_MUTEX_DATA (mutex);
> +  fat_cond *c = NULL;
> +  scm_i_thread *t = SCM_I_CURRENT_THREAD;
> +  int err = 0, ret = 0;
>  
>    scm_i_scm_pthread_mutex_lock (&m->lock);
>    if (!scm_is_eq (m->owner, scm_current_thread ()))
>      {
>        if (scm_is_false (m->owner))
> -	msg = "mutex not locked";
> -      else
> -	msg = "mutex not locked by current thread";
> +	{
> +	  if (!m->unchecked_unlock)
> +	    scm_misc_error (NULL, "mutex not locked", SCM_EOL);
> +	}
> +      else if (!m->allow_external_unlock)
> +	scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL);
> +    }

Need to unlock m->lock before raising the error?

>  SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
> @@ -1393,20 +1590,11 @@
>    
>    if (!SCM_UNBNDP (t))
>      {
> -      if (scm_is_pair (t))
> -	{
> -	  waittime.tv_sec = scm_to_ulong (SCM_CAR (t));
> -	  waittime.tv_nsec = scm_to_ulong (SCM_CAR (t)) * 1000;
> -	}
> -      else
> -	{
> -	  waittime.tv_sec = scm_to_ulong (t);
> -	  waittime.tv_nsec = 0;
> -	}
> +      to_timespec (t, &waittime);
>        waitptr = &waittime;
>      }
>  
> -  return scm_from_bool (fat_cond_timedwait (cv, mx, waitptr));
> +  return fat_cond_timedwait (cv, mx, waitptr) ? SCM_BOOL_T : SCM_BOOL_F;

Better to eliminate fat_cond_timedwait completely now, I think.
(i.e. Just rewrite the last line as a fat_mutex_unlock() call.)

Finally, please note that we will need a NEWS entry for this work.
Are you happy to write that too?  (You may of course prefer to defer
this until the SRFI-18 Scheme parts are committed too - that's
absolutely fine.)

Regards,
      Neil

Re: srfi-18 requirements

[Julian Graham]

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

Hi Neil,

>  It looks great.  I still have a few minor queries, but it's close
>  enough now that I've committed this latest patch to CVS; it'll be much
>  more convenient to work on the few remaining queries incrementally,
>  rather than with respect to threads.c as it was prior to all these
>  changes.

Hey, great!  Maybe this is premature (without the Scheme
implementation being in yet), but: Thanks for your patience and
prudent counsel over these last several months.

As regards the changes below, I've attached a patch against the new
HEAD that I think resolves the issues you mentioned.


>  Finally, please note that we will need a NEWS entry for this work.
>  Are you happy to write that too?  (You may of course prefer to defer
>  this until the SRFI-18 Scheme parts are committed too - that's
>  absolutely fine.)

Yes, I'm happy to write the NEWS entry, but think I would like to wait
to submit it until everything's in.  And speaking of the Scheme parts,
shall I go ahead and send you a patch that includes those?  I expect
that my original implementation won't need that much tweaking to
cooperate with the new core interfaces; it shouldn't take long.

Speaking of which, though, I've already run into some difficulty
implementing mutex-state -- the solution you proposed earlier depends
on mutex-owner being visible to Scheme code (it's not, at the moment),
and I can't figure out how to write mutex-state efficiently without it
(or some other way of passively inspecting the mutex).  Any
suggestions would be appreciated!


Regards,
Julian

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

Index: doc/ref/api-scheduling.texi
===================================================================
RCS file: /sources/guile/guile/guile-core/doc/ref/api-scheduling.texi,v
retrieving revision 1.20
diff -a -u -r1.20 api-scheduling.texi
--- doc/ref/api-scheduling.texi	8 Mar 2008 16:22:39 -0000	1.20
+++ doc/ref/api-scheduling.texi	11 Mar 2008 03:38:00 -0000
@@ -377,7 +377,7 @@
 @sp 1
 @deffn {Scheme Procedure} make-mutex . flags
 @deffnx {C Function} scm_make_mutex ()
-@deffnx {C Function} scm_make_mutex_with_flags (SCM flag)
+@deffnx {C Function} scm_make_mutex_with_flags (SCM flags)
 Return a new mutex.  It is initially unlocked.  If @var{flags} is 
 specified, it must be a list of symbols specifying configuration flags
 for the newly-created mutex.  The supported flags are: 
Index: libguile/threads.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.92
diff -a -u -r1.92 threads.c
--- libguile/threads.c	8 Mar 2008 16:22:39 -0000	1.92
+++ libguile/threads.c	11 Mar 2008 03:38:08 -0000
@@ -74,7 +74,7 @@
       double sec = scm_c_truncate (time);
 
       waittime->tv_sec = (long) sec;
-      waittime->tv_nsec = (long) ((time - sec) * 1000000);
+      waittime->tv_nsec = (long) ((time - sec) * 1000000000);
     }
 }
 
@@ -1170,9 +1170,9 @@
   return scm_make_mutex_with_flags (SCM_EOL);
 }
 
-static SCM unchecked_unlock_sym;
-static SCM allow_external_unlock_sym;
-static SCM recursive_sym;
+SCM_SYMBOL (unchecked_unlock_sym, "unchecked-unlock");
+SCM_SYMBOL (allow_external_unlock_sym, "allow-external-unlock");
+SCM_SYMBOL (recursive_sym, "recursive");
 
 SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1,
 	    (SCM flags),
@@ -1192,7 +1192,7 @@
       else if (scm_is_eq (flag, recursive_sym))
 	recursive = 1;
       else 
-	SCM_MISC_ERROR ("unsupported mutex option", SCM_EOL);
+	SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag));
       ptr = SCM_CDR (ptr);
     }
   return make_fat_mutex (recursive, unchecked_unlock, external_unlock);
@@ -1378,10 +1378,16 @@
       if (scm_is_false (m->owner))
 	{
 	  if (!m->unchecked_unlock)
-	    scm_misc_error (NULL, "mutex not locked", SCM_EOL);
+	    {
+	      scm_i_pthread_mutex_unlock (&m->lock);
+	      scm_misc_error (NULL, "mutex not locked", SCM_EOL);
+	    }
 	}
       else if (!m->allow_external_unlock)
-	scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL);
+	{
+	  scm_i_pthread_mutex_unlock (&m->lock);
+	  scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL);
+	}
     }
 
   if (! (SCM_UNBNDP (cond)))
@@ -1563,13 +1569,6 @@
 }
 #undef FUNC_NAME
 
-static int
-fat_cond_timedwait (SCM cond, SCM mutex,
-		    const scm_t_timespec *waittime)
-{
-  return fat_mutex_unlock (mutex, cond, waittime, 1);
-}
-
 SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
 	    (SCM cv, SCM mx, SCM t),
 "Wait until @var{cond-var} has been signalled.  While waiting, "
@@ -1594,7 +1593,7 @@
       waitptr = &waittime;
     }
 
-  return fat_cond_timedwait (cv, mx, waitptr) ? SCM_BOOL_T : SCM_BOOL_F;
+  return fat_mutex_unlock (mx, cv, waitptr, 1) ? SCM_BOOL_T : SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -1997,12 +1996,6 @@
   scm_set_smob_print (scm_tc16_mutex, fat_mutex_print);
   scm_set_smob_free (scm_tc16_mutex, fat_mutex_free);
 
-  unchecked_unlock_sym = 
-    scm_permanent_object (scm_from_locale_symbol ("unchecked-unlock"));
-  allow_external_unlock_sym = 
-    scm_permanent_object (scm_from_locale_symbol ("allow-external-unlock"));
-  recursive_sym = scm_permanent_object (scm_from_locale_symbol ("recursive"));
-
   scm_tc16_condvar = scm_make_smob_type ("condition-variable",
 					 sizeof (fat_cond));
   scm_set_smob_mark (scm_tc16_condvar, fat_cond_mark);

Re: srfi-18 requirements

[Julian Graham]

Any updates on this?  I know you guys are busy with the repository,
but I'm pretty close to having the Scheme implementation for SRFI-18
finished.  Like I said, I think enabling scm_mutex_owner would allow
me to proceed, but I don't want to un-ifdef it without knowing why it
was disabled in the first place (the ChangeLogs don't shed any light
on the matter).

(From a theoretical standpoint, I don't see a problem with the
existence of something like scm_mutex_owner.  The man page for
pthread_mutex_lock claims that it's not part of the pthreads spec
because it could cause an unacceptable performance hit, but it's
pretty clear from playing around with gdb that Linux's pthreads
implementation stores the requisite information...)


>  Speaking of which, though, I've already run into some difficulty
>  implementing mutex-state -- the solution you proposed earlier depends
>  on mutex-owner being visible to Scheme code (it's not, at the moment),
>  and I can't figure out how to write mutex-state efficiently without it
>  (or some other way of passively inspecting the mutex).  Any
>  suggestions would be appreciated!

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Any updates on this?  I know you guys are busy with the repository,
> but I'm pretty close to having the Scheme implementation for SRFI-18
> finished.  Like I said, I think enabling scm_mutex_owner would allow
> me to proceed, but I don't want to un-ifdef it without knowing why it
> was disabled in the first place (the ChangeLogs don't shed any light
> on the matter).

Hi Julian,

Sorry for the delay (again!), I've been busy with non-Guile stuff.
I'm planning to respond to your emails properly tomorrow.

    Neil

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> As regards the changes below, I've attached a patch against the new
> HEAD that I think resolves the issues you mentioned.

Thanks, that's in CVS now.

>>  Finally, please note that we will need a NEWS entry for this work.
>>  Are you happy to write that too?  (You may of course prefer to defer
>>  this until the SRFI-18 Scheme parts are committed too - that's
>>  absolutely fine.)
>
> Yes, I'm happy to write the NEWS entry, but think I would like to wait
> to submit it until everything's in.

Absolutely fine.

>  And speaking of the Scheme parts,
> shall I go ahead and send you a patch that includes those?  I expect
> that my original implementation won't need that much tweaking to
> cooperate with the new core interfaces; it shouldn't take long.

Yes please!

> Speaking of which, though, I've already run into some difficulty
> implementing mutex-state -- the solution you proposed earlier depends
> on mutex-owner being visible to Scheme code (it's not, at the moment),
> and I can't figure out how to write mutex-state efficiently without it
> (or some other way of passively inspecting the mutex).  Any
> suggestions would be appreciated!

> [...] I think enabling scm_mutex_owner would allow me to proceed,
> but I don't want to un-ifdef it without knowing why it was disabled
> in the first place (the ChangeLogs don't shed any light on the
> matter).

I also see no problem - in API terms - with un-ifdefing
scm_mutex_owner (and scm_mutex_level, while we're there).  Could you
just review, though, whether you're happy with their implementation?
In particular, should these functions lock and unlock m->lock?

> (From a theoretical standpoint, I don't see a problem with the
> existence of something like scm_mutex_owner.  The man page for
> pthread_mutex_lock claims that it's not part of the pthreads spec
> because it could cause an unacceptable performance hit, but it's
> pretty clear from playing around with gdb that Linux's pthreads
> implementation stores the requisite information...)

But that's spec vs. implementation.  I'd tend to give the spec writers
the benefit of the doubt here, i.e. to assume that they had reasonable
implementations in mind where it would be a performance hit.

(And of course, the pthreads point/argument doesn't transfer in detail
across to Guile's API, because our mutexes offer a lot more features
than the base pthreads mutexes.)

> Regards,
> Julian

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

>  I also see no problem - in API terms - with un-ifdefing
>  scm_mutex_owner (and scm_mutex_level, while we're there).  Could you
>  just review, though, whether you're happy with their implementation?
>  In particular, should these functions lock and unlock m->lock?

Given that SCM is supposed to be more or less opaque, I think it's
probably safer to at least lock within scm_mutex_owner.  Otherwise,
I'm happy with those C implementations.

...Except that I've run into a few more snags related to ownership
when it comes to mixing of core calls and SRFI-18 calls --
specifically, notifying the SRFI-18 implementation of changes to
ownership that occur as a result of locking / unlocking a mutex from
the core code.  For example, what should be the result of
`mutex-state' after the following series of expressions?


(use-modules (srfi srfi-18))

(define m (make-mutex))
(mutex-lock! m (current-time) #f)
(unlock-mutex m)
(lock-mutex m)


...according to the pure Scheme ownership implementation you suggested
back in January, locking a mutex via SRFI-18 `mutex-lock!' with an
explicit non-current-thread owner would set an object property on the
mutex, but if core code that is unaware of the SRFI-18 implementation
details unlocks and relocks the mutex, the object property gets out of
sync in a way that I don't think is possible to detect.  (Or is this
not a valid use case?  My understanding based on our previous
conversations is that we want core and SRFI-18 code to be able to
co-exist as much as possible...)

There's a related problem with SRFI-18's requirement that threads
waiting on mutexes be notified when the owner thread exits -- the core
implementation now notifies waiters when the owner exits, but as far
as the core is concerned, the owner will always be the thread that
called `lock-mutex'.

A possible solution that comes to mind is making the core aware of any
object properties that SRFI-18 defines, but that's not optimal from a
design point of view.


>  But that's spec vs. implementation.  I'd tend to give the spec writers
>  the benefit of the doubt here, i.e. to assume that they had reasonable
>  implementations in mind where it would be a performance hit.
>
>  (And of course, the pthreads point/argument doesn't transfer in detail
>  across to Guile's API, because our mutexes offer a lot more features
>  than the base pthreads mutexes.)

Certainly -- I was just looking for reasons that `mutex-owner'
shouldn't be enabled.  (My expectation was that the pthreads spec
would reject features like that on the basis that "good"
multi-threaded code shouldn't need to query things like mutex
ownership, but I didn't see any objections on that front...)


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

>>  I also see no problem - in API terms - with un-ifdefing
>>  scm_mutex_owner (and scm_mutex_level, while we're there).  Could you
>>  just review, though, whether you're happy with their implementation?
>>  In particular, should these functions lock and unlock m->lock?
>
> Given that SCM is supposed to be more or less opaque, I think it's
> probably safer to at least lock within scm_mutex_owner.  Otherwise,
> I'm happy with those C implementations.

OK, let's enable those then.

> ...Except that I've run into a few more snags related to ownership
> when it comes to mixing of core calls and SRFI-18 calls --
> specifically, notifying the SRFI-18 implementation of changes to
> ownership that occur as a result of locking / unlocking a mutex from
> the core code.  For example, what should be the result of
> `mutex-state' after the following series of expressions?
>
>
> (use-modules (srfi srfi-18))
>
> (define m (make-mutex))
> (mutex-lock! m (current-time) #f)
> (unlock-mutex m)
> (lock-mutex m)

I believe that this issue disappears if we conclude that we do in fact
need to represent locked/not-owned somehow in the core - and I'm now
inclined to that conclusion - see below.

For the record, though, and in case we do not reach that conclusion,
here's what I wrote when considering this scenario on its own:

============ assuming locked/not-owned is NOT in core =============
Hmmm, tricky.....

> My understanding based on our previous
> conversations is that we want core and SRFI-18 code to be able to
> co-exist as much as possible...)

I agree that we want co-existence in some sense, but I'm not sure that
sense extends to mixing core and SRFI-18 API calls for the same
mutex.  I'm struggling right now to explain exactly what I mean - but
my intuition is that the use case above is going beyond
reasonableness, and so we could reasonably say that the result of
mutex-state would be undefined in this case.

(In practice, of course, it will probably be locked/not-owned.)

What do you think?
============ assuming locked/not-owned is NOT in core =============

> There's a related problem with SRFI-18's requirement that threads
> waiting on mutexes be notified when the owner thread exits -- the core
> implementation now notifies waiters when the owner exits, but as far
> as the core is concerned, the owner will always be the thread that
> called `lock-mutex'.

I think there are two separate things here.

1. Calling lock-mutex with a thread parameter different from the
calling thread, and which isn't #f.  I believe this should be a core
feature (as well as a SRFI-18 one), and it had completely escaped my
notice that this detail had evaporated from your patches.  I believe
you implemented this originally, then removed it following my attempt
to draw a line between core stuff and SRFI-18 stuff - so I guess you
thought that was one of the implications of what I wrote; sorry about
that.  Would it be easy at this point to reinstate this?

2. Calling lock-mutex with thread parameter #f, such as to produce the
SRFI-18 locked/not-owned state.  My previous pure Scheme suggestion
for locked/not-owned was based on my statement that:

   "AFAICS, SRFI-18 specifies nothing at all (apart from mutex-state
   itself) which depends on the difference between locked/owned and
   locked/not-owned.  Therefore I don't think we should support this
   state in the core."

But I see now that that statement is wrong - because thread exit may
cause a locked/owned mutex to transition to unlocked/abandoned, but
will have no effect on a locked/not-owned mutex.

So it now looks like we do need locked/not-owned in the core after
all.

In terms of the C/Scheme boundary, one possible representation of this
would be to introduce a mutex-locked? primitive, which is significant
when mutex-owner returns #f, and distinguishes between the normal
unlocked state and locked/not-owned.  Then I think SRFI-18 mutex state
could be written as

(define (mutex-state m)
  (let ((owner (mutex-owner m)))
    (if owner
        (if (thread-exited? owner)
            'abandoned
            owner)
        (if (mutex-locked? m)
            'not-owned
            'not-abandoned))))

That would avoid reintroducing a detail that I disliked in the
original patch, namely the definition of the SRFI-18 state symbols in
the C code.

What do you think?

Regards,
        Neil

Re: srfi-18 requirements

[Julian Graham]

>  > My understanding based on our previous
>  > conversations is that we want core and SRFI-18 code to be able to
>  > co-exist as much as possible...)
>
>  I agree that we want co-existence in some sense, but I'm not sure that
>  sense extends to mixing core and SRFI-18 API calls for the same
>  mutex.  I'm struggling right now to explain exactly what I mean - but
>  my intuition is that the use case above is going beyond
>  reasonableness, and so we could reasonably say that the result of
>  mutex-state would be undefined in this case.

Were we to go this route (i.e., non-coexistence), I think the best
solution would be something along the lines of the divide between
Guile's built-in hash tables and SRFI-69 hash tables -- that is,
obvious incompatibility based on data type.  But that seems like an
awful lot of work and a potential loss in terms of flexibility for
developers.

With regard to supporting locked/not-owned:


>  1. Calling lock-mutex with a thread parameter different from the
>  calling thread, and which isn't #f.  I believe this should be a core
>  feature (as well as a SRFI-18 one), and it had completely escaped my
>  notice that this detail had evaporated from your patches.  I believe
>  you implemented this originally, then removed it following my attempt
>  to draw a line between core stuff and SRFI-18 stuff - so I guess you
>  thought that was one of the implications of what I wrote; sorry about
>  that.  Would it be easy at this point to reinstate this?

That was my assumption, yes.  Sorry!  I can certainly reinstate, and
will do so in the next patch I submit.  While we're discussing this,
though, any design issues you'd like to consider?  E.g., this might
not be something we'd want every mutex to support, so we could add a
flag to make-mutex, a la the earlier stuff for external unlocking.


>  2. Calling lock-mutex with thread parameter #f, such as to produce the
>  SRFI-18 locked/not-owned state.  My previous pure Scheme suggestion
>  for locked/not-owned was based on my statement that:

...

>  In terms of the C/Scheme boundary, one possible representation of this
>  would be to introduce a mutex-locked? primitive, which is significant
>  when mutex-owner returns #f, and distinguishes between the normal
>  unlocked state and locked/not-owned.

...

>  What do you think?

I think that's quite elegant, actually.  On initial consideration I
was going to suggest that we bring back the use of SCM_UNSPECIFIED in
the context of mutex ownership (that is, fat_mutex.owner can be
SCM_UNSPECIFIED, #f, or a thread) that I'd removed in the final
version of my patch -- after all, mutex-owner is for all intents and
purposes new to the API, so we've got some freedom in how it's
defined.  ...But I think I prefer the solution you describe above,
since it has the additional benefit of exposing only as much
information about mutex state as a caller is interested in.  So I'll
go with that, I think, and send you a new patch for the core that
incorporates all of this.  Let me know if that's not okay.


Regards,
Julian

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Were we to go this route (i.e., non-coexistence), I think the best
> solution would be something along the lines of the divide between
> Guile's built-in hash tables and SRFI-69 hash tables -- that is,
> obvious incompatibility based on data type.  But that seems like an
> awful lot of work and a potential loss in terms of flexibility for
> developers.

I agree; so overall, it seems clear that we don't want to take this
route.

> With regard to supporting locked/not-owned:
>
>
>>  1. Calling lock-mutex with a thread parameter different from the
>>  calling thread, and which isn't #f.  I believe this should be a core
>>  feature (as well as a SRFI-18 one), and it had completely escaped my
>>  notice that this detail had evaporated from your patches.  I believe
>>  you implemented this originally, then removed it following my attempt
>>  to draw a line between core stuff and SRFI-18 stuff - so I guess you
>>  thought that was one of the implications of what I wrote; sorry about
>>  that.  Would it be easy at this point to reinstate this?
>
> That was my assumption, yes.  Sorry!  I can certainly reinstate, and
> will do so in the next patch I submit.  While we're discussing this,
> though, any design issues you'd like to consider?  E.g., this might
> not be something we'd want every mutex to support, so we could add a
> flag to make-mutex, a la the earlier stuff for external unlocking.

I think it depends whether we see the existing make-mutex flags as a
policing thing or as a trying-to-be-helpful-at-runtime thing.  My view
is that they are mostly trying to be helpful, specifically to catch
the bugs where a developer who is expecting traditional mutex
behaviour accidentally calls unlock-mutex from the wrong thread, or on
a mutex that isn't locked.  In addition, there is the possibility that
some existing code might be relying on exceptions being raised in
these cases.

The (lock-mutex ... thread) case feels to me to be quite different
from this, because the (lock-mutex ...) call that a developer has to
write, in order to take advantage of the SRFI-18 features, is
different at the source code level: to get the SRFI-18 behaviour, the
developer has to explicitly supply the optional thread parameter.

This makes it impossible (or as near impossible as we care about) that
a developer would get the SRFI-18 behaviour by mistake; and existing
code (which cannot specify the thread parameter, because it isn't
supported yet!) will automatically continue to get the traditional
behaviour.

Therefore I don't see the same kind of need for a make-mutex flag
here, as there was for the unlock cases.

>>  2. Calling lock-mutex with thread parameter #f, such as to produce the
>>  SRFI-18 locked/not-owned state.  My previous pure Scheme suggestion
>>  for locked/not-owned was based on my statement that:
>
> ...
>
>>  In terms of the C/Scheme boundary, one possible representation of this
>>  would be to introduce a mutex-locked? primitive, which is significant
>>  when mutex-owner returns #f, and distinguishes between the normal
>>  unlocked state and locked/not-owned.
>
> ...
>
>>  What do you think?
>
> I think that's quite elegant, actually.  On initial consideration I
> was going to suggest that we bring back the use of SCM_UNSPECIFIED in
> the context of mutex ownership (that is, fat_mutex.owner can be
> SCM_UNSPECIFIED, #f, or a thread) that I'd removed in the final
> version of my patch -- after all, mutex-owner is for all intents and
> purposes new to the API, so we've got some freedom in how it's
> defined.  ...But I think I prefer the solution you describe above,
> since it has the additional benefit of exposing only as much
> information about mutex state as a caller is interested in.  So I'll
> go with that, I think, and send you a new patch for the core that
> incorporates all of this.  Let me know if that's not okay.

Sounds good to me!

Regards,
      Neil

Re: srfi-18 requirements

[Julian Graham]

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

Hi Neil,

(Apologies for the delay in getting this to you -- a host of
professional and personal crises reared up over the last week or so.)

Find attached a patch (in two parts -- sorry, still getting used to
git) to the core threading code that includes the changes we
discussed, specifically:

* Re-added support for locking mutexes with an owner other than the
current thread
* Enabled the previously ifdef'd out functions scm_mutex_owner and
scm_mutex_level
* Added a new function, scm_mutex_locked_p, useful for distinguishing
between unlocked and unowned mutex states.
* Updated the threads.test file to reflect the changes above
* Updated the documentation in api-scheduling.texi to reflect the changes above
* Updated the ChangeLog to reflect the changes above

Also attached are updated versions of the Scheme SRFI-18
implementation as well as the SRFI-18-specific test code.

A couple of notes: For purposes of elegance, I've changed semantics of
fat_mutex.level -- where previously all non-recursive mutexes had a
level of -1, recursiveness is now denoted by an integer field on
fat_mutex.  Any mutex (recursive or not) is in a locked state iff its
level is greater than 0.

Second, during the testing I did for this round of changes, I noticed
a few more deadlocks that I believe are related to the existing core
threading model (as opposed to the changes included in this patch).
These seem to crop up when I run overnight tests on modified core
code, probably because different timings and thread interactions are
introduced.  I think I've got fixes for some of them, and I'll
follow-up in a separate mailing list thread.


Regards,
Julian

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-latest-set-of-SRFI-18-support-changes-to-core-thread.patch --]
[-- Type: text/x-diff; name=0001-latest-set-of-SRFI-18-support-changes-to-core-thread.patch, Size: 14332 bytes --]

From 4f04a30ccb5f4129c0720f6b10bbad3ef9244cb6 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Sun, 13 Apr 2008 19:51:23 -0400
Subject: [PATCH] latest set of SRFI-18 support changes to core threads

---
 doc/ref/api-scheduling.texi   |   33 +++++++-
 libguile/threads.c            |  162 ++++++++++++++++++++++------------------
 libguile/threads.h            |    5 +-
 test-suite/tests/threads.test |   46 ++++++++++++
 4 files changed, 168 insertions(+), 78 deletions(-)

diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index ec136fb..29eed5e 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -409,17 +409,21 @@ function is equivalent to calling `make-mutex' and specifying the
 @code{recursive} flag.
 @end deffn
 
-@deffn {Scheme Procedure} lock-mutex mutex [timeout]
+@deffn {Scheme Procedure} lock-mutex mutex [timeout [owner]]
 @deffnx {C Function} scm_lock_mutex (mutex)
-@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout)
-Lock @var{mutex}.  If the mutex is already locked by another thread
-then block and return only when @var{mutex} has been acquired.
+@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout, owner)
+Lock @var{mutex}.  If the mutex is already locked, then block and 
+return only when @var{mutex} has been acquired.
 
 When @var{timeout} is given, it specifies a point in time where the 
 waiting should be aborted.  It can be either an integer as returned 
 by @code{current-time} or a pair as returned by @code{gettimeofday}.  
 When the waiting is aborted, @code{#f} is returned. 
 
+When @var{owner} is given, it specifies an owner for @var{mutex} other
+than the calling thread.  @var{owner} may also be @code{#f}, 
+indicating that the mutex should be locked but left unowned.
+
 For standard mutexes (@code{make-mutex}), and error is signalled if
 the thread has itself already locked @var{mutex}.
 
@@ -471,6 +475,27 @@ returned by @code{current-time} or a pair as returned by
 returned.  Otherwise the function returns @code{#t}.
 @end deffn
 
+@deffn {Scheme Procedure} mutex-owner mutex
+@deffnx {C Function} scm_mutex_owner (mutex)
+Return the current owner of @var{mutex}, in the form of a thread or 
+@code{#f} (indicating no owner).  Note that a mutex may be unowned but
+still locked.
+@end deffn
+
+@deffn {Scheme Procedure} mutex-level mutex
+@deffnx {C Function} scm_mutex_level (mutex)
+Return the current lock level of @var{mutex}.  If @var{mutex} is
+currently unlocked, this value will be 0; otherwise, it will be the
+number of times @var{mutex} has been recursively locked by its current
+owner.
+@end deffn
+
+@deffn {Scheme Procedure} mutex-locked? mutex
+@deffnx {C Function} scm_mutex_locked_p (mutex)
+Return @code{#t} if @var{mutex} is locked, regardless of ownership;
+otherwise, return @code{#f}.
+@end deffn
+
 @deffn {Scheme Procedure} make-condition-variable
 @deffnx {C Function} scm_make_condition_variable ()
 Return a new condition variable.
diff --git a/libguile/threads.c b/libguile/threads.c
index 68c5f79..938644c 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -511,9 +511,9 @@ guilify_self_2 (SCM parent)
 typedef struct {
   scm_i_pthread_mutex_t lock;
   SCM owner;
-  int level;      /* how much the owner owns us.  
-		     < 0 for non-recursive mutexes */
+  int level; /* how much the owner owns us.  <= 1 for non-recursive mutexes */
 
+  int recursive; /* allow recursive locking? */
   int unchecked_unlock; /* is it an error to unlock an unlocked mutex? */
   int allow_external_unlock; /* is it an error to unlock a mutex that is not
 				owned by the current thread? */
@@ -1154,8 +1154,9 @@ make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock)
   m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
   scm_i_pthread_mutex_init (&m->lock, NULL);
   m->owner = SCM_BOOL_F;
-  m->level = recursive? 0 : -1;
+  m->level = 0;
 
+  m->recursive = recursive;
   m->unchecked_unlock = unchecked_unlock;
   m->allow_external_unlock = external_unlock;
 
@@ -1211,79 +1212,77 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
 SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error");
 
 static SCM
-fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
+fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
 {
   fat_mutex *m = SCM_MUTEX_DATA (mutex);
 
-  SCM thread = scm_current_thread ();
-  scm_i_thread *t = SCM_I_THREAD_DATA (thread);
-
+  SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner;
   SCM err = SCM_BOOL_F;
 
   struct timeval current_time;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
-  if (scm_is_false (m->owner))
-    {
-      m->owner = thread;
-      scm_i_pthread_mutex_lock (&t->admin_mutex);
-      t->mutexes = scm_cons (mutex, t->mutexes);
-      scm_i_pthread_mutex_unlock (&t->admin_mutex);
-      *ret = 1;
-    }
-  else if (scm_is_eq (m->owner, thread))
+
+  while (1)
     {
-      if (m->level >= 0)
+      if (m->level == 0)
 	{
+	  m->owner = new_owner;
 	  m->level++;
-	  *ret = 1;
-	}
-      else
-	err = scm_cons (scm_misc_error_key,
-			scm_from_locale_string ("mutex already locked by "
-						"current thread"));
-    }
-  else
-    {
-      int first_iteration = 1;
-      while (1)
-	{
-	  if (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner))
+	  
+	  if (SCM_I_IS_THREAD (new_owner))
 	    {
+	      scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
 	      scm_i_pthread_mutex_lock (&t->admin_mutex);
 	      t->mutexes = scm_cons (mutex, t->mutexes);
 	      scm_i_pthread_mutex_unlock (&t->admin_mutex);
-	      *ret = 1;
-	      if (scm_c_thread_exited_p (m->owner)) 
-		{
-		  m->owner = thread;
-		  err = scm_cons (scm_abandoned_mutex_error_key,
-				  scm_from_locale_string ("lock obtained on "
-							  "abandoned mutex"));
-		}
-	      break;
 	    }
-	  else if (!first_iteration)
+	  *ret = 1;
+	  break;
+	}
+      else if (SCM_I_IS_THREAD (m->owner) && scm_c_thread_exited_p (m->owner))
+	{
+	  m->owner = new_owner;
+	  err = scm_cons (scm_abandoned_mutex_error_key,
+			  scm_from_locale_string ("lock obtained on abandoned "
+						  "mutex"));
+	  *ret = 1;
+	  break;
+	}
+      else if (scm_is_eq (m->owner, new_owner))
+	{
+	  if (m->recursive)
+	    {
+	      m->level++;
+	      *ret = 1;		  
+	    }
+	  else
 	    {
-	      if (timeout != NULL) 
+	      err = scm_cons (scm_misc_error_key,
+			      scm_from_locale_string ("mutex already locked "
+						      "by thread"));
+	      *ret = 0;
+	    }
+	  break;  
+	}
+      else
+	{
+	  if (timeout != NULL) 
+	    {
+	      gettimeofday (&current_time, NULL);
+	      if (current_time.tv_sec > timeout->tv_sec ||
+		  (current_time.tv_sec == timeout->tv_sec &&
+		   current_time.tv_usec * 1000 > timeout->tv_nsec))
 		{
-		  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;
-		    }
+		  *ret = 0;
+		  break;
 		}
-	      scm_i_pthread_mutex_unlock (&m->lock);
-	      SCM_TICK;
-	      scm_i_scm_pthread_mutex_lock (&m->lock);
 	    }
-	  else
-	    first_iteration = 0;
-	  block_self (m->waiting, mutex, &m->lock, timeout);
+	  scm_i_pthread_mutex_unlock (&m->lock);
+	  SCM_TICK;
+	  scm_i_scm_pthread_mutex_lock (&m->lock);
 	}
+      block_self (m->waiting, mutex, &m->lock, timeout);
     }
   scm_i_pthread_mutex_unlock (&m->lock);
   return err;
@@ -1291,11 +1290,11 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
 
 SCM scm_lock_mutex (SCM mx)
 {
-  return scm_lock_mutex_timed (mx, SCM_UNDEFINED);
+  return scm_lock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED);
 }
 
-SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0,
-	    (SCM m, SCM timeout),
+SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
+	    (SCM m, SCM timeout, SCM owner),
 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
 "blocks until the mutex becomes available. The function returns when "
 "the calling thread owns the lock on @var{mutex}.  Locking a mutex that "
@@ -1315,7 +1314,7 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0,
       waittime = &cwaittime;
     }
 
-  exception = fat_mutex_lock (m, waittime, &ret);
+  exception = fat_mutex_lock (m, waittime, owner, &ret);
   if (!scm_is_false (exception))
     scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
   return ret ? SCM_BOOL_T : SCM_BOOL_F;
@@ -1346,7 +1345,7 @@ SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
   to_timespec (scm_from_int(0), &cwaittime);
   waittime = &cwaittime;
   
-  exception = fat_mutex_lock (mutex, waittime, &ret);
+  exception = fat_mutex_lock (mutex, waittime, SCM_UNDEFINED, &ret);
   if (!scm_is_false (exception))
     scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
   return ret ? SCM_BOOL_T : SCM_BOOL_F;
@@ -1373,15 +1372,19 @@ fat_mutex_unlock (SCM mutex, SCM cond,
   int err = 0, ret = 0;
 
   scm_i_scm_pthread_mutex_lock (&m->lock);
-  if (!scm_is_eq (m->owner, scm_current_thread ()))
+
+  SCM owner = m->owner;
+
+  if (!scm_is_eq (owner, scm_current_thread ()))
     {
-      if (scm_is_false (m->owner))
+      if (m->level == 0)
 	{
 	  if (!m->unchecked_unlock)
 	    {
 	      scm_i_pthread_mutex_unlock (&m->lock);
 	      scm_misc_error (NULL, "mutex not locked", SCM_EOL);
 	    }
+	  owner = scm_current_thread ();
 	}
       else if (!m->allow_external_unlock)
 	{
@@ -1392,8 +1395,6 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 
   if (! (SCM_UNBNDP (cond)))
     {
-      int lock_ret = 0;
-
       c = SCM_CONDVAR_DATA (cond);
       while (1)
 	{
@@ -1402,8 +1403,9 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 	  scm_i_scm_pthread_mutex_lock (&c->lock);
 	  if (m->level > 0)
 	    m->level--;
-	  else
+	  if (m->level == 0)
 	    m->owner = unblock_from_queue (m->waiting);
+
 	  scm_i_pthread_mutex_unlock (&m->lock);
 	  
 	  t->block_asyncs++;
@@ -1430,7 +1432,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
 	  if (brk)
 	    {
 	      if (relock)
-		fat_mutex_lock (mutex, NULL, &lock_ret);
+		scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
 	      scm_i_pthread_mutex_unlock (&c->lock);
 	      break;
 	    }
@@ -1449,8 +1451,9 @@ fat_mutex_unlock (SCM mutex, SCM cond,
     {
       if (m->level > 0)
 	m->level--;
-      else
+      if (m->level == 0) 
 	m->owner = unblock_from_queue (m->waiting);
+	  
       scm_i_pthread_mutex_unlock (&m->lock);
       ret = 1;
     }
@@ -1501,22 +1504,27 @@ SCM_DEFINE (scm_mutex_p, "mutex?", 1, 0, 0,
 }
 #undef FUNC_NAME 
 
-#if 0
-
 SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
 	    (SCM mx),
 	    "Return the thread owning @var{mx}, or @code{#f}.")
 #define FUNC_NAME s_scm_mutex_owner
 {
+  SCM owner;
+  fat_mutex *m = NULL;
+
   SCM_VALIDATE_MUTEX (1, mx);
-  return (SCM_MUTEX_DATA(mx))->owner;
+  m = SCM_MUTEX_DATA (mx);
+  scm_i_pthread_mutex_lock (&m->lock);
+  owner = m->owner;
+  scm_i_pthread_mutex_unlock (&m->lock);
+
+  return owner;
 }
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
 	    (SCM mx),
-	    "Return the lock level of a recursive mutex, or -1\n"
-	    "for a standard mutex.")
+	    "Return the lock level of mutex @var{mx}.")
 #define FUNC_NAME s_scm_mutex_level
 {
   SCM_VALIDATE_MUTEX (1, mx);
@@ -1524,7 +1532,15 @@ SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif
+SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0,
+	    (SCM mx),
+	    "Returns @code{#t} if the mutex @var{mx} is locked.")
+#define FUNC_NAME s_scm_mutex_locked_p
+{
+  SCM_VALIDATE_MUTEX (1, mx);
+  return SCM_MUTEX_DATA (mx)->level > 0 ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
 
 static SCM
 fat_cond_mark (SCM cv)
diff --git a/libguile/threads.h b/libguile/threads.h
index e1944a5..d10e0f8 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -170,12 +170,15 @@ SCM_API SCM scm_make_mutex (void);
 SCM_API SCM scm_make_recursive_mutex (void);
 SCM_API SCM scm_make_mutex_with_flags (SCM flags);
 SCM_API SCM scm_lock_mutex (SCM m);
-SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout);
+SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner);
 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 timeout);
 SCM_API SCM scm_mutex_p (SCM o);
+SCM_API SCM scm_mutex_locked_p (SCM m);
+SCM_API SCM scm_mutex_owner (SCM m);
+SCM_API SCM scm_mutex_level (SCM m);
 
 SCM_API SCM scm_make_condition_variable (void);
 SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex);
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 62ee0cd..9cd062d 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -279,6 +279,52 @@
 	  (not (thread-cleanup (current-thread)))))
 
       ;;
+      ;; mutex ownership
+      ;;
+
+      (with-test-prefix "mutex-ownership"
+	(pass-if "mutex ownership for locked mutex"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m)
+	    (eq? (mutex-owner m) (current-thread))))
+
+	(pass-if "mutex ownership for unlocked mutex"
+	  (let ((m (make-mutex)))
+	    (not (mutex-owner m))))
+
+	(pass-if "locking mutex on behalf of other thread"
+	  (let* ((m (make-mutex))
+		 (t (begin-thread 'foo)))
+	    (lock-mutex m #f t)
+	    (eq? (mutex-owner m) t)))
+
+        (pass-if "locking mutex with no owner"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m #f #f)
+	    (not (mutex-owner m)))))
+
+      ;;
+      ;; mutex lock levels
+      ;;
+
+      (with-test-prefix "mutex-lock-levels"
+			
+        (pass-if "unlocked level is 0"
+	  (let ((m (make-mutex)))
+	    (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0))))
+
+        (pass-if "non-recursive lock level is 1"
+	  (let ((m (make-mutex)))
+	    (lock-mutex m)
+	    (and (mutex-locked? m) (eqv? (mutex-level m) 1))))
+
+	(pass-if "recursive lock level is >1"
+	  (let ((m (make-mutex 'recursive)))
+	    (lock-mutex m)
+	    (lock-mutex m)
+	    (and (mutex-locked? m) (eqv? (mutex-level m) 2)))))
+
+      ;;
       ;; mutex behavior
       ;;
 
-- 
1.5.4.3


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-ChangeLog-updates-for-latest-set-of-SRFI-18-changes.patch --]
[-- Type: text/x-diff; name=0002-ChangeLog-updates-for-latest-set-of-SRFI-18-changes.patch, Size: 2507 bytes --]

From e9a8373bd67f8b39ad378175931fa258f953a3ba Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Sun, 13 Apr 2008 20:31:18 -0400
Subject: [PATCH] ChangeLog updates for latest set of SRFI-18 changes

---
 doc/ref/ChangeLog    |    8 ++++++++
 libguile/ChangeLog   |   14 ++++++++++++++
 test-suite/ChangeLog |    9 +++++++++
 3 files changed, 31 insertions(+), 0 deletions(-)

diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog
index 7719819..4a0a943 100644
--- a/doc/ref/ChangeLog
+++ b/doc/ref/ChangeLog
@@ -1,3 +1,11 @@
+2008-04-13  Julian Graham  <joolean@gmail.com>
+
+	* api-scheduling.texi (Mutexes and Condition Variables): Add
+	documentation for new functions "scm_mutex_owner",
+	"scm_mutex_level", and "scm_mutex_locked_p".  Update
+	documentation for function "scm_lock_mute_timed" to reflect
+	addition of optional ownership argument.
+
 2008-03-28  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* libguile-concepts.texi (Multi-Threading): Fix typo.
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index ea75158..48a849e 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,17 @@
+2008-04-13  Julian Graham  <joolean@gmail.com>
+
+	* threads.c (fat_mutex)[recursive]: New field.
+	(make_fat_mutex): Adjust initialization to reflect changes to
+	mutex lock level semantics.
+	(fat_mutex_lock, fat_mutex_unlock): Add support for unowned 
+	mutexes and locking mutexes on behalf of other threads.
+	(scm_lock_mutex, scm_lock_mutex_timed): Update to reflect
+	signature change to fat_mutex_lock.
+	(scm_mutex_owner, scm_mutex_level, scm_mutex_locked_p): New /
+	re-enabled functions.
+	* threads.h (scm_mutex_owner, scm_mutex_level, 
+	scm_mutex_locked_p): Prototypes for new functions.
+
 2008-04-13  Ludovic Courtès  <ludo@gnu.org>
 
 	* inline.h (SCM_C_USE_EXTERN_INLINE): New macro.  Use it to make
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 7b546b3..fcacd9c 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,12 @@
+2008-04-13  Julian Graham  <joolean@gmail.com>
+
+	* tests/threads.test (mutex-ownership, mutex-lock-levels): New 
+	test prefix.
+	(mutex ownership for locked mutex, mutex ownership for unlocked
+	mutex, locking mutex on behalf of other thread, locking mutex
+	with no owner, unlocked level is 0, non-recursive lock level
+	is 1, recursive lock level is >1): New tests.
+
 2008-04-13  Ludovic Courtès  <ludo@gnu.org>
 
 	* tests/goops.test (defining classes)[interaction with
-- 
1.5.4.3


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

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

;; Copyright (C) 2008 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; 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: 2008-04-11

;;; 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)
  :use-module (srfi srfi-34)
  :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
 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))

(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 abandoned-mutex-exception (list 'abandoned-mutex-exception))
(define join-timeout-exception (list 'join-timeout-exception))
(define terminated-thread-exception (list 'terminated-thread-exception))
(define uncaught-exception (list 'uncaught-exception))

(define mutex-owners (make-weak-key-hash-table))
(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) 
  (srfi-18-exception-preserver (cons uncaught-exception obj)))

(define thread->exception (make-object-property))

(define (srfi-18-exception-preserver obj)
  (if (or (terminated-thread-exception? obj)
          (uncaught-exception? obj))
      (set! (thread->exception (current-thread)) obj)))

(define (srfi-18-exception-handler key . args)

  ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
  ;; if one is caught at this level, it has already been taken care of by
  ;; `initial-handler'.

  (and (not (eq? key 'srfi-34))
       (srfi-18-exception-preserver (if (null? args) 
					(cons uncaught-exception key)
					(cons* 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 (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-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)
				       srfi-18-exception-handler)))
	  (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) 
				 (srfi-18-exception-preserver
				  terminated-thread-exception)))
	  (set-thread-cleanup! thread
			       (lambda () (srfi-18-exception-preserver
					   terminated-thread-exception))))
      (cancel-thread thread)
      *unspecified*))
  (thread-terminate-inner!))

(define (thread-join! thread . args) 
  (define thread-join-inner!
    (wrap (lambda ()
	    (let ((v (apply join-thread (cons thread args)))
		  (e (thread->exception thread)))
	      (if (and (= (length args) 1) (not v))
		  (raise join-timeout-exception))
	      (if e (raise e))
	      v))))
  (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) 
	      'unchecked-unlock 
	      'allow-external-unlock 
	      'recursive)))
      (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-state mutex)
  (let ((owner (mutex-owner mutex)))
    (if owner
	(if (thread-exited? owner) 'abandoned owner)
	(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))

(define (mutex-lock! mutex . args) 
  (define mutex-lock-inner!
    (wrap (lambda ()
	    (catch 'abandoned-mutex-error
		   (lambda () (apply lock-mutex (cons mutex args)))
		   (lambda (key . args) (raise abandoned-mutex-exception))))))
  (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: srfi-18.test --]
[-- Type: application/octet-stream, Size: 15868 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* ((m1 (make-mutex 'thread-terminate-2a))
	   (m2 (make-mutex 'thread-terminate-2b))
	   (c (make-condition-variable 'thread-terminate-2))
	   (t (make-thread (lambda () 
			     (mutex-lock! m1) 
			     (condition-variable-signal! c)
			     (mutex-unlock! m1)
			     (mutex-lock! m2))
			   'thread-terminate-2))
	   (success #f))
      (mutex-lock! m1)
      (mutex-lock! m2)
      (thread-start! t)
      (mutex-unlock! m1 c)
      (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* ((m (make-mutex 'thread-join-2))
	   (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
      (mutex-lock! m)
      (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* ((m (make-mutex 'thread-join-3))
	   (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
	   (success #f))
      (mutex-lock! m)
      (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* ((m1 (make-mutex 'mutex-lock-4a))
	   (m2 (make-mutex 'mutex-lock-4b))
	   (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
      (mutex-lock! m1)
      (thread-start! t)
      (mutex-lock! m2 #f t)
      (let ((success (eq? (mutex-state m2) t))) 
	(thread-terminate! t) success)))

  (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* ((m1 (make-mutex 'mutex-lock-6a))
	   (m2 (make-mutex 'mutex-lock-6b))
	   (c (make-condition-variable 'mutex-lock-6))
	   (t (make-thread (lambda () 
			     (mutex-lock! m1)
			     (mutex-lock! m2)
			     (condition-variable-signal! c))))
	   (success #f))
      (mutex-lock! m1)
      (thread-start! t)
      (with-exception-handler
       (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
       (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
      success)))

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

  (pass-if "initial handler captures non-SRFI-18 throw"
    (let ((t (make-thread (lambda () (throw '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)))

Re: srfi-18 requirements

[Julian Graham]

Any updates / thoughts on the patch?  I'd welcome any comments or
revisions you guys'd like to make.  (I'd also be happy to write up a
NEWS file entry, if you're waiting for one...)


Regards,
Julian


>  Find attached a patch (in two parts -- sorry, still getting used to
>  git) to the core threading code that includes the changes we
>  discussed, specifically:

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Any updates / thoughts on the patch?  I'd welcome any comments or
> revisions you guys'd like to make.  (I'd also be happy to write up a
> NEWS file entry, if you're waiting for one...)

Working on it this evening...

     Neil

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> Find attached a patch (in two parts [...]

Thanks; I've reviewed and applied those to my tree, and rebuilding
now; will push shortly unless I see any build errors.

> * Re-added support for locking mutexes with an owner other than the
> current thread
> * Enabled the previously ifdef'd out functions scm_mutex_owner and
> scm_mutex_level
> * Added a new function, scm_mutex_locked_p, useful for distinguishing
> between unlocked and unowned mutex states.
> * Updated the threads.test file to reflect the changes above
> * Updated the documentation in api-scheduling.texi to reflect the changes above
> * Updated the ChangeLog to reflect the changes above

All great.

> Also attached are updated versions of the Scheme SRFI-18
> implementation as well as the SRFI-18-specific test code.

I haven't covered these yet.  Will try to soon, but could you resubmit
anyway as a GIT commit patch, so that you end up being properly
credited for the commit?

> A couple of notes: For purposes of elegance, I've changed semantics of
> fat_mutex.level -- where previously all non-recursive mutexes had a
> level of -1, recursiveness is now denoted by an integer field on
> fat_mutex.  Any mutex (recursive or not) is in a locked state iff its
> level is greater than 0.

Cool; I think this is nicer than the previous -1 representation.

> Second, during the testing I did for this round of changes, I noticed
> a few more deadlocks that I believe are related to the existing core
> threading model (as opposed to the changes included in this patch).
> These seem to crop up when I run overnight tests on modified core
> code, probably because different timings and thread interactions are
> introduced.  I think I've got fixes for some of them, and I'll
> follow-up in a separate mailing list thread.

OK.  I'll look out for those.

Even though I've already committed, I had one query...

> @@ -1211,79 +1212,77 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
>  SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error");
>  
>  static SCM
> -fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret)
> +fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
>  {
>    fat_mutex *m = SCM_MUTEX_DATA (mutex);
>  
> -  SCM thread = scm_current_thread ();
> -  scm_i_thread *t = SCM_I_THREAD_DATA (thread);
> -
> +  SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner;
>    SCM err = SCM_BOOL_F;
>  
>    struct timeval current_time;
>  
>    scm_i_scm_pthread_mutex_lock (&m->lock);
> -  if (scm_is_false (m->owner))
> -    {
> -      m->owner = thread;
> -      scm_i_pthread_mutex_lock (&t->admin_mutex);
> -      t->mutexes = scm_cons (mutex, t->mutexes);
> -      scm_i_pthread_mutex_unlock (&t->admin_mutex);
> -      *ret = 1;
> -    }
> -  else if (scm_is_eq (m->owner, thread))
> +
> +  while (1)
>      {
> -      if (m->level >= 0)
> +      if (m->level == 0)
>  	{
> +	  m->owner = new_owner;
>  	  m->level++;
> -	  *ret = 1;
> -	}
> -      else
> -	err = scm_cons (scm_misc_error_key,
> -			scm_from_locale_string ("mutex already locked by "
> -						"current thread"));
> -    }
> -  else
> -    {
> -      int first_iteration = 1;
> -      while (1)
> -	{
> -	  if (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner))
> +	  
> +	  if (SCM_I_IS_THREAD (new_owner))
>  	    {
> +	      scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
>  	      scm_i_pthread_mutex_lock (&t->admin_mutex);
>  	      t->mutexes = scm_cons (mutex, t->mutexes);
>  	      scm_i_pthread_mutex_unlock (&t->admin_mutex);
> -	      *ret = 1;
> -	      if (scm_c_thread_exited_p (m->owner)) 
> -		{
> -		  m->owner = thread;
> -		  err = scm_cons (scm_abandoned_mutex_error_key,
> -				  scm_from_locale_string ("lock obtained on "
> -							  "abandoned mutex"));
> -		}
> -	      break;
>  	    }
> -	  else if (!first_iteration)
> +	  *ret = 1;
> +	  break;
> +	}
> +      else if (SCM_I_IS_THREAD (m->owner) && scm_c_thread_exited_p (m->owner))
> +	{
> +	  m->owner = new_owner;

Should m->level be set to 1 here?

Regards, and thanks once again for your work on this area!

     Neil

Re: srfi-18 requirements

[Julian Graham]

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

Hi Neil,

> I haven't covered these yet.  Will try to soon, but could you resubmit
> anyway as a GIT commit patch, so that you end up being properly
> credited for the commit?

Yes -- find one attached.  As an aside, I've been having some
difficulty with git, specifically when it comes to backing out commits
that I've created prematurely (e.g., without git-adding the
ChangeLogs).  Do you guys have any recommendations for tools that add
a bit of sugar to the interface, or do I just have to buckle down and
learn the thing?


> Should m->level be set to 1 here?

Can I take it you're talking about the case in which a thread is
taking over an abandoned mutex that may have been locked more than
once, recursively, by the exited thread?  If so, yes -- m->level
should definitely be set back to 1.  Thanks for catching that!


> Regards, and thanks once again for your work on this area!

My pleasure!  Thank you for your continued patience.


Regards,
Julian

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Scheme-SRFI-18-implementation-and-tests-file.patch --]
[-- Type: text/x-diff; name=0001-Scheme-SRFI-18-implementation-and-tests-file.patch, Size: 30433 bytes --]

From 75e5e5c7aad78876fb9e4a2c1523491f58985917 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Thu, 15 May 2008 00:50:50 -0400
Subject: [PATCH] Scheme SRFI-18 implementation and tests file

---
 srfi/ChangeLog                |    4 +
 srfi/srfi-18.scm              |  379 ++++++++++++++++++++++++++++++++
 test-suite/ChangeLog          |    4 +
 test-suite/tests/srfi-18.test |  477 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 864 insertions(+), 0 deletions(-)
 create mode 100644 srfi/srfi-18.scm
 create mode 100644 test-suite/tests/srfi-18.test

diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 1f6c599..fe88665 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,7 @@
+2008-05-15  Julian Graham  <joolean@gmail.com>
+
+	* srfi-18.scm: New file.
+
 2008-04-28  Ludovic Courtès  <ludo@gnu.org>
 
 	* srfi-1.c (scm_srfi1_partition): Properly type-check LIST.
diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm
new file mode 100644
index 0000000..0593f4e
--- /dev/null
+++ b/srfi/srfi-18.scm
@@ -0,0 +1,379 @@
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; 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: 2008-04-11
+
+;;; 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)
+  :use-module (srfi srfi-34)
+  :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
+ 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))
+
+(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 abandoned-mutex-exception (list 'abandoned-mutex-exception))
+(define join-timeout-exception (list 'join-timeout-exception))
+(define terminated-thread-exception (list 'terminated-thread-exception))
+(define uncaught-exception (list 'uncaught-exception))
+
+(define mutex-owners (make-weak-key-hash-table))
+(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) 
+  (srfi-18-exception-preserver (cons uncaught-exception obj)))
+
+(define thread->exception (make-object-property))
+
+(define (srfi-18-exception-preserver obj)
+  (if (or (terminated-thread-exception? obj)
+          (uncaught-exception? obj))
+      (set! (thread->exception (current-thread)) obj)))
+
+(define (srfi-18-exception-handler key . args)
+
+  ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
+  ;; if one is caught at this level, it has already been taken care of by
+  ;; `initial-handler'.
+
+  (and (not (eq? key 'srfi-34))
+       (srfi-18-exception-preserver (if (null? args) 
+					(cons uncaught-exception key)
+					(cons* 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 (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-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)
+				       srfi-18-exception-handler)))
+	  (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) 
+				 (srfi-18-exception-preserver
+				  terminated-thread-exception)))
+	  (set-thread-cleanup! thread
+			       (lambda () (srfi-18-exception-preserver
+					   terminated-thread-exception))))
+      (cancel-thread thread)
+      *unspecified*))
+  (thread-terminate-inner!))
+
+(define (thread-join! thread . args) 
+  (define thread-join-inner!
+    (wrap (lambda ()
+	    (let ((v (apply join-thread (cons thread args)))
+		  (e (thread->exception thread)))
+	      (if (and (= (length args) 1) (not v))
+		  (raise join-timeout-exception))
+	      (if e (raise e))
+	      v))))
+  (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) 
+	      'unchecked-unlock 
+	      'allow-external-unlock 
+	      'recursive)))
+      (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-state mutex)
+  (let ((owner (mutex-owner mutex)))
+    (if owner
+	(if (thread-exited? owner) 'abandoned owner)
+	(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
+
+(define (mutex-lock! mutex . args) 
+  (define mutex-lock-inner!
+    (wrap (lambda ()
+	    (catch 'abandoned-mutex-error
+		   (lambda () (apply lock-mutex (cons mutex args)))
+		   (lambda (key . args) (raise abandoned-mutex-exception))))))
+  (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
\ No newline at end of file
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 1d73fbf..5f97142 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,7 @@
+2008-05-15  Julian Graham  <joolean@gmail.com>
+
+	* tests/srfi-18.test: New file.
+
 2008-05-14  Julian Graham  <joolean@gmail.com>
 
 	* tests/threads.test (mutex-ownership, mutex-lock-levels): New
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
new file mode 100644
index 0000000..d116768
--- /dev/null
+++ b/test-suite/tests/srfi-18.test
@@ -0,0 +1,477 @@
+;;;; 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* ((m1 (make-mutex 'thread-terminate-2a))
+	   (m2 (make-mutex 'thread-terminate-2b))
+	   (c (make-condition-variable 'thread-terminate-2))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m1) 
+			     (condition-variable-signal! c)
+			     (mutex-unlock! m1)
+			     (mutex-lock! m2))
+			   'thread-terminate-2))
+	   (success #f))
+      (mutex-lock! m1)
+      (mutex-lock! m2)
+      (thread-start! t)
+      (mutex-unlock! m1 c)
+      (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* ((m (make-mutex 'thread-join-2))
+	   (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
+      (mutex-lock! m)
+      (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* ((m (make-mutex 'thread-join-3))
+	   (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
+	   (success #f))
+      (mutex-lock! m)
+      (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* ((m1 (make-mutex 'mutex-lock-4a))
+	   (m2 (make-mutex 'mutex-lock-4b))
+	   (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
+      (mutex-lock! m1)
+      (thread-start! t)
+      (mutex-lock! m2 #f t)
+      (let ((success (eq? (mutex-state m2) t))) 
+	(thread-terminate! t) success)))
+
+  (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* ((m1 (make-mutex 'mutex-lock-6a))
+	   (m2 (make-mutex 'mutex-lock-6b))
+	   (c (make-condition-variable 'mutex-lock-6))
+	   (t (make-thread (lambda () 
+			     (mutex-lock! m1)
+			     (mutex-lock! m2)
+			     (condition-variable-signal! c))))
+	   (success #f))
+      (mutex-lock! m1)
+      (thread-start! t)
+      (with-exception-handler
+       (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+       (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
+      success)))
+
+(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))
+
+  (pass-if "initial handler captures non-SRFI-18 throw"
+    (let ((t (make-thread (lambda () (throw '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)))
-- 
1.5.4.3

Re: srfi-18 requirements

[Neil Jerram]

[-- Attachment #1.1: Type: text/plain, Size: 346 bytes --]

2008/5/15 Julian Graham <joolean@gmail.com>:

> Hi Neil,
>
> > I haven't covered these yet.  Will try to soon, but could you resubmit
> > anyway as a GIT commit patch, so that you end up being properly
> > credited for the commit?
>
> Yes -- find one attached.


OK, that's in now.  I had a few minor comments, please see the attached.

    Neil

[-- Attachment #1.2: Type: text/html, Size: 781 bytes --]

[-- Attachment #2: 0001-Comments-on-srfi-18.scm.patch --]
[-- Type: text/plain, Size: 4218 bytes --]

From c06926f30220cdc4dff93b490118e57f2973a02d Mon Sep 17 00:00:00 2001
From: Neil Jerram <neil@ossau.uklinux.net>
Date: Sat, 24 May 2008 12:36:58 +0100
Subject: [PATCH] Comments on srfi-18.scm

---
 srfi/srfi-18.scm |   48 +++++++++++++++++++++++++++++++++++++++---------
 1 files changed, 39 insertions(+), 9 deletions(-)

diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm
index 0593f4e..85547f0 100644
--- a/srfi/srfi-18.scm
+++ b/srfi/srfi-18.scm
@@ -32,12 +32,21 @@
 
 (define-module (srfi srfi-18)
   :use-module (srfi srfi-34)
+
+;; NJ: Do we need this use-module, given that the following code
+;; accesses everything from SRFI-34 using (@ ...)?
+
   :export (
 
 ;;; Threads
  ;; current-thread			<= in the core
  ;; thread?				<= in the core
  make-thread
+
+;; NJ: Is it commented/documented somewhere that someone should
+;; normally either use (srfi srfi-18), or (ice-9 threads), but not
+;; both?
+
  thread-name
  thread-specific
  thread-specific-set!
@@ -50,6 +59,9 @@
 ;;; Mutexes
  ;; mutex?				<= in the core
  make-mutex
+
+;; NJ: make-mutex is is the core too.  So should this be a #:replace ?
+
  mutex-name
  mutex-specific
  mutex-specific-set!
@@ -60,6 +72,9 @@
 ;;; Condition variables
  ;; condition-variable?			<= in the core
  make-condition-variable
+
+;; NJ: as above; make-condition-variable is in the core.
+
  condition-variable-name
  condition-variable-specific
  condition-variable-specific-set!
@@ -69,6 +84,9 @@
 
 ;;; Time
  current-time
+
+;; NJ: as above; current-time is in the core.
+
  time?
  time->seconds
  seconds->time
@@ -83,6 +101,9 @@
  uncaught-exception-reason
  )
   :re-export (thread? mutex? condition-variable?)
+
+;; NJ: do things from the core need to be re-exported?
+
   :replace (current-time 
 	    make-thread 
 	    make-mutex 
@@ -103,10 +124,13 @@
 (define uncaught-exception (list 'uncaught-exception))
 
 (define mutex-owners (make-weak-key-hash-table))
+;; NJ: appears to be unused!
 (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))
+;; NJ: suggest using make-object-property for all of these.  Note that
+;; hashq-remove! can be implemented as setting to #f.
 
 ;; EXCEPTIONS
 
@@ -136,6 +160,7 @@
   (let ((ct (current-thread)))
     (or (hashq-ref thread-exception-handlers ct)
 	(hashq-set! thread-exception-handlers ct (list initial-handler)))))
+;; NJ: does hashq-set! return the value that it has just set?
 
 (define (with-exception-handler handler thunk)
   (let ((ct (current-thread))
@@ -143,13 +168,14 @@
     (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))))))
+;; NJ: rewrite without apply:
+    ((@ (srfi srfi-34) with-exception-handler) 
+     (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-exception-handler)
   (car (current-handler-stack)))
@@ -246,13 +272,17 @@
 (define (wrap thunk)
   (lambda (continuation)
     (with-exception-handler (lambda (obj)
-			      (apply (current-exception-handler) (list obj))
-			      (apply continuation (list)))
+;; NJ: without apply: 
+			      ((current-exception-handler) obj)
+			      (continuation))
 			    thunk)))
 
 ;; A pass-thru to cancel-thread that first installs a handler that throws
 ;; terminated-thread exception, as per SRFI-18, 
 
+;; NJ: do similar semantics apply if a SRFI-18 thread terminates under
+;; its own stream?
+
 (define (thread-terminate! thread)
   (define (thread-terminate-inner!)
     (let ((current-handler (thread-cleanup thread)))
-- 
1.5.4.2

Re: srfi-18 requirements

[Neil Jerram]

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

2008/5/24 Neil Jerram <neiljerram@googlemail.com>:

> 2008/5/15 Julian Graham <joolean@gmail.com>:
>
>> Hi Neil,
>>
>> > I haven't covered these yet.  Will try to soon, but could you resubmit
>> > anyway as a GIT commit patch, so that you end up being properly
>> > credited for the commit?
>>
>> Yes -- find one attached.
>
>
> OK, that's in now.
>

Hmm.  In the master branch, I'm now seeing a hang when "make check" tries to
run srfi-18.test.  I unfortunately don't have time to investigate further
right now; anyone working on the master branch who sees this - please just
suppress srfi-18.test for now.

Regards,
        Neil

[-- Attachment #2: Type: text/html, Size: 1317 bytes --]

Re: srfi-18 requirements

[Julian Graham]

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

Hi Neil,


On Sat, May 24, 2008 at 7:42 AM, Neil Jerram <neiljerram@googlemail.com> wrote:
>
> OK, that's in now.  I had a few minor comments, please see the attached.
>

Hey, that's great!  I know there are some unresolved issues -- I'll
address them as soon as I can.  Thanks, again, to you and Ludovic for
being patient and helpful in shaping that original morass of code over
these many (almost 8?  Yikes) months.

As promised, I've written a NEWS entry; find attached a git patch for
that.  And I've taken a look at the comments you made and integrated
them into a separate patch, also attached.  I tried to write something
resembling a ChangeLog entry in my commit message, as per what you and
Andy Wingo were discussing earlier.  Let me know if it's not
sufficient.

Sorry about the module import/export redundancies -- I was kind of
fuzzy on the semantics around export vs. re-export vs. replace.
Likewise object-property, of which I was unaware when I originally
wrote that code last year.

The only thing I didn't change was the `thread-terminate!' behavior.
If I understand your comment, then, no, the exit of a non-canceled
SRFI-18 thread doesn't require the installation of that exception
handler.  (That handler's purpose is to notify future joiners of the
cancellation event, which is unnecessary if the thread is never
canceled.)


Regards,
Julian

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Update-NEWS-file-for-SRFI-18-and-associated-core-thr.patch --]
[-- Type: text/x-diff; name=0001-Update-NEWS-file-for-SRFI-18-and-associated-core-thr.patch, Size: 3491 bytes --]

From 75c5ec7b90a5cb1057520a8051ce5033212c77be Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Sat, 24 May 2008 19:11:12 -0400
Subject: [PATCH] Update NEWS file for SRFI-18 and associated core thread changes

---
 NEWS |   60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 files changed, 58 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index 5f84659..a52378b 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,7 @@ Changes in 1.9.0:
 * New modules (see the manual for details)
 
 ** The `(ice-9 i18n)' module provides internationalization support
+** `(srfi srfi-18)'
 
 * Changes to the distribution
 
@@ -26,14 +27,69 @@ be used for efficiently implementing a Scheme code coverage.
 ** Duplicate bindings among used modules are resolved lazily.
 This slightly improves program startup times.
 
-** New thread cancellation and thread cleanup API
-See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'.
+** Changes and additions to the thread and synchronization API
+
+There is a new thread cancellation and thread cleanup API.  See
+`cancel-thread', `set-thread-cleanup!', and `thread-cleanup' in the
+manual for details.
+
+New predicates `mutex?', `condition-variable?', and `mutex-locked?'
+have been added.
+
+Functions for examining the state of a locked mutex, `mutex-level' and
+`mutex-owner', have been added.
+
+Some of the existing thread functions now take optional arguments that
+extend their functionality: `make-mutex' now accepts zero or more
+flags that allow the user to configure various aspects of the behavior
+of the returned mutex; `join-thread' and `lock-mutex' now accept
+timeout arguments that allow users to limit the amount of time those
+functions will wait; `join-thread' also now has the ability to return
+a failure value of the caller's choosing, in order to distinguish
+between timeout and threads returning #f; `unlock-mutex' can now 
+optionally wait for a specified condition variable to be signaled 
+before returning.  See the manual for details.
+
+Threads waiting on a locked mutex will now be notified if the owner
+exits before unlocking it.
 
 * Changes to the C interface
 
 ** Functions for handling `scm_option' now no longer require an argument
 indicating length of the `scm_t_option' array.
 
+** Corresponding C functions for the thread API enhancements have been
+** added
+
+These functions provide access to the new features provided by the 
+Scheme thread API enhancements described above.  Where changes to the 
+signatures of the existing C API would have been required, new functions
+with distinct names have been introduced, in order to preserve backwards 
+compatibility with existing code.
+
+  Synchronization type predicates:
+
+  - SCM scm_mutex_p (SCM obj)
+  - SCM scm_condition_variable_p (SCM obj)
+
+  Timeout and other enhancements for existing thread primitives:
+
+  - SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner)
+  - SCM scm_join_thread_timed (SCM t, SCM timeout, SCM timeoutval)
+  - SCM scm_unlock_mutex_timed (SCM m, SCM cond, SCM timeout)
+  - SCM scm_make_mutex_with_flags (SCM flags)
+
+  Thread cancellation and cleanup:
+
+  - SCM scm_cancel_thread (SCM t)
+  - SCM scm_set_thread_cleanup_x (SCM thread, SCM proc)
+  - SCM scm_thread_cleanup (SCM thread)
+
+  Mutex inspection:
+
+  - SCM scm_mutex_owner (SCM m)
+  - SCM scm_mutex_level (SCM m)
+  - SCM scm_mutex_locked_p (SCM m)
 
 \f
 Changes in 1.8.5 (since 1.8.4)
-- 
1.5.4.3


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0001-srfi-18.scm-Remove-redundant-module-imports-and-s.patch --]
[-- Type: text/x-diff; name=0001-srfi-18.scm-Remove-redundant-module-imports-and-s.patch, Size: 8176 bytes --]

From 5f3e413789bdb455a166057c392ab1999cd80155 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Sat, 24 May 2008 20:52:45 -0400
Subject: [PATCH] * srfi-18.scm: Remove redundant module imports and symbol exports.
   (object-names, object-specifics, thread-start-conds,
   thread-exception-handlers): Convert to object properties.
   (current-handler-stack, with-exception-handler, make-thread,
   thread-name, thread-specific, thread-specific-set!, thread-start!,
   make-mutex, mutex-name, mutex-specific, mutex-specific-set!,
   make-condition-variable, condition-variable-name,
   condition-variable-specific, condition-variable-specific-set!): Use
   object properties instead of hash tables.
   (with-exception-handler, wrap): Remove unnecessary use of `apply'.

---
 srfi/srfi-18.scm |  115 ++++++++++++++++++++++++------------------------------
 1 files changed, 51 insertions(+), 64 deletions(-)

diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm
index 0593f4e..21db266 100644
--- a/srfi/srfi-18.scm
+++ b/srfi/srfi-18.scm
@@ -31,7 +31,6 @@
 ;;; Code:
 
 (define-module (srfi srfi-18)
-  :use-module (srfi srfi-34)
   :export (
 
 ;;; Threads
@@ -49,7 +48,6 @@
 
 ;;; Mutexes
  ;; mutex?				<= in the core
- make-mutex
  mutex-name
  mutex-specific
  mutex-specific-set!
@@ -59,7 +57,6 @@
 
 ;;; Condition variables
  ;; condition-variable?			<= in the core
- make-condition-variable
  condition-variable-name
  condition-variable-specific
  condition-variable-specific-set!
@@ -68,7 +65,6 @@
  condition-variable-wait!
 
 ;;; Time
- current-time
  time?
  time->seconds
  seconds->time
@@ -82,7 +78,6 @@
  uncaught-exception?
  uncaught-exception-reason
  )
-  :re-export (thread? mutex? condition-variable?)
   :replace (current-time 
 	    make-thread 
 	    make-mutex 
@@ -102,11 +97,10 @@
 (define terminated-thread-exception (list 'terminated-thread-exception))
 (define uncaught-exception (list 'uncaught-exception))
 
-(define mutex-owners (make-weak-key-hash-table))
-(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))
+(define object-name (make-object-property))
+(define object-specific (make-object-property))
+(define thread-start-cond (make-object-property))
+(define thread-exception-handler (make-object-property))
 
 ;; EXCEPTIONS
 
@@ -134,22 +128,21 @@
 
 (define (current-handler-stack)
   (let ((ct (current-thread)))
-    (or (hashq-ref thread-exception-handlers ct)
-	(hashq-set! thread-exception-handlers ct (list initial-handler)))))
+    (or (thread-exception-handler ct)
+	(let ((ih (list initial-handler)))
+	  (set! (thread-exception-handler ct) ih)
+	  ih))))
 
 (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))))))
+    (set! (thread-exception-handler ct) (cons handler hl))
+    ((@ (srfi srfi-34) with-exception-handler) 
+     (lambda (obj) (set! (thread-exception-handler ct) hl) (handler obj))
+     (lambda () 
+       (let ((r (thunk))) (set! (thread-exception-handler ct) hl) r)))))
 
 (define (current-exception-handler)
   (car (current-handler-stack)))
@@ -191,31 +184,29 @@
 	(lock-mutex lm)
 	(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
 				       srfi-18-exception-handler)))
-	  (hashq-set! thread-start-conds t (cons sm sc))
-	  (and n (hashq-set! object-names t n))
+	  (set! (thread-start-cond t) (cons sm sc))
+	  (and n (set! (object-name 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")))
+  (object-name (check-arg-type thread? thread "thread-name")))
 
 (define (thread-specific thread)
-  (hashq-ref object-specifics 
-	     (check-arg-type thread? thread "thread-specific")))
+  (object-specific (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*)
+  (set! (object-specific 
+	 (check-arg-type thread? thread "thread-specific-set!"))
+	obj))
 
 (define (thread-start! thread)
-  (let ((x (hashq-ref thread-start-conds
-		      (check-arg-type thread? thread "thread-start!"))))
+  (let ((x (thread-start-cond
+	    (check-arg-type thread? thread "thread-start!"))))
     (and x (let ((smutex (car x))
 		 (scond (cdr x)))
-	     (hashq-remove! thread-start-conds thread)
+	     (set! (thread-start-cond thread) #f)
 	     (lock-mutex smutex)
 	     (signal-condition-variable scond)
 	     (unlock-mutex smutex)))
@@ -284,27 +275,24 @@
 ;; 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) 
-	      'unchecked-unlock 
-	      'allow-external-unlock 
-	      'recursive)))
-      (and n (hashq-set! object-names m n)) m)))
+(define (make-mutex . name)
+  (let ((n (and (pair? name) (car name)))
+	(m ((@ (guile) make-mutex) 
+	    'unchecked-unlock 
+	    'allow-external-unlock 
+	    'recursive)))
+    (and n (set! (object-name m) n)) 
+    m))
 
 (define (mutex-name mutex)
-  (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
+  (object-name (check-arg-type mutex? mutex "mutex-name")))
 
 (define (mutex-specific mutex)
-  (hashq-ref object-specifics 
-	     (check-arg-type mutex? mutex "mutex-specific")))
+  (object-specific (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*)
+  (set! (object-specific (check-arg-type mutex? mutex "mutex-specific-set!"))
+	obj))
 
 (define (mutex-state mutex)
   (let ((owner (mutex-owner mutex)))
@@ -326,29 +314,28 @@
 ;; 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 (make-condition-variable . name)
+  (let ((n (and (pair? name) (car name)))
+	(m ((@ (guile) make-condition-variable))))
+    (and n (set! (object-name m) n)) 
+    m))
 
 (define (condition-variable-name condition-variable)
-  (hashq-ref object-names (check-arg-type condition-variable? 
-					  condition-variable
-					  "condition-variable-name")))
+  (object-name (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")))
+  (object-specific (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*)
+  (set! (object-specific
+	 (check-arg-type condition-variable? 
+			 condition-variable 
+			 "condition-variable-specific-set!"))
+	obj))
 
 (define (condition-variable-signal! cond) 
   (signal-condition-variable cond) 
-- 
1.5.4.3

Re: srfi-18 requirements

[Ludovic Courtès]

Hello,

"Neil Jerram" <neiljerram@googlemail.com> writes:

> OK, that's in now.  I had a few minor comments, please see the attached.

BTW, it'd be nice to have an "SRFI-18" node in the manual.  :-)

Thanks,
Ludovic.

Re: srfi-18 requirements

[Julian Graham]

> BTW, it'd be nice to have an "SRFI-18" node in the manual.  :-)

Working on it...  Should have something for you in a few days.


Regards,
Julian

Re: srfi-18 requirements

[Julian Graham]

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

Yikes, didn't mean for it to take this long.  Work got crazy, then my
laptop died.  At any rate, find attached a draft of an SRFI-18
section.  Let me know what you think.  Apologies in advance for any
punctuation screw-ups or missing spaces.


On Mon, Jun 2, 2008 at 12:48 AM, Julian Graham <joolean@gmail.com> wrote:
>> BTW, it'd be nice to have an "SRFI-18" node in the manual.  :-)
>
> Working on it...  Should have something for you in a few days.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-srfi-modules.texi-SRFI-18-New-sections.patch --]
[-- Type: text/x-diff; name=0001-srfi-modules.texi-SRFI-18-New-sections.patch, Size: 15571 bytes --]

From 69e05dc39167e3103171be27887529659b709b65 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@countyhell.(none)>
Date: Sat, 21 Jun 2008 00:55:17 -0400
Subject: [PATCH] srfi-modules.texi (SRFI-18): New sections.

---
 doc/ref/srfi-modules.texi |  345 ++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 343 insertions(+), 2 deletions(-)

diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 31ba498..26b95ec 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -34,6 +34,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-14::                     Character-set library.
 * SRFI-16::                     case-lambda
 * SRFI-17::                     Generalized set!
+* SRFI-18::                     Multithreading support
 * SRFI-19::                     Time/Date library.
 * SRFI-26::                     Specializing parameters
 * SRFI-31::                     A special form `rec' for recursive evaluation
@@ -1678,6 +1679,344 @@ The same as the Guile core @code{make-procedure-with-setter}
 @end defun
 
 
+@node SRFI-18
+@subsection SRFI-18 - Multithreading support
+@cindex SRFI-18
+
+This is an implementation of the SRFI-18 threading and synchronization
+library.  The functions and variables described here are provided by
+
+@example
+(use-modules (srfi srfi-18))
+@end example
+
+As a general rule, the data types and functions in this SRFI-18
+implementation are compatible with the types and functions in Guile's
+core threading code.  For example, mutexes created with the SRFI-18 
+@code{make-mutex} function can be passed to the built-in Guile 
+function @code{lock-mutex} (@pxref{Mutexes and Condition Variables}),
+and mutexes created with the build-in Guile function @code{make-mutex}
+can be passed to the SRFI-18 function @code{mutex-lock!}.  Cases in
+which this does not hold true are noted in the following sections.
+
+@menu
+* SRFI-18 Threads::             Executing code 
+* SRFI-18 Mutexes::             Mutual exclusion devices
+* SRFI-18 Condition variables:: Synchronizing of groups of threads
+* SRFI-18 Time::                Representation of times and durations
+* SRFI-18 Exceptions::          Signalling and handling errors
+@end menu
+
+@node SRFI-18 Threads
+@subsubsection SRFI-18 Threads
+
+Threads created by SRFI-18 differ in two ways from threads created by 
+Guile's built-in thread functions.  First, a thread created by SRFI-18
+@code{make-thread} begins in a blocked state and will not start 
+execution until @code{thread-start!} is called on it.  Second, SRFI-18
+threads are constructed with a top-level exception handler that 
+captures any exceptions that are thrown on thread exit.  In all other
+regards, SRFI-18 threads are identical to normal Guile threads.
+
+@defun current-thread
+Returns the thread that called this function.  This is the same
+procedure as the same-named built-in procedure @code{current-thread}
+(@pxref{Threads}).
+@end defun
+
+@defun thread? obj
+Returns @code{#t} if @var{obj} is a thread, @code{#f} otherwise.  This
+is the same procedure as the same-named built-in procedure 
+@code{thread?} (@pxref{Threads}).
+@end defun
+
+@defun make-thread thunk [name]
+Call @code{thunk} in a new thread and with a new dynamic state,
+returning the new thread and optionally assigning it the object name
+@var{name}, which may be any Scheme object.
+
+Note that the name @code{make-thread} conflicts with the 
+@code{(ice-9 threads)} function @code{make-thread}.  Applications 
+wanting to use both of these functions will need to refer to them by 
+different names.
+@end defun
+
+@defun thread-name thread
+Returns the name assigned to @var{thread} at the time of its creation,
+or @code{#f} if it was not given a name.
+@end defun
+
+@defun thread-specific thread
+@defunx thread-specific-set! thread obj
+Get or set the ``object-specific'' property of @var{thread}.  In
+Guile's implementation of SRFI-18, this value is stored as an object
+property, and will be @code{#f} if not set.
+@end defun
+
+@defun thread-start! thread
+Unblocks @var{thread} and allows it to begin execution if it has not
+done so already.
+@end defun
+
+@defun thread-yield!
+If one or more threads are waiting to execute, calling 
+@code{thread-yield!} forces an immediate context switch to one of them.
+Otherwise, @code{thread-yield!} has no effect.  @code{thread-yield!} 
+behaves identically to the Guile built-in function @code{yield}.
+@end defun
+
+@defun thread-sleep! timeout
+The current thread waits until the point specified by the time object
+@var{timeout} is reached (@pxref{SRFI-18 Time}).  This blocks the 
+thread only if @var{timeout} represents a point in the future.  it is 
+an error for @var{timeout} to be @code{#f}.
+@end defun
+
+@defun thread-terminate! thread
+Causes an abnormal termination of @var{thread}.  If @var{thread} is
+not already terminated, all mutexes owned by @var{thread} become
+unlocked/abandoned.  If @var{thread} is the current thread, 
+@code{thread-terminate!} does not return.  Otherwise 
+@code{thread-terminate!} returns an unspecified value; the termination
+of @var{thread} will occur before @code{thread-terminate!} returns.  
+Subsequent attempts to join on @var{thread} will cause a ``terminated 
+thread exception'' to be raised.
+
+@code{thread-terminate!} is compatible with the thread cancellation
+procedures in the core threads API (@pxref{Threads}) in that if a 
+cleanup handler has been installed for the target thread, it will be 
+called before the thread exits and its return value (or exception, if
+any) will be stored for later retrieval via a call to 
+@code{thread-join!}.
+@end defun
+
+@defun thread-join! thread [timeout [timeout-val]]
+Wait for @var{thread} to terminate and return its exit value.  When a 
+time value @var{timeout} is given, it specifies a point in time where
+the waiting should be aborted.  When the waiting is aborted, 
+@var{timeoutval} is returned if it is specified; otherwise, a
+@code{join-timeout-exception} exception is raised 
+(@pxref{SRFI-18 Exceptions}).  Exceptions may also be raised if the 
+thread was terminated by a call to @code{thread-terminate!} 
+(@code{terminated-thread-exception} will be raised) or if the thread 
+exited by raising an exception that was handled by the top-level 
+exception handler (@code{uncaught-exception} will be raised; the 
+original exception can be retrieved using 
+@code{uncaught-exception-reason}).
+@end defun
+
+
+@node SRFI-18 Mutexes
+@subsubsection SRFI-18 Mutexes
+
+The behavior of Guile's built-in mutexes is parameterized via a set of
+flags passed to the @code{make-mutex} procedure in the core
+(@pxref{Mutexes and Condition Variables}).  To satisfy the requirements
+for mutexes specified by SRFI-18, the @code{make-mutex} procedure
+described below sets the following flags:
+@itemize @bullet
+@item
+@code{recursive}: the mutex can be locked recursively
+@item
+@code{unchecked-unlock}: attempts to unlock a mutex that is already
+unlocked will not raise an exception
+@item
+@code{allow-external-unlock}: the mutex can be unlocked by any thread,
+not just the thread that locked it originally
+@end itemize
+
+@defun make-mutex [name]
+Returns a new mutex, optionally assigning it the object name 
+@var{name}, which may be any Scheme object.  The returned mutex will be
+created with the configuration described above.  Note that the name 
+@code{make-mutex} conflicts with Guile core function @code{make-mutex}.
+Applications wanting to use both of these functions will need to refer 
+to them by different names.
+@end defun
+
+@defun mutex-name mutex
+Returns the name assigned to @var{mutex} at the time of its creation, 
+or @code{#f} if it was not given a name.
+@end defun
+
+@defun mutex-specific mutex
+@defunx mutex-specific-set! mutex obj
+Get or set the ``object-specific'' property of @var{mutex}.  In Guile's
+implementation of SRFI-18, this value is stored as an object property, 
+and will be @code{#f} if not set.
+@end defun
+
+@defun mutex-state mutex
+Returns information about the state of @var{mutex}.  Possible values 
+are:
+@itemize @bullet
+@item
+thread @code{T}: the mutex is in the locked/owned state and thread T
+is the owner of the mutex
+@item 
+symbol @code{not-owned}: the mutex is in the locked/not-owned state
+@item
+symbol @code{abandoned}: the mutex is in the unlocked/abandoned state
+@item
+symbol @code{not-abandoned}: the mutex is in the 
+unlocked/not-abandoned state 
+@end itemize
+@end defun
+
+@defun mutex-lock! mutex [timeout [thread]]
+Lock @var{mutex}, optionally specifying a time object @var{timeout}
+after which to abort the lock attempt and a thread @var{thread} giving
+a new owner for @var{mutex} different than the current thread.  This 
+procedure has the same behavior as the @code{lock-mutex} procedure in 
+the core library.
+@end defun
+
+@defun mutex-unlock! mutex [condition-variable [timeout]]
+Unlock @var{mutex}, optionally specifying a condition variable
+@var{condition-variable} on which to wait, either indefinitely or,
+optionally, until the time object @var{timeout} has passed, to be
+signalled.  This procedure has the same behavior as the 
+@code{unlock-mutex} procedure in the core library.
+@end defun
+
+
+@node SRFI-18 Condition variables
+@subsubsection SRFI-18 Condition variables
+
+SRFI-18 does not specify a ``wait'' function for condition variables.
+Waiting on a condition variable can be simulated using the SRFI-18
+@code{mutex-unlock!} function described in the previous section, or
+Guile's built-in @code{wait-condition-variable} procedure can be used.
+
+@defun condition-variable? obj
+Returns @code{#t} if @var{obj} is a condition variable, @code{#f}
+otherwise.  This is the same procedure as the same-named built-in 
+procedure
+(@pxref{Mutexes and Condition Variables, @code{condition-variable?}}).
+@end defun
+
+@defun make-condition-variable [name]
+Returns a new condition variable, optionally assigning it the object
+name @var{name}, which may be any Scheme object.  This procedure 
+replaces a procedure of the same name in the core library.
+@end defun
+
+@defun condition-variable-name condition-variable
+Returns the name assigned to @var{thread} at the time of its creation,
+or @code{#f} if it was not given a name.
+@end defun
+
+@defun condition-variable-specific condition-variable
+@defunx condition-variable-specific-set! condition-variable obj
+Get or set the ``object-specific'' property of 
+@var{condition-variable}.  In Guile's implementation of SRFI-18, this
+value is stored as an object property, and will be @code{#f} if not 
+set.
+@end defun
+
+@defun condition-variable-signal! condition-variable
+@defunx condition-variable-broadcast! condition-variable
+Wake up one thread that is waiting for @var{condition-variable}, in
+the case of @code{condition-variable-signal!}, or all threads waiting
+for it, in the case of @code{condition-variable-broadcast!}.  The
+behavior of these procedures is equivalent to that of the procedures
+@code{signal-condition-variable} and 
+@code{broadcast-condition-variable} in the core library.
+@end defun
+
+
+@node SRFI-18 Time
+@subsubsection SRFI-18 Time
+
+The SRFI-18 time functions manipulate time in two formats: a 
+``time object'' type that represents an absolute point in time in some 
+implementation-specific way; and the number of seconds since some 
+unspecified ``epoch''.  In Guile's implementation, the epoch is the
+Unix epoch, 00:00:00 UTC, January 1, 1970.
+
+@defun current-time
+Return the current time as a time object.  This procedure replaces 
+the procedure of the same name in the core library, which returns the
+current time in seconds since the epoch.
+@end defun
+
+@defun time? obj
+Returns @code{#t} if @var{obj} is a time object, @code{#f} otherwise.
+@end defun
+
+@defun time->seconds time
+@defunx seconds->time seconds
+Convert between time objects and numerical values representing the
+number of seconds since the epoch.  When converting from a time object 
+to seconds, the return value is the number of seconds between 
+@var{time} and the epoch.  When converting from seconds to a time 
+object, the return value is a time object that represents a time 
+@var{seconds} seconds after the epoch.
+@end defun
+
+
+@node SRFI-18 Exceptions
+@subsubsection SRFI-18 Exceptions
+
+SRFI-18 exceptions are identical to the exceptions provided by 
+Guile's implementation of SRFI-34.  The behavior of exception 
+handlers invoked to handle exceptions thrown from SRFI-18 functions,
+however, differs from the conventional behavior of SRFI-34 in that
+the continuation of the handler is the same as that of the call to
+the function.  Handlers are called in a tail-recursive manner; the
+exceptions do not ``bubble up''.
+
+@defun current-exception-handler
+Returns the current exception handler.
+@end defun
+
+@defun with-exception-handler handler thunk
+Installs @var{handler} as the current exception handler and calls the
+procedure @var{thunk} with no arguments, returning its value as the 
+value of the exception.  @var{handler} must be a procedure that accepts
+a single argument. The current exception handler at the time this 
+procedure is called will be restored after the call returns.
+@end defun
+
+@defun raise obj
+Raise @var{obj} as an exception.  This is the same procedure as the
+same-named procedure defined in SRFI 34.
+@end defun
+
+@defun join-timeout-exception? obj
+Returns @code{#t} if @var{obj} is an exception raised as the result of 
+performing a timed join on a thread that does not exit within the
+specified timeout, @code{#f} otherwise.
+@end defun
+
+@defun abandoned-mutex-exception? obj
+Returns @code{#t} if @var{obj} is an exception raised as the result of
+attempting to lock a mutex that has been abandoned by its owner thread,
+@code{#f} otherwise.
+@end defun
+
+@defun terminated-thread-exception? obj
+Returns @code{#t} if @var{obj} is an exception raised as the result of 
+joining on a thread that exited as the result of a call to
+@code{thread-terminate!}.
+@end defun
+
+@defun uncaught-exception? obj
+@defunx uncaught-exception-reason exc
+@code{uncaught-exception?} returns @code{#t} if @var{obj} is an 
+exception thrown as the result of joining a thread that exited by
+raising an exception that was handled by the top-level exception
+handler installed by @code{make-thread}.  When this occurs, the 
+original exception is preserved as part of the exception thrown by
+@code{thread-join!} and can be accessed by calling 
+@code{uncaught-exception-reason} on that exception.  Note that
+because this exception-preservation mechanism is a side-effect of
+@code{make-thread}, joining on threads that exited as described above
+but were created by other means will not raise this 
+@code{uncaught-exception} error.
+@end defun
+
+
 @node SRFI-19
 @subsection SRFI-19 - Time/Date Library
 @cindex SRFI-19
@@ -1845,8 +2184,10 @@ Return the current time of the given @var{type}.  The default
 @var{type} is @code{time-utc}.
 
 Note that the name @code{current-time} conflicts with the Guile core
-@code{current-time} function (@pxref{Time}).  Applications wanting to
-use both will need to use a different name for one of them.
+@code{current-time} function (@pxref{Time}) as well as the SRFI-18
+@code{current-time} function (@pxref{SRFI-18 Time}).  Applications 
+wanting to use more than one of these functions will need to refer to
+them by different names.
 @end defun
 
 @defun time-resolution [type]
-- 
1.5.4.3

Re: srfi-18 requirements

[Ludovic Courtès]

Hi,

"Julian Graham" <joolean@gmail.com> writes:

> Yikes, didn't mean for it to take this long.  Work got crazy, then my
> laptop died.  At any rate, find attached a draft of an SRFI-18
> section.  Let me know what you think.  Apologies in advance for any
> punctuation screw-ups or missing spaces.

Looks perfect!

I committed it along with a ChangeLog and a NEWS entry. (BTW, you forgot
to set your email address in Git.)

Thanks,
Ludovic.

Re: srfi-18 requirements

[Neil Jerram]

"Julian Graham" <joolean@gmail.com> writes:

> With regard to your comments about the rest of the patch, agreed, except:
>
> Given the similarities between the existing Guile threading code and
> SRFI-18, what level of comptability between these two domains will be
> supported?  For example, SRFI-18 specifies that threads waiting on a
> mutex held by a thread that exits should be notified of the exit and
> that one of them will then be able to lock that mutex.  Given the
> changes you describe below, will this behavior only work if all the
> components in the user's code were created using the SRFI-18 API?

No.  I think that what SRFI-18 says about abandoned mutexes makes good
sense for threads in general, and also that it is generally good to
make Guile's behaviour here better defined.  So I'm happy for what
SRFI-18 says about abandoned mutexes to apply equally to both core and
SRFI-18 threads.

> What about a thread that calls SRFI-18's thread-join function on a
> non-SRFI-18 thread that died with an exception?

Well, according to the picture of my previous email - in which it is
the job of the thread-handler (as specified to call-with-new-thread)
to preserve the death exception - I think it is clear that a
non-SRFI-18 thread would _not_ save off its death exception in the way
that SRFI-18 says, and hence that this exception will _not_ be
available when another thread (whether SRFI-18 or not) does a
join-thread on the terminated thread.

The implication is that if you want this detail of the SRFI-18
semantics, both of the threads involved must be SRFI-18 threads.

That all seems fine to me.  I'm happy with that implication, and I
think the overall picture is clear.

>  (Are you sure you
> don't want thread exceptions in the core?  I feel like join-thread
> isn't really "complete" without them...)

Yes, I feel pretty sure about this.  SRFI-18's edicts in this area do
not feel obviously correct and generally applicable in the same way as
what it says about abandoned mutexes (for example).  Therefore, if we
can factor this out of the core - and it appears that we can - I think
we should do so.

>> Finally, there are quite a few spurious changes (or perhaps just that
>> I don't understand yet) in patch: whitespace, line break and docstring
>> changes.  Can you revert all these, as they only confuse the overall
>> picture?
>
> This may have just been stuff that Ludovic asked me to clean up (or
> that I just cleaned up ad-hoc).  It can all go.

Sorry if we've been giving opposing steers.  I think in a tricky patch
like this one, it's best to minimize distractions; hence I recommend
following GCS for any new or changed code, but not including
janitorial changes (even to conform to GCS) to code that would not
otherwise have changed.

(Purely janitorial changes are fine per se, but should be separate.)

>> I'm sorry that I'm asking for some significant changes here, but I
>> hope that you'll agree that they make the enhancement clearer, and in
>> particular that it is a good thing to reduce the changes that we need
>> to make to the C code.  Please let me know what you think.
>
> Not a problem.  Thank you for taking the time to all this analysis.
> What's the next thing you'd like me to submit?  How about (2), the
> enhancement patch for timed joins?

Do you mean that timed joins is separable from the rest of the C
enhancements (e.g. timed mutex locking)?  If so, timed joins on its
own would be great.  If not (which I was expecting, although without
too much thought), it's fine for the next patch to be all of the C
code enhancements.

Regards,
        Neil