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