; * lisp/ldefs-boot.el: Update.
[emacs.git] / src / thread.c
blob47f55e7f67caafbde8808650136c9ac9d0eb2aa7
1 /* Threading code.
2 Copyright (C) 2012-2019 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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.
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.
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/>. */
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"
29 static struct thread_state main_thread;
31 struct thread_state *current_thread = &main_thread;
33 static struct thread_state *all_threads = &main_thread;
35 static sys_mutex_t global_lock;
37 extern int poll_suppress_count;
38 extern volatile int interrupt_input_blocked;
42 /* m_specpdl is set when the thread is created and cleared when the
43 thread dies. */
44 #define thread_live_p(STATE) ((STATE)->m_specpdl != NULL)
48 static void
49 release_global_lock (void)
51 sys_mutex_unlock (&global_lock);
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)
59 struct thread_state *prev_thread = current_thread;
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;
66 if (prev_thread != current_thread)
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 ();
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);
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)
88 Lisp_Object sym = current_thread->error_symbol;
89 Lisp_Object data = current_thread->error_data;
91 current_thread->error_symbol = Qnil;
92 current_thread->error_data = Qnil;
93 Fsignal (sym, data);
97 static void
98 acquire_global_lock (struct thread_state *self)
100 sys_mutex_lock (&global_lock);
101 post_acquire_global_lock (self);
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)
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;
118 if (current_thread->not_holding_lock)
120 struct thread_state *self = current_thread;
122 acquire_global_lock (self);
123 current_thread->not_holding_lock = 0;
129 static void
130 lisp_mutex_init (lisp_mutex_t *mutex)
132 mutex->owner = NULL;
133 mutex->count = 0;
134 sys_cond_init (&mutex->condition);
137 /* Lock MUTEX for thread LOCKER, setting its lock count to COUNT, if
138 non-zero, or to 1 otherwise.
140 If MUTEX is locked by LOCKER, COUNT must be zero, and the MUTEX's
141 lock count will be incremented.
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.
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)
155 struct thread_state *self;
157 if (mutex->owner == NULL)
159 mutex->owner = locker;
160 mutex->count = new_count == 0 ? 1 : new_count;
161 return 0;
163 if (mutex->owner == locker)
165 eassert (new_count == 0);
166 ++mutex->count;
167 return 0;
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;
177 if (new_count == 0 && !NILP (self->error_symbol))
178 return 1;
180 mutex->owner = self;
181 mutex->count = new_count == 0 ? 1 : new_count;
183 return 1;
186 static int
187 lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
189 return lisp_mutex_lock_for_thread (mutex, current_thread, new_count);
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)
201 if (mutex->owner != current_thread)
202 error ("Cannot unlock mutex owned by another thread");
204 if (--mutex->count > 0)
205 return 0;
207 mutex->owner = NULL;
208 sys_cond_broadcast (&mutex->condition);
210 return 1;
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)
218 unsigned int result = mutex->count;
220 /* Ensured by condvar code. */
221 eassert (mutex->owner == current_thread);
223 mutex->count = 0;
224 mutex->owner = NULL;
225 sys_cond_broadcast (&mutex->condition);
227 return result;
230 static void
231 lisp_mutex_destroy (lisp_mutex_t *mutex)
233 sys_cond_destroy (&mutex->condition);
236 static int
237 lisp_mutex_owned_p (lisp_mutex_t *mutex)
239 return mutex->owner == current_thread;
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.
250 A thread can acquire a mutex any number of times.
252 NAME, if given, is used as the name of the mutex. The name is
253 informational only. */)
254 (Lisp_Object name)
256 struct Lisp_Mutex *mutex;
257 Lisp_Object result;
259 if (!NILP (name))
260 CHECK_STRING (name);
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);
269 XSETMUTEX (result, mutex);
270 return result;
273 static void
274 mutex_lock_callback (void *arg)
276 struct Lisp_Mutex *mutex = arg;
277 struct thread_state *self = current_thread;
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);
287 static void
288 do_unwind_mutex_lock (void)
290 current_thread->event_object = Qnil;
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)
303 struct Lisp_Mutex *lmutex;
304 ptrdiff_t count = SPECPDL_INDEX ();
306 CHECK_MUTEX (mutex);
307 lmutex = XMUTEX (mutex);
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);
315 static void
316 mutex_unlock_callback (void *arg)
318 struct Lisp_Mutex *mutex = arg;
319 struct thread_state *self = current_thread;
321 if (lisp_mutex_unlock (&mutex->mutex))
322 post_acquire_global_lock (self); /* FIXME: is this call needed? */
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)
332 struct Lisp_Mutex *lmutex;
334 CHECK_MUTEX (mutex);
335 lmutex = XMUTEX (mutex);
337 flush_stack_call_func (mutex_unlock_callback, lmutex);
338 return Qnil;
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)
346 struct Lisp_Mutex *lmutex;
348 CHECK_MUTEX (mutex);
349 lmutex = XMUTEX (mutex);
351 return lmutex->name;
354 void
355 finalize_one_mutex (struct Lisp_Mutex *mutex)
357 lisp_mutex_destroy (&mutex->mutex);
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.
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)
374 struct Lisp_CondVar *condvar;
375 Lisp_Object result;
377 CHECK_MUTEX (mutex);
378 if (!NILP (name))
379 CHECK_STRING (name);
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);
389 XSETCONDVAR (result, condvar);
390 return result;
393 static void
394 condition_wait_callback (void *arg)
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;
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))
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;
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);
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.
430 The mutex associated with COND must be held when this is called.
431 It is an error if it is not held.
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)
439 struct Lisp_CondVar *cvar;
440 struct Lisp_Mutex *mutex;
442 CHECK_CONDVAR (cond);
443 cvar = XCONDVAR (cond);
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");
449 flush_stack_call_func (condition_wait_callback, cvar);
451 return Qnil;
454 /* Used to communicate arguments to condition_notify_callback. */
455 struct notify_args
457 struct Lisp_CondVar *cvar;
458 int all;
461 static void
462 condition_notify_callback (void *arg)
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;
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);
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.
489 The mutex associated with COND must be held when this is called.
490 It is an error if it is not held.
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)
497 struct Lisp_CondVar *cvar;
498 struct Lisp_Mutex *mutex;
499 struct notify_args args;
501 CHECK_CONDVAR (cond);
502 cvar = XCONDVAR (cond);
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");
508 args.cvar = cvar;
509 args.all = !NILP (all);
510 flush_stack_call_func (condition_notify_callback, &args);
512 return Qnil;
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)
519 struct Lisp_CondVar *cvar;
521 CHECK_CONDVAR (cond);
522 cvar = XCONDVAR (cond);
524 return cvar->mutex;
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)
532 struct Lisp_CondVar *cvar;
534 CHECK_CONDVAR (cond);
535 cvar = XCONDVAR (cond);
537 return cvar->name;
540 void
541 finalize_one_condvar (struct Lisp_CondVar *condvar)
543 sys_cond_destroy (&condvar->cond);
548 struct select_args
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;
560 static void
561 really_call_select (void *arg)
563 struct select_args *sa = arg;
564 struct thread_state *self = current_thread;
565 sigset_t oldset;
567 block_interrupt_signal (&oldset);
568 self->not_holding_lock = 1;
569 release_global_lock ();
570 restore_signal_mask (&oldset);
572 sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
573 sa->timeout, sa->sigmask);
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)
582 acquire_global_lock (self);
583 self->not_holding_lock = 0;
585 restore_signal_mask (&oldset);
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)
593 struct select_args sa;
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;
608 static void
609 mark_one_thread (struct thread_state *thread)
611 /* Get the stack top now, in case mark_specpdl changes it. */
612 void *stack_top = thread->stack_top;
614 mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
616 mark_stack (thread->m_stack_bottom, stack_top);
618 for (struct handler *handler = thread->m_handlerlist;
619 handler; handler = handler->next)
621 mark_object (handler->tag_or_ch);
622 mark_object (handler->val);
625 if (thread->m_current_buffer)
627 Lisp_Object tem;
628 XSETBUFFER (tem, thread->m_current_buffer);
629 mark_object (tem);
632 mark_object (thread->m_last_thing_searched);
634 if (!NILP (thread->m_saved_last_thing_searched))
635 mark_object (thread->m_saved_last_thing_searched);
638 static void
639 mark_threads_callback (void *ignore)
641 struct thread_state *iter;
643 for (iter = all_threads; iter; iter = iter->next_thread)
645 Lisp_Object thread_obj;
647 XSETTHREAD (thread_obj, iter);
648 mark_object (thread_obj);
649 mark_one_thread (iter);
653 void
654 mark_threads (void)
656 flush_stack_call_func (mark_threads_callback, NULL);
659 void
660 unmark_main_thread (void)
662 main_thread.header.size &= ~ARRAY_MARK_FLAG;
667 static void
668 yield_callback (void *ignore)
670 struct thread_state *self = current_thread;
672 release_global_lock ();
673 sys_thread_yield ();
674 acquire_global_lock (self);
677 DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
678 doc: /* Yield the CPU to another thread. */)
679 (void)
681 flush_stack_call_func (yield_callback, NULL);
682 return Qnil;
685 static Lisp_Object
686 invoke_thread_function (void)
688 ptrdiff_t count = SPECPDL_INDEX ();
690 Ffuncall (1, &current_thread->function);
691 return unbind_to (count, Qnil);
694 static Lisp_Object last_thread_error;
696 static Lisp_Object
697 record_thread_error (Lisp_Object error_form)
699 last_thread_error = error_form;
700 return error_form;
703 static void *
704 run_thread (void *state)
706 /* Make sure stack_top and m_stack_bottom are properly aligned as GC
707 expects. */
708 max_align_t stack_pos;
710 struct thread_state *self = state;
711 struct thread_state **iter;
713 self->m_stack_bottom = self->stack_top = (char *) &stack_pos;
714 self->thread_id = sys_thread_self ();
716 acquire_global_lock (self);
718 /* Put a dummy catcher at top-level so that handlerlist is never NULL.
719 This is important since handlerlist->nextfree holds the freelist
720 which would otherwise leak every time we unwind back to top-level. */
721 handlerlist_sentinel = xzalloc (sizeof (struct handler));
722 handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
723 struct handler *c = push_handler (Qunbound, CATCHER);
724 eassert (c == handlerlist_sentinel);
725 handlerlist_sentinel->nextfree = NULL;
726 handlerlist_sentinel->next = NULL;
728 /* It might be nice to do something with errors here. */
729 internal_condition_case (invoke_thread_function, Qt, record_thread_error);
731 update_processes_for_thread_death (Fcurrent_thread ());
733 xfree (self->m_specpdl - 1);
734 self->m_specpdl = NULL;
735 self->m_specpdl_ptr = NULL;
736 self->m_specpdl_size = 0;
739 struct handler *c, *c_next;
740 for (c = handlerlist_sentinel; c; c = c_next)
742 c_next = c->nextfree;
743 xfree (c);
747 current_thread = NULL;
748 sys_cond_broadcast (&self->thread_condvar);
750 /* Unlink this thread from the list of all threads. Note that we
751 have to do this very late, after broadcasting our death.
752 Otherwise the GC may decide to reap the thread_state object,
753 leading to crashes. */
754 for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
756 *iter = (*iter)->next_thread;
758 release_global_lock ();
760 return NULL;
763 void
764 finalize_one_thread (struct thread_state *state)
766 sys_cond_destroy (&state->thread_condvar);
769 DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
770 doc: /* Start a new thread and run FUNCTION in it.
771 When the function exits, the thread dies.
772 If NAME is given, it must be a string; it names the new thread. */)
773 (Lisp_Object function, Lisp_Object name)
775 sys_thread_t thr;
776 struct thread_state *new_thread;
777 Lisp_Object result;
778 const char *c_name = NULL;
779 size_t offset = offsetof (struct thread_state, m_stack_bottom);
781 /* Can't start a thread in temacs. */
782 if (!initialized)
783 emacs_abort ();
785 if (!NILP (name))
786 CHECK_STRING (name);
788 new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom,
789 PVEC_THREAD);
790 memset ((char *) new_thread + offset, 0,
791 sizeof (struct thread_state) - offset);
793 new_thread->function = function;
794 new_thread->name = name;
795 new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
796 new_thread->m_saved_last_thing_searched = Qnil;
797 new_thread->m_current_buffer = current_thread->m_current_buffer;
798 new_thread->error_symbol = Qnil;
799 new_thread->error_data = Qnil;
800 new_thread->event_object = Qnil;
802 new_thread->m_specpdl_size = 50;
803 new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
804 * sizeof (union specbinding));
805 /* Skip the dummy entry. */
806 ++new_thread->m_specpdl;
807 new_thread->m_specpdl_ptr = new_thread->m_specpdl;
809 sys_cond_init (&new_thread->thread_condvar);
811 /* We'll need locking here eventually. */
812 new_thread->next_thread = all_threads;
813 all_threads = new_thread;
815 if (!NILP (name))
816 c_name = SSDATA (ENCODE_UTF_8 (name));
818 if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
820 /* Restore the previous situation. */
821 all_threads = all_threads->next_thread;
822 #ifdef THREADS_ENABLED
823 error ("Could not start a new thread");
824 #else
825 error ("Concurrency is not supported in this configuration");
826 #endif
829 /* FIXME: race here where new thread might not be filled in? */
830 XSETTHREAD (result, new_thread);
831 return result;
834 DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
835 doc: /* Return the current thread. */)
836 (void)
838 Lisp_Object result;
839 XSETTHREAD (result, current_thread);
840 return result;
843 DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
844 doc: /* Return the name of the THREAD.
845 The name is the same object that was passed to `make-thread'. */)
846 (Lisp_Object thread)
848 struct thread_state *tstate;
850 CHECK_THREAD (thread);
851 tstate = XTHREAD (thread);
853 return tstate->name;
856 static void
857 thread_signal_callback (void *arg)
859 struct thread_state *tstate = arg;
860 struct thread_state *self = current_thread;
862 sys_cond_broadcast (tstate->wait_condvar);
863 post_acquire_global_lock (self);
866 DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
867 doc: /* Signal an error in a thread.
868 This acts like `signal', but arranges for the signal to be raised
869 in THREAD. If THREAD is the current thread, acts just like `signal'.
870 This will interrupt a blocked call to `mutex-lock', `condition-wait',
871 or `thread-join' in the target thread. */)
872 (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
874 struct thread_state *tstate;
876 CHECK_THREAD (thread);
877 tstate = XTHREAD (thread);
879 if (tstate == current_thread)
880 Fsignal (error_symbol, data);
882 /* What to do if thread is already signaled? */
883 /* What if error_symbol is Qnil? */
884 tstate->error_symbol = error_symbol;
885 tstate->error_data = data;
887 if (tstate->wait_condvar)
888 flush_stack_call_func (thread_signal_callback, tstate);
890 return Qnil;
893 DEFUN ("thread-live-p", Fthread_live_p, Sthread_live_p, 1, 1, 0,
894 doc: /* Return t if THREAD is alive, or nil if it has exited. */)
895 (Lisp_Object thread)
897 struct thread_state *tstate;
899 CHECK_THREAD (thread);
900 tstate = XTHREAD (thread);
902 return thread_live_p (tstate) ? Qt : Qnil;
905 DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
906 doc: /* Return the object that THREAD is blocking on.
907 If THREAD is blocked in `thread-join' on a second thread, return that
908 thread.
909 If THREAD is blocked in `mutex-lock', return the mutex.
910 If THREAD is blocked in `condition-wait', return the condition variable.
911 Otherwise, if THREAD is not blocked, return nil. */)
912 (Lisp_Object thread)
914 struct thread_state *tstate;
916 CHECK_THREAD (thread);
917 tstate = XTHREAD (thread);
919 return tstate->event_object;
922 static void
923 thread_join_callback (void *arg)
925 struct thread_state *tstate = arg;
926 struct thread_state *self = current_thread;
927 Lisp_Object thread;
929 XSETTHREAD (thread, tstate);
930 self->event_object = thread;
931 self->wait_condvar = &tstate->thread_condvar;
932 while (thread_live_p (tstate) && NILP (self->error_symbol))
933 sys_cond_wait (self->wait_condvar, &global_lock);
935 self->wait_condvar = NULL;
936 self->event_object = Qnil;
937 post_acquire_global_lock (self);
940 DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
941 doc: /* Wait for THREAD to exit.
942 This blocks the current thread until THREAD exits or until
943 the current thread is signaled.
944 It is an error for a thread to try to join itself. */)
945 (Lisp_Object thread)
947 struct thread_state *tstate;
949 CHECK_THREAD (thread);
950 tstate = XTHREAD (thread);
952 if (tstate == current_thread)
953 error ("Cannot join current thread");
955 if (thread_live_p (tstate))
956 flush_stack_call_func (thread_join_callback, tstate);
958 return Qnil;
961 DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
962 doc: /* Return a list of all the live threads. */)
963 (void)
965 Lisp_Object result = Qnil;
966 struct thread_state *iter;
968 for (iter = all_threads; iter; iter = iter->next_thread)
970 if (thread_live_p (iter))
972 Lisp_Object thread;
974 XSETTHREAD (thread, iter);
975 result = Fcons (thread, result);
979 return result;
982 DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 0, 0,
983 doc: /* Return the last error form recorded by a dying thread. */)
984 (void)
986 return last_thread_error;
991 bool
992 thread_check_current_buffer (struct buffer *buffer)
994 struct thread_state *iter;
996 for (iter = all_threads; iter; iter = iter->next_thread)
998 if (iter == current_thread)
999 continue;
1001 if (iter->m_current_buffer == buffer)
1002 return true;
1005 return false;
1010 static void
1011 init_main_thread (void)
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;
1025 bool
1026 main_thread_p (void *ptr)
1028 return ptr == &main_thread;
1031 void
1032 init_threads_once (void)
1034 init_main_thread ();
1037 void
1038 init_threads (void)
1040 init_main_thread ();
1041 sys_cond_init (&main_thread.thread_condvar);
1042 sys_mutex_init (&global_lock);
1043 sys_mutex_lock (&global_lock);
1044 current_thread = &main_thread;
1045 main_thread.thread_id = sys_thread_self ();
1048 void
1049 syms_of_threads (void)
1051 #ifndef THREADS_ENABLED
1052 if (0)
1053 #endif
1055 defsubr (&Sthread_yield);
1056 defsubr (&Smake_thread);
1057 defsubr (&Scurrent_thread);
1058 defsubr (&Sthread_name);
1059 defsubr (&Sthread_signal);
1060 defsubr (&Sthread_live_p);
1061 defsubr (&Sthread_join);
1062 defsubr (&Sthread_blocker);
1063 defsubr (&Sall_threads);
1064 defsubr (&Smake_mutex);
1065 defsubr (&Smutex_lock);
1066 defsubr (&Smutex_unlock);
1067 defsubr (&Smutex_name);
1068 defsubr (&Smake_condition_variable);
1069 defsubr (&Scondition_wait);
1070 defsubr (&Scondition_notify);
1071 defsubr (&Scondition_mutex);
1072 defsubr (&Scondition_name);
1073 defsubr (&Sthread_last_error);
1075 staticpro (&last_thread_error);
1076 last_thread_error = Qnil;
1078 Fdefalias (intern_c_string ("thread-alive-p"),
1079 intern_c_string ("thread-live-p"), Qnil);
1081 Fprovide (intern_c_string ("threads"), Qnil);
1084 DEFSYM (Qthreadp, "threadp");
1085 DEFSYM (Qmutexp, "mutexp");
1086 DEFSYM (Qcondition_variable_p, "condition-variable-p");