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