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_bottom_variable;
 151   struct thread_state *self = state;
 152   struct thread_state **iter;
 153   struct gcpro gcpro1;
 154   Lisp_Object buffer;
 155
 156   self->stack_bottom = &stack_bottom_variable;
 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   xfree (self->m_specpdl);
 185   xfree (self);
 186
 187   pthread_mutex_unlock (&global_lock);
 188
 189   return NULL;
 190 }
 191
 192 DEFUN ("run-in-thread", Frun_in_thread, Srun_in_thread, 1, 1, 0,
 193        doc: /* Start a new thread and run FUNCTION in it.
 194 When the function exits, the thread dies.  */)
 195      (function)
 196      Lisp_Object function;
 197 {
 198   pthread_t thr;
 199   struct thread_state *new_thread;
 200   struct specbinding *p;
 201
 202   /* Can't start a thread in temacs.  */
 203   if (!initialized)
 204     abort ();
 205
 206   new_thread = (struct thread_state *) allocate_pseudovector (VECSIZE (struct thread_state),
 207                                                               2, PVEC_THREAD);
 208   memset (new_thread, OFFSETOF (struct thread_state,
 209                                 m_gcprolist),
 210           sizeof (struct thread_state) - OFFSETOF (struct thread_state,
 211                                                    m_gcprolist));
 212
 213   new_thread->func = function;
 214   new_thread->initial_specpdl = Qnil;
 215
 216   for (p = specpdl; p != specpdl_ptr; ++p)
 217     {
 218       if (p->func)
 219         {
 220           Lisp_Object sym = p->symbol;
 221           if (!SYMBOLP (sym))
 222             sym = XCAR (sym);
 223           new_thread->initial_specpdl
 224             = Fcons (Fcons (sym, find_symbol_value (sym)),
 225                      new_thread->initial_specpdl);
 226         }
 227     }
 228
 229   /* We'll need locking here.  */
 230   new_thread->next_thread = all_threads;
 231   all_threads = new_thread;
 232
 233   /* FIXME check result */
 234   pthread_create (&thr, NULL, run_thread, new_thread);
 235
 236   return Qnil;
 237 }
 238
 239 /* Get the current thread as a lisp object.  */
 240 Lisp_Object
 241 get_current_thread (void)
 242 {
 243   Lisp_Object result;
 244   XSETTHREAD (result, current_thread);
 245   return result;
 246 }
 247
 248 /* Get the main thread as a lisp object.  */
 249 Lisp_Object
 250 get_main_thread (void)
 251 {
 252   Lisp_Object result;
 253   XSETTHREAD (result, &primary_thread);
 254   return result;
 255 }
 256
 257 int
 258 other_threads_p (void)
 259 {
 260   return all_threads->next_thread != NULL;
 261 }
 262
 263 void
 264 init_threads (void)
 265 {
 266   pthread_mutex_init (&global_lock, NULL);
 267   pthread_mutex_lock (&global_lock);
 268 }
 269
 270 void
 271 syms_of_threads (void)
 272 {
 273   defsubr (&Srun_in_thread);
 274   defsubr (&Syield);
 275 }