src/thread.c

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