2 Copyright (C) 2012 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 <http://www.gnu.org/licenses/>. */
23 #include "character.h"
28 extern void unbind_for_thread_switch (void);
29 extern void rebind_for_thread_switch (void);
31 static struct thread_state primary_thread
;
33 struct thread_state
*current_thread
= &primary_thread
;
35 static struct thread_state
*all_threads
= &primary_thread
;
37 sys_mutex_t global_lock
;
39 Lisp_Object Qthreadp
, Qmutexp
;
43 DEFUN ("make-mutex", Fmake_mutex
, Smake_mutex
, 0, 1, 0,
47 struct Lisp_Mutex
*mutex
;
50 mutex
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex
, mutex
, PVEC_MUTEX
);
51 memset ((char *) mutex
+ offsetof (struct Lisp_Mutex
, mutex
),
52 0, sizeof (struct Lisp_Mutex
) - offsetof (struct Lisp_Mutex
,
55 lisp_mutex_init (&mutex
->mutex
);
57 XSETMUTEX (result
, mutex
);
62 mutex_lock_callback (void *arg
)
64 struct Lisp_Mutex
*mutex
= arg
;
66 /* This calls post_acquire_global_lock. */
67 lisp_mutex_lock (&mutex
->mutex
);
71 do_unwind_mutex_lock (Lisp_Object ignore
)
73 current_thread
->event_object
= Qnil
;
77 DEFUN ("mutex-lock", Fmutex_lock
, Smutex_lock
, 1, 1, 0,
81 struct Lisp_Mutex
*mutex
;
82 ptrdiff_t count
= SPECPDL_INDEX ();
87 current_thread
->event_object
= obj
;
88 record_unwind_protect (do_unwind_mutex_lock
, Qnil
);
89 flush_stack_call_func (mutex_lock_callback
, mutex
);
90 return unbind_to (count
, Qnil
);
94 mutex_unlock_callback (void *arg
)
96 struct Lisp_Mutex
*mutex
= arg
;
98 /* This calls post_acquire_global_lock. */
99 lisp_mutex_unlock (&mutex
->mutex
);
102 DEFUN ("mutex-unlock", Fmutex_unlock
, Smutex_unlock
, 1, 1, 0,
106 struct Lisp_Mutex
*mutex
;
109 mutex
= XMUTEX (obj
);
111 flush_stack_call_func (mutex_unlock_callback
, mutex
);
115 DEFUN ("mutex-name", Fmutex_name
, Smutex_name
, 1, 1, 0,
119 struct Lisp_Mutex
*mutex
;
122 mutex
= XMUTEX (obj
);
128 finalize_one_mutex (struct Lisp_Mutex
*mutex
)
130 lisp_mutex_destroy (&mutex
->mutex
);
136 release_global_lock (void)
138 sys_mutex_unlock (&global_lock
);
141 /* You must call this after acquiring the global lock.
142 acquire_global_lock does it for you. */
144 post_acquire_global_lock (struct thread_state
*self
)
148 if (self
!= current_thread
)
150 unbind_for_thread_switch ();
151 current_thread
= self
;
152 rebind_for_thread_switch ();
155 /* We need special handling to re-set the buffer. */
156 XSETBUFFER (buffer
, self
->m_current_buffer
);
157 self
->m_current_buffer
= 0;
158 set_buffer_internal (XBUFFER (buffer
));
160 if (!EQ (current_thread
->error_symbol
, Qnil
))
162 Lisp_Object sym
= current_thread
->error_symbol
;
163 Lisp_Object data
= current_thread
->error_data
;
165 current_thread
->error_symbol
= Qnil
;
166 current_thread
->error_data
= Qnil
;
172 acquire_global_lock (struct thread_state
*self
)
174 sys_mutex_lock (&global_lock
);
175 post_acquire_global_lock (self
);
193 really_call_select (void *arg
)
195 struct select_args
*sa
= arg
;
196 struct thread_state
*self
= current_thread
;
198 release_global_lock ();
199 sa
->result
= (sa
->func
) (sa
->max_fds
, sa
->rfds
, sa
->wfds
, sa
->efds
,
200 sa
->timeout
, sa
->sigmask
);
201 acquire_global_lock (self
);
205 thread_select (select_func
*func
, int max_fds
, SELECT_TYPE
*rfds
,
206 SELECT_TYPE
*wfds
, SELECT_TYPE
*efds
, EMACS_TIME
*timeout
,
209 struct select_args sa
;
212 sa
.max_fds
= max_fds
;
216 sa
.timeout
= timeout
;
217 sa
.sigmask
= sigmask
;
218 flush_stack_call_func (really_call_select
, &sa
);
225 mark_one_thread (struct thread_state
*thread
)
227 struct specbinding
*bind
;
228 struct handler
*handler
;
231 for (bind
= thread
->m_specpdl
; bind
!= thread
->m_specpdl_ptr
; bind
++)
233 mark_object (bind
->symbol
);
234 mark_object (bind
->old_value
);
235 mark_object (bind
->saved_value
);
238 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
239 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
240 mark_stack (thread
->m_stack_bottom
, thread
->stack_top
);
244 for (tail
= thread
->m_gcprolist
; tail
; tail
= tail
->next
)
245 for (i
= 0; i
< tail
->nvars
; i
++)
246 mark_object (tail
->var
[i
]);
250 if (thread
->m_byte_stack_list
)
251 mark_byte_stack (thread
->m_byte_stack_list
);
254 mark_catchlist (thread
->m_catchlist
);
256 for (handler
= thread
->m_handlerlist
; handler
; handler
= handler
->next
)
258 mark_object (handler
->handler
);
259 mark_object (handler
->var
);
262 mark_backtrace (thread
->m_backtrace_list
);
265 if (thread
->m_current_buffer
)
267 XSETBUFFER (tem
, thread
->m_current_buffer
);
271 mark_object (thread
->m_last_thing_searched
);
273 if (thread
->m_saved_last_thing_searched
)
274 mark_object (thread
->m_saved_last_thing_searched
);
278 mark_threads_callback (void *ignore
)
280 struct thread_state
*iter
;
282 for (iter
= all_threads
; iter
; iter
= iter
->next_thread
)
284 Lisp_Object thread_obj
;
286 XSETTHREAD (thread_obj
, iter
);
287 mark_object (thread_obj
);
288 mark_one_thread (iter
);
295 flush_stack_call_func (mark_threads_callback
, NULL
);
299 unmark_threads (void)
301 struct thread_state
*iter
;
303 for (iter
= all_threads
; iter
; iter
= iter
->next_thread
)
304 if (iter
->m_byte_stack_list
)
305 unmark_byte_stack (iter
->m_byte_stack_list
);
311 yield_callback (void *ignore
)
313 struct thread_state
*self
= current_thread
;
315 release_global_lock ();
317 acquire_global_lock (self
);
320 DEFUN ("thread-yield", Fthread_yield
, Sthread_yield
, 0, 0, 0,
321 doc
: /* Yield the CPU to another thread. */)
324 flush_stack_call_func (yield_callback
, NULL
);
329 invoke_thread_function (void)
333 int count
= SPECPDL_INDEX ();
335 Ffuncall (1, ¤t_thread
->function
);
336 return unbind_to (count
, Qnil
);
340 do_nothing (Lisp_Object whatever
)
346 run_thread (void *state
)
349 struct thread_state
*self
= state
;
350 struct thread_state
**iter
;
352 self
->m_stack_bottom
= &stack_pos
;
353 self
->stack_top
= self
->m_stack_bottom
= &stack_pos
;
354 self
->thread_id
= sys_thread_self ();
356 acquire_global_lock (self
);
358 /* It might be nice to do something with errors here. */
359 internal_condition_case (invoke_thread_function
, Qt
, do_nothing
);
361 unbind_for_thread_switch ();
363 update_processes_for_thread_death (Fcurrent_thread ());
365 /* Unlink this thread from the list of all threads. */
366 for (iter
= &all_threads
; *iter
!= self
; iter
= &(*iter
)->next_thread
)
368 *iter
= (*iter
)->next_thread
;
370 self
->m_last_thing_searched
= Qnil
;
371 self
->m_saved_last_thing_searched
= Qnil
;
373 self
->function
= Qnil
;
374 self
->error_symbol
= Qnil
;
375 self
->error_data
= Qnil
;
376 xfree (self
->m_specpdl
);
377 self
->m_specpdl
= NULL
;
378 self
->m_specpdl_ptr
= NULL
;
379 self
->m_specpdl_size
= 0;
381 sys_cond_broadcast (&self
->thread_condvar
);
383 release_global_lock ();
389 finalize_one_thread (struct thread_state
*state
)
391 sys_cond_destroy (&state
->thread_condvar
);
394 DEFUN ("make-thread", Fmake_thread
, Smake_thread
, 1, 2, 0,
395 doc
: /* Start a new thread and run FUNCTION in it.
396 When the function exits, the thread dies.
397 If NAME is given, it names the new thread. */)
398 (Lisp_Object function
, Lisp_Object name
)
401 struct thread_state
*new_thread
;
404 /* Can't start a thread in temacs. */
408 new_thread
= ALLOCATE_PSEUDOVECTOR (struct thread_state
, m_gcprolist
,
410 memset ((char *) new_thread
+ offsetof (struct thread_state
, m_gcprolist
),
411 0, sizeof (struct thread_state
) - offsetof (struct thread_state
,
414 new_thread
->function
= function
;
415 new_thread
->name
= name
;
416 new_thread
->m_last_thing_searched
= Qnil
; /* copy from parent? */
417 new_thread
->m_saved_last_thing_searched
= Qnil
;
418 new_thread
->m_current_buffer
= current_thread
->m_current_buffer
;
419 new_thread
->error_symbol
= Qnil
;
420 new_thread
->error_data
= Qnil
;
421 new_thread
->event_object
= Qnil
;
423 new_thread
->m_specpdl_size
= 50;
424 new_thread
->m_specpdl
= xmalloc (new_thread
->m_specpdl_size
425 * sizeof (struct specbinding
));
426 new_thread
->m_specpdl_ptr
= new_thread
->m_specpdl
;
428 sys_cond_init (&new_thread
->thread_condvar
);
430 /* We'll need locking here eventually. */
431 new_thread
->next_thread
= all_threads
;
432 all_threads
= new_thread
;
434 if (! sys_thread_create (&thr
, run_thread
, new_thread
))
436 /* Restore the previous situation. */
437 all_threads
= all_threads
->next_thread
;
438 error ("Could not start a new thread");
441 /* FIXME: race here where new thread might not be filled in? */
442 XSETTHREAD (result
, new_thread
);
446 DEFUN ("current-thread", Fcurrent_thread
, Scurrent_thread
, 0, 0, 0,
447 doc
: /* Return the current thread. */)
451 XSETTHREAD (result
, current_thread
);
455 DEFUN ("thread-name", Fthread_name
, Sthread_name
, 1, 1, 0,
456 doc
: /* Return the name of the THREAD.
457 The name is the same object that was passed to `make-thread'. */)
460 struct thread_state
*tstate
;
462 CHECK_THREAD (thread
);
463 tstate
= XTHREAD (thread
);
469 thread_signal_callback (void *arg
)
471 struct thread_state
*tstate
= arg
;
472 struct thread_state
*self
= current_thread
;
474 sys_cond_broadcast (tstate
->wait_condvar
);
475 post_acquire_global_lock (self
);
478 DEFUN ("thread-signal", Fthread_signal
, Sthread_signal
, 3, 3, 0,
480 (Lisp_Object thread
, Lisp_Object error_symbol
, Lisp_Object data
)
482 struct thread_state
*tstate
;
484 CHECK_THREAD (thread
);
485 tstate
= XTHREAD (thread
);
487 if (tstate
== current_thread
)
488 Fsignal (error_symbol
, data
);
490 /* What to do if thread is already signalled? */
491 /* What if error_symbol is Qnil? */
492 tstate
->error_symbol
= error_symbol
;
493 tstate
->error_data
= data
;
495 if (tstate
->wait_condvar
)
496 flush_stack_call_func (thread_signal_callback
, tstate
);
501 DEFUN ("thread-alive-p", Fthread_alive_p
, Sthread_alive_p
, 1, 1, 0,
505 struct thread_state
*tstate
;
507 CHECK_THREAD (thread
);
508 tstate
= XTHREAD (thread
);
510 /* m_specpdl is set when the thread is created and cleared when the
512 return tstate
->m_specpdl
== NULL
? Qnil
: Qt
;
515 DEFUN ("thread-blocker", Fthread_blocker
, Sthread_blocker
, 1, 1, 0,
519 struct thread_state
*tstate
;
521 CHECK_THREAD (thread
);
522 tstate
= XTHREAD (thread
);
524 return tstate
->event_object
;
528 thread_join_callback (void *arg
)
530 struct thread_state
*tstate
= arg
;
531 struct thread_state
*self
= current_thread
;
534 XSETTHREAD (thread
, tstate
);
535 self
->event_object
= thread
;
536 self
->wait_condvar
= &tstate
->thread_condvar
;
537 while (tstate
->m_specpdl
!= NULL
&& EQ (self
->error_symbol
, Qnil
))
538 sys_cond_wait (self
->wait_condvar
, &global_lock
);
540 self
->wait_condvar
= NULL
;
541 self
->event_object
= Qnil
;
542 post_acquire_global_lock (self
);
545 DEFUN ("thread-join", Fthread_join
, Sthread_join
, 1, 1, 0,
549 struct thread_state
*tstate
;
551 CHECK_THREAD (thread
);
552 tstate
= XTHREAD (thread
);
554 if (tstate
->m_specpdl
!= NULL
)
555 flush_stack_call_func (thread_join_callback
, tstate
);
560 DEFUN ("all-threads", Fall_threads
, Sall_threads
, 0, 0, 0,
561 doc
: /* Return a list of all threads. */)
564 Lisp_Object result
= Qnil
;
565 struct thread_state
*iter
;
567 for (iter
= all_threads
; iter
; iter
= iter
->next_thread
)
571 XSETTHREAD (thread
, iter
);
572 result
= Fcons (thread
, result
);
581 init_primary_thread (void)
583 primary_thread
.header
.size
584 = PSEUDOVECSIZE (struct thread_state
, m_gcprolist
);
585 XSETPVECTYPE (&primary_thread
, PVEC_THREAD
);
586 primary_thread
.m_last_thing_searched
= Qnil
;
587 primary_thread
.m_saved_last_thing_searched
= Qnil
;
588 primary_thread
.name
= Qnil
;
589 primary_thread
.function
= Qnil
;
590 primary_thread
.error_symbol
= Qnil
;
591 primary_thread
.error_data
= Qnil
;
592 primary_thread
.event_object
= Qnil
;
594 sys_cond_init (&primary_thread
.thread_condvar
);
598 init_threads_once (void)
600 init_primary_thread ();
606 init_primary_thread ();
608 sys_mutex_init (&global_lock
);
609 sys_mutex_lock (&global_lock
);
613 syms_of_threads (void)
615 defsubr (&Sthread_yield
);
616 defsubr (&Smake_thread
);
617 defsubr (&Scurrent_thread
);
618 defsubr (&Sthread_name
);
619 defsubr (&Sthread_signal
);
620 defsubr (&Sthread_alive_p
);
621 defsubr (&Sthread_join
);
622 defsubr (&Sthread_blocker
);
623 defsubr (&Sall_threads
);
624 defsubr (&Smake_mutex
);
625 defsubr (&Smutex_lock
);
626 defsubr (&Smutex_unlock
);
627 defsubr (&Smutex_name
);
629 Qthreadp
= intern_c_string ("threadp");
630 staticpro (&Qthreadp
);
631 Qmutexp
= intern_c_string ("mutexp");
632 staticpro (&Qmutexp
);