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