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