This adds most of the thread features visible to emacs lisp.

I roughly followed the Bordeaux threads API:

http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation

... but not identically.  In particular I chose not to implement
interrupt-thread or destroy-thread, but instead a thread-signalling
approach.

I'm still undecided about *default-special-bindings* (which I did not
implement).  I think it would be more emacs-like to capture the let
bindings at make-thread time, but IIRC Stefan didn't like this idea
the first time around.

There are one or two semantics issues pointed out in the patch where I
could use some advice.

src/alloc.c

@@ -3102,6 +3102,9 @@ sweep_vectors (void)
 	      ptrdiff_t nbytes = PSEUDOVECTOR_NBYTES (vector);
 	      ptrdiff_t total_bytes = nbytes;
 
+	      if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
+		finalize_one_thread ((struct thread_state *) vector);
+
 	      next = ADVANCE (vector, nbytes);
 
 	      /* While NEXT is not marked, try to coalesce with VECTOR,

src/data.c

@@ -94,6 +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 Qinteractive_form;
 
@@ -211,6 +212,8 @@ for example, (type-of 1) returns `integer'.  */)
 	return Qfont_entity;
       if (FONT_OBJECT_P (object))
 	return Qfont_object;
+      if (THREADP (object))
+	return Qthread;
       return Qvector;
 
     case Lisp_Float:
@@ -458,6 +461,16 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
   return Qnil;
 }
 
+DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
+       doc: /* Return t if OBJECT is a thread.  */)
+  (Lisp_Object object)
+{
+  if (THREADP (object))
+    return Qt;
+  else
+    return Qnil;
+}
+
 
 /* Extract and set components of lists */
 
@@ -3091,6 +3104,7 @@ syms_of_data (void)
   DEFSYM (Qchar_table, "char-table");
   DEFSYM (Qbool_vector, "bool-vector");
   DEFSYM (Qhash_table, "hash-table");
+  DEFSYM (Qthread, "thread");
   /* Used by Fgarbage_collect.  */
   DEFSYM (Qinterval, "interval");
   DEFSYM (Qmisc, "misc");
@@ -3133,6 +3147,7 @@ syms_of_data (void)
   defsubr (&Ssubrp);
   defsubr (&Sbyte_code_function_p);
   defsubr (&Schar_or_string_p);
+  defsubr (&Sthreadp);
   defsubr (&Scar);
   defsubr (&Scdr);
   defsubr (&Scar_safe);

src/emacs.c

@@ -1552,6 +1552,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
       syms_of_ntterm ();
 #endif /* WINDOWSNT */
 
+      syms_of_threads ();
+
       keys_of_casefiddle ();
       keys_of_cmds ();
       keys_of_buffer ();

src/lisp.h

@@ -554,6 +554,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
 #define XBOOL_VECTOR(a) (eassert (BOOL_VECTOR_P (a)), \
 			 ((struct Lisp_Bool_Vector *) \
 			  XUNTAG (a, Lisp_Vectorlike)))
+#define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a))
 
 /* Construct a Lisp_Object from a value or address.  */
 
@@ -1822,6 +1823,9 @@ typedef struct {
 #define CHECK_OVERLAY(x) \
   CHECK_TYPE (OVERLAYP (x), Qoverlayp, x)
 
+#define CHECK_THREAD(x) \
+  CHECK_TYPE (THREADP (x), Qthreadp, 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) \
@@ -2444,6 +2448,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 Qcdr;
 

src/systhread.c

@@ -105,19 +105,12 @@ lisp_mutex_lock (lisp_mutex_t *mutex)
     }
 
   self = current_thread;
-  while (mutex->owner != NULL /* && EQ (self->error_symbol, Qnil) */)
+  self->wait_condvar = &mutex->condition;
+  while (mutex->owner != NULL && EQ (self->error_symbol, Qnil))
     pthread_cond_wait (&mutex->condition, &global_lock);
+  self->wait_condvar = NULL;
 
