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