condition variables

This implements condition variables for elisp.
This needs more tests.

6 files changed, 255 insertions, 20 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 80d22d61d66..19b77d567d0 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3106,6 +3106,8 @@ sweep_vectors (void)
 		finalize_one_thread ((struct thread_state *) vector);
 	      else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
 		finalize_one_mutex ((struct Lisp_Mutex *) vector);
+	      else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
+		finalize_one_condvar ((struct Lisp_CondVar *) vector);
 
 	      next = ADVANCE (vector, nbytes);
 
diff --git a/src/data.c b/src/data.c
index b47c2d12aff..e6342caadf1 100644
--- a/src/data.c
+++ b/src/data.c
@@ -94,7 +94,7 @@ static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
 static Lisp_Object Qsubrp, Qmany, Qunevalled;
 Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
 static Lisp_Object Qdefun;
-Lisp_Object Qthread, Qmutex;
+Lisp_Object Qthread, Qmutex, Qcondition_variable;
 
 Lisp_Object Qinteractive_form;
 
@@ -216,6 +216,8 @@ for example, (type-of 1) returns `integer'.  */)
 	return Qthread;
       if (MUTEXP (object))
 	return Qmutex;
+      if (CONDVARP (object))
+	return Qcondition_variable;
       return Qvector;
 
     case Lisp_Float:
@@ -482,6 +484,17 @@ DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0,
   else
     return Qnil;
 }
+
+DEFUN ("condition-variablep", Fcondition_variablep, Scondition_variablep,
+       1, 1, 0,
+       doc: /* Return t if OBJECT is a condition variable.  */)
+  (Lisp_Object object)
+{
+  if (CONDVARP (object))
+    return Qt;
+  else
+    return Qnil;
+}
 
 /* Extract and set components of lists */
 
@@ -3117,6 +3130,7 @@ syms_of_data (void)
   DEFSYM (Qhash_table, "hash-table");
   DEFSYM (Qthread, "thread");
   DEFSYM (Qmutex, "mutex");
+  DEFSYM (Qcondition_variable, "condition-variable");
   /* Used by Fgarbage_collect.  */
   DEFSYM (Qinterval, "interval");
   DEFSYM (Qmisc, "misc");
@@ -3161,6 +3175,7 @@ syms_of_data (void)
   defsubr (&Schar_or_string_p);
   defsubr (&Sthreadp);
   defsubr (&Smutexp);
+  defsubr (&Scondition_variablep);
   defsubr (&Scar);
   defsubr (&Scdr);
   defsubr (&Scar_safe);
diff --git a/src/lisp.h b/src/lisp.h
index 34ecfe697d6..2a75dfcbc7d 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -367,6 +367,7 @@ enum pvec_type
   PVEC_OTHER,
   PVEC_THREAD,
   PVEC_MUTEX,
+  PVEC_CONDVAR,
   /* These last 4 are special because we OR them in fns.c:internal_equal,
      so they have to use a disjoint bit pattern:
      if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE
@@ -557,6 +558,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
 			  XUNTAG (a, Lisp_Vectorlike)))
 #define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a))
 #define XMUTEX(a) (eassert (MUTEXP (a)), (struct Lisp_Mutex *) XPNTR(a))
+#define XCONDVAR(a) (eassert (CONDVARP (a)), (struct Lisp_CondVar *) XPNTR(a))
 
 /* Construct a Lisp_Object from a value or address.  */
 
@@ -609,6 +611,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
 #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
 #define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
 #define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
+#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
 
 /* Convenience macros for dealing with Lisp arrays.  */
 
@@ -1709,6 +1712,7 @@ typedef struct {
 #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME)
 #define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD)
 #define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX)
+#define CONDVARP(x) PSEUDOVECTORP (x, PVEC_CONDVAR)
 
 /* Test for image (image . spec)  */
 #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage))
@@ -1833,6 +1837,9 @@ typedef struct {
 #define CHECK_MUTEX(x) \
   CHECK_TYPE (MUTEXP (x), Qmutexp, x)
 
+#define CHECK_CONDVAR(x) \
+  CHECK_TYPE (CONDVARP (x), Qcondition_variablep, x)
+
 /* Since we can't assign directly to the CAR or CDR fields of a cons
    cell, use these when checking that those fields contain numbers.  */
 #define CHECK_NUMBER_CAR(x) \
@@ -2455,7 +2462,7 @@ extern Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
 extern Lisp_Object Qbuffer_or_string_p;
 extern Lisp_Object Qfboundp;
 extern Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
-extern Lisp_Object Qthreadp, Qmutexp;
+extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep;
 
 extern Lisp_Object Qcdr;
 
diff --git a/src/print.c b/src/print.c
index b14a769dc74..78a0707627c 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1967,6 +1967,18 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag
 	    }
 	  PRINTCHAR ('>');
 	}
+      else if (CONDVARP (obj))
+	{
+	  strout ("#<condvar ", -1, -1, printcharfun);
+	  if (STRINGP (XCONDVAR (obj)->name))
+	    print_string (XCONDVAR (obj)->name, printcharfun);
+	  else
+	    {
+	      int len = sprintf (buf, "%p", XCONDVAR (obj));
+	      strout (buf, len, len, printcharfun);
+	    }
+	  PRINTCHAR ('>');
+	}
       else
 	{
 	  ptrdiff_t size = ASIZE (obj);
diff --git a/src/thread.c b/src/thread.c
index 9c39b84eb50..4657d6a797e 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -32,7 +32,7 @@ static struct thread_state *all_threads = &primary_thread;
 
 static sys_mutex_t global_lock;
 
-Lisp_Object Qthreadp, Qmutexp;
+Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep;
 
 
 
@@ -89,36 +89,41 @@ lisp_mutex_init (lisp_mutex_t *mutex)
   sys_cond_init (&mutex->condition);
 }
 
-static void
-lisp_mutex_lock (lisp_mutex_t *mutex)
+static int
+lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
 {
   struct thread_state *self;
 
   if (mutex->owner == NULL)
     {
       mutex->owner = current_thread;
-      mutex->count = 1;
-      return;
+      mutex->count = new_count == 0 ? 1 : new_count;
+      return 0;
     }
   if (mutex->owner == current_thread)
     {
+      eassert (new_count == 0);
       ++mutex->count;
-      return;
+      return 0;
     }
 
   self = current_thread;
   self->wait_condvar = &mutex->condition;
-  while (mutex->owner != NULL && EQ (self->error_symbol, Qnil))
+  while (mutex->owner != NULL && (new_count != 0
+				  || EQ (self->error_symbol, Qnil)))
     sys_cond_wait (&mutex->condition, &global_lock);
   self->wait_condvar = NULL;
 
-  post_acquire_global_lock (self);
+  if (new_count == 0 && !NILP (self->error_symbol))
+    return 1;
 
   mutex->owner = self;
-  mutex->count = 1;
+  mutex->count = new_count == 0 ? 1 : new_count;
+
+  return 1;
 }
 
-static void
+static int
 lisp_mutex_unlock (lisp_mutex_t *mutex)
 {
   struct thread_state *self = current_thread;
@@ -127,12 +132,28 @@ lisp_mutex_unlock (lisp_mutex_t *mutex)
     error ("blah");
 
   if (--mutex->count > 0)
-    return;
+    return 0;
 
   mutex->owner = NULL;
   sys_cond_broadcast (&mutex->condition);
 
-  post_acquire_global_lock (self);
+  return 1;
+}
+
+static unsigned int
+lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
+{
+  struct thread_state *self = current_thread;
+  unsigned int result = mutex->count;
+
+  /* Ensured by condvar code.  */
+  eassert (mutex->owner == current_thread);
+
+  mutex->count = 0;
+  mutex->owner = NULL;
+  sys_cond_broadcast (&mutex->condition);
+
+  return result;
 }
 
 static void
@@ -141,6 +162,12 @@ lisp_mutex_destroy (lisp_mutex_t *mutex)
   sys_cond_destroy (&mutex->condition);
 }
 
+static int
+lisp_mutex_owned_p (lisp_mutex_t *mutex)
+{
+  return mutex->owner == current_thread;
+}
+
 
 
 DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
@@ -173,9 +200,10 @@ static void
 mutex_lock_callback (void *arg)
 {
   struct Lisp_Mutex *mutex = arg;
+  struct thread_state *self = current_thread;
 
-  /* This calls post_acquire_global_lock.  */
-  lisp_mutex_lock (&mutex->mutex);
+  if (lisp_mutex_lock (&mutex->mutex, 0))
+    post_acquire_global_lock (self);
 }
 
 static Lisp_Object
@@ -211,9 +239,10 @@ static void
 mutex_unlock_callback (void *arg)
 {
   struct Lisp_Mutex *mutex = arg;
+  struct thread_state *self = current_thread;
 
-  /* This calls post_acquire_global_lock.  */
-  lisp_mutex_unlock (&mutex->mutex);
+  if (lisp_mutex_unlock (&mutex->mutex))
+    post_acquire_global_lock (self);
 }
 
 DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
@@ -253,6 +282,154 @@ finalize_one_mutex (struct Lisp_Mutex *mutex)
 
 
 
+DEFUN ("make-condition-variable",
+       Fmake_condition_variable, Smake_condition_variable,
+       1, 2, 0,
+       doc: /* Make a condition variable.
+A condition variable provides a way for a thread to sleep while
+waiting for a state change.
+
+MUTEX is the mutex associated with this condition variable.
+NAME, if given, is the name of this condition variable.  The name is
+informational only.  */)
+  (Lisp_Object mutex, Lisp_Object name)
+{
+  struct Lisp_CondVar *condvar;
+  Lisp_Object result;
+
+  CHECK_MUTEX (mutex);
+  if (!NILP (name))
+    CHECK_STRING (name);
+
+  condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+  memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
+	  0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
+						      cond));
+  condvar->mutex = mutex;
+  condvar->name = name;
+  sys_cond_init (&condvar->cond);
+
+  XSETCONDVAR (result, condvar);
+  return result;
+}
+
+static void
+condition_wait_callback (void *arg)
+{
+  struct Lisp_CondVar *cvar = arg;
+  struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
+  struct thread_state *self = current_thread;
+  unsigned int saved_count;
+  Lisp_Object cond;
+
+  XSETCONDVAR (cond, cvar);
+  current_thread->event_object = cond;
+  saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+  /* If we were signalled while unlocking, we skip the wait, but we
+     still must reacquire our lock.  */
+  if (NILP (self->error_symbol))
+    {
+      self->wait_condvar = &cvar->cond;
+      sys_cond_wait (&cvar->cond, &global_lock);
+      self->wait_condvar = NULL;
+    }
+  lisp_mutex_lock (&mutex->mutex, saved_count);
+  current_thread->event_object = Qnil;
+  post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
+       doc: /* Wait for the condition variable to be notified.
+CONDITION is the condition variable to wait on.
+
+The mutex associated with CONDITION must be held when this is called.
+It is an error if it is not held.
+
+This atomically releases the mutex and waits for CONDITION to be
+notified.  When `condition-wait' returns, the mutex will again be
+locked by this thread.  */)
+  (Lisp_Object condition)
+{
+  struct Lisp_CondVar *cvar;
+  struct Lisp_Mutex *mutex;
+
+  CHECK_CONDVAR (condition);
+  cvar = XCONDVAR (condition);
+
+  mutex = XMUTEX (cvar->mutex);
+  if (!lisp_mutex_owned_p (&mutex->mutex))
+    error ("fixme");
+
+  flush_stack_call_func (condition_wait_callback, cvar);
+
+  return Qnil;
+}
+
+/* Used to communicate argumnets to condition_notify_callback.  */
+struct notify_args
+{
+  struct Lisp_CondVar *cvar;
+  int all;
+};
+
+static void
+condition_notify_callback (void *arg)
+{
+  struct notify_args *na = arg;
+  struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
+  struct thread_state *self = current_thread;
+  unsigned int saved_count;
+  Lisp_Object cond;
+
+  XSETCONDVAR (cond, na->cvar);
+  saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+  if (na->all)
+    sys_cond_broadcast (&na->cvar->cond);
+  else
+    sys_cond_signal (&na->cvar->cond);
+  lisp_mutex_lock (&mutex->mutex, saved_count);
+  post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
+       doc: /* Notify a condition variable.
+This wakes a thread waiting on CONDITION.
+If ALL is non-nil, all waiting threads are awoken.
+
+The mutex associated with CONDITION must be held when this is called.
+It is an error if it is not held.
+
+This atomically releases the mutex when notifying CONDITION.  When
+`condition-notify' returns, the mutex will again be locked by this
+thread.  */)
+  (Lisp_Object condition, Lisp_Object all)
+{
+  struct Lisp_CondVar *cvar;
+  struct Lisp_Mutex *mutex;
+  struct notify_args args;
+
+  CHECK_CONDVAR (condition);
+  cvar = XCONDVAR (condition);
+
+  mutex = XMUTEX (cvar->mutex);
+  if (!lisp_mutex_owned_p (&mutex->mutex))
+    error ("fixme");
+
+  args.cvar = cvar;
+  args.all = !NILP (all);
+  flush_stack_call_func (condition_notify_callback, &args);
+
+  return Qnil;
+}
+
+void
+finalize_one_condvar (struct Lisp_CondVar *condvar)
+{
+  sys_cond_destroy (&condvar->cond);
+}
+
+
+
 struct select_args
 {
   select_func *func;
@@ -555,8 +732,8 @@ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
        doc: /* Signal an error in a thread.
 This acts like `signal', but arranges for the signal to be raised
 in THREAD.  If THREAD is the current thread, acts just like `signal'.
-This will interrupt a blocked call to `mutex-lock' or`thread-join' in
-the target thread.  */)
+This will interrupt a blocked call to `mutex-lock', `condition-wait',
+or `thread-join' in the target thread.  */)
   (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
 {
   struct thread_state *tstate;
@@ -597,6 +774,7 @@ DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
 If THREAD is blocked in `thread-join' on a second thread, return that
 thread.
 If THREAD is blocked in `mutex-lock', return the mutex.
+If THREAD is blocked in `condition-wait', return the condition variable.
 Otherwise, if THREAD is not blocked, return nil.  */)
   (Lisp_Object thread)
 {
@@ -711,9 +889,14 @@ syms_of_threads (void)
   defsubr (&Smutex_lock);
   defsubr (&Smutex_unlock);
   defsubr (&Smutex_name);
+  defsubr (&Smake_condition_variable);
+  defsubr (&Scondition_wait);
+  defsubr (&Scondition_notify);
 
   Qthreadp = intern_c_string ("threadp");
   staticpro (&Qthreadp);
   Qmutexp = intern_c_string ("mutexp");
   staticpro (&Qmutexp);
+  Qcondition_variablep = intern_c_string ("condition-variablep");
+  staticpro (&Qcondition_variablep);
 }
diff --git a/src/thread.h b/src/thread.h
index 6b66ea4d1c3..989acec6afb 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -215,11 +215,27 @@ struct Lisp_Mutex
   lisp_mutex_t mutex;
 };
 
+/* A condition variable as a lisp object.  */
+struct Lisp_CondVar
+{
+  struct vectorlike_header header;
+
+  /* The associated mutex.  */
+  Lisp_Object mutex;
+
+  /* The name of the condition variable, or nil.  */
+  Lisp_Object name;
+
+  /* The lower-level condition variable object.  */
+  sys_cond_t cond;
+};
+
 extern struct thread_state *current_thread;
 
 extern void unmark_threads (void);
 extern void finalize_one_thread (struct thread_state *state);
 extern void finalize_one_mutex (struct Lisp_Mutex *);
+extern void finalize_one_condvar (struct Lisp_CondVar *);
 
 extern void init_threads_once (void);
 extern void init_threads (void);