src/thread.c

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