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