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