src/thread.c

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