src/thread.c

   1 /* Threading code.
   2 Copyright (C) 2012-2018 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 <https://www.gnu.org/licenses/>.  */
  18
  19
  20 #include <config.h>
  21 #include <setjmp.h>
  22 #include "lisp.h"
  23 #include "character.h"
  24 #include "buffer.h"
  25 #include "process.h"
  26 #include "coding.h"
  27 #include "syssignal.h"
  28
  29 static struct thread_state main_thread;
  30
  31 struct thread_state *current_thread = &main_thread;
  32
  33 static struct thread_state *all_threads = &main_thread;
  34
  35 static sys_mutex_t global_lock;
  36
  37 extern int poll_suppress_count;
  38 extern volatile int interrupt_input_blocked;
  39
  40 \f
  41
  42 /* m_specpdl is set when the thread is created and cleared when the
  43    thread dies.  */
  44 #define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
  45
  46 \f
  47
  48 static void
  49 release_global_lock (void)
  50 {
  51   sys_mutex_unlock (&global_lock);
  52 }
  53
  54 /* You must call this after acquiring the global lock.
  55    acquire_global_lock does it for you.  */
  56 static void
  57 post_acquire_global_lock (struct thread_state *self)
  58 {
  59   struct thread_state *prev_thread = current_thread;
  60
  61   /* Do this early on, so that code below could signal errors (e.g.,
  62      unbind_for_thread_switch might) correctly, because we are already
  63      running in the context of the thread pointed by SELF.  */
  64   current_thread = self;
  65
  66   if (prev_thread != current_thread)
  67     {
  68       /* PREV_THREAD is NULL if the previously current thread
  69          exited.  In this case, there is no reason to unbind, and
  70          trying will crash.  */
  71       if (prev_thread != NULL)
  72         unbind_for_thread_switch (prev_thread);
  73       rebind_for_thread_switch ();
  74
  75        /* Set the new thread's current buffer.  This needs to be done
  76           even if it is the same buffer as that of the previous thread,
  77           because of thread-local bindings.  */
  78       set_buffer_internal_2 (current_buffer);
  79     }
  80
  81    /* We could have been signaled while waiting to grab the global lock
  82       for the first time since this thread was created, in which case
  83       we didn't yet have the opportunity to set up the handlers.  Delay
  84       raising the signal in that case (it will be actually raised when
  85       the thread comes here after acquiring the lock the next time).  */
  86   if (!NILP (current_thread->error_symbol) && handlerlist)
  87     {
  88       Lisp_Object sym = current_thread->error_symbol;
  89       Lisp_Object data = current_thread->error_data;
  90
  91       current_thread->error_symbol = Qnil;
  92       current_thread->error_data = Qnil;
  93       Fsignal (sym, data);
  94     }
  95 }
  96
  97 static void
  98 acquire_global_lock (struct thread_state *self)
  99 {
 100   sys_mutex_lock (&global_lock);
 101   post_acquire_global_lock (self);
 102 }
 103
 104 /* This is called from keyboard.c when it detects that SIGINT was
 105    delivered to the main thread and interrupted thread_select before
 106    the main thread could acquire the lock.  We must acquire the lock
 107    to prevent a thread from running without holding the global lock,
 108    and to avoid repeated calls to sys_mutex_unlock, which invokes
 109    undefined behavior.  */
 110 void
 111 maybe_reacquire_global_lock (void)
 112 {
 113   /* SIGINT handler is always run on the main thread, see
 114      deliver_process_signal, so reflect that in our thread-tracking
 115      variables.  */
 116   current_thread = &main_thread;
 117
 118   if (current_thread->not_holding_lock)
 119     {
 120       struct thread_state *self = current_thread;
 121
 122       acquire_global_lock (self);
 123       current_thread->not_holding_lock = 0;
 124     }
 125 }
 126
 127 \f
 128
 129 static void
 130 lisp_mutex_init (lisp_mutex_t *mutex)
 131 {
 132   mutex->owner = NULL;
 133   mutex->count = 0;
 134   sys_cond_init (&mutex->condition);
 135 }
 136
 137 /* Lock MUTEX for thread LOCKER, setting its lock count to COUNT, if
 138    non-zero, or to 1 otherwise.
 139
 140    If MUTEX is locked by LOCKER, COUNT must be zero, and the MUTEX's
 141    lock count will be incremented.
 142
 143    If MUTEX is locked by another thread, this function will release
 144    the global lock, giving other threads a chance to run, and will
 145    wait for the MUTEX to become unlocked; when MUTEX becomes unlocked,
 146    and will then re-acquire the global lock.
 147
 148    Return value is 1 if the function waited for the MUTEX to become
 149    unlocked (meaning other threads could have run during the wait),
 150    zero otherwise.  */
 151 static int
 152 lisp_mutex_lock_for_thread (lisp_mutex_t *mutex, struct thread_state *locker,
 153                             int new_count)
 154 {
 155   struct thread_state *self;
 156
 157   if (mutex->owner == NULL)
 158     {
 159       mutex->owner = locker;
 160       mutex->count = new_count == 0 ? 1 : new_count;
 161       return 0;
 162     }
 163   if (mutex->owner == locker)
 164     {
 165       eassert (new_count == 0);
 166       ++mutex->count;
 167       return 0;
 168     }
 169
 170   self = locker;
 171   self->wait_condvar = &mutex->condition;
 172   while (mutex->owner != NULL && (new_count != 0
 173                                   || NILP (self->error_symbol)))
 174     sys_cond_wait (&mutex->condition, &global_lock);
 175   self->wait_condvar = NULL;
 176
 177   if (new_count == 0 && !NILP (self->error_symbol))
 178     return 1;
 179
 180   mutex->owner = self;
 181   mutex->count = new_count == 0 ? 1 : new_count;
 182
 183   return 1;
 184 }
 185
 186 static int
 187 lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
 188 {
 189   return lisp_mutex_lock_for_thread (mutex, current_thread, new_count);
 190 }
 191
 192 /* Decrement MUTEX's lock count.  If the lock count becomes zero after
 193    decrementing it, meaning the mutex is now unlocked, broadcast that
 194    to all the threads that might be waiting to lock the mutex.  This
 195    function signals an error if MUTEX is locked by a thread other than
 196    the current one.  Return value is 1 if the mutex becomes unlocked,
 197    zero otherwise.  */
 198 static int
 199 lisp_mutex_unlock (lisp_mutex_t *mutex)
 200 {
 201   if (mutex->owner != current_thread)
 202     error ("Cannot unlock mutex owned by another thread");
 203
 204   if (--mutex->count > 0)
 205     return 0;
 206
 207   mutex->owner = NULL;
 208   sys_cond_broadcast (&mutex->condition);
 209
 210   return 1;
 211 }
 212
 213 /* Like lisp_mutex_unlock, but sets MUTEX's lock count to zero
 214    regardless of its value.  Return the previous lock count.  */
 215 static unsigned int
 216 lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
 217 {
 218   unsigned int result = mutex->count;
 219
 220   /* Ensured by condvar code.  */
 221   eassert (mutex->owner == current_thread);
 222
 223   mutex->count = 0;
 224   mutex->owner = NULL;
 225   sys_cond_broadcast (&mutex->condition);
 226
 227   return result;
 228 }
 229
 230 static void
 231 lisp_mutex_destroy (lisp_mutex_t *mutex)
 232 {
 233   sys_cond_destroy (&mutex->condition);
 234 }
 235
 236 static int
 237 lisp_mutex_owned_p (lisp_mutex_t *mutex)
 238 {
 239   return mutex->owner == current_thread;
 240 }
 241
 242 \f
 243
 244 DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
 245        doc: /* Create a mutex.
 246 A mutex provides a synchronization point for threads.
 247 Only one thread at a time can hold a mutex.  Other threads attempting
 248 to acquire it will block until the mutex is available.
 249
 250 A thread can acquire a mutex any number of times.
 251
 252 NAME, if given, is used as the name of the mutex.  The name is
 253 informational only.  */)
 254   (Lisp_Object name)
 255 {
 256   struct Lisp_Mutex *mutex;
 257   Lisp_Object result;
 258
 259   if (!NILP (name))
 260     CHECK_STRING (name);
 261
 262   mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
 263   memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
 264           0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
 265                                                     mutex));
 266   mutex->name = name;
 267   lisp_mutex_init (&mutex->mutex);
 268
 269   XSETMUTEX (result, mutex);
 270   return result;
 271 }
 272
 273 static void
 274 mutex_lock_callback (void *arg)
 275 {
 276   struct Lisp_Mutex *mutex = arg;
 277   struct thread_state *self = current_thread;
 278
 279   /* Calling lisp_mutex_lock might yield to other threads while this
 280      one waits for the mutex to become unlocked, so we need to
 281      announce us as the current thread by calling
 282      post_acquire_global_lock.  */
 283   if (lisp_mutex_lock (&mutex->mutex, 0))
 284     post_acquire_global_lock (self);
 285 }
 286
 287 static void
 288 do_unwind_mutex_lock (void)
 289 {
 290   current_thread->event_object = Qnil;
 291 }
 292
 293 DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
 294        doc: /* Acquire a mutex.
 295 If the current thread already owns MUTEX, increment the count and
 296 return.
 297 Otherwise, if no thread owns MUTEX, make the current thread own it.
 298 Otherwise, block until MUTEX is available, or until the current thread
 299 is signaled using `thread-signal'.
 300 Note that calls to `mutex-lock' and `mutex-unlock' must be paired.  */)
 301   (Lisp_Object mutex)
 302 {
 303   struct Lisp_Mutex *lmutex;
 304   ptrdiff_t count = SPECPDL_INDEX ();
 305
 306   CHECK_MUTEX (mutex);
 307   lmutex = XMUTEX (mutex);
 308
 309   current_thread->event_object = mutex;
 310   record_unwind_protect_void (do_unwind_mutex_lock);
 311   flush_stack_call_func (mutex_lock_callback, lmutex);
 312   return unbind_to (count, Qnil);
 313 }
 314
 315 static void
 316 mutex_unlock_callback (void *arg)
 317 {
 318   struct Lisp_Mutex *mutex = arg;
 319   struct thread_state *self = current_thread;
 320
 321   if (lisp_mutex_unlock (&mutex->mutex))
 322     post_acquire_global_lock (self); /* FIXME: is this call needed? */
 323 }
 324
 325 DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
 326        doc: /* Release the mutex.
 327 If this thread does not own MUTEX, signal an error.
 328 Otherwise, decrement the mutex's count.  If the count is zero,
 329 release MUTEX.   */)
 330   (Lisp_Object mutex)
 331 {
 332   struct Lisp_Mutex *lmutex;
 333
 334   CHECK_MUTEX (mutex);
 335   lmutex = XMUTEX (mutex);
 336
 337   flush_stack_call_func (mutex_unlock_callback, lmutex);
 338   return Qnil;
 339 }
 340
 341 DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
 342        doc: /* Return the name of MUTEX.
 343 If no name was given when MUTEX was created, return nil.  */)
 344   (Lisp_Object mutex)
 345 {
 346   struct Lisp_Mutex *lmutex;
 347
 348   CHECK_MUTEX (mutex);
 349   lmutex = XMUTEX (mutex);
 350
 351   return lmutex->name;
 352 }
 353
 354 void
 355 finalize_one_mutex (struct Lisp_Mutex *mutex)
 356 {
 357   lisp_mutex_destroy (&mutex->mutex);
 358 }
 359
 360 \f
 361
 362 DEFUN ("make-condition-variable",
 363        Fmake_condition_variable, Smake_condition_variable,
 364        1, 2, 0,
 365        doc: /* Make a condition variable associated with MUTEX.
 366 A condition variable provides a way for a thread to sleep while
 367 waiting for a state change.
 368
 369 MUTEX is the mutex associated with this condition variable.
 370 NAME, if given, is the name of this condition variable.  The name is
 371 informational only.  */)
 372   (Lisp_Object mutex, Lisp_Object name)
 373 {
 374   struct Lisp_CondVar *condvar;
 375   Lisp_Object result;
 376
 377   CHECK_MUTEX (mutex);
 378   if (!NILP (name))
 379     CHECK_STRING (name);
 380
 381   condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
 382   memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
 383           0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
 384                                                       cond));
 385   condvar->mutex = mutex;
 386   condvar->name = name;
 387   sys_cond_init (&condvar->cond);
 388
 389   XSETCONDVAR (result, condvar);
 390   return result;
 391 }
 392
 393 static void
 394 condition_wait_callback (void *arg)
 395 {
 396   struct Lisp_CondVar *cvar = arg;
 397   struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
 398   struct thread_state *self = current_thread;
 399   unsigned int saved_count;
 400   Lisp_Object cond;
 401
 402   XSETCONDVAR (cond, cvar);
 403   self->event_object = cond;
 404   saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
 405   /* If signaled while unlocking, skip the wait but reacquire the lock.  */
 406   if (NILP (self->error_symbol))
 407     {
 408       self->wait_condvar = &cvar->cond;
 409       /* This call could switch to another thread.  */
 410       sys_cond_wait (&cvar->cond, &global_lock);
 411       self->wait_condvar = NULL;
 412     }
 413   self->event_object = Qnil;
 414   /* Since sys_cond_wait could switch threads, we need to lock the
 415      mutex for the thread which was the current when we were called,
 416      otherwise lisp_mutex_lock will record the wrong thread as the
 417      owner of the mutex lock.  */
 418   lisp_mutex_lock_for_thread (&mutex->mutex, self, saved_count);
 419   /* Calling lisp_mutex_lock_for_thread might yield to other threads
 420      while this one waits for the mutex to become unlocked, so we need
 421      to announce us as the current thread by calling
 422      post_acquire_global_lock.  */
 423   post_acquire_global_lock (self);
 424 }
 425
 426 DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
 427        doc: /* Wait for the condition variable COND to be notified.
 428 COND is the condition variable to wait on.
 429
 430 The mutex associated with COND must be held when this is called.
 431 It is an error if it is not held.
 432
 433 This releases the mutex and waits for COND to be notified or for
 434 this thread to be signaled with `thread-signal'.  When
 435 `condition-wait' returns, COND's mutex will again be locked by
 436 this thread.  */)
 437   (Lisp_Object cond)
 438 {
 439   struct Lisp_CondVar *cvar;
 440   struct Lisp_Mutex *mutex;
 441
 442   CHECK_CONDVAR (cond);
 443   cvar = XCONDVAR (cond);
 444
 445   mutex = XMUTEX (cvar->mutex);
 446   if (!lisp_mutex_owned_p (&mutex->mutex))
 447     error ("Condition variable's mutex is not held by current thread");
 448
 449   flush_stack_call_func (condition_wait_callback, cvar);
 450
 451   return Qnil;
 452 }
 453
 454 /* Used to communicate arguments to condition_notify_callback.  */
 455 struct notify_args
 456 {
 457   struct Lisp_CondVar *cvar;
 458   int all;
 459 };
 460
 461 static void
 462 condition_notify_callback (void *arg)
 463 {
 464   struct notify_args *na = arg;
 465   struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
 466   struct thread_state *self = current_thread;
 467   unsigned int saved_count;
 468   Lisp_Object cond;
 469
 470   XSETCONDVAR (cond, na->cvar);
 471   saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
 472   if (na->all)
 473     sys_cond_broadcast (&na->cvar->cond);
 474   else
 475     sys_cond_signal (&na->cvar->cond);
 476   /* Calling lisp_mutex_lock might yield to other threads while this
 477      one waits for the mutex to become unlocked, so we need to
 478      announce us as the current thread by calling
 479      post_acquire_global_lock.  */
 480   lisp_mutex_lock (&mutex->mutex, saved_count);
 481   post_acquire_global_lock (self);
 482 }
 483
 484 DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
 485        doc: /* Notify COND, a condition variable.
 486 This wakes a thread waiting on COND.
 487 If ALL is non-nil, all waiting threads are awoken.
 488
 489 The mutex associated with COND must be held when this is called.
 490 It is an error if it is not held.
 491
 492 This releases COND's mutex when notifying COND.  When
 493 `condition-notify' returns, the mutex will again be locked by this
 494 thread.  */)
 495   (Lisp_Object cond, Lisp_Object all)
 496 {
 497   struct Lisp_CondVar *cvar;
 498   struct Lisp_Mutex *mutex;
 499   struct notify_args args;
 500
 501   CHECK_CONDVAR (cond);
 502   cvar = XCONDVAR (cond);
 503
 504   mutex = XMUTEX (cvar->mutex);
 505   if (!lisp_mutex_owned_p (&mutex->mutex))
 506     error ("Condition variable's mutex is not held by current thread");
 507
 508   args.cvar = cvar;
 509   args.all = !NILP (all);
 510   flush_stack_call_func (condition_notify_callback, &args);
 511
 512   return Qnil;
 513 }
 514
 515 DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
 516        doc: /* Return the mutex associated with condition variable COND.  */)
 517   (Lisp_Object cond)
 518 {
 519   struct Lisp_CondVar *cvar;
 520
 521   CHECK_CONDVAR (cond);
 522   cvar = XCONDVAR (cond);
 523
 524   return cvar->mutex;
 525 }
 526
 527 DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
 528        doc: /* Return the name of condition variable COND.
 529 If no name was given when COND was created, return nil.  */)
 530   (Lisp_Object cond)
 531 {
 532   struct Lisp_CondVar *cvar;
 533
 534   CHECK_CONDVAR (cond);
 535   cvar = XCONDVAR (cond);
 536
 537   return cvar->name;
 538 }
 539
 540 void
 541 finalize_one_condvar (struct Lisp_CondVar *condvar)
 542 {
 543   sys_cond_destroy (&condvar->cond);
 544 }
 545
 546 \f
 547
 548 struct select_args
 549 {
 550   select_func *func;
 551   int max_fds;
 552   fd_set *rfds;
 553   fd_set *wfds;
 554   fd_set *efds;
 555   struct timespec *timeout;
 556   sigset_t *sigmask;
 557   int result;
 558 };
 559
 560 static void
 561 really_call_select (void *arg)
 562 {
 563   struct select_args *sa = arg;
 564   struct thread_state *self = current_thread;
 565   sigset_t oldset;
 566
 567   block_interrupt_signal (&oldset);
 568   self->not_holding_lock = 1;
 569   release_global_lock ();
 570   restore_signal_mask (&oldset);
 571
 572   sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
 573                            sa->timeout, sa->sigmask);
 574
 575   block_interrupt_signal (&oldset);
 576   /* If we were interrupted by C-g while inside sa->func above, the
 577      signal handler could have called maybe_reacquire_global_lock, in
 578      which case we are already holding the lock and shouldn't try
 579      taking it again, or else we will hang forever.  */
 580   if (self->not_holding_lock)
 581     {
 582       acquire_global_lock (self);
 583       self->not_holding_lock = 0;
 584     }
 585   restore_signal_mask (&oldset);
 586 }
 587
 588 int
 589 thread_select (select_func *func, int max_fds, fd_set *rfds,
 590                fd_set *wfds, fd_set *efds, struct timespec *timeout,
 591                sigset_t *sigmask)
 592 {
 593   struct select_args sa;
 594
 595   sa.func = func;
 596   sa.max_fds = max_fds;
 597   sa.rfds = rfds;
 598   sa.wfds = wfds;
 599   sa.efds = efds;
 600   sa.timeout = timeout;
 601   sa.sigmask = sigmask;
 602   flush_stack_call_func (really_call_select, &sa);
 603   return sa.result;
 604 }
 605
 606 \f
 607
 608 static void
 609 mark_one_thread (struct thread_state *thread)
 610 {
 611   /* Get the stack top now, in case mark_specpdl changes it.  */
 612   void *stack_top = thread->stack_top;
 613
 614   mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
 615
 616   mark_stack (thread->m_stack_bottom, stack_top);
 617
 618   for (struct handler *handler = thread->m_handlerlist;
 619        handler; handler = handler->next)
 620     {
 621       mark_object (handler->tag_or_ch);
 622       mark_object (handler->val);
 623     }
 624
 625   if (thread->m_current_buffer)
 626     {
 627       Lisp_Object tem;
 628       XSETBUFFER (tem, thread->m_current_buffer);
 629       mark_object (tem);
 630     }
 631
 632   mark_object (thread->m_last_thing_searched);
 633
 634   if (!NILP (thread->m_saved_last_thing_searched))
 635     mark_object (thread->m_saved_last_thing_searched);
 636 }
 637
 638 static void
 639 mark_threads_callback (void *ignore)
 640 {
 641   struct thread_state *iter;
 642
 643   for (iter = all_threads; iter; iter = iter->next_thread)
 644     {
 645       Lisp_Object thread_obj;
 646
 647       XSETTHREAD (thread_obj, iter);
 648       mark_object (thread_obj);
 649       mark_one_thread (iter);
 650     }
 651 }
 652
 653 void
 654 mark_threads (void)
 655 {
 656   flush_stack_call_func (mark_threads_callback, NULL);
 657 }
 658
 659 \f
 660
 661 static void
 662 yield_callback (void *ignore)
 663 {
 664   struct thread_state *self = current_thread;
 665
 666   release_global_lock ();
 667   sys_thread_yield ();
 668   acquire_global_lock (self);
 669 }
 670
 671 DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
 672        doc: /* Yield the CPU to another thread.  */)
 673      (void)
 674 {
 675   flush_stack_call_func (yield_callback, NULL);
 676   return Qnil;
 677 }
 678
 679 static Lisp_Object
 680 invoke_thread_function (void)
 681 {
 682   ptrdiff_t count = SPECPDL_INDEX ();
 683
 684   Ffuncall (1, &current_thread->function);
 685   return unbind_to (count, Qnil);
 686 }
 687
 688 static Lisp_Object last_thread_error;
 689
 690 static Lisp_Object
 691 record_thread_error (Lisp_Object error_form)
 692 {
 693   last_thread_error = error_form;
 694   return error_form;
 695 }
 696
 697 static void *
 698 run_thread (void *state)
 699 {
 700   /* Make sure stack_top and m_stack_bottom are properly aligned as GC
 701      expects.  */
 702   max_align_t stack_pos;
 703
 704   struct thread_state *self = state;
 705   struct thread_state **iter;
 706
 707   self->m_stack_bottom = self->stack_top = (char *) &stack_pos;
 708   self->thread_id = sys_thread_self ();
 709
 710   acquire_global_lock (self);
 711
 712   /* Put a dummy catcher at top-level so that handlerlist is never NULL.
 713      This is important since handlerlist->nextfree holds the freelist
 714      which would otherwise leak every time we unwind back to top-level.   */
 715   handlerlist_sentinel = xzalloc (sizeof (struct handler));
 716   handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
 717   struct handler *c = push_handler (Qunbound, CATCHER);
 718   eassert (c == handlerlist_sentinel);
 719   handlerlist_sentinel->nextfree = NULL;
 720   handlerlist_sentinel->next = NULL;
 721
 722   /* It might be nice to do something with errors here.  */
 723   internal_condition_case (invoke_thread_function, Qt, record_thread_error);
 724
 725   update_processes_for_thread_death (Fcurrent_thread ());
 726
 727   xfree (self->m_specpdl - 1);
 728   self->m_specpdl = NULL;
 729   self->m_specpdl_ptr = NULL;
 730   self->m_specpdl_size = 0;
 731
 732   {
 733     struct handler *c, *c_next;
 734     for (c = handlerlist_sentinel; c; c = c_next)
 735       {
 736         c_next = c->nextfree;
 737         xfree (c);
 738       }
 739   }
 740
 741   current_thread = NULL;
 742   sys_cond_broadcast (&self->thread_condvar);
 743
 744   /* Unlink this thread from the list of all threads.  Note that we
 745      have to do this very late, after broadcasting our death.
 746      Otherwise the GC may decide to reap the thread_state object,
 747      leading to crashes.  */
 748   for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
 749     ;
 750   *iter = (*iter)->next_thread;
 751
 752   release_global_lock ();
 753
 754   return NULL;
 755 }
 756
 757 void
 758 finalize_one_thread (struct thread_state *state)
 759 {
 760   sys_cond_destroy (&state->thread_condvar);
 761 }
 762
 763 DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
 764        doc: /* Start a new thread and run FUNCTION in it.
 765 When the function exits, the thread dies.
 766 If NAME is given, it must be a string; it names the new thread.  */)
 767   (Lisp_Object function, Lisp_Object name)
 768 {
 769   sys_thread_t thr;
 770   struct thread_state *new_thread;
 771   Lisp_Object result;
 772   const char *c_name = NULL;
 773   size_t offset = offsetof (struct thread_state, m_stack_bottom);
 774
 775   /* Can't start a thread in temacs.  */
 776   if (!initialized)
 777     emacs_abort ();
 778
 779   if (!NILP (name))
 780     CHECK_STRING (name);
 781
 782   new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom,
 783                                       PVEC_THREAD);
 784   memset ((char *) new_thread + offset, 0,
 785           sizeof (struct thread_state) - offset);
 786
 787   new_thread->function = function;
 788   new_thread->name = name;
 789   new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
 790   new_thread->m_saved_last_thing_searched = Qnil;
 791   new_thread->m_current_buffer = current_thread->m_current_buffer;
 792   new_thread->error_symbol = Qnil;
 793   new_thread->error_data = Qnil;
 794   new_thread->event_object = Qnil;
 795
 796   new_thread->m_specpdl_size = 50;
 797   new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
 798                                    * sizeof (union specbinding));
 799   /* Skip the dummy entry.  */
 800   ++new_thread->m_specpdl;
 801   new_thread->m_specpdl_ptr = new_thread->m_specpdl;
 802
 803   sys_cond_init (&new_thread->thread_condvar);
 804
 805   /* We'll need locking here eventually.  */
 806   new_thread->next_thread = all_threads;
 807   all_threads = new_thread;
 808
 809   if (!NILP (name))
 810     c_name = SSDATA (ENCODE_UTF_8 (name));
 811
 812   if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
 813     {
 814       /* Restore the previous situation.  */
 815       all_threads = all_threads->next_thread;
 816 #ifdef THREADS_ENABLED
 817       error ("Could not start a new thread");
 818 #else
 819       error ("Concurrency is not supported in this configuration");
 820 #endif
 821     }
 822
 823   /* FIXME: race here where new thread might not be filled in?  */
 824   XSETTHREAD (result, new_thread);
 825   return result;
 826 }
 827
 828 DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
 829        doc: /* Return the current thread.  */)
 830   (void)
 831 {
 832   Lisp_Object result;
 833   XSETTHREAD (result, current_thread);
 834   return result;
 835 }
 836
 837 DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
 838        doc: /* Return the name of the THREAD.
 839 The name is the same object that was passed to `make-thread'.  */)
 840      (Lisp_Object thread)
 841 {
 842   struct thread_state *tstate;
 843
 844   CHECK_THREAD (thread);
 845   tstate = XTHREAD (thread);
 846
 847   return tstate->name;
 848 }
 849
 850 static void
 851 thread_signal_callback (void *arg)
 852 {
 853   struct thread_state *tstate = arg;
 854   struct thread_state *self = current_thread;
 855
 856   sys_cond_broadcast (tstate->wait_condvar);
 857   post_acquire_global_lock (self);
 858 }
 859
 860 DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
 861        doc: /* Signal an error in a thread.
 862 This acts like `signal', but arranges for the signal to be raised
 863 in THREAD.  If THREAD is the current thread, acts just like `signal'.
 864 This will interrupt a blocked call to `mutex-lock', `condition-wait',
 865 or `thread-join' in the target thread.  */)
 866   (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
 867 {
 868   struct thread_state *tstate;
 869
 870   CHECK_THREAD (thread);
 871   tstate = XTHREAD (thread);
 872
 873   if (tstate == current_thread)
 874     Fsignal (error_symbol, data);
 875
 876   /* What to do if thread is already signaled?  */
 877   /* What if error_symbol is Qnil?  */
 878   tstate->error_symbol = error_symbol;
 879   tstate->error_data = data;
 880
 881   if (tstate->wait_condvar)
 882     flush_stack_call_func (thread_signal_callback, tstate);
 883
 884   return Qnil;
 885 }
 886
 887 DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
 888        doc: /* Return t if THREAD is alive, or nil if it has exited.  */)
 889   (Lisp_Object thread)
 890 {
 891   struct thread_state *tstate;
 892
 893   CHECK_THREAD (thread);
 894   tstate = XTHREAD (thread);
 895
 896   return thread_alive_p (tstate) ? Qt : Qnil;
 897 }
 898
 899 DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
 900        doc: /* Return the object that THREAD is blocking on.
 901 If THREAD is blocked in `thread-join' on a second thread, return that
 902 thread.
 903 If THREAD is blocked in `mutex-lock', return the mutex.
 904 If THREAD is blocked in `condition-wait', return the condition variable.
 905 Otherwise, if THREAD is not blocked, return nil.  */)
 906   (Lisp_Object thread)
 907 {
 908   struct thread_state *tstate;
 909
 910   CHECK_THREAD (thread);
 911   tstate = XTHREAD (thread);
 912
 913   return tstate->event_object;
 914 }
 915
 916 static void
 917 thread_join_callback (void *arg)
 918 {
 919   struct thread_state *tstate = arg;
 920   struct thread_state *self = current_thread;
 921   Lisp_Object thread;
 922
 923   XSETTHREAD (thread, tstate);
 924   self->event_object = thread;
 925   self->wait_condvar = &tstate->thread_condvar;
 926   while (thread_alive_p (tstate) && NILP (self->error_symbol))
 927     sys_cond_wait (self->wait_condvar, &global_lock);
 928
 929   self->wait_condvar = NULL;
 930   self->event_object = Qnil;
 931   post_acquire_global_lock (self);
 932 }
 933
 934 DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
 935        doc: /* Wait for THREAD to exit.
 936 This blocks the current thread until THREAD exits or until
 937 the current thread is signaled.
 938 It is an error for a thread to try to join itself.  */)
 939   (Lisp_Object thread)
 940 {
 941   struct thread_state *tstate;
 942
 943   CHECK_THREAD (thread);
 944   tstate = XTHREAD (thread);
 945
 946   if (tstate == current_thread)
 947     error ("Cannot join current thread");
 948
 949   if (thread_alive_p (tstate))
 950     flush_stack_call_func (thread_join_callback, tstate);
 951
 952   return Qnil;
 953 }
 954
 955 DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
 956        doc: /* Return a list of all the live threads.  */)
 957   (void)
 958 {
 959   Lisp_Object result = Qnil;
 960   struct thread_state *iter;
 961
 962   for (iter = all_threads; iter; iter = iter->next_thread)
 963     {
 964       if (thread_alive_p (iter))
 965         {
 966           Lisp_Object thread;
 967
 968           XSETTHREAD (thread, iter);
 969           result = Fcons (thread, result);
 970         }
 971     }
 972
 973   return result;
 974 }
 975
 976 DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 1, 0,
 977        doc: /* Return the last error form recorded by a dying thread.
 978 If CLEANUP is non-nil, remove this error form from history.  */)
 979      (Lisp_Object cleanup)
 980 {
 981   Lisp_Object result = last_thread_error;
 982
 983   if (!NILP (cleanup))
 984     last_thread_error = Qnil;
 985
 986   return result;
 987 }
 988
 989 \f
 990
 991 bool
 992 thread_check_current_buffer (struct buffer *buffer)
 993 {
 994   struct thread_state *iter;
 995
 996   for (iter = all_threads; iter; iter = iter->next_thread)
 997     {
 998       if (iter == current_thread)
 999         continue;
1000
1001       if (iter->m_current_buffer == buffer)
1002         return true;
1003     }
1004
1005   return false;
1006 }
1007
1008 \f
1009
1010 static void
1011 init_main_thread (void)
1012 {
1013   main_thread.header.size
1014     = PSEUDOVECSIZE (struct thread_state, m_stack_bottom);
1015   XSETPVECTYPE (&main_thread, PVEC_THREAD);
1016   main_thread.m_last_thing_searched = Qnil;
1017   main_thread.m_saved_last_thing_searched = Qnil;
1018   main_thread.name = Qnil;
1019   main_thread.function = Qnil;
1020   main_thread.error_symbol = Qnil;
1021   main_thread.error_data = Qnil;
1022   main_thread.event_object = Qnil;
1023 }
1024
1025 bool
1026 main_thread_p (void *ptr)
1027 {
1028   return ptr == &main_thread;
1029 }
1030
1031 bool
1032 in_current_thread (void)
1033 {
1034   if (current_thread == NULL)
1035     return false;
1036   return sys_thread_equal (sys_thread_self (), current_thread->thread_id);
1037 }
1038
1039 void
1040 init_threads_once (void)
1041 {
1042   init_main_thread ();
1043 }
1044
1045 void
1046 init_threads (void)
1047 {
1048   init_main_thread ();
1049   sys_cond_init (&main_thread.thread_condvar);
1050   sys_mutex_init (&global_lock);
1051   sys_mutex_lock (&global_lock);
1052   current_thread = &main_thread;
1053   main_thread.thread_id = sys_thread_self ();
1054 }
1055
1056 void
1057 syms_of_threads (void)
1058 {
1059 #ifndef THREADS_ENABLED
1060   if (0)
1061 #endif
1062     {
1063       defsubr (&Sthread_yield);
1064       defsubr (&Smake_thread);
1065       defsubr (&Scurrent_thread);
1066       defsubr (&Sthread_name);
1067       defsubr (&Sthread_signal);
1068       defsubr (&Sthread_alive_p);
1069       defsubr (&Sthread_join);
1070       defsubr (&Sthread_blocker);
1071       defsubr (&Sall_threads);
1072       defsubr (&Smake_mutex);
1073       defsubr (&Smutex_lock);
1074       defsubr (&Smutex_unlock);
1075       defsubr (&Smutex_name);
1076       defsubr (&Smake_condition_variable);
1077       defsubr (&Scondition_wait);
1078       defsubr (&Scondition_notify);
1079       defsubr (&Scondition_mutex);
1080       defsubr (&Scondition_name);
1081       defsubr (&Sthread_last_error);
1082
1083       staticpro (&last_thread_error);
1084       last_thread_error = Qnil;
1085
1086       Fprovide (intern_c_string ("threads"), Qnil);
1087     }
1088
1089   DEFSYM (Qthreadp, "threadp");
1090   DEFSYM (Qmutexp, "mutexp");
1091   DEFSYM (Qcondition_variable_p, "condition-variable-p");
1092
1093   DEFVAR_LISP ("main-thread",
1094                Vmain_thread,
1095     doc: /* The main thread of Emacs.  */);
1096 #ifdef THREADS_ENABLED
1097   XSETTHREAD (Vmain_thread, &main_thread);
1098 #else
1099   Vmain_thread = Qnil;
1100 #endif
1101 }