src/thread.c

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