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   struct handler *handler;
 599   Lisp_Object tem;
 600
 601   mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
 602
 603   mark_stack (thread->m_stack_bottom, thread->stack_top);
 604
 605   for (handler = thread->m_handlerlist; handler; handler = handler->next)
 606     {
 607       mark_object (handler->tag_or_ch);
 608       mark_object (handler->val);
 609     }
 610
 611   if (thread->m_current_buffer)
 612     {
 613       XSETBUFFER (tem, thread->m_current_buffer);
 614       mark_object (tem);
 615     }
 616
 617   mark_object (thread->m_last_thing_searched);
 618
 619   if (!NILP (thread->m_saved_last_thing_searched))
 620     mark_object (thread->m_saved_last_thing_searched);
 621 }
 622
 623 static void
 624 mark_threads_callback (void *ignore)
 625 {
 626   struct thread_state *iter;
 627
 628   for (iter = all_threads; iter; iter = iter->next_thread)
 629     {
 630       Lisp_Object thread_obj;
 631
 632       XSETTHREAD (thread_obj, iter);
 633       mark_object (thread_obj);
 634       mark_one_thread (iter);
 635     }
 636 }
 637
 638 void
 639 mark_threads (void)
 640 {
 641   flush_stack_call_func (mark_threads_callback, NULL);
 642 }
 643
 644 \f
 645
 646 static void
 647 yield_callback (void *ignore)
 648 {
 649   struct thread_state *self = current_thread;
 650
 651   release_global_lock ();
 652   sys_thread_yield ();
 653   acquire_global_lock (self);
 654 }
 655
 656 DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
 657        doc: /* Yield the CPU to another thread.  */)
 658      (void)
 659 {
 660   flush_stack_call_func (yield_callback, NULL);
 661   return Qnil;
 662 }
 663
 664 static Lisp_Object
 665 invoke_thread_function (void)
 666 {
 667   int count = SPECPDL_INDEX ();
 668
 669   Ffuncall (1, &current_thread->function);
 670   return unbind_to (count, Qnil);
 671 }
 672
 673 static Lisp_Object last_thread_error;
 674
 675 static Lisp_Object
 676 record_thread_error (Lisp_Object error_form)
 677 {
 678   last_thread_error = error_form;
 679   return error_form;
 680 }
 681
 682 static void *
 683 run_thread (void *state)
 684 {
 685   /* Make sure stack_top and m_stack_bottom are properly aligned as GC
 686      expects.  */
 687   max_align_t stack_pos;
 688
 689   struct thread_state *self = state;
 690   struct thread_state **iter;
 691
 692   self->m_stack_bottom = self->stack_top = (char *) &stack_pos;
 693   self->thread_id = sys_thread_self ();
 694
 695   acquire_global_lock (self);
 696
 697   /* Put a dummy catcher at top-level so that handlerlist is never NULL.
 698      This is important since handlerlist->nextfree holds the freelist
 699      which would otherwise leak every time we unwind back to top-level.   */
 700   handlerlist_sentinel = xzalloc (sizeof (struct handler));
 701   handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
 702   struct handler *c = push_handler (Qunbound, CATCHER);
 703   eassert (c == handlerlist_sentinel);
 704   handlerlist_sentinel->nextfree = NULL;
 705   handlerlist_sentinel->next = NULL;
 706
 707   /* It might be nice to do something with errors here.  */
 708   internal_condition_case (invoke_thread_function, Qt, record_thread_error);
 709
 710   update_processes_for_thread_death (Fcurrent_thread ());
 711
 712   xfree (self->m_specpdl - 1);
 713   self->m_specpdl = NULL;
 714   self->m_specpdl_ptr = NULL;
 715   self->m_specpdl_size = 0;
 716
 717   {
 718     struct handler *c, *c_next;
 719     for (c = handlerlist_sentinel; c; c = c_next)
 720       {
 721         c_next = c->nextfree;
 722         xfree (c);
 723       }
 724   }
 725
 726   current_thread = NULL;
 727   sys_cond_broadcast (&self->thread_condvar);
 728
 729   /* Unlink this thread from the list of all threads.  Note that we
 730      have to do this very late, after broadcasting our death.
 731      Otherwise the GC may decide to reap the thread_state object,
 732      leading to crashes.  */
 733   for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
 734     ;
 735   *iter = (*iter)->next_thread;
 736
 737   release_global_lock ();
 738
 739   return NULL;
 740 }
 741
 742 void
 743 finalize_one_thread (struct thread_state *state)
 744 {
 745   sys_cond_destroy (&state->thread_condvar);
 746 }
 747
 748 DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
 749        doc: /* Start a new thread and run FUNCTION in it.
 750 When the function exits, the thread dies.
 751 If NAME is given, it must be a string; it names the new thread.  */)
 752   (Lisp_Object function, Lisp_Object name)
 753 {
 754   sys_thread_t thr;
 755   struct thread_state *new_thread;
 756   Lisp_Object result;
 757   const char *c_name = NULL;
 758   size_t offset = offsetof (struct thread_state, m_stack_bottom);
 759
 760   /* Can't start a thread in temacs.  */
 761   if (!initialized)
 762     emacs_abort ();
 763
 764   if (!NILP (name))
 765     CHECK_STRING (name);
 766
 767   new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom,
 768                                       PVEC_THREAD);
 769   memset ((char *) new_thread + offset, 0,
 770           sizeof (struct thread_state) - offset);
 771
 772   new_thread->function = function;
 773   new_thread->name = name;
 774   new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
 775   new_thread->m_saved_last_thing_searched = Qnil;
 776   new_thread->m_current_buffer = current_thread->m_current_buffer;
 777   new_thread->error_symbol = Qnil;
 778   new_thread->error_data = Qnil;
 779   new_thread->event_object = Qnil;
 780
 781   new_thread->m_specpdl_size = 50;
 782   new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
 783                                    * sizeof (union specbinding));
 784   /* Skip the dummy entry.  */
 785   ++new_thread->m_specpdl;
 786   new_thread->m_specpdl_ptr = new_thread->m_specpdl;
 787
 788   sys_cond_init (&new_thread->thread_condvar);
 789
 790   /* We'll need locking here eventually.  */
 791   new_thread->next_thread = all_threads;
 792   all_threads = new_thread;
 793
 794   if (!NILP (name))
 795     c_name = SSDATA (ENCODE_UTF_8 (name));
 796
 797   if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
 798     {
 799       /* Restore the previous situation.  */
 800       all_threads = all_threads->next_thread;
 801       error ("Could not start a new thread");
 802     }
 803
 804   /* FIXME: race here where new thread might not be filled in?  */
 805   XSETTHREAD (result, new_thread);
 806   return result;
 807 }
 808
 809 DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
 810        doc: /* Return the current thread.  */)
 811   (void)
 812 {
 813   Lisp_Object result;
 814   XSETTHREAD (result, current_thread);
 815   return result;
 816 }
 817
 818 DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
 819        doc: /* Return the name of the THREAD.
 820 The name is the same object that was passed to `make-thread'.  */)
 821      (Lisp_Object thread)
 822 {
 823   struct thread_state *tstate;
 824
 825   CHECK_THREAD (thread);
 826   tstate = XTHREAD (thread);
 827
 828   return tstate->name;
 829 }
 830
 831 static void
 832 thread_signal_callback (void *arg)
 833 {
 834   struct thread_state *tstate = arg;
 835   struct thread_state *self = current_thread;
 836
 837   sys_cond_broadcast (tstate->wait_condvar);
 838   post_acquire_global_lock (self);
 839 }
 840
 841 DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
 842        doc: /* Signal an error in a thread.
 843 This acts like `signal', but arranges for the signal to be raised
 844 in THREAD.  If THREAD is the current thread, acts just like `signal'.
 845 This will interrupt a blocked call to `mutex-lock', `condition-wait',
 846 or `thread-join' in the target thread.  */)
 847   (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
 848 {
 849   struct thread_state *tstate;
 850
 851   CHECK_THREAD (thread);
 852   tstate = XTHREAD (thread);
 853
 854   if (tstate == current_thread)
 855     Fsignal (error_symbol, data);
 856
 857   /* What to do if thread is already signaled?  */
 858   /* What if error_symbol is Qnil?  */
 859   tstate->error_symbol = error_symbol;
 860   tstate->error_data = data;
 861
 862   if (tstate->wait_condvar)
 863     flush_stack_call_func (thread_signal_callback, tstate);
 864
 865   return Qnil;
 866 }
 867
 868 DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
 869        doc: /* Return t if THREAD is alive, or nil if it has exited.  */)
 870   (Lisp_Object thread)
 871 {
 872   struct thread_state *tstate;
 873
 874   CHECK_THREAD (thread);
 875   tstate = XTHREAD (thread);
 876
 877   return thread_alive_p (tstate) ? Qt : Qnil;
 878 }
 879
 880 DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
 881        doc: /* Return the object that THREAD is blocking on.
 882 If THREAD is blocked in `thread-join' on a second thread, return that
 883 thread.
 884 If THREAD is blocked in `mutex-lock', return the mutex.
 885 If THREAD is blocked in `condition-wait', return the condition variable.
 886 Otherwise, if THREAD is not blocked, return nil.  */)
 887   (Lisp_Object thread)
 888 {
 889   struct thread_state *tstate;
 890
 891   CHECK_THREAD (thread);
 892   tstate = XTHREAD (thread);
 893
 894   return tstate->event_object;
 895 }
 896
 897 static void
 898 thread_join_callback (void *arg)
 899 {
 900   struct thread_state *tstate = arg;
 901   struct thread_state *self = current_thread;
 902   Lisp_Object thread;
 903
 904   XSETTHREAD (thread, tstate);
 905   self->event_object = thread;
 906   self->wait_condvar = &tstate->thread_condvar;
 907   while (thread_alive_p (tstate) && NILP (self->error_symbol))
 908     sys_cond_wait (self->wait_condvar, &global_lock);
 909
 910   self->wait_condvar = NULL;
 911   self->event_object = Qnil;
 912   post_acquire_global_lock (self);
 913 }
 914
 915 DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
 916        doc: /* Wait for THREAD to exit.
 917 This blocks the current thread until THREAD exits or until
 918 the current thread is signaled.
 919 It is an error for a thread to try to join itself.  */)
 920   (Lisp_Object thread)
 921 {
 922   struct thread_state *tstate;
 923
 924   CHECK_THREAD (thread);
 925   tstate = XTHREAD (thread);
 926
 927   if (tstate == current_thread)
 928     error ("Cannot join current thread");
 929
 930   if (thread_alive_p (tstate))
 931     flush_stack_call_func (thread_join_callback, tstate);
 932
 933   return Qnil;
 934 }
 935
 936 DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
 937        doc: /* Return a list of all the live threads.  */)
 938   (void)
 939 {
 940   Lisp_Object result = Qnil;
 941   struct thread_state *iter;
 942
 943   for (iter = all_threads; iter; iter = iter->next_thread)
 944     {
 945       if (thread_alive_p (iter))
 946         {
 947           Lisp_Object thread;
 948
 949           XSETTHREAD (thread, iter);
 950           result = Fcons (thread, result);
 951         }
 952     }
 953
 954   return result;
 955 }
 956
 957 DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 0, 0,
 958        doc: /* Return the last error form recorded by a dying thread.  */)
 959   (void)
 960 {
 961   return last_thread_error;
 962 }
 963
 964 \f
 965
 966 bool
 967 thread_check_current_buffer (struct buffer *buffer)
 968 {
 969   struct thread_state *iter;
 970
 971   for (iter = all_threads; iter; iter = iter->next_thread)
 972     {
 973       if (iter == current_thread)
 974         continue;
 975
 976       if (iter->m_current_buffer == buffer)
 977         return true;
 978     }
 979
 980   return false;
 981 }
 982
 983 \f
 984
 985 static void
 986 init_main_thread (void)
 987 {
 988   main_thread.header.size
 989     = PSEUDOVECSIZE (struct thread_state, m_stack_bottom);
 990   XSETPVECTYPE (&main_thread, PVEC_THREAD);
 991   main_thread.m_last_thing_searched = Qnil;
 992   main_thread.m_saved_last_thing_searched = Qnil;
 993   main_thread.name = Qnil;
 994   main_thread.function = Qnil;
 995   main_thread.error_symbol = Qnil;
 996   main_thread.error_data = Qnil;
 997   main_thread.event_object = Qnil;
 998 }
 999