-#if 0
-  if (!EQ (self->error_symbol, Qnil))
-    {
-      Lisp_Object error_symbol = self->error_symbol;
-      Lisp_Object data = self->error_data;
-      self->error_symbol = Qnil;
-      self->error_data = Qnil;
-      Fsignal (error_symbol, error_data);
-    }
-#endif
+  post_acquire_global_lock (self);
 
   mutex->owner = self;
   mutex->count = 1;

src/thread.c

@@ -20,15 +20,70 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #include <config.h>
 #include <setjmp.h>
 #include "lisp.h"
+#include "character.h"
+#include "buffer.h"
 
-struct thread_state the_only_thread;
+/* FIXME */
+extern void unbind_for_thread_switch (void);
+extern void rebind_for_thread_switch (void);
 
-struct thread_state *current_thread = &the_only_thread;
+static struct thread_state primary_thread;
 
-struct thread_state *all_threads = &the_only_thread;
+struct thread_state *current_thread = &primary_thread;
+
+static struct thread_state *all_threads = &primary_thread;
 
 sys_mutex_t global_lock;
 
+Lisp_Object Qthreadp;
+
+
+
+static void
+release_global_lock (void)
+{
+  sys_mutex_unlock (&global_lock);
+}
+
+/* You must call this after acquiring the global lock.
+   acquire_global_lock does it for you.  */
+void
+post_acquire_global_lock (struct thread_state *self)
+{
+  Lisp_Object buffer;
+
+  if (self != current_thread)
+    {
+      unbind_for_thread_switch ();
+      current_thread = self;
+      rebind_for_thread_switch ();
+    }
+
+  /* We need special handling to re-set the buffer.  */
+  XSETBUFFER (buffer, self->m_current_buffer);
+  self->m_current_buffer = 0;
+  set_buffer_internal (XBUFFER (buffer));
+
+  if (!EQ (current_thread->error_symbol, Qnil))
+    {
+      Lisp_Object sym = current_thread->error_symbol;
+      Lisp_Object data = current_thread->error_data;
+
+      current_thread->error_symbol = Qnil;
+      current_thread->error_data = Qnil;
+      Fsignal (sym, data);
+    }
+}
+
+static void
+acquire_global_lock (struct thread_state *self)
+{
+  sys_mutex_lock (&global_lock);
+  post_acquire_global_lock (self);
+}
+
+
+
 static void
 mark_one_thread (struct thread_state *thread)
 {
@@ -113,19 +168,302 @@ unmark_threads (void)
       unmark_byte_stack (iter->m_byte_stack_list);
 }
 
