src/thread.c

   1 /* Threading code.
   2    Copyright (C) 2012 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software: you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation, either version 3 of the License, or
   9 (at your option) any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  18
  19
  20 #include <config.h>
  21 #include <setjmp.h>
  22 #include "lisp.h"
  23 #include "character.h"
  24 #include "buffer.h"
  25 #include "process.h"
  26
  27 /* FIXME */
  28 extern void unbind_for_thread_switch (void);
  29 extern void rebind_for_thread_switch (void);
  30
  31 static struct thread_state primary_thread;
  32
  33 struct thread_state *current_thread = &primary_thread;
  34
  35 static struct thread_state *all_threads = &primary_thread;
  36
  37 sys_mutex_t global_lock;
  38
  39 Lisp_Object Qthreadp, Qmutexp;
  40
  41 \f
  42
  43 DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
  44        doc: /* FIXME */)
  45   (Lisp_Object name)
  46 {
  47   struct Lisp_Mutex *mutex;
  48   Lisp_Object result;
  49
  50   mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
  51   memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
  52           0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
  53                                                     mutex));
  54   mutex->name = name;
  55   lisp_mutex_init (&mutex->mutex);
  56
  57   XSETMUTEX (result, mutex);
  58   return result;
  59 }
  60
  61 static void
  62 mutex_lock_callback (void *arg)
  63 {
  64   struct Lisp_Mutex *mutex = arg;
  65
  66   /* This calls post_acquire_global_lock.  */
  67   lisp_mutex_lock (&mutex->mutex);
  68 }
  69
  70 static Lisp_Object
  71 do_unwind_mutex_lock (Lisp_Object ignore)
  72 {
  73   current_thread->event_object = Qnil;
  74   return Qnil;
  75 }
  76
  77 DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
  78        doc: /* FIXME */)
  79   (Lisp_Object obj)
  80 {
  81   struct Lisp_Mutex *mutex;
  82   ptrdiff_t count = SPECPDL_INDEX ();
  83
  84   CHECK_MUTEX (obj);
  85   mutex = XMUTEX (obj);
  86
  87   current_thread->event_object = obj;
  88   record_unwind_protect (do_unwind_mutex_lock, Qnil);
  89   flush_stack_call_func (mutex_lock_callback, mutex);
  90   return unbind_to (count, Qnil);
  91 }
  92
  93 static void
  94 mutex_unlock_callback (void *arg)
  95 {
  96   struct Lisp_Mutex *mutex = arg;
  97
  98   /* This calls post_acquire_global_lock.  */
  99   lisp_mutex_unlock (&mutex->mutex);
 100 }
 101
 102 DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
 103        doc: /* FIXME */)
 104   (Lisp_Object obj)
 105 {
 106   struct Lisp_Mutex *mutex;
 107
 108   CHECK_MUTEX (obj);
 109   mutex = XMUTEX (obj);
 110
 111   flush_stack_call_func (mutex_unlock_callback, mutex);
 112   return Qnil;
 113 }
 114
 115 DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
 116        doc: /* FIXME */)
 117   (Lisp_Object obj)
 118 {
 119   struct Lisp_Mutex *mutex;
 120
 121   CHECK_MUTEX (obj);
 122   mutex = XMUTEX (obj);
 123
 124   return mutex->name;
 125 }
 126
 127 void
 128 finalize_one_mutex (struct Lisp_Mutex *mutex)
 129 {
 130   lisp_mutex_destroy (&mutex->mutex);
 131 }
 132
 133 \f
 134
 135 static void
 136 release_global_lock (void)
 137 {
 138   sys_mutex_unlock (&global_lock);
 139 }
 140
 141 /* You must call this after acquiring the global lock.
 142    acquire_global_lock does it for you.  */
 143 void
 144 post_acquire_global_lock (struct thread_state *self)
 145 {
 146   Lisp_Object buffer;
 147
 148   if (self != current_thread)
 149     {
 150       unbind_for_thread_switch ();
 151       current_thread = self;
 152       rebind_for_thread_switch ();
 153     }
 154
 155   /* We need special handling to re-set the buffer.  */
 156   XSETBUFFER (buffer, self->m_current_buffer);
 157   self->m_current_buffer = 0;
 158   set_buffer_internal (XBUFFER (buffer));
 159
 160   if (!EQ (current_thread->error_symbol, Qnil))
 161     {
 162       Lisp_Object sym = current_thread->error_symbol;
 163       Lisp_Object data = current_thread->error_data;
 164
 165       current_thread->error_symbol = Qnil;
 166       current_thread->error_data = Qnil;
 167       Fsignal (sym, data);
 168     }
 169 }
 170
 171 static void
 172 acquire_global_lock (struct thread_state *self)
 173 {
 174   sys_mutex_lock (&global_lock);
 175   post_acquire_global_lock (self);
 176 }
 177
 178 \f
 179
 180 struct select_args
 181 {
 182   select_func *func;
 183   int max_fds;
 184   SELECT_TYPE *rfds;
 185   SELECT_TYPE *wfds;
 186   SELECT_TYPE *efds;
 187   EMACS_TIME *timeout;
 188   sigset_t *sigmask;
 189   int result;
 190 };
 191
 192 static void
 193 really_call_select (void *arg)
 194 {
 195   struct select_args *sa = arg;
 196   struct thread_state *self = current_thread;
 197
 198   release_global_lock ();
 199   sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
 200                            sa->timeout, sa->sigmask);
 201   acquire_global_lock (self);
 202 }
 203
 204 int
 205 thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds,
 206                SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout,
 207                sigset_t *sigmask)
 208 {
 209   struct select_args sa;
 210
 211   sa.func = func;
 212   sa.max_fds = max_fds;
 213   sa.rfds = rfds;
 214   sa.wfds = wfds;
 215   sa.efds = efds;
 216   sa.timeout = timeout;
 217   sa.sigmask = sigmask;
 218   flush_stack_call_func (really_call_select, &sa);
 219   return sa.result;
 220 }
 221
 222 \f
 223
 224 static void
 225 mark_one_thread (struct thread_state *thread)
 226 {
 227   struct specbinding *bind;
 228   struct handler *handler;
 229   Lisp_Object tem;
 230
 231   for (bind = thread->m_specpdl; bind != thread->m_specpdl_ptr; bind++)
 232     {
 233       mark_object (bind->symbol);
 234       mark_object (bind->old_value);
 235       mark_object (bind->saved_value);
 236     }
 237
 238 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
 239      || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
 240   mark_stack (thread->m_stack_bottom, thread->stack_top);
 241 #else
 242   {
 243     struct gcpro *tail;
 244     for (tail = thread->m_gcprolist; tail; tail = tail->next)
 245       for (i = 0; i < tail->nvars; i++)
 246         mark_object (tail->var[i]);
 247   }
 248
 249 #if BYTE_MARK_STACK
 250   if (thread->m_byte_stack_list)
 251     mark_byte_stack (thread->m_byte_stack_list);
 252 #endif
 253
 254   mark_catchlist (thread->m_catchlist);
 255
 256   for (handler = thread->m_handlerlist; handler; handler = handler->next)
 257     {
 258       mark_object (handler->handler);
 259       mark_object (handler->var);
 260     }
 261
 262   mark_backtrace (thread->m_backtrace_list);
 263 #endif
 264
 265   if (thread->m_current_buffer)
 266     {
 267       XSETBUFFER (tem, thread->m_current_buffer);
 268       mark_object (tem);
 269     }
 270
 271   mark_object (thread->m_last_thing_searched);
 272
 273   if (thread->m_saved_last_thing_searched)
 274     mark_object (thread->m_saved_last_thing_searched);
 275 }
 276
 277 static void
 278 mark_threads_callback (void *ignore)
 279 {
 280   struct thread_state *iter;
 281
 282   for (iter = all_threads; iter; iter = iter->next_thread)
 283     {
 284       Lisp_Object thread_obj;
 285
 286       XSETTHREAD (thread_obj, iter);
 287       mark_object (thread_obj);
 288       mark_one_thread (iter);
 289     }
 290 }
 291
 292 void
 293 mark_threads (void)
 294 {
 295   flush_stack_call_func (mark_threads_callback, NULL);
 296 }
 297
 298 void
 299 unmark_threads (void)
 300 {
 301   struct thread_state *iter;
 302
 303   for (iter = all_threads; iter; iter = iter->next_thread)
 304     if (iter->m_byte_stack_list)
 305       unmark_byte_stack (iter->m_byte_stack_list);
 306 }
 307
 308 \f
 309
 310 static void
 311 yield_callback (void *ignore)
 312 {
 313   struct thread_state *self = current_thread;
 314
 315   release_global_lock ();
 316   sys_thread_yield ();
 317   acquire_global_lock (self);
 318 }
 319
 320 DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
 321        doc: /* Yield the CPU to another thread.  */)
 322      (void)
 323 {
 324   flush_stack_call_func (yield_callback, NULL);
 325   return Qnil;
 326 }
 327
 328 static Lisp_Object
 329 invoke_thread_function (void)
 330 {
 331   Lisp_Object iter;
 332
 333   int count = SPECPDL_INDEX ();
 334
 335   Ffuncall (1, &current_thread->function);
 336   return unbind_to (count, Qnil);
 337 }
 338
 339 static Lisp_Object
 340 do_nothing (Lisp_Object whatever)
 341 {
 342   return whatever;
 343 }
 344
 345 static void *
 346 run_thread (void *state)
 347 {
 348   char stack_pos;
 349   struct thread_state *self = state;
 350   struct thread_state **iter;
 351
 352   self->m_stack_bottom = &stack_pos;
 353   self->stack_top = self->m_stack_bottom = &stack_pos;
 354   self->thread_id = sys_thread_self ();
 355
 356   acquire_global_lock (self);
 357
 358   /* It might be nice to do something with errors here.  */
 359   internal_condition_case (invoke_thread_function, Qt, do_nothing);
 360
 361   unbind_for_thread_switch ();
 362
 363   update_processes_for_thread_death (Fcurrent_thread ());
 364
 365   /* Unlink this thread from the list of all threads.  */
 366   for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
 367     ;
 368   *iter = (*iter)->next_thread;
 369
 370   self->m_last_thing_searched = Qnil;
 371   self->m_saved_last_thing_searched = Qnil;
 372   self->name = Qnil;
 373   self->function = Qnil;
 374   self->error_symbol = Qnil;
 375   self->error_data = Qnil;
 376   xfree (self->m_specpdl);
 377   self->m_specpdl = NULL;
 378   self->m_specpdl_ptr = NULL;
 379   self->m_specpdl_size = 0;
 380
 381   sys_cond_broadcast (&self->thread_condvar);
 382
 383   release_global_lock ();
 384
 385   return NULL;
 386 }
 387
 388 void
 389 finalize_one_thread (struct thread_state *state)
 390 {
 391   sys_cond_destroy (&state->thread_condvar);
 392 }
 393
 394 DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
 395        doc: /* Start a new thread and run FUNCTION in it.
 396 When the function exits, the thread dies.
 397 If NAME is given, it names the new thread.  */)
 398   (Lisp_Object function, Lisp_Object name)
 399 {
 400   sys_thread_t thr;
 401   struct thread_state *new_thread;
 402   Lisp_Object result;
 403
 404   /* Can't start a thread in temacs.  */
 405   if (!initialized)
 406     abort ();
 407
 408   new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist,
 409                                       PVEC_THREAD);
 410   memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist),
 411           0, sizeof (struct thread_state) - offsetof (struct thread_state,
 412                                                       m_gcprolist));
 413
 414   new_thread->function = function;
 415   new_thread->name = name;
 416   new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
 417   new_thread->m_saved_last_thing_searched = Qnil;
 418   new_thread->m_current_buffer = current_thread->m_current_buffer;
 419   new_thread->error_symbol = Qnil;
 420   new_thread->error_data = Qnil;
 421   new_thread->event_object = Qnil;
 422
 423   new_thread->m_specpdl_size = 50;
 424   new_thread->m_specpdl = xmalloc (new_thread->m_specpdl_size
 425                                    * sizeof (struct specbinding));
 426   new_thread->m_specpdl_ptr = new_thread->m_specpdl;
 427
 428   sys_cond_init (&new_thread->thread_condvar);
 429
 430   /* We'll need locking here eventually.  */
 431   new_thread->next_thread = all_threads;
 432   all_threads = new_thread;
 433
 434   if (! sys_thread_create (&thr, run_thread, new_thread))
 435     {
 436       /* Restore the previous situation.  */
 437       all_threads = all_threads->next_thread;
 438       error ("Could not start a new thread");
 439     }
 440
 441   /* FIXME: race here where new thread might not be filled in?  */
 442   XSETTHREAD (result, new_thread);
 443   return result;
 444 }
 445
 446 DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
 447        doc: /* Return the current thread.  */)
 448   (void)
 449 {
 450   Lisp_Object result;
 451   XSETTHREAD (result, current_thread);
 452   return result;
 453 }
 454
 455 DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
 456        doc: /* Return the name of the THREAD.
 457 The name is the same object that was passed to `make-thread'.  */)
 458      (Lisp_Object thread)
 459 {
 460   struct thread_state *tstate;
 461
 462   CHECK_THREAD (thread);
 463   tstate = XTHREAD (thread);
 464
 465   return tstate->name;
 466 }
 467
 468 static void
 469 thread_signal_callback (void *arg)
 470 {
 471   struct thread_state *tstate = arg;
 472   struct thread_state *self = current_thread;
 473
 474   sys_cond_broadcast (tstate->wait_condvar);
 475   post_acquire_global_lock (self);
 476 }
 477
 478 DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
 479        doc: /* FIXME */)
 480   (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
 481 {
 482   struct thread_state *tstate;
 483
 484   CHECK_THREAD (thread);
 485   tstate = XTHREAD (thread);
 486
 487   if (tstate == current_thread)
 488     Fsignal (error_symbol, data);
 489
 490   /* What to do if thread is already signalled?  */
 491   /* What if error_symbol is Qnil?  */
 492   tstate->error_symbol = error_symbol;
 493   tstate->error_data = data;
 494
 495   if (tstate->wait_condvar)
 496     flush_stack_call_func (thread_signal_callback, tstate);
 497
 498   return Qnil;
 499 }
 500
 501 DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
 502        doc: /* FIXME */)
 503   (Lisp_Object thread)
 504 {
 505   struct thread_state *tstate;
 506
 507   CHECK_THREAD (thread);
 508   tstate = XTHREAD (thread);
 509
 510   /* m_specpdl is set when the thread is created and cleared when the
 511      thread dies.  */
 512   return tstate->m_specpdl == NULL ? Qnil : Qt;
 513 }
 514
 515 DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
 516        doc: /* FIXME */)
 517   (Lisp_Object thread)
 518 {
 519   struct thread_state *tstate;
 520
 521   CHECK_THREAD (thread);
 522   tstate = XTHREAD (thread);
 523
 524   return tstate->event_object;
 525 }
 526
 527 static void
 528 thread_join_callback (void *arg)
 529 {
 530   struct thread_state *tstate = arg;
 531   struct thread_state *self = current_thread;
 532   Lisp_Object thread;
 533
 534   XSETTHREAD (thread, tstate);
 535   self->event_object = thread;
 536   self->wait_condvar = &tstate->thread_condvar;
 537   while (tstate->m_specpdl != NULL && EQ (self->error_symbol, Qnil))
 538     sys_cond_wait (self->wait_condvar, &global_lock);
 539
 540   self->wait_condvar = NULL;
 541   self->event_object = Qnil;
 542   post_acquire_global_lock (self);
 543 }
 544
 545 DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
 546        doc: /* FIXME */)
 547   (Lisp_Object thread)
 548 {
 549   struct thread_state *tstate;
 550
 551   CHECK_THREAD (thread);
 552   tstate = XTHREAD (thread);
 553
 554   if (tstate->m_specpdl != NULL)
 555     flush_stack_call_func (thread_join_callback, tstate);
 556
 557   return Qnil;
 558 }
 559
 560 DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
 561        doc: /* Return a list of all threads.  */)
 562      (void)
 563 {
 564   Lisp_Object result = Qnil;
 565   struct thread_state *iter;
 566
 567   for (iter = all_threads; iter; iter = iter->next_thread)
 568     {
 569       Lisp_Object thread;
 570
 571       XSETTHREAD (thread, iter);
 572       result = Fcons (thread, result);
 573     }
 574
 575   return result;
 576 }
 577
 578 \f
 579
 580 static void
 581 init_primary_thread (void)
 582 {
 583   primary_thread.header.size
 584     = PSEUDOVECSIZE (struct thread_state, m_gcprolist);
 585   XSETPVECTYPE (&primary_thread, PVEC_THREAD);
 586   primary_thread.m_last_thing_searched = Qnil;
 587   primary_thread.m_saved_last_thing_searched = Qnil;
 588   primary_thread.name = Qnil;
 589   primary_thread.function = Qnil;
 590   primary_thread.error_symbol = Qnil;
 591   primary_thread.error_data = Qnil;
 592   primary_thread.event_object = Qnil;
 593
 594   sys_cond_init (&primary_thread.thread_condvar);
 595 }
 596
 597 void
 598 init_threads_once (void)
 599 {
 600   init_primary_thread ();
 601 }
 602
 603 void
 604 init_threads (void)
 605 {
 606   init_primary_thread ();
 607
 608   sys_mutex_init (&global_lock);
 609   sys_mutex_lock (&global_lock);
 610 }
 611
 612 void
 613 syms_of_threads (void)
 614 {
 615   defsubr (&Sthread_yield);
 616   defsubr (&Smake_thread);
 617   defsubr (&Scurrent_thread);
 618   defsubr (&Sthread_name);
 619   defsubr (&Sthread_signal);
 620   defsubr (&Sthread_alive_p);
 621   defsubr (&Sthread_join);
 622   defsubr (&Sthread_blocker);
 623   defsubr (&Sall_threads);
 624   defsubr (&Smake_mutex);
 625   defsubr (&Smutex_lock);
 626   defsubr (&Smutex_unlock);
 627   defsubr (&Smutex_name);
 628
 629   Qthreadp = intern_c_string ("threadp");
 630   staticpro (&Qthreadp);
 631   Qmutexp = intern_c_string ("mutexp");
 632   staticpro (&Qmutexp);
 633 }