src/thread.c

   1
   2 #include <config.h>
   3 #include "lisp.h"
   4 #include <pthread.h>
   5
   6 void mark_byte_stack P_ ((struct byte_stack *));
   7 void mark_backtrace P_ ((struct backtrace *));
   8 void mark_catchlist P_ ((struct catchtag *));
   9 void mark_stack P_ ((char *, char *));
  10 void flush_stack_call_func P_ ((void (*) (char *, void *), void *));
  11
  12
  13 static struct thread_state primary_thread;
  14
  15 static struct thread_state *all_threads = &primary_thread;
  16
  17 __thread struct thread_state *current_thread = &primary_thread;
  18
  19 pthread_mutex_t global_lock;
  20
  21 static void
  22 mark_one_thread (struct thread_state *thread)
  23 {
  24   register struct specbinding *bind;
  25   struct handler *handler;
  26   Lisp_Object tem;
  27
  28   for (bind = thread->m_specpdl; bind != thread->m_specpdl_ptr; bind++)
  29     {
  30       mark_object (bind->symbol);
  31       mark_object (bind->old_value);
  32     }
  33
  34 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
  35      || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
  36   mark_stack (thread->stack_bottom, thread->stack_top);
  37 #else
  38   {
  39     register struct gcpro *tail;
  40     for (tail = thread->m_gcprolist; tail; tail = tail->next)
  41       for (i = 0; i < tail->nvars; i++)
  42         mark_object (tail->var[i]);
  43   }
  44 #endif
  45
  46   mark_byte_stack (thread->m_byte_stack_list);
  47
  48   mark_catchlist (thread->m_catchlist);
  49
  50   for (handler = thread->m_handlerlist; handler; handler = handler->next)
  51     {
  52       mark_object (handler->handler);
  53       mark_object (handler->var);
  54     }
  55
  56   mark_backtrace (thread->m_backtrace_list);
  57
  58   if (thread->m_current_buffer)
  59     {
  60       XSETBUFFER (tem, thread->m_current_buffer);
  61       mark_object (tem);
  62     }
  63 }
  64
  65 static void
  66 mark_threads_callback (char *end, void *ignore)
  67 {
  68   struct thread_state *iter;
  69
  70   current_thread->stack_top = end;
  71   for (iter = all_threads; iter; iter = iter->next_thread)
  72     {
  73       Lisp_Object thread_obj;
  74       XSETTHREAD (thread_obj, iter);
  75       mark_object (thread_obj);
  76       mark_one_thread (iter);
  77     }
  78 }
  79
  80 void
  81 mark_threads (void)
  82 {
  83   flush_stack_call_func (mark_threads_callback, NULL);
  84 }
  85
  86 void
  87 unmark_threads (void)
  88 {
  89   struct thread_state *iter;
  90
  91   for (iter = all_threads; iter; iter = iter->next_thread)
  92     unmark_byte_stack (iter->m_byte_stack_list);
  93 }
  94
  95 static void
  96 thread_yield_callback (char *end, void *ignore)
  97 {
  98   current_thread->stack_top = end;
  99   pthread_mutex_unlock (&global_lock);
 100   sched_yield ();
 101   pthread_mutex_lock (&global_lock);
 102 }
 103
 104 void
 105 thread_yield (void)
 106 {
 107   /* Note: currently it is safe to check this here, but eventually it
 108      will require a lock to ensure non-racy operation.  */
 109   /* Only yield if there is another thread to yield to.  */
 110   if (all_threads->next_thread)
 111     flush_stack_call_func (thread_yield_callback, NULL);
 112 }
 113
 114 DEFUN ("yield", Fyield, Syield, 0, 0, 0,
 115        doc: /* Yield to the next thread.  */)
 116      (void)
 117 {
 118   thread_yield ();
 119 }
 120
 121 static Lisp_Object
 122 invoke_thread_function (void)
 123 {
 124   Lisp_Object iter;
 125
 126   int count = SPECPDL_INDEX ();
 127
 128   /* Set up specpdl.  */
 129   for (iter = current_thread->initial_specpdl;
 130        !EQ (iter, Qnil);
 131        iter = XCDR (iter))
 132     {
 133       /* We may bind a variable twice -- but it doesn't matter because
 134          there is no way to undo these bindings without exiting the
 135          thread.  */
 136       specbind (XCAR (XCAR (iter)), XCDR (XCAR (iter)));
 137     }
 138   current_thread->initial_specpdl = Qnil;
 139
 140   Ffuncall (1, &current_thread->func);
 141   return unbind_to (count, Qnil);
 142 }
 143
 144 static Lisp_Object
 145 do_nothing (Lisp_Object whatever)
 146 {
 147   return whatever;
 148 }
 149
 150 static void *
 151 run_thread (void *state)
 152 {
 153   char stack_pos;
 154   struct thread_state *self = state;
 155   struct thread_state **iter;
 156   struct gcpro gcpro1;
 157   Lisp_Object buffer;
 158
 159   self->stack_top = self->stack_bottom = &stack_pos;
 160
 161   self->m_specpdl_size = 50;
 162   self->m_specpdl = xmalloc (self->m_specpdl_size
 163                              * sizeof (struct specbinding));
 164   self->m_specpdl_ptr = self->m_specpdl;
 165
 166   /* Thread-local assignment.  */
 167   current_thread = self;
 168
 169   pthread_mutex_lock (&global_lock);
 170
 171   /* We need special handling to set the initial buffer.  Our parent
 172      thread is very likely to be using this same buffer so we will
 173      typically wait for the parent thread to release it first.  */
 174   XSETBUFFER (buffer, self->m_current_buffer);
 175   GCPRO1 (buffer);
 176   self->m_current_buffer = 0;
 177   set_buffer_internal (XBUFFER (buffer));
 178
 179   /* It might be nice to do something with errors here.  */
 180   internal_condition_case (invoke_thread_function, Qt, do_nothing);
 181
 182   /* Unlink this thread from the list of all threads.  */
 183   for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
 184     ;
 185   *iter = (*iter)->next_thread;
 186
 187   release_buffer (self);
 188
 189   xfree (self->m_specpdl);
 190   xfree (self);
 191
 192   pthread_mutex_unlock (&global_lock);
 193
 194   return NULL;
 195 }
 196
 197 DEFUN ("run-in-thread", Frun_in_thread, Srun_in_thread, 1, 1, 0,
 198        doc: /* Start a new thread and run FUNCTION in it.
 199 When the function exits, the thread dies.  */)
 200      (function)
 201      Lisp_Object function;
 202 {
 203   pthread_t thr;
 204   struct thread_state *new_thread;
 205   struct specbinding *p;
 206
 207   /* Can't start a thread in temacs.  */
 208   if (!initialized)
 209     abort ();
 210
 211   new_thread = (struct thread_state *) allocate_pseudovector (VECSIZE (struct thread_state),
 212                                                               2, PVEC_THREAD);
 213   memset ((char *) new_thread + OFFSETOF (struct thread_state, m_gcprolist),
 214           0, sizeof (struct thread_state) - OFFSETOF (struct thread_state,
 215                                                       m_gcprolist));
 216
 217   new_thread->func = function;
 218   new_thread->initial_specpdl = Qnil;
 219   new_thread->m_current_buffer = current_thread->m_current_buffer;
 220
 221   for (p = specpdl; p != specpdl_ptr; ++p)
 222     {
 223       if (!p->func)
 224         {
 225           Lisp_Object sym = p->symbol;
 226           if (!SYMBOLP (sym))
 227             sym = XCAR (sym);
 228           new_thread->initial_specpdl
 229             = Fcons (Fcons (sym, find_symbol_value (sym)),
 230                      new_thread->initial_specpdl);
 231         }
 232     }
 233
 234   /* We'll need locking here.  */
 235   new_thread->next_thread = all_threads;
 236   all_threads = new_thread;
 237
 238   /* FIXME check result */
 239   pthread_create (&thr, NULL, run_thread, new_thread);
 240
 241   return Qnil;
 242 }
 243
 244 /* Get the current thread as a lisp object.  */
 245 Lisp_Object
 246 get_current_thread (void)
 247 {
 248   Lisp_Object result;
 249   XSETTHREAD (result, current_thread);
 250   return result;
 251 }
 252
 253 /* Get the main thread as a lisp object.  */
 254 Lisp_Object
 255 get_main_thread (void)
 256 {
 257   Lisp_Object result;
 258   XSETTHREAD (result, &primary_thread);
 259   return result;
 260 }
 261
 262 int
 263 other_threads_p (void)
 264 {
 265   return all_threads->next_thread != NULL;
 266 }
 267
 268 void
 269 init_threads (void)
 270 {
 271   pthread_mutex_init (&global_lock, NULL);
 272   pthread_mutex_lock (&global_lock);
 273 }
 274
 275 void
 276 syms_of_threads (void)
 277 {
 278   defsubr (&Srun_in_thread);
 279   defsubr (&Syield);
 280 }