+
+
+static void
+yield_callback (void *ignore)
+{
+  struct thread_state *self = current_thread;
+
+  release_global_lock ();
+  sys_thread_yield ();
+  acquire_global_lock (self);
+}
+
+DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
+       doc: /* Yield the CPU to another thread.  */)
+     (void)
+{
+  flush_stack_call_func (yield_callback, NULL);
+  return Qnil;
+}
+
+static Lisp_Object
+invoke_thread_function (void)
+{
+  Lisp_Object iter;
+
+  int count = SPECPDL_INDEX ();
+
+  Ffuncall (1, &current_thread->function);
+  return unbind_to (count, Qnil);
+}
+
+static Lisp_Object
+do_nothing (Lisp_Object whatever)
+{
+  return whatever;
+}
+
+static void *
+run_thread (void *state)
+{
+  char stack_pos;
+  struct thread_state *self = state;
+  struct thread_state **iter;
+
+  self->m_stack_bottom = &stack_pos;
+  self->stack_top = self->m_stack_bottom = &stack_pos;
+  self->thread_id = sys_thread_self ();
+
+  acquire_global_lock (self);
+
+  /* It might be nice to do something with errors here.  */
+  internal_condition_case (invoke_thread_function, Qt, do_nothing);
+
+  unbind_for_thread_switch ();
+
+  /* Unlink this thread from the list of all threads.  */
+  for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+    ;
+  *iter = (*iter)->next_thread;
+
+  self->m_last_thing_searched = Qnil;
+  self->m_saved_last_thing_searched = Qnil;
+  self->name = Qnil;
+  self->function = Qnil;
+  self->error_symbol = Qnil;
+  self->error_data = Qnil;
+  xfree (self->m_specpdl);
+  self->m_specpdl = NULL;
+  self->m_specpdl_ptr = NULL;
+  self->m_specpdl_size = 0;
+
+  sys_cond_broadcast (&self->thread_condvar);
+
+  release_global_lock ();
+
+  return NULL;
+}
+
+void
+finalize_one_thread (struct thread_state *state)
+{
+  sys_cond_destroy (&state->thread_condvar);
+}
+
+DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
+       doc: /* Start a new thread and run FUNCTION in it.
+When the function exits, the thread dies.
+If NAME is given, it names the new thread.  */)
+  (Lisp_Object function, Lisp_Object name)
+{
+  sys_thread_t thr;
+  struct thread_state *new_thread;
+  Lisp_Object result;
+
+  /* Can't start a thread in temacs.  */
+  if (!initialized)
+    abort ();
+
+  new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist,
+				      PVEC_THREAD);
+  memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist),
+	  0, sizeof (struct thread_state) - offsetof (struct thread_state,
+						      m_gcprolist));
+
+  new_thread->function = function;
+  new_thread->name = name;
+  new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
+  new_thread->m_saved_last_thing_searched = Qnil;
+  new_thread->m_current_buffer = current_thread->m_current_buffer;
+  new_thread->error_symbol = Qnil;
+  new_thread->error_data = Qnil;
+
+  new_thread->m_specpdl_size = 50;
+  new_thread->m_specpdl = xmalloc (new_thread->m_specpdl_size
+				   * sizeof (struct specbinding));
+  new_thread->m_specpdl_ptr = new_thread->m_specpdl;
+
+  sys_cond_init (&new_thread->thread_condvar);
+
+  /* We'll need locking here eventually.  */
+  new_thread->next_thread = all_threads;
+  all_threads = new_thread;
+
+  if (! sys_thread_create (&thr, run_thread, new_thread))
+    {
+      /* Restore the previous situation.  */
+      all_threads = all_threads->next_thread;
+      error ("Could not start a new thread");
+    }
+
+  /* FIXME: race here where new thread might not be filled in?  */
+  XSETTHREAD (result, new_thread);
+  return result;
+}
+
+DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
+       doc: /* Return the current thread.  */)
+  (void)
+{
+  Lisp_Object result;
+  XSETTHREAD (result, current_thread);
+  return result;
+}
+
+DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
+       doc: /* Return the name of the THREAD.
+The name is the same object that was passed to `make-thread'.  */)
+     (Lisp_Object thread)
+{
+  struct thread_state *tstate;
+
+  CHECK_THREAD (thread);
+  tstate = XTHREAD (thread);
+
+  return tstate->name;
+}
+
+static void
+thread_signal_callback (void *arg)
+{
+  struct thread_state *tstate = arg;
+  struct thread_state *self = current_thread;
+
+  sys_cond_broadcast (tstate->wait_condvar);
+  post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
+       doc: /* FIXME */)
+  (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
+{
+  struct thread_state *tstate;
+
+  CHECK_THREAD (thread);
+  tstate = XTHREAD (thread);
+
+  if (tstate == current_thread)
+    Fsignal (error_symbol, data);
+
+  /* What to do if thread is already signalled?  */
+  /* What if error_symbol is Qnil?  */
+  tstate->error_symbol = error_symbol;
+  tstate->error_data = data;
+
+  if (tstate->wait_condvar)
+    flush_stack_call_func (thread_signal_callback, tstate);
+
+  return Qnil;
+}
+
+DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
+       doc: /* FIXME */)
+  (Lisp_Object thread)
+{
+  struct thread_state *tstate;
+
+  CHECK_THREAD (thread);
+  tstate = XTHREAD (thread);
+
+  /* m_specpdl is set when the thread is created and cleared when the
+     thread dies.  */
+  return tstate->m_specpdl == NULL ? Qnil : Qt;
+}
+
+static void
+thread_join_callback (void *arg)
+{
+  struct thread_state *tstate = arg;
+  struct thread_state *self = current_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;
+  post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
+       doc: /* FIXME */)
+  (Lisp_Object thread)
+{
+  struct thread_state *tstate;
+
+  CHECK_THREAD (thread);
+  tstate = XTHREAD (thread);
+
+  if (tstate->m_specpdl != NULL)
+    flush_stack_call_func (thread_join_callback, tstate);
+
+  return Qnil;
+}
+
+DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
+       doc: /* Return a list of all threads.  */)
+     (void)
+{
+  Lisp_Object result = Qnil;
+  struct thread_state *iter;
+
+  for (iter = all_threads; iter; iter = iter->next_thread)
+    {
+      Lisp_Object thread;
+
+      XSETTHREAD (thread, iter);
+      result = Fcons (thread, result);
+    }
+
+  return result;
+}
+
+
+
+static void
+init_primary_thread (void)
+{
+  primary_thread.header.size
+    = PSEUDOVECSIZE (struct thread_state, m_gcprolist);
+  XSETPVECTYPE (&primary_thread, PVEC_THREAD);
+  primary_thread.m_last_thing_searched = Qnil;
+  primary_thread.m_saved_last_thing_searched = Qnil;
+  primary_thread.name = Qnil;
+  primary_thread.function = Qnil;
+  primary_thread.error_symbol = Qnil;
+  primary_thread.error_data = Qnil;
+
+  sys_cond_init (&primary_thread.thread_condvar);
+}
+
 void
 init_threads_once (void)
 {
-  the_only_thread.header.size
-    = PSEUDOVECSIZE (struct thread_state, m_gcprolist);
-  XSETPVECTYPE (&the_only_thread, PVEC_THREAD);
-  the_only_thread.m_last_thing_searched = Qnil;
-  the_only_thread.m_saved_last_thing_searched = Qnil;
+  init_primary_thread ();
 }
 
 void
 init_threads (void)
 {
+  init_primary_thread ();
+
   sys_mutex_init (&global_lock);
   sys_mutex_lock (&global_lock);
 }
