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