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   return Qnil;
 127 }
 128
 129 static Lisp_Object
 130 invoke_thread_function (void)
 131 {
 132   Lisp_Object iter;
 133
 134   int count = SPECPDL_INDEX ();
 135
 136   /* Set up specpdl.  */
 137   for (iter = current_thread->initial_specpdl;
 138        !EQ (iter, Qnil);
 139        iter = XCDR (iter))
 140     {
 141       /* We may bind a variable twice -- but it doesn't matter because
 142          there is no way to undo these bindings without exiting the
 143          thread.  */
 144       specbind (XCAR (XCAR (iter)), XCDR (XCAR (iter)));
 145     }
 146   current_thread->initial_specpdl = Qnil;
 147
 148   Feval (current_thread->func);
 149   return unbind_to (count, Qnil);
 150 }
 151
 152 static Lisp_Object
 153 do_nothing (Lisp_Object whatever)
 154 {
 155   return whatever;
 156 }
 157
 158 static void *
 159 run_thread (void *state)
 160 {
 161   struct thread_state *self = state;
 162   struct thread_state **iter;
 163   struct gcpro gcpro1;
 164   Lisp_Object buffer;
 165   char stack_pos;
 166
 167   self->stack_top = self->stack_bottom = &stack_pos;
 168
 169   self->m_specpdl_size = 50;
 170   self->m_specpdl = xmalloc (self->m_specpdl_size
 171                              * sizeof (struct specbinding));
 172   self->m_specpdl_ptr = self->m_specpdl;
 173   self->pthread_id = pthread_self ();
 174
 175   /* Thread-local assignment.  */
 176   current_thread = self;
 177
 178   pthread_mutex_lock (&global_lock);
 179
 180   /* We need special handling to set the initial buffer.  Our parent
 181      thread is very likely to be using this same buffer so we will
 182      typically wait for the parent thread to release it first.  */
 183   XSETBUFFER (buffer, self->m_current_buffer);
 184   GCPRO1 (buffer);
 185   self->m_current_buffer = 0;
 186   set_buffer_internal (XBUFFER (buffer));
 187
 188   /* It might be nice to do something with errors here.  */
 189   internal_condition_case (invoke_thread_function, Qt, do_nothing);
 190
 191   /* Unlink this thread from the list of all threads.  */
 192   for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
 193     ;
 194   *iter = (*iter)->next_thread;
 195
 196   release_buffer (self);
 197   xfree (self->m_specpdl);
 198
 199   pthread_mutex_unlock (&global_lock);
 200
 201   return NULL;
 202 }
 203
 204 DEFUN ("run-in-thread", Frun_in_thread, Srun_in_thread, 1, 1, 0,
 205        doc: /* Start a new thread and run FUNCTION in it.
 206 When the function exits, the thread dies.  */)
 207      (function)
 208      Lisp_Object function;
 209 {
 210   char stack_pos;
 211   pthread_t thr;
 212   struct thread_state *new_thread;
 213   struct specbinding *p;
 214
 215   /* Can't start a thread in temacs.  */
 216   if (!initialized)
 217     abort ();
 218
 219   new_thread = (struct thread_state *) allocate_pseudovector (VECSIZE (struct thread_state),
 220                                                               2, PVEC_THREAD);
 221   memset ((char *) new_thread + OFFSETOF (struct thread_state, m_gcprolist),
 222           0, sizeof (struct thread_state) - OFFSETOF (struct thread_state,
 223                                                       m_gcprolist));
 224
 225   new_thread->func = function;
 226   new_thread->initial_specpdl = Qnil;
 227   new_thread->m_current_buffer = current_thread->m_current_buffer;
 228   new_thread->stack_bottom = &stack_pos;
 229
 230   for (p = specpdl; p != specpdl_ptr; ++p)
 231     {
 232       if (!p->func)
 233         {
 234           Lisp_Object sym = p->symbol;
 235           if (!SYMBOLP (sym))
 236             sym = XCAR (sym);
 237           new_thread->initial_specpdl
 238             = Fcons (Fcons (sym, find_symbol_value (sym)),
 239                      new_thread->initial_specpdl);
 240         }
 241     }
 242
 243   /* We'll need locking here.  */
 244   new_thread->next_thread = all_threads;
 245   all_threads = new_thread;
 246
 247   if (pthread_create (&thr, NULL, run_thread, new_thread))
 248     {
 249       /* Restore the previous situation.  */
 250       all_threads = all_threads->next_thread;
 251     }
 252
 253   return Qnil;
 254 }
 255
 256 /* Get the current thread as a lisp object.  */
 257 Lisp_Object
 258 get_current_thread (void)
 259 {
 260   Lisp_Object result;
 261   XSETTHREAD (result, current_thread);
 262   return result;
 263 }
 264
 265 /* Get the main thread as a lisp object.  */
 266 Lisp_Object
 267 get_main_thread (void)
 268 {
 269   Lisp_Object result;
 270   XSETTHREAD (result, &primary_thread);
 271   return result;
 272 }
 273
 274 /* Is the current an user thread.  */
 275 int
 276 user_thread_p (void)
 277 {
 278   struct thread_state *it = all_threads;
 279   pthread_t self = pthread_self ();
 280   do
 281     {
 282       if (it->pthread_id == self)
 283         return 1;
 284     }
 285   while (it = it->next_thread);
 286
 287   return 0;
 288 }
 289
 290 DEFUN ("inhibit-yield", Finhibit_yield, Sinhibit_yield, 1, 1, 0,
 291        doc: /* Inhibit the yield function. */)
 292      (val)
 293      Lisp_Object val;
 294 {
 295   if (!EQ (val, Qnil))
 296     inhibit_yield_counter++;
 297   else if (inhibit_yield_counter > 0)
 298     inhibit_yield_counter--;
 299
 300   return Qnil;
 301 }
 302
 303
 304 int
 305 other_threads_p (void)
 306 {
 307   return all_threads->next_thread != NULL;
 308 }
 309
 310 void
 311 init_threads (void)
 312 {
 313   pthread_mutex_init (&global_lock, NULL);
 314   pthread_mutex_lock (&global_lock);
 315   primary_thread.pthread_id = pthread_self ();
 316 }
 317
 318 void
 319 syms_of_threads (void)
 320 {
 321   defsubr (&Srun_in_thread);
 322   defsubr (&Syield);
 323   defsubr (&Sinhibit_yield);
 324 }