+
+void
+syms_of_threads (void)
+{
+  defsubr (&Sthread_yield);
+  defsubr (&Smake_thread);
+  defsubr (&Scurrent_thread);
+  defsubr (&Sthread_name);
+  defsubr (&Sthread_signal);
+  defsubr (&Sthread_alive_p);
+  defsubr (&Sthread_join);
+  defsubr (&Sall_threads);
+
+  Qthreadp = intern_c_string ("threadp");
+  staticpro (&Qthreadp);
+}

src/thread.h

@@ -34,6 +34,16 @@ struct thread_state
   Lisp_Object m_saved_last_thing_searched;
 #define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
 
+  /* The thread's name.  */
+  Lisp_Object name;
+
+  /* The thread's function.  */
+  Lisp_Object function;
+
+  /* If non-nil, this thread has been signalled.  */
+  Lisp_Object error_symbol;
+  Lisp_Object error_data;
+
   /* m_gcprolist must be the first non-lisp field.  */
   /* Recording what needs to be marked for gc.  */
   struct gcpro *m_gcprolist;
@@ -142,6 +152,18 @@ struct thread_state
   /*re_char*/ unsigned char *m_whitespace_regexp;
 #define whitespace_regexp (current_thread->m_whitespace_regexp)
 
+  /* The OS identifier for this thread.  */
+  sys_thread_t thread_id;
+
+  /* The condition variable for this thread.  This is associated with
+     the global lock.  This thread broadcasts to it when it exits.  */
+  sys_cond_t thread_condvar;
+
+  /* This thread might be waiting for some condition.  If so, this
+     points to the condition.  If the thread is interrupted, the
+     interrupter should broadcast to this condition.  */
+  sys_cond_t *wait_condvar;
+
   /* Threads are kept on a linked list.  */
   struct thread_state *next_thread;
 };
@@ -149,10 +171,13 @@ struct thread_state
 extern struct thread_state *current_thread;
 
 extern sys_mutex_t global_lock;
+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 init_threads_once (void);
 extern void init_threads (void);
+extern void syms_of_threads (void);
 
 #endif /* THREAD_H */