1000 bool
1001 main_thread_p (void *ptr)
1002 {
1003   return ptr == &main_thread;
1004 }
1005
1006 void
1007 init_threads_once (void)
1008 {
1009   init_main_thread ();
1010 }
1011
1012 void
1013 init_threads (void)
1014 {
1015   init_main_thread ();
1016   sys_cond_init (&main_thread.thread_condvar);
1017   sys_mutex_init (&global_lock);
1018   sys_mutex_lock (&global_lock);
1019   current_thread = &main_thread;
1020   main_thread.thread_id = sys_thread_self ();
1021 }
1022
1023 void
1024 syms_of_threads (void)
1025 {
1026 #ifndef THREADS_ENABLED
1027   if (0)
1028 #endif
1029     {
1030       defsubr (&Sthread_yield);
1031       defsubr (&Smake_thread);
1032       defsubr (&Scurrent_thread);
1033       defsubr (&Sthread_name);
1034       defsubr (&Sthread_signal);
1035       defsubr (&Sthread_alive_p);
1036       defsubr (&Sthread_join);
1037       defsubr (&Sthread_blocker);
1038       defsubr (&Sall_threads);
1039       defsubr (&Smake_mutex);
1040       defsubr (&Smutex_lock);
1041       defsubr (&Smutex_unlock);
1042       defsubr (&Smutex_name);
1043       defsubr (&Smake_condition_variable);
1044       defsubr (&Scondition_wait);
1045       defsubr (&Scondition_notify);
1046       defsubr (&Scondition_mutex);
1047       defsubr (&Scondition_name);
1048       defsubr (&Sthread_last_error);
1049
1050       staticpro (&last_thread_error);
1051       last_thread_error = Qnil;
1052     }
1053
1054   DEFSYM (Qthreadp, "threadp");
1055   DEFSYM (Qmutexp, "mutexp");
1056   DEFSYM (Qcondition_variable_p, "condition-variable-p");
1057 }