This supplies the mutex implementation for Emacs Lisp.

A lisp mutex is implemented using a condition variable, so that we can
interrupt a mutex-lock operation by calling thread-signal on the
blocking thread.  I did things this way because pthread_mutex_lock
can't readily be interrupted.

6 files changed, 117 insertions, 3 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 69742a325d1..80d22d61d66 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3104,6 +3104,8 @@ sweep_vectors (void)
 
               if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
                 finalize_one_thread ((struct thread_state *) vector);
+              else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
+                finalize_one_mutex ((struct Lisp_Mutex *) vector);
 
               next = ADVANCE (vector, nbytes);
 
diff --git a/src/data.c b/src/data.c
index fd2194fe1ae..b47c2d12aff 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;
+Lisp_Object Qthread, Qmutex;
 
 Lisp_Object Qinteractive_form;
 
@@ -214,6 +214,8 @@ for example, (type-of 1) returns `integer'.  */)
         return Qfont_object;
       if (THREADP (object))
         return Qthread;
+      if (MUTEXP (object))
+        return Qmutex;
       return Qvector;
 
     case Lisp_Float:
@@ -471,6 +473,15 @@ DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
     return Qnil;
 }
 
+DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0,
+       doc: /* Return t if OBJECT is a mutex.  */)
+  (Lisp_Object object)
+{
+  if (MUTEXP (object))
+    return Qt;
+  else
+    return Qnil;
+}
 
 /* Extract and set components of lists */
 
@@ -3105,6 +3116,7 @@ syms_of_data (void)
   DEFSYM (Qbool_vector, "bool-vector");
   DEFSYM (Qhash_table, "hash-table");
   DEFSYM (Qthread, "thread");
+  DEFSYM (Qmutex, "mutex");
   /* Used by Fgarbage_collect.  */
   DEFSYM (Qinterval, "interval");
   DEFSYM (Qmisc, "misc");
@@ -3148,6 +3160,7 @@ syms_of_data (void)
   defsubr (&Sbyte_code_function_p);
   defsubr (&Schar_or_string_p);
   defsubr (&Sthreadp);
+  defsubr (&Smutexp);
   defsubr (&Scar);
   defsubr (&Scdr);
   defsubr (&Scar_safe);
diff --git a/src/lisp.h b/src/lisp.h
index 52a523259db..f0c831852f6 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -366,6 +366,7 @@ enum pvec_type
   PVEC_SUBR,
   PVEC_OTHER,
   PVEC_THREAD,
+  PVEC_MUTEX,
   /* 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
@@ -555,6 +556,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
                          ((struct Lisp_Bool_Vector *) \
                           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))
 
 /* Construct a Lisp_Object from a value or address.  */
 
@@ -606,6 +608,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
 #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
 #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))
 
 /* Convenience macros for dealing with Lisp arrays.  */
 
@@ -1705,6 +1708,7 @@ typedef struct {
 #define BOOL_VECTOR_P(x) PSEUDOVECTORP (x, PVEC_BOOL_VECTOR)
 #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME)
 #define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD)
+#define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX)
 
 /* Test for image (image . spec)  */
 #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage))
@@ -1826,6 +1830,9 @@ typedef struct {
 #define CHECK_THREAD(x) \
   CHECK_TYPE (THREADP (x), Qthreadp, x)
 
+#define CHECK_MUTEX(x) \
+  CHECK_TYPE (MUTEXP (x), Qmutexp, 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) \
@@ -2448,7 +2455,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;
+extern Lisp_Object Qthreadp, Qmutexp;
 
 extern Lisp_Object Qcdr;
 
diff --git a/src/print.c b/src/print.c
index 4537521b9fa..42e7241ecba 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1955,6 +1955,14 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag
             }
           PRINTCHAR ('>');
         }
+      else if (MUTEXP (obj))
+        {
+          int len;
+          strout ("#<mutex ", -1, -1, printcharfun);
+          len = sprintf (buf, "%p", XMUTEX (obj));
+          strout (buf, len, len, printcharfun);
+          PRINTCHAR ('>');
+        }
       else
         {
           ptrdiff_t size = ASIZE (obj);
diff --git a/src/thread.c b/src/thread.c
index 5da2e10f1ae..80557e5d5ee 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -35,7 +35,83 @@ static struct thread_state *all_threads = &primary_thread;
 
 sys_mutex_t global_lock;
 
-Lisp_Object Qthreadp;
+Lisp_Object Qthreadp, Qmutexp;
+
+
+
+struct Lisp_Mutex
+{
+  struct vectorlike_header header;
+
+  lisp_mutex_t mutex;
+};
+
+DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 0, 0,
+       doc: /* FIXME */)
+  (void)
+{
+  struct Lisp_Mutex *mutex;
+  Lisp_Object result;
+
+  mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+  memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
+          0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
+                                                    mutex));
+  lisp_mutex_init (&mutex->mutex);
+
+  XSETMUTEX (result, mutex);
+  return result;
+}
+
+static void
+mutex_lock_callback (void *arg)
+{
+  struct Lisp_Mutex *mutex = arg;
+
+  /* This calls post_acquire_global_lock.  */
+  lisp_mutex_lock (&mutex->mutex);
+}
+
+DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+       doc: /* FIXME */)
+  (Lisp_Object obj)
+{
+  struct Lisp_Mutex *mutex;
+
+  CHECK_MUTEX (obj);
+  mutex = XMUTEX (obj);
+
+  flush_stack_call_func (mutex_lock_callback, mutex);
+  return Qnil;
+}
+
+static void
+mutex_unlock_callback (void *arg)
+{
+  struct Lisp_Mutex *mutex = arg;
+
+  /* This calls post_acquire_global_lock.  */
+  lisp_mutex_unlock (&mutex->mutex);
+}
+
+DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+       doc: /* FIXME */)
+  (Lisp_Object obj)
+{
+  struct Lisp_Mutex *mutex;
+
+  CHECK_MUTEX (obj);
+  mutex = XMUTEX (obj);
+
+  flush_stack_call_func (mutex_unlock_callback, mutex);
+  return Qnil;
+}
+
+void
+finalize_one_mutex (struct Lisp_Mutex *mutex)
+{
+  lisp_mutex_destroy (&mutex->mutex);
+}
 
 
 
@@ -463,7 +539,12 @@ syms_of_threads (void)
   defsubr (&Sthread_alive_p);
   defsubr (&Sthread_join);
   defsubr (&Sall_threads);
+  defsubr (&Smake_mutex);
+  defsubr (&Smutex_lock);
+  defsubr (&Smutex_unlock);
 
   Qthreadp = intern_c_string ("threadp");
   staticpro (&Qthreadp);
+  Qmutexp = intern_c_string ("mutexp");
+  staticpro (&Qmutexp);
 }
diff --git a/src/thread.h b/src/thread.h
index 3b533316817..d3ec38a22b9 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -168,6 +168,8 @@ struct thread_state
   struct thread_state *next_thread;
 };
 
+struct Lisp_Mutex;
+
 extern struct thread_state *current_thread;
 
 extern sys_mutex_t global_lock;
@@ -175,6 +177,7 @@ extern void post_acquire_global_lock (struct thread_state *);
 
 extern void unmark_threads (void);
 extern void finalize_one_thread (struct thread_state *state);
+extern void finalize_one_mutex (struct Lisp_Mutex *);
 
 extern void init_threads_once (void);
 extern void init_threads (void);