[PATCH 10/10] add thread-blocker

[Tom Tromey]

This adds thread-blocker, a function to examine what a thread is
blocked on.  I thought this would be another nice debugging addition.

Like the mutex-name patch, I separated this out for ease of dropping.

I think on the whole I'd prefer to keep this one, though.  It seems to
me that it is a good idea to provide introspection like this, not simply
because we can, but also because it makes it easier to debug threaded
Emacs Lisp code without having to resort to gdb.

---
 src/thread.c |   31 ++++++++++++++++++++++++++++++-
 src/thread.h |    4 ++++
 2 files changed, 34 insertions(+), 1 deletions(-)

diff --git a/src/thread.c b/src/thread.c
index 9ec418f..40c8be9 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -66,17 +66,27 @@ mutex_lock_callback (void *arg)
   lisp_mutex_lock (&mutex->mutex);
 }
 
+static Lisp_Object
+do_unwind_mutex_lock (Lisp_Object ignore)
+{
+  current_thread->event_object = Qnil;
+  return Qnil;
+}
+
 DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
        doc: /* FIXME */)
   (Lisp_Object obj)
 {
   struct Lisp_Mutex *mutex;
+  ptrdiff_t count = SPECPDL_INDEX ();
 
   CHECK_MUTEX (obj);
   mutex = XMUTEX (obj);
 
+  current_thread->event_object = obj;
+  record_unwind_protect (do_unwind_mutex_lock, Qnil);
   flush_stack_call_func (mutex_lock_callback, mutex);
-  return Qnil;
+  return unbind_to (count, Qnil);
 }
 
 static void
@@ -361,6 +371,7 @@ If NAME is given, it names the new thread.  */)
   new_thread->m_current_buffer = current_thread->m_current_buffer;
   new_thread->error_symbol = Qnil;
   new_thread->error_data = Qnil;
+  new_thread->event_object = Qnil;
 
   new_thread->m_specpdl_size = 50;
   new_thread->m_specpdl = xmalloc (new_thread->m_specpdl_size
@@ -454,17 +465,33 @@ DEFUN ("thread-alive-p", Fthread_alive_p, 
Sthread_alive_p, 1, 1, 0,
   return tstate->m_specpdl == NULL ? Qnil : Qt;
 }
 
+DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
+       doc: /* FIXME */)
+  (Lisp_Object thread)
+{
+  struct thread_state *tstate;
+
+  CHECK_THREAD (thread);
+  tstate = XTHREAD (thread);
+
+  return tstate->event_object;
+}
+
 static void
 thread_join_callback (void *arg)
 {
   struct thread_state *tstate = arg;
   struct thread_state *self = current_thread;
+  Lisp_Object thread;
 
+  XSETTHREAD (thread, tstate);
+  self->event_object = thread;
   self->wait_condvar = &tstate->thread_condvar;
   while (tstate->m_specpdl != NULL && EQ (self->error_symbol, Qnil))
     sys_cond_wait (self->wait_condvar, &global_lock);
 
   self->wait_condvar = NULL;
+  self->event_object = Qnil;
   post_acquire_global_lock (self);
 }
 
@@ -515,6 +542,7 @@ init_primary_thread (void)
   primary_thread.function = Qnil;
   primary_thread.error_symbol = Qnil;
   primary_thread.error_data = Qnil;
+  primary_thread.event_object = Qnil;
 
   sys_cond_init (&primary_thread.thread_condvar);
 }
@@ -544,6 +572,7 @@ syms_of_threads (void)
   defsubr (&Sthread_signal);
   defsubr (&Sthread_alive_p);
   defsubr (&Sthread_join);
+  defsubr (&Sthread_blocker);
   defsubr (&Sall_threads);
   defsubr (&Smake_mutex);
   defsubr (&Smutex_lock);
diff --git a/src/thread.h b/src/thread.h
index 1a193b1..d21887a 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -44,6 +44,10 @@ struct thread_state
   Lisp_Object error_symbol;
   Lisp_Object error_data;
 
+  /* If we are waiting for some event, this holds the object we are
+     waiting on.  */
+  Lisp_Object event_object;
+
   /* m_gcprolist must be the first non-lisp field.  */
   /* Recording what needs to be marked for gc.  */
   struct gcpro *m_gcprolist;
-- 
1.7.7.6