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