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