root/src/thread.c

DEFINITIONS

1. release_global_lock
2. rebind_for_thread_switch
3. unbind_for_thread_switch
4. post_acquire_global_lock
5. acquire_global_lock
6. maybe_reacquire_global_lock
7. lisp_mutex_init
8. lisp_mutex_lock_for_thread
9. lisp_mutex_lock
10. lisp_mutex_unlock
11. lisp_mutex_unlock_for_wait
12. lisp_mutex_destroy
13. lisp_mutex_owned_p
14. DEFUN
15. mutex_lock_callback
16. do_unwind_mutex_lock
17. DEFUN
18. mutex_unlock_callback
19. DEFUN
20. DEFUN
21. finalize_one_mutex
22. condition_wait_callback
23. DEFUN
24. condition_notify_callback
25. DEFUN
26. DEFUN
27. finalize_one_condvar
28. really_call_select
29. thread_select
30. mark_one_thread
31. mark_threads_callback
32. mark_threads
33. unmark_main_thread
34. yield_callback
35. DEFUN
36. invoke_thread_function
37. record_thread_error
38. run_thread
39. free_search_regs
40. finalize_one_thread
41. DEFUN
42. DEFUN
43. thread_signal_callback
44. DEFUN
45. DEFUN
46. thread_join_callback
47. DEFUN
48. DEFUN
49. DEFUN
50. thread_check_current_buffer
51. main_thread_p
52. in_current_thread
53. init_threads
54. syms_of_threads

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