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 || abort_on_gc;
 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 other_threads_p () ? Qt : 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   /* We need special handling to set the initial buffer.  Our parent
 186      thread is very likely to be using this same buffer so we will
 187      typically wait for the parent thread to release it first.  */
 188   XSETBUFFER (buffer, self->m_current_buffer);
 189   GCPRO1 (buffer);
 190   self->m_current_buffer = 0;
 191   set_buffer_internal (XBUFFER (buffer));
 192
 193   pthread_mutex_lock (&global_lock);
 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, 2, 0,
 212        doc: /* Start a new thread and run FUNCTION in it.
 213 When the function exits, the thread dies.  When NOLOCK is no-nil the thread
 214 does not try to get a lock on the current buffer.  */)
 215      (function, nolock)
 216      Lisp_Object function;
 217      Lisp_Object nolock;
 218 {
 219   char stack_pos;
 220   pthread_t thr;
 221   struct thread_state *new_thread;
 222   struct specbinding *p;
 223
 224   /* Can't start a thread in temacs.  */
 225   if (!initialized)
 226     abort ();
 227
 228   new_thread = (struct thread_state *) allocate_pseudovector (VECSIZE (struct thread_state),
 229                                                               2, PVEC_THREAD);
 230   memset ((char *) new_thread + OFFSETOF (struct thread_state, m_gcprolist),
 231           0, sizeof (struct thread_state) - OFFSETOF (struct thread_state,
 232                                                       m_gcprolist));
 233
 234   new_thread->func = function;
 235   new_thread->nolock = !EQ (nolock, Qnil);
 236   new_thread->initial_specpdl = Qnil;
 237   new_thread->m_current_buffer = current_thread->m_current_buffer;
 238   new_thread->stack_bottom = &stack_pos;
 239
 240   for (p = specpdl; p != specpdl_ptr; ++p)
 241     {
 242       if (!p->func)
 243         {
 244           Lisp_Object sym = p->symbol;
 245           if (!SYMBOLP (sym))
 246             sym = XCAR (sym);
 247           new_thread->initial_specpdl
 248             = Fcons (Fcons (sym, find_symbol_value (sym)),
 249                      new_thread->initial_specpdl);
 250         }
 251     }
 252
 253   /* We'll need locking here.  */
 254   new_thread->next_thread = all_threads;
 255   all_threads = new_thread;
 256
 257   if (pthread_create (&thr, NULL, run_thread, new_thread))
 258     {
 259       /* Restore the previous situation.  */
 260       all_threads = all_threads->next_thread;
 261     }
 262
 263   return Qnil;
 264 }
 265
 266 /* Get the current thread as a lisp object.  */
 267 Lisp_Object
 268 get_current_thread (void)
 269 {
 270   Lisp_Object result;
 271   XSETTHREAD (result, current_thread);
 272   return result;
 273 }
 274
 275 /* Get the main thread as a lisp object.  */
 276 Lisp_Object
 277 get_main_thread (void)
 278 {
 279   Lisp_Object result;
 280   XSETTHREAD (result, &primary_thread);
 281   return result;
 282 }
 283
 284 /* Is the current an user thread.  */
 285 int
 286 user_thread_p (void)
 287 {
 288   struct thread_state *it = all_threads;
 289   pthread_t self = pthread_self ();
 290   do
 291     {
 292       if (it->pthread_id == self)
 293         return 1;
 294     }
 295   while (it = it->next_thread);
 296
 297   return 0;
 298 }
 299
 300 DEFUN ("inhibit-yield", Finhibit_yield, Sinhibit_yield, 1, 1, 0,
 301        doc: /* Inhibit the yield function.  */)
 302      (val)
 303      Lisp_Object val;
 304 {
 305   if (!EQ (val, Qnil))
 306     inhibit_yield_counter++;
 307   else if (inhibit_yield_counter > 0)
 308     inhibit_yield_counter--;
 309
 310   return Qnil;
 311 }
 312
 313
 314 int
 315 other_threads_p (void)
 316 {
 317   return all_threads->next_thread != NULL;
 318 }
 319
 320 void
 321 init_threads (void)
 322 {
 323   pthread_mutex_init (&global_lock, NULL);
 324   pthread_mutex_lock (&global_lock);
 325   primary_thread.pthread_id = pthread_self ();
 326   primary_thread.nolock = 0;
 327 }
 328
 329 void
 330 syms_of_threads (void)
 331 {
 332   defsubr (&Srun_in_thread);
 333   defsubr (&Syield);
 334   defsubr (&Sinhibit_yield);
 335 }