src/thread.c

   1 /* Threading code.
   2 Copyright (C) 2012-2016 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 #include "coding.h"
  27
  28 static struct thread_state primary_thread;
  29
  30 struct thread_state *current_thread = &primary_thread;
  31
  32 static struct thread_state *all_threads = &primary_thread;
  33
  34 static sys_mutex_t global_lock;
  35
  36 extern int poll_suppress_count;
  37 extern volatile int interrupt_input_blocked;
  38
  39 \f
  40
  41 /* m_specpdl is set when the thread is created and cleared when the
  42    thread dies.  */
  43 #define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
  44
  45 \f
  46
  47 static void
  48 release_global_lock (void)
  49 {
  50   sys_mutex_unlock (&global_lock);
  51 }
  52
  53 /* You must call this after acquiring the global lock.
  54    acquire_global_lock does it for you.  */
  55 static void
  56 post_acquire_global_lock (struct thread_state *self)
  57 {
  58   struct thread_state *prev_thread = current_thread;
  59
  60   /* Do this early on, so that code below could signal errors (e.g.,
  61      unbind_for_thread_switch might) correctly, because we are already
  62      running in the context of the thread pointed by SELF.  */
  63   current_thread = self;
  64
  65   if (prev_thread != current_thread)
  66     {
  67       /* PREV_THREAD is NULL if the previously current thread
  68          exited.  In this case, there is no reason to unbind, and
  69          trying will crash.  */
  70       if (prev_thread != NULL)
  71         unbind_for_thread_switch (prev_thread);
  72       rebind_for_thread_switch ();
  73
  74        /* Set the new thread's current buffer.  This needs to be done
  75           even if it is the same buffer as that of the previous thread,
  76           because of thread-local bindings.  */
  77       set_buffer_internal_2 (current_buffer);
  78     }
  79
  80   if (!NILP (current_thread->error_symbol))
  81     {
  82       Lisp_Object sym = current_thread->error_symbol;
  83       Lisp_Object data = current_thread->error_data;
  84
  85       current_thread->error_symbol = Qnil;
  86       current_thread->error_data = Qnil;
  87       Fsignal (sym, data);
  88     }
  89 }
  90
  91 static void
  92 acquire_global_lock (struct thread_state *self)
  93 {
  94   sys_mutex_lock (&global_lock);
  95   post_acquire_global_lock (self);
  96 }
  97
  98 \f
  99
 100 static void
 101 lisp_mutex_init (lisp_mutex_t *mutex)
 102 {
 103   mutex->owner = NULL;
 104   mutex->count = 0;
 105   sys_cond_init (&mutex->condition);
 106 }
 107
 108 static int
 109 lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
 110 {
 111   struct thread_state *self;
 112
 113   if (mutex->owner == NULL)
 114     {
 115       mutex->owner = current_thread;
 116       mutex->count = new_count == 0 ? 1 : new_count;
 117       return 0;
 118     }
 119   if (mutex->owner == current_thread)
 120     {
 121       eassert (new_count == 0);
 122       ++mutex->count;
 123       return 0;
 124     }
 125
 126   self = current_thread;
 127   self->wait_condvar = &mutex->condition;
 128   while (mutex->owner != NULL && (new_count != 0
 129                                   || NILP (self->error_symbol)))
 130     sys_cond_wait (&mutex->condition, &global_lock);
 131   self->wait_condvar = NULL;
 132
 133   if (new_count == 0 && !NILP (self->error_symbol))
 134     return 1;
 135
 136   mutex->owner = self;
 137   mutex->count = new_count == 0 ? 1 : new_count;
 138
 139   return 1;
 140 }
 141
 142 static int
 143 lisp_mutex_unlock (lisp_mutex_t *mutex)
 144 {
 145   if (mutex->owner != current_thread)
 146     error ("Cannot unlock mutex owned by another thread");
 147
 148   if (--mutex->count > 0)
 149     return 0;
 150
 151   mutex->owner = NULL;
 152   sys_cond_broadcast (&mutex->condition);
 153
 154   return 1;
 155 }
 156
 157 static unsigned int
 158 lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
 159 {
 160   unsigned int result = mutex->count;
 161
 162   /* Ensured by condvar code.  */
 163   eassert (mutex->owner == current_thread);
 164
 165   mutex->count = 0;
 166   mutex->owner = NULL;
 167   sys_cond_broadcast (&mutex->condition);
 168
 169   return result;
 170 }
 171
 172 static void
 173 lisp_mutex_destroy (lisp_mutex_t *mutex)
 174 {
 175   sys_cond_destroy (&mutex->condition);
 176 }
 177
 178 static int
 179 lisp_mutex_owned_p (lisp_mutex_t *mutex)
 180 {
 181   return mutex->owner == current_thread;
 182 }
 183
 184 \f
 185
 186 DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
 187        doc: /* Create a mutex.
 188 A mutex provides a synchronization point for threads.
 189 Only one thread at a time can hold a mutex.  Other threads attempting
 190 to acquire it will block until the mutex is available.
 191
 192 A thread can acquire a mutex any number of times.
 193
 194 NAME, if given, is used as the name of the mutex.  The name is
 195 informational only.  */)
 196   (Lisp_Object name)
 197 {
 198   struct Lisp_Mutex *mutex;
 199   Lisp_Object result;
 200
 201   if (!NILP (name))
 202     CHECK_STRING (name);
 203
 204   mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
 205   memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
 206           0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
 207                                                     mutex));
 208   mutex->name = name;
 209   lisp_mutex_init (&mutex->mutex);
 210
 211   XSETMUTEX (result, mutex);
 212   return result;
 213 }
 214
 215 static void
 216 mutex_lock_callback (void *arg)
 217 {
 218   struct Lisp_Mutex *mutex = arg;
 219   struct thread_state *self = current_thread;
 220
 221   if (lisp_mutex_lock (&mutex->mutex, 0))
 222     post_acquire_global_lock (self);
 223 }
 224
 225 static void
 226 do_unwind_mutex_lock (void)
 227 {
 228   current_thread->event_object = Qnil;
 229 }
 230
 231 DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
 232        doc: /* Acquire a mutex.
 233 If the current thread already owns MUTEX, increment the count and
 234 return.
 235 Otherwise, if no thread owns MUTEX, make the current thread own it.
 236 Otherwise, block until MUTEX is available, or until the current thread
 237 is signalled using `thread-signal'.
 238 Note that calls to `mutex-lock' and `mutex-unlock' must be paired.  */)
 239   (Lisp_Object mutex)
 240 {
 241   struct Lisp_Mutex *lmutex;
 242   ptrdiff_t count = SPECPDL_INDEX ();
 243
 244   CHECK_MUTEX (mutex);
 245   lmutex = XMUTEX (mutex);
 246
 247   current_thread->event_object = mutex;
 248   record_unwind_protect_void (do_unwind_mutex_lock);
 249   flush_stack_call_func (mutex_lock_callback, lmutex);
 250   return unbind_to (count, Qnil);
 251 }
 252
 253 static void
 254 mutex_unlock_callback (void *arg)
 255 {
 256   struct Lisp_Mutex *mutex = arg;
 257   struct thread_state *self = current_thread;
 258
 259   if (lisp_mutex_unlock (&mutex->mutex))
 260     post_acquire_global_lock (self);
 261 }
 262
 263 DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
 264        doc: /* Release the mutex.
 265 If this thread does not own MUTEX, signal an error.
 266 Otherwise, decrement the mutex's count.  If the count is zero,
 267 release MUTEX.   */)
 268   (Lisp_Object mutex)
 269 {
 270   struct Lisp_Mutex *lmutex;
 271
 272   CHECK_MUTEX (mutex);
 273   lmutex = XMUTEX (mutex);
 274
 275   flush_stack_call_func (mutex_unlock_callback, lmutex);
 276   return Qnil;
 277 }
 278
 279 DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
 280        doc: /* Return the name of MUTEX.
 281 If no name was given when MUTEX was created, return nil.  */)
 282   (Lisp_Object mutex)
 283 {
 284   struct Lisp_Mutex *lmutex;
 285
 286   CHECK_MUTEX (mutex);
 287   lmutex = XMUTEX (mutex);
 288
 289   return lmutex->name;
 290 }
 291
 292 void
 293 finalize_one_mutex (struct Lisp_Mutex *mutex)
 294 {
 295   lisp_mutex_destroy (&mutex->mutex);
 296 }
 297
 298 \f
 299
 300 DEFUN ("make-condition-variable",
 301        Fmake_condition_variable, Smake_condition_variable,
 302        1, 2, 0,
 303        doc: /* Make a condition variable associated with MUTEX.
 304 A condition variable provides a way for a thread to sleep while
 305 waiting for a state change.
 306
 307 MUTEX is the mutex associated with this condition variable.
 308 NAME, if given, is the name of this condition variable.  The name is
 309 informational only.  */)
 310   (Lisp_Object mutex, Lisp_Object name)
 311 {
 312   struct Lisp_CondVar *condvar;
 313   Lisp_Object result;
 314
 315   CHECK_MUTEX (mutex);
 316   if (!NILP (name))
 317     CHECK_STRING (name);
 318
 319   condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
 320   memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
 321           0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
 322                                                       cond));
 323   condvar->mutex = mutex;
 324   condvar->name = name;
 325   sys_cond_init (&condvar->cond);
 326
 327   XSETCONDVAR (result, condvar);
 328   return result;
 329 }
 330
 331 static void
 332 condition_wait_callback (void *arg)
 333 {
 334   struct Lisp_CondVar *cvar = arg;
 335   struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
 336   struct thread_state *self = current_thread;
 337   unsigned int saved_count;
 338   Lisp_Object cond;
 339
 340   XSETCONDVAR (cond, cvar);
 341   self->event_object = cond;
 342   saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
 343   /* If we were signalled while unlocking, we skip the wait, but we
 344      still must reacquire our lock.  */
 345   if (NILP (self->error_symbol))
 346     {
 347       self->wait_condvar = &cvar->cond;
 348       sys_cond_wait (&cvar->cond, &global_lock);
 349       self->wait_condvar = NULL;
 350     }
 351   lisp_mutex_lock (&mutex->mutex, saved_count);
 352   self->event_object = Qnil;
 353   post_acquire_global_lock (self);
 354 }
 355
 356 DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
 357        doc: /* Wait for the condition variable COND to be notified.
 358 COND is the condition variable to wait on.
 359
 360 The mutex associated with COND must be held when this is called.
 361 It is an error if it is not held.
 362
 363 This releases the mutex and waits for COND to be notified or for
 364 this thread to be signalled with `thread-signal'.  When
 365 `condition-wait' returns, COND's mutex will again be locked by
 366 this thread.  */)
 367   (Lisp_Object cond)
 368 {
 369   struct Lisp_CondVar *cvar;
 370   struct Lisp_Mutex *mutex;
 371
 372   CHECK_CONDVAR (cond);
 373   cvar = XCONDVAR (cond);
 374
 375   mutex = XMUTEX (cvar->mutex);
 376   if (!lisp_mutex_owned_p (&mutex->mutex))
 377     error ("Condition variable's mutex is not held by current thread");
 378
 379   flush_stack_call_func (condition_wait_callback, cvar);
 380
 381   return Qnil;
 382 }
 383
 384 /* Used to communicate argumnets to condition_notify_callback.  */
 385 struct notify_args
 386 {
 387   struct Lisp_CondVar *cvar;
 388   int all;
 389 };
 390
 391 static void
 392 condition_notify_callback (void *arg)
 393 {
 394   struct notify_args *na = arg;
 395   struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
 396   struct thread_state *self = current_thread;
 397   unsigned int saved_count;
 398   Lisp_Object cond;
 399
 400   XSETCONDVAR (cond, na->cvar);
 401   saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
 402   if (na->all)
 403     sys_cond_broadcast (&na->cvar->cond);
 404   else
 405     sys_cond_signal (&na->cvar->cond);
 406   lisp_mutex_lock (&mutex->mutex, saved_count);
 407   post_acquire_global_lock (self);
 408 }
 409
 410 DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
 411        doc: /* Notify COND, a condition variable.
 412 This wakes a thread waiting on COND.
 413 If ALL is non-nil, all waiting threads are awoken.
 414
 415 The mutex associated with COND must be held when this is called.
 416 It is an error if it is not held.
 417
 418 This releases COND's mutex when notifying COND.  When
 419 `condition-notify' returns, the mutex will again be locked by this
 420 thread.  */)
 421   (Lisp_Object cond, Lisp_Object all)
 422 {
 423   struct Lisp_CondVar *cvar;
 424   struct Lisp_Mutex *mutex;
 425   struct notify_args args;
 426
 427   CHECK_CONDVAR (cond);
 428   cvar = XCONDVAR (cond);
 429
 430   mutex = XMUTEX (cvar->mutex);
 431   if (!lisp_mutex_owned_p (&mutex->mutex))
 432     error ("Condition variable's mutex is not held by current thread");
 433
 434   args.cvar = cvar;
 435   args.all = !NILP (all);
 436   flush_stack_call_func (condition_notify_callback, &args);
 437
 438   return Qnil;
 439 }
 440
 441 DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
 442        doc: /* Return the mutex associated with condition variable COND.  */)
 443   (Lisp_Object cond)
 444 {
 445   struct Lisp_CondVar *cvar;
 446
 447   CHECK_CONDVAR (cond);
 448   cvar = XCONDVAR (cond);
 449
 450   return cvar->mutex;
 451 }
 452
 453 DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
 454        doc: /* Return the name of condition variable COND.
 455 If no name was given when COND was created, return nil.  */)
 456   (Lisp_Object cond)
 457 {
 458   struct Lisp_CondVar *cvar;
 459
 460   CHECK_CONDVAR (cond);
 461   cvar = XCONDVAR (cond);
 462
 463   return cvar->name;
 464 }
 465
 466 void
 467 finalize_one_condvar (struct Lisp_CondVar *condvar)
 468 {
 469   sys_cond_destroy (&condvar->cond);
 470 }
 471
 472 \f
 473
 474 struct select_args
 475 {
 476   select_func *func;
 477   int max_fds;
 478   fd_set *rfds;
 479   fd_set *wfds;
 480   fd_set *efds;
 481   struct timespec *timeout;
 482   sigset_t *sigmask;
 483   int result;
 484 };
 485
 486 static void
 487 really_call_select (void *arg)
 488 {
 489   struct select_args *sa = arg;
 490   struct thread_state *self = current_thread;
 491
 492   release_global_lock ();
 493   sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
 494                            sa->timeout, sa->sigmask);
 495   acquire_global_lock (self);
 496 }
 497
 498 int
 499 thread_select (select_func *func, int max_fds, fd_set *rfds,
 500                fd_set *wfds, fd_set *efds, struct timespec *timeout,
 501                sigset_t *sigmask)
 502 {
 503   struct select_args sa;
 504
 505   sa.func = func;
 506   sa.max_fds = max_fds;
 507   sa.rfds = rfds;
 508   sa.wfds = wfds;
 509   sa.efds = efds;
 510   sa.timeout = timeout;
 511   sa.sigmask = sigmask;
 512   flush_stack_call_func (really_call_select, &sa);
 513   return sa.result;
 514 }
 515
 516 \f
 517
 518 static void
 519 mark_one_thread (struct thread_state *thread)
 520 {
 521   struct handler *handler;
 522   Lisp_Object tem;
 523
 524   mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
 525
 526   mark_stack (thread->m_stack_bottom, thread->stack_top);
 527
 528   for (handler = thread->m_handlerlist; handler; handler = handler->next)
 529     {
 530       mark_object (handler->tag_or_ch);
 531       mark_object (handler->val);
 532     }
 533
 534   if (thread->m_current_buffer)
 535     {
 536       XSETBUFFER (tem, thread->m_current_buffer);
 537       mark_object (tem);
 538     }
 539
 540   mark_object (thread->m_last_thing_searched);
 541
 542   if (!NILP (thread->m_saved_last_thing_searched))
 543     mark_object (thread->m_saved_last_thing_searched);
 544 }
 545
 546 static void
 547 mark_threads_callback (void *ignore)
 548 {
 549   struct thread_state *iter;
 550
 551   for (iter = all_threads; iter; iter = iter->next_thread)
 552     {
 553       Lisp_Object thread_obj;
 554
 555       XSETTHREAD (thread_obj, iter);
 556       mark_object (thread_obj);
 557       mark_one_thread (iter);
 558     }
 559 }
 560
 561 void
 562 mark_threads (void)
 563 {
 564   flush_stack_call_func (mark_threads_callback, NULL);
 565 }
 566
 567 void
 568 unmark_threads (void)
 569 {
 570   struct thread_state *iter;
 571
 572   for (iter = all_threads; iter; iter = iter->next_thread)
 573     if (iter->m_byte_stack_list)
 574       relocate_byte_stack (iter->m_byte_stack_list);
 575 }
 576
 577 \f
 578
 579 static void
 580 yield_callback (void *ignore)
 581 {
 582   struct thread_state *self = current_thread;
 583
 584   release_global_lock ();
 585   sys_thread_yield ();
 586   acquire_global_lock (self);
 587 }
 588
 589 DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
 590        doc: /* Yield the CPU to another thread.  */)
 591      (void)
 592 {
 593   flush_stack_call_func (yield_callback, NULL);
 594   return Qnil;
 595 }
 596
 597 static Lisp_Object
 598 invoke_thread_function (void)
 599 {
 600   int count = SPECPDL_INDEX ();
 601
 602   Ffuncall (1, &current_thread->function);
 603   return unbind_to (count, Qnil);
 604 }
 605
 606 static Lisp_Object
 607 do_nothing (Lisp_Object whatever)
 608 {
 609   return whatever;
 610 }
 611
 612 static void *
 613 run_thread (void *state)
 614 {
 615   char stack_pos;
 616   struct thread_state *self = state;
 617   struct thread_state **iter;
 618
 619   self->m_stack_bottom = &stack_pos;
 620   self->stack_top = &stack_pos;
 621   self->thread_id = sys_thread_self ();
 622
 623   acquire_global_lock (self);
 624
 625   { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
 626        This is important since handlerlist->nextfree holds the freelist
 627        which would otherwise leak every time we unwind back to top-level.   */
 628     handlerlist_sentinel = xzalloc (sizeof (struct handler));
 629     handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
 630     struct handler *c = push_handler (Qunbound, CATCHER);
 631     eassert (c == handlerlist_sentinel);
 632     handlerlist_sentinel->nextfree = NULL;
 633     handlerlist_sentinel->next = NULL;
 634   }
 635
 636   /* It might be nice to do something with errors here.  */
 637   internal_condition_case (invoke_thread_function, Qt, do_nothing);
 638
 639   update_processes_for_thread_death (Fcurrent_thread ());
 640
 641   xfree (self->m_specpdl - 1);
 642   self->m_specpdl = NULL;
 643   self->m_specpdl_ptr = NULL;
 644   self->m_specpdl_size = 0;
 645
 646   {
 647     struct handler *c, *c_next;
 648     for (c = handlerlist_sentinel; c; c = c_next)
 649       {
 650         c_next = c->nextfree;
 651         xfree (c);
 652       }
 653   }
 654
 655   current_thread = NULL;
 656   sys_cond_broadcast (&self->thread_condvar);
 657
 658   /* Unlink this thread from the list of all threads.  Note that we
 659      have to do this very late, after broadcasting our death.
 660      Otherwise the GC may decide to reap the thread_state object,
 661      leading to crashes.  */
 662   for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
 663     ;
 664   *iter = (*iter)->next_thread;
 665
 666   release_global_lock ();
 667
 668   return NULL;
 669 }
 670
 671 void
 672 finalize_one_thread (struct thread_state *state)
 673 {
 674   sys_cond_destroy (&state->thread_condvar);
 675 }
 676
 677 DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
 678        doc: /* Start a new thread and run FUNCTION in it.
 679 When the function exits, the thread dies.
 680 If NAME is given, it must be a string; it names the new thread.  */)
 681   (Lisp_Object function, Lisp_Object name)
 682 {
 683   sys_thread_t thr;
 684   struct thread_state *new_thread;
 685   Lisp_Object result;
 686   const char *c_name = NULL;
 687   size_t offset = offsetof (struct thread_state, m_byte_stack_list);
 688
 689   /* Can't start a thread in temacs.  */
 690   if (!initialized)
 691     emacs_abort ();
 692
 693   if (!NILP (name))
 694     CHECK_STRING (name);
 695
 696   new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
 697                                       PVEC_THREAD);
 698   memset ((char *) new_thread + offset, 0,
 699           sizeof (struct thread_state) - offset);
 700
 701   new_thread->function = function;
 702   new_thread->name = name;
 703   new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
 704   new_thread->m_saved_last_thing_searched = Qnil;
 705   new_thread->m_current_buffer = current_thread->m_current_buffer;
 706   new_thread->error_symbol = Qnil;
 707   new_thread->error_data = Qnil;
 708   new_thread->event_object = Qnil;
 709
 710   new_thread->m_specpdl_size = 50;
 711   new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
 712                                    * sizeof (union specbinding));
 713   /* Skip the dummy entry.  */
 714   ++new_thread->m_specpdl;
 715   new_thread->m_specpdl_ptr = new_thread->m_specpdl;
 716
 717   sys_cond_init (&new_thread->thread_condvar);
 718
 719   /* We'll need locking here eventually.  */
 720   new_thread->next_thread = all_threads;
 721   all_threads = new_thread;
 722
 723   if (!NILP (name))
 724     c_name = SSDATA (ENCODE_UTF_8 (name));
 725
 726   if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
 727     {
 728       /* Restore the previous situation.  */
 729       all_threads = all_threads->next_thread;
 730       error ("Could not start a new thread");
 731     }
 732
 733   /* FIXME: race here where new thread might not be filled in?  */
 734   XSETTHREAD (result, new_thread);
 735   return result;
 736 }
 737
 738 DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
 739        doc: /* Return the current thread.  */)
 740   (void)
 741 {
 742   Lisp_Object result;
 743   XSETTHREAD (result, current_thread);
 744   return result;
 745 }
 746
 747 DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
 748        doc: /* Return the name of the THREAD.
 749 The name is the same object that was passed to `make-thread'.  */)
 750      (Lisp_Object thread)
 751 {
 752   struct thread_state *tstate;
 753
 754   CHECK_THREAD (thread);
 755   tstate = XTHREAD (thread);
 756
 757   return tstate->name;
 758 }
 759
 760 static void
 761 thread_signal_callback (void *arg)
 762 {
 763   struct thread_state *tstate = arg;
 764   struct thread_state *self = current_thread;
 765
 766   sys_cond_broadcast (tstate->wait_condvar);
 767   post_acquire_global_lock (self);
 768 }
 769
 770 DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
 771        doc: /* Signal an error in a thread.
 772 This acts like `signal', but arranges for the signal to be raised
 773 in THREAD.  If THREAD is the current thread, acts just like `signal'.
 774 This will interrupt a blocked call to `mutex-lock', `condition-wait',
 775 or `thread-join' in the target thread.  */)
 776   (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
 777 {
 778   struct thread_state *tstate;
 779
 780   CHECK_THREAD (thread);
 781   tstate = XTHREAD (thread);
 782
 783   if (tstate == current_thread)
 784     Fsignal (error_symbol, data);
 785
 786   /* What to do if thread is already signalled?  */
 787   /* What if error_symbol is Qnil?  */
 788   tstate->error_symbol = error_symbol;
 789   tstate->error_data = data;
 790
 791   if (tstate->wait_condvar)
 792     flush_stack_call_func (thread_signal_callback, tstate);
 793
 794   return Qnil;
 795 }
 796
 797 DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
 798        doc: /* Return t if THREAD is alive, or nil if it has exited.  */)
 799   (Lisp_Object thread)
 800 {
 801   struct thread_state *tstate;
 802
 803   CHECK_THREAD (thread);
 804   tstate = XTHREAD (thread);
 805
 806   return thread_alive_p (tstate) ? Qt : Qnil;
 807 }
 808
 809 DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
 810        doc: /* Return the object that THREAD is blocking on.
 811 If THREAD is blocked in `thread-join' on a second thread, return that
 812 thread.
 813 If THREAD is blocked in `mutex-lock', return the mutex.
 814 If THREAD is blocked in `condition-wait', return the condition variable.
 815 Otherwise, if THREAD is not blocked, return nil.  */)
 816   (Lisp_Object thread)
 817 {
 818   struct thread_state *tstate;
 819
 820   CHECK_THREAD (thread);
 821   tstate = XTHREAD (thread);
 822
 823   return tstate->event_object;
 824 }
 825
 826 static void
 827 thread_join_callback (void *arg)
 828 {
 829   struct thread_state *tstate = arg;
 830   struct thread_state *self = current_thread;
 831   Lisp_Object thread;
 832
 833   XSETTHREAD (thread, tstate);
 834   self->event_object = thread;
 835   self->wait_condvar = &tstate->thread_condvar;
 836   while (thread_alive_p (tstate) && NILP (self->error_symbol))
 837     sys_cond_wait (self->wait_condvar, &global_lock);
 838
 839   self->wait_condvar = NULL;
 840   self->event_object = Qnil;
 841   post_acquire_global_lock (self);
 842 }
 843
 844 DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
 845        doc: /* Wait for THREAD to exit.
 846 This blocks the current thread until THREAD exits or until
 847 the current thread is signaled.
 848 It is an error for a thread to try to join itself.  */)
 849   (Lisp_Object thread)
 850 {
 851   struct thread_state *tstate;
 852
 853   CHECK_THREAD (thread);
 854   tstate = XTHREAD (thread);
 855
 856   if (tstate == current_thread)
 857     error ("Cannot join current thread");
 858
 859   if (thread_alive_p (tstate))
 860     flush_stack_call_func (thread_join_callback, tstate);
 861
 862   return Qnil;
 863 }
 864
 865 DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
 866        doc: /* Return a list of all the live threads.  */)
 867   (void)
 868 {
 869   Lisp_Object result = Qnil;
 870   struct thread_state *iter;
 871
 872   for (iter = all_threads; iter; iter = iter->next_thread)
 873     {
 874       if (thread_alive_p (iter))
 875         {
 876           Lisp_Object thread;
 877
 878           XSETTHREAD (thread, iter);
 879           result = Fcons (thread, result);
 880         }
 881     }
 882
 883   return result;
 884 }
 885
 886 \f
 887
 888 bool
 889 thread_check_current_buffer (struct buffer *buffer)
 890 {
 891   struct thread_state *iter;
 892
 893   for (iter = all_threads; iter; iter = iter->next_thread)
 894     {
 895       if (iter == current_thread)
 896         continue;
 897
 898       if (iter->m_current_buffer == buffer)
 899         return true;
 900     }
 901
 902   return false;
 903 }
 904
 905 \f
 906
 907 static void
 908 init_primary_thread (void)
 909 {
 910   primary_thread.header.size
 911     = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
 912   XSETPVECTYPE (&primary_thread, PVEC_THREAD);
 913   primary_thread.m_last_thing_searched = Qnil;
 914   primary_thread.m_saved_last_thing_searched = Qnil;
 915   primary_thread.name = Qnil;
 916   primary_thread.function = Qnil;
 917   primary_thread.error_symbol = Qnil;
 918   primary_thread.error_data = Qnil;
 919   primary_thread.event_object = Qnil;
 920 }
 921
 922 void
 923 init_threads_once (void)
 924 {
 925   init_primary_thread ();
 926 }
 927
 928 void
 929 init_threads (void)
 930 {
 931   init_primary_thread ();
 932   sys_cond_init (&primary_thread.thread_condvar);
 933   sys_mutex_init (&global_lock);
 934   sys_mutex_lock (&global_lock);
 935   current_thread = &primary_thread;
 936   primary_thread.thread_id = sys_thread_self ();
 937 }
 938
 939 void
 940 syms_of_threads (void)
 941 {
 942 #ifndef THREADS_ENABLED
 943   if (0)
 944 #endif
 945     {
 946       defsubr (&Sthread_yield);
 947       defsubr (&Smake_thread);
 948       defsubr (&Scurrent_thread);
 949       defsubr (&Sthread_name);
 950       defsubr (&Sthread_signal);
 951       defsubr (&Sthread_alive_p);
 952       defsubr (&Sthread_join);
 953       defsubr (&Sthread_blocker);
 954       defsubr (&Sall_threads);
 955       defsubr (&Smake_mutex);
 956       defsubr (&Smutex_lock);
 957       defsubr (&Smutex_unlock);
 958       defsubr (&Smutex_name);
 959       defsubr (&Smake_condition_variable);
 960       defsubr (&Scondition_wait);
 961       defsubr (&Scondition_notify);
 962       defsubr (&Scondition_mutex);
 963       defsubr (&Scondition_name);
 964     }
 965
 966   DEFSYM (Qthreadp, "threadp");
 967   DEFSYM (Qmutexp, "mutexp");
 968   DEFSYM (Qcondition_variable_p, "condition-variable-p");
 969 }