thread.c 28 KB
Newer Older
1
/* Threading code.
2
Copyright (C) 2012-2017 Free Software Foundation, Inc.
3 4 5 6 7 8 9 10 11 12 13 14 15 16

This file is part of GNU Emacs.

GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

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 21 22


#include <config.h>
#include <setjmp.h>
#include "lisp.h"
23 24
#include "character.h"
#include "buffer.h"
Tom Tromey's avatar
Tom Tromey committed
25
#include "process.h"
26
#include "coding.h"
27
#include "syssignal.h"
28

29
static struct thread_state main_thread;
30

31
struct thread_state *current_thread = &main_thread;
32

33
static struct thread_state *all_threads = &main_thread;
34

Tom Tromey's avatar
Tom Tromey committed
35
static sys_mutex_t global_lock;
36

Ken Raeburn's avatar
Ken Raeburn committed
37 38
extern int poll_suppress_count;
extern volatile int interrupt_input_blocked;
39 40 41



Tom Tromey's avatar
Tom Tromey committed
42 43 44 45 46 47
/* m_specpdl is set when the thread is created and cleared when the
   thread dies.  */
#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)



Tom Tromey's avatar
Tom Tromey committed
48 49 50 51 52 53 54 55 56 57 58
static void
release_global_lock (void)
{
  sys_mutex_unlock (&global_lock);
}

/* You must call this after acquiring the global lock.
   acquire_global_lock does it for you.  */
static void
post_acquire_global_lock (struct thread_state *self)
{
59
  struct thread_state *prev_thread = current_thread;
Tom Tromey's avatar
Tom Tromey committed
60

61 62 63 64 65 66
  /* Do this early on, so that code below could signal errors (e.g.,
     unbind_for_thread_switch might) correctly, because we are already
     running in the context of the thread pointed by SELF.  */
  current_thread = self;

  if (prev_thread != current_thread)
Tom Tromey's avatar
Tom Tromey committed
67
    {
68
      /* PREV_THREAD is NULL if the previously current thread
69 70
	 exited.  In this case, there is no reason to unbind, and
	 trying will crash.  */
71 72
      if (prev_thread != NULL)
	unbind_for_thread_switch (prev_thread);
Tom Tromey's avatar
Tom Tromey committed
73 74
      rebind_for_thread_switch ();

75 76 77 78 79
       /* Set the new thread's current buffer.  This needs to be done
	  even if it is the same buffer as that of the previous thread,
	  because of thread-local bindings.  */
      set_buffer_internal_2 (current_buffer);
    }
Tom Tromey's avatar
Tom Tromey committed
80

81 82 83 84 85 86
   /* We could have been signaled while waiting to grab the global lock
      for the first time since this thread was created, in which case
      we didn't yet have the opportunity to set up the handlers.  Delay
      raising the signal in that case (it will be actually raised when
      the thread comes here after acquiring the lock the next time).  */
  if (!NILP (current_thread->error_symbol) && handlerlist)
Tom Tromey's avatar
Tom Tromey committed
87 88 89 90 91 92 93 94 95 96 97 98 99
    {
      Lisp_Object sym = current_thread->error_symbol;
      Lisp_Object data = current_thread->error_data;

      current_thread->error_symbol = Qnil;
      current_thread->error_data = Qnil;
      Fsignal (sym, data);
    }
}

static void
acquire_global_lock (struct thread_state *self)
{
100
  sys_mutex_lock (&global_lock);
Tom Tromey's avatar
Tom Tromey committed
101 102 103
  post_acquire_global_lock (self);
}

104 105 106 107 108 109
/* This is called from keyboard.c when it detects that SIGINT was
   delivered to the main thread and interrupted thread_select before
   the main thread could acquire the lock.  We must acquire the lock
   to prevent a thread from running without holding the global lock,
   and to avoid repeated calls to sys_mutex_unlock, which invokes
   undefined behavior.  */
110 111 112
void
maybe_reacquire_global_lock (void)
{
113 114 115 116 117
  /* SIGINT handler is always run on the main thread, see
     deliver_process_signal, so reflect that in our thread-tracking
     variables.  */
  current_thread = &main_thread;

118 119 120 121 122 123 124 125 126
  if (current_thread->not_holding_lock)
    {
      struct thread_state *self = current_thread;

      acquire_global_lock (self);
      current_thread->not_holding_lock = 0;
    }
}

Tom Tromey's avatar
Tom Tromey committed
127 128 129 130 131 132 133 134 135 136


static void
lisp_mutex_init (lisp_mutex_t *mutex)
{
  mutex->owner = NULL;
  mutex->count = 0;
  sys_cond_init (&mutex->condition);
}

137 138
/* Lock MUTEX for thread LOCKER, setting its lock count to COUNT, if
   non-zero, or to 1 otherwise.
139

140 141
   If MUTEX is locked by LOCKER, COUNT must be zero, and the MUTEX's
   lock count will be incremented.
142 143 144 145 146 147 148 149 150

   If MUTEX is locked by another thread, this function will release
   the global lock, giving other threads a chance to run, and will
   wait for the MUTEX to become unlocked; when MUTEX becomes unlocked,
   and will then re-acquire the global lock.

   Return value is 1 if the function waited for the MUTEX to become
   unlocked (meaning other threads could have run during the wait),
   zero otherwise.  */
Tom Tromey's avatar
Tom Tromey committed
151
static int
152 153
lisp_mutex_lock_for_thread (lisp_mutex_t *mutex, struct thread_state *locker,
			    int new_count)
Tom Tromey's avatar
Tom Tromey committed
154 155 156 157 158
{
  struct thread_state *self;

  if (mutex->owner == NULL)
    {
159
      mutex->owner = locker;
Tom Tromey's avatar
Tom Tromey committed
160 161
      mutex->count = new_count == 0 ? 1 : new_count;
      return 0;
Tom Tromey's avatar
Tom Tromey committed
162
    }
163
  if (mutex->owner == locker)
Tom Tromey's avatar
Tom Tromey committed
164
    {
Tom Tromey's avatar
Tom Tromey committed
165
      eassert (new_count == 0);
Tom Tromey's avatar
Tom Tromey committed
166
      ++mutex->count;
Tom Tromey's avatar
Tom Tromey committed
167
      return 0;
Tom Tromey's avatar
Tom Tromey committed
168 169
    }

170
  self = locker;
Tom Tromey's avatar
Tom Tromey committed
171
  self->wait_condvar = &mutex->condition;
Tom Tromey's avatar
Tom Tromey committed
172
  while (mutex->owner != NULL && (new_count != 0
Tom Tromey's avatar
Tom Tromey committed
173
				  || NILP (self->error_symbol)))
Tom Tromey's avatar
Tom Tromey committed
174 175 176
    sys_cond_wait (&mutex->condition, &global_lock);
  self->wait_condvar = NULL;

Tom Tromey's avatar
Tom Tromey committed
177 178
  if (new_count == 0 && !NILP (self->error_symbol))
    return 1;
Tom Tromey's avatar
Tom Tromey committed
179 180

  mutex->owner = self;
Tom Tromey's avatar
Tom Tromey committed
181 182 183
  mutex->count = new_count == 0 ? 1 : new_count;

  return 1;
Tom Tromey's avatar
Tom Tromey committed
184 185
}

186 187 188 189 190 191
static int
lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
{
  return lisp_mutex_lock_for_thread (mutex, current_thread, new_count);
}

192 193 194 195 196 197
/* Decrement MUTEX's lock count.  If the lock count becomes zero after
   decrementing it, meaning the mutex is now unlocked, broadcast that
   to all the threads that might be waiting to lock the mutex.  This
   function signals an error if MUTEX is locked by a thread other than
   the current one.  Return value is 1 if the mutex becomes unlocked,
   zero otherwise.  */
Tom Tromey's avatar
Tom Tromey committed
198
static int
Tom Tromey's avatar
Tom Tromey committed
199 200 201
lisp_mutex_unlock (lisp_mutex_t *mutex)
{
  if (mutex->owner != current_thread)
Eli Zaretskii's avatar
Eli Zaretskii committed
202
    error ("Cannot unlock mutex owned by another thread");
Tom Tromey's avatar
Tom Tromey committed
203 204

  if (--mutex->count > 0)
Tom Tromey's avatar
Tom Tromey committed
205
    return 0;
Tom Tromey's avatar
Tom Tromey committed
206 207 208 209

  mutex->owner = NULL;
  sys_cond_broadcast (&mutex->condition);

Tom Tromey's avatar
Tom Tromey committed
210 211 212
  return 1;
}

213 214
/* Like lisp_mutex_unlock, but sets MUTEX's lock count to zero
   regardless of its value.  Return the previous lock count.  */
Tom Tromey's avatar
Tom Tromey committed
215 216 217 218 219 220 221 222 223 224 225 226 227
static unsigned int
lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
{
  unsigned int result = mutex->count;

  /* Ensured by condvar code.  */
  eassert (mutex->owner == current_thread);

  mutex->count = 0;
  mutex->owner = NULL;
  sys_cond_broadcast (&mutex->condition);

  return result;
Tom Tromey's avatar
Tom Tromey committed
228 229 230 231 232 233 234 235
}

static void
lisp_mutex_destroy (lisp_mutex_t *mutex)
{
  sys_cond_destroy (&mutex->condition);
}

Tom Tromey's avatar
Tom Tromey committed
236 237 238 239 240 241
static int
lisp_mutex_owned_p (lisp_mutex_t *mutex)
{
  return mutex->owner == current_thread;
}

Tom Tromey's avatar
Tom Tromey committed
242 243


244
DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
245 246 247 248 249 250 251 252 253
       doc: /* Create a mutex.
A mutex provides a synchronization point for threads.
Only one thread at a time can hold a mutex.  Other threads attempting
to acquire it will block until the mutex is available.

A thread can acquire a mutex any number of times.

NAME, if given, is used as the name of the mutex.  The name is
informational only.  */)
254
  (Lisp_Object name)
255 256 257 258
{
  struct Lisp_Mutex *mutex;
  Lisp_Object result;

259 260 261
  if (!NILP (name))
    CHECK_STRING (name);

262 263 264 265
  mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
  memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
	  0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
						    mutex));
266
  mutex->name = name;
267 268 269 270 271 272 273 274 275 276
  lisp_mutex_init (&mutex->mutex);

  XSETMUTEX (result, mutex);
  return result;
}

static void
mutex_lock_callback (void *arg)
{
  struct Lisp_Mutex *mutex = arg;
Tom Tromey's avatar
Tom Tromey committed
277
  struct thread_state *self = current_thread;
278

279 280 281 282
  /* Calling lisp_mutex_lock might yield to other threads while this
     one waits for the mutex to become unlocked, so we need to
     announce us as the current thread by calling
     post_acquire_global_lock.  */
Tom Tromey's avatar
Tom Tromey committed
283 284
  if (lisp_mutex_lock (&mutex->mutex, 0))
    post_acquire_global_lock (self);
285 286
}

287 288
static void
do_unwind_mutex_lock (void)
289 290 291 292
{
  current_thread->event_object = Qnil;
}

293
DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
294 295 296 297 298
       doc: /* Acquire a mutex.
If the current thread already owns MUTEX, increment the count and
return.
Otherwise, if no thread owns MUTEX, make the current thread own it.
Otherwise, block until MUTEX is available, or until the current thread
Paul Eggert's avatar
Paul Eggert committed
299
is signaled using `thread-signal'.
300 301 302 303
Note that calls to `mutex-lock' and `mutex-unlock' must be paired.  */)
  (Lisp_Object mutex)
{
  struct Lisp_Mutex *lmutex;
304
  ptrdiff_t count = SPECPDL_INDEX ();
305

306 307
  CHECK_MUTEX (mutex);
  lmutex = XMUTEX (mutex);
308

309
  current_thread->event_object = mutex;
310
  record_unwind_protect_void (do_unwind_mutex_lock);
311
  flush_stack_call_func (mutex_lock_callback, lmutex);
312
  return unbind_to (count, Qnil);
313 314 315 316 317 318
}

static void
mutex_unlock_callback (void *arg)
{
  struct Lisp_Mutex *mutex = arg;
Tom Tromey's avatar
Tom Tromey committed
319
  struct thread_state *self = current_thread;
320

Tom Tromey's avatar
Tom Tromey committed
321
  if (lisp_mutex_unlock (&mutex->mutex))
322
    post_acquire_global_lock (self); /* FIXME: is this call needed? */
323 324 325
}

DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
326
       doc: /* Release the mutex.
Ken Raeburn's avatar
Ken Raeburn committed
327
If this thread does not own MUTEX, signal an error.
328 329 330
Otherwise, decrement the mutex's count.  If the count is zero,
release MUTEX.   */)
  (Lisp_Object mutex)
331
{
332
  struct Lisp_Mutex *lmutex;
333

334 335
  CHECK_MUTEX (mutex);
  lmutex = XMUTEX (mutex);
336

337
  flush_stack_call_func (mutex_unlock_callback, lmutex);
338 339 340
  return Qnil;
}

341
DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
342 343 344
       doc: /* Return the name of MUTEX.
If no name was given when MUTEX was created, return nil.  */)
  (Lisp_Object mutex)
345
{
346
  struct Lisp_Mutex *lmutex;
347

348 349
  CHECK_MUTEX (mutex);
  lmutex = XMUTEX (mutex);
350

351
  return lmutex->name;
352 353
}

354 355 356 357 358
void
finalize_one_mutex (struct Lisp_Mutex *mutex)
{
  lisp_mutex_destroy (&mutex->mutex);
}
359 360 361



Tom Tromey's avatar
Tom Tromey committed
362 363 364
DEFUN ("make-condition-variable",
       Fmake_condition_variable, Smake_condition_variable,
       1, 2, 0,
365
       doc: /* Make a condition variable associated with MUTEX.
Tom Tromey's avatar
Tom Tromey committed
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
A condition variable provides a way for a thread to sleep while
waiting for a state change.

MUTEX is the mutex associated with this condition variable.
NAME, if given, is the name of this condition variable.  The name is
informational only.  */)
  (Lisp_Object mutex, Lisp_Object name)
{
  struct Lisp_CondVar *condvar;
  Lisp_Object result;

  CHECK_MUTEX (mutex);
  if (!NILP (name))
    CHECK_STRING (name);

  condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
  memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
	  0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
						      cond));
  condvar->mutex = mutex;
  condvar->name = name;
  sys_cond_init (&condvar->cond);

  XSETCONDVAR (result, condvar);
  return result;
}

static void
condition_wait_callback (void *arg)
{
  struct Lisp_CondVar *cvar = arg;
  struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
  struct thread_state *self = current_thread;
  unsigned int saved_count;
  Lisp_Object cond;

  XSETCONDVAR (cond, cvar);
Tom Tromey's avatar
Tom Tromey committed
403
  self->event_object = cond;
Tom Tromey's avatar
Tom Tromey committed
404
  saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
Paul Eggert's avatar
Paul Eggert committed
405
  /* If signaled while unlocking, skip the wait but reacquire the lock.  */
Tom Tromey's avatar
Tom Tromey committed
406 407 408
  if (NILP (self->error_symbol))
    {
      self->wait_condvar = &cvar->cond;
409
      /* This call could switch to another thread.  */
Tom Tromey's avatar
Tom Tromey committed
410 411 412
      sys_cond_wait (&cvar->cond, &global_lock);
      self->wait_condvar = NULL;
    }
Tom Tromey's avatar
Tom Tromey committed
413
  self->event_object = Qnil;
414 415 416 417 418 419 420 421
  /* Since sys_cond_wait could switch threads, we need to lock the
     mutex for the thread which was the current when we were called,
     otherwise lisp_mutex_lock will record the wrong thread as the
     owner of the mutex lock.  */
  lisp_mutex_lock_for_thread (&mutex->mutex, self, saved_count);
  /* Calling lisp_mutex_lock_for_thread might yield to other threads
     while this one waits for the mutex to become unlocked, so we need
     to announce us as the current thread by calling
422
     post_acquire_global_lock.  */
423
  post_acquire_global_lock (self);
Tom Tromey's avatar
Tom Tromey committed
424 425 426
}

DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
427 428
       doc: /* Wait for the condition variable COND to be notified.
COND is the condition variable to wait on.
Tom Tromey's avatar
Tom Tromey committed
429

430
The mutex associated with COND must be held when this is called.
Tom Tromey's avatar
Tom Tromey committed
431 432
It is an error if it is not held.

433
This releases the mutex and waits for COND to be notified or for
Paul Eggert's avatar
Paul Eggert committed
434
this thread to be signaled with `thread-signal'.  When
435 436 437
`condition-wait' returns, COND's mutex will again be locked by
this thread.  */)
  (Lisp_Object cond)
Tom Tromey's avatar
Tom Tromey committed
438 439 440 441
{
  struct Lisp_CondVar *cvar;
  struct Lisp_Mutex *mutex;

442 443
  CHECK_CONDVAR (cond);
  cvar = XCONDVAR (cond);
Tom Tromey's avatar
Tom Tromey committed
444 445 446

  mutex = XMUTEX (cvar->mutex);
  if (!lisp_mutex_owned_p (&mutex->mutex))
Eli Zaretskii's avatar
Eli Zaretskii committed
447
    error ("Condition variable's mutex is not held by current thread");
Tom Tromey's avatar
Tom Tromey committed
448 449 450 451 452 453

  flush_stack_call_func (condition_wait_callback, cvar);

  return Qnil;
}

Paul Eggert's avatar
Paul Eggert committed
454
/* Used to communicate arguments to condition_notify_callback.  */
Tom Tromey's avatar
Tom Tromey committed
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
struct notify_args
{
  struct Lisp_CondVar *cvar;
  int all;
};

static void
condition_notify_callback (void *arg)
{
  struct notify_args *na = arg;
  struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
  struct thread_state *self = current_thread;
  unsigned int saved_count;
  Lisp_Object cond;

  XSETCONDVAR (cond, na->cvar);
  saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
  if (na->all)
    sys_cond_broadcast (&na->cvar->cond);
  else
    sys_cond_signal (&na->cvar->cond);
476 477 478 479
  /* Calling lisp_mutex_lock might yield to other threads while this
     one waits for the mutex to become unlocked, so we need to
     announce us as the current thread by calling
     post_acquire_global_lock.  */
Tom Tromey's avatar
Tom Tromey committed
480 481 482 483 484
  lisp_mutex_lock (&mutex->mutex, saved_count);
  post_acquire_global_lock (self);
}

DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
485 486
       doc: /* Notify COND, a condition variable.
This wakes a thread waiting on COND.
Tom Tromey's avatar
Tom Tromey committed
487 488
If ALL is non-nil, all waiting threads are awoken.

489
The mutex associated with COND must be held when this is called.
Tom Tromey's avatar
Tom Tromey committed
490 491
It is an error if it is not held.

492
This releases COND's mutex when notifying COND.  When
Tom Tromey's avatar
Tom Tromey committed
493 494
`condition-notify' returns, the mutex will again be locked by this
thread.  */)
495
  (Lisp_Object cond, Lisp_Object all)
Tom Tromey's avatar
Tom Tromey committed
496 497 498 499 500
{
  struct Lisp_CondVar *cvar;
  struct Lisp_Mutex *mutex;
  struct notify_args args;

501 502
  CHECK_CONDVAR (cond);
  cvar = XCONDVAR (cond);
Tom Tromey's avatar
Tom Tromey committed
503 504 505

  mutex = XMUTEX (cvar->mutex);
  if (!lisp_mutex_owned_p (&mutex->mutex))
Eli Zaretskii's avatar
Eli Zaretskii committed
506
    error ("Condition variable's mutex is not held by current thread");
Tom Tromey's avatar
Tom Tromey committed
507 508 509 510 511 512 513 514

  args.cvar = cvar;
  args.all = !NILP (all);
  flush_stack_call_func (condition_notify_callback, &args);

  return Qnil;
}

515
DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
516 517
       doc: /* Return the mutex associated with condition variable COND.  */)
  (Lisp_Object cond)
518 519 520
{
  struct Lisp_CondVar *cvar;

521 522
  CHECK_CONDVAR (cond);
  cvar = XCONDVAR (cond);
523 524 525 526 527

  return cvar->mutex;
}

DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
528 529 530
       doc: /* Return the name of condition variable COND.
If no name was given when COND was created, return nil.  */)
  (Lisp_Object cond)
531 532 533
{
  struct Lisp_CondVar *cvar;

534 535
  CHECK_CONDVAR (cond);
  cvar = XCONDVAR (cond);
536 537 538 539

  return cvar->name;
}

Tom Tromey's avatar
Tom Tromey committed
540 541 542 543 544 545 546 547
void
finalize_one_condvar (struct Lisp_CondVar *condvar)
{
  sys_cond_destroy (&condvar->cond);
}



Tom Tromey's avatar
Tom Tromey committed
548 549 550 551
struct select_args
{
  select_func *func;
  int max_fds;
Ken Raeburn's avatar
Ken Raeburn committed
552 553 554 555
  fd_set *rfds;
  fd_set *wfds;
  fd_set *efds;
  struct timespec *timeout;
Tom Tromey's avatar
Tom Tromey committed
556 557 558 559 560 561 562 563 564
  sigset_t *sigmask;
  int result;
};

static void
really_call_select (void *arg)
{
  struct select_args *sa = arg;
  struct thread_state *self = current_thread;
565
  sigset_t oldset;
Tom Tromey's avatar
Tom Tromey committed
566

567 568
  block_interrupt_signal (&oldset);
  self->not_holding_lock = 1;
Tom Tromey's avatar
Tom Tromey committed
569
  release_global_lock ();
570 571
  restore_signal_mask (&oldset);

Tom Tromey's avatar
Tom Tromey committed
572 573
  sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
			   sa->timeout, sa->sigmask);
574 575

  block_interrupt_signal (&oldset);
576 577 578 579 580 581 582 583 584
  /* If we were interrupted by C-g while inside sa->func above, the
     signal handler could have called maybe_reacquire_global_lock, in
     which case we are already holding the lock and shouldn't try
     taking it again, or else we will hang forever.  */
  if (self->not_holding_lock)
    {
      acquire_global_lock (self);
      self->not_holding_lock = 0;
    }
585
  restore_signal_mask (&oldset);
Tom Tromey's avatar
Tom Tromey committed
586 587 588
}

int
Ken Raeburn's avatar
Ken Raeburn committed
589 590
thread_select (select_func *func, int max_fds, fd_set *rfds,
	       fd_set *wfds, fd_set *efds, struct timespec *timeout,
Tom Tromey's avatar
Tom Tromey committed
591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607
	       sigset_t *sigmask)
{
  struct select_args sa;

  sa.func = func;
  sa.max_fds = max_fds;
  sa.rfds = rfds;
  sa.wfds = wfds;
  sa.efds = efds;
  sa.timeout = timeout;
  sa.sigmask = sigmask;
  flush_stack_call_func (really_call_select, &sa);
  return sa.result;
}



608 609 610
static void
mark_one_thread (struct thread_state *thread)
{
611 612
  /* Get the stack top now, in case mark_specpdl changes it.  */
  void *stack_top = thread->stack_top;
613

614
  mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
615

616
  mark_stack (thread->m_stack_bottom, stack_top);
617

618 619
  for (struct handler *handler = thread->m_handlerlist;
       handler; handler = handler->next)
620
    {
Ken Raeburn's avatar
Ken Raeburn committed
621 622
      mark_object (handler->tag_or_ch);
      mark_object (handler->val);
623 624 625 626
    }

  if (thread->m_current_buffer)
    {
627
      Lisp_Object tem;
628 629 630 631 632 633
      XSETBUFFER (tem, thread->m_current_buffer);
      mark_object (tem);
    }

  mark_object (thread->m_last_thing_searched);

634
  if (!NILP (thread->m_saved_last_thing_searched))
635 636 637 638 639 640 641 642 643
    mark_object (thread->m_saved_last_thing_searched);
}

static void
mark_threads_callback (void *ignore)
{
  struct thread_state *iter;

  for (iter = all_threads; iter; iter = iter->next_thread)
644 645 646 647 648 649 650
    {
      Lisp_Object thread_obj;

      XSETTHREAD (thread_obj, iter);
      mark_object (thread_obj);
      mark_one_thread (iter);
    }
651 652 653 654 655 656 657 658
}

void
mark_threads (void)
{
  flush_stack_call_func (mark_threads_callback, NULL);
}

659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681


static void
yield_callback (void *ignore)
{
  struct thread_state *self = current_thread;

  release_global_lock ();
  sys_thread_yield ();
  acquire_global_lock (self);
}

DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
       doc: /* Yield the CPU to another thread.  */)
     (void)
{
  flush_stack_call_func (yield_callback, NULL);
  return Qnil;
}

static Lisp_Object
invoke_thread_function (void)
{
682
  ptrdiff_t count = SPECPDL_INDEX ();
683 684 685 686 687

  Ffuncall (1, &current_thread->function);
  return unbind_to (count, Qnil);
}

688 689
static Lisp_Object last_thread_error;

690
static Lisp_Object
691
record_thread_error (Lisp_Object error_form)
692
{
693 694
  last_thread_error = error_form;
  return error_form;
695 696 697 698 699
}

static void *
run_thread (void *state)
{
700 701
  /* Make sure stack_top and m_stack_bottom are properly aligned as GC
     expects.  */
702
  max_align_t stack_pos;
703

704 705 706
  struct thread_state *self = state;
  struct thread_state **iter;

707
  self->m_stack_bottom = self->stack_top = (char *) &stack_pos;
708 709 710 711
  self->thread_id = sys_thread_self ();

  acquire_global_lock (self);

712 713 714 715 716 717 718 719 720
  /* Put a dummy catcher at top-level so that handlerlist is never NULL.
     This is important since handlerlist->nextfree holds the freelist
     which would otherwise leak every time we unwind back to top-level.   */
  handlerlist_sentinel = xzalloc (sizeof (struct handler));
  handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
  struct handler *c = push_handler (Qunbound, CATCHER);
  eassert (c == handlerlist_sentinel);
  handlerlist_sentinel->nextfree = NULL;
  handlerlist_sentinel->next = NULL;
Ken Raeburn's avatar
Ken Raeburn committed
721

722
  /* It might be nice to do something with errors here.  */
723
  internal_condition_case (invoke_thread_function, Qt, record_thread_error);
724

Tom Tromey's avatar
Tom Tromey committed
725 726
  update_processes_for_thread_death (Fcurrent_thread ());

Tom Tromey's avatar
Tom Tromey committed
727
  xfree (self->m_specpdl - 1);
728 729 730 731
  self->m_specpdl = NULL;
  self->m_specpdl_ptr = NULL;
  self->m_specpdl_size = 0;

Ken Raeburn's avatar
Ken Raeburn committed
732 733 734 735 736 737 738 739 740
  {
    struct handler *c, *c_next;
    for (c = handlerlist_sentinel; c; c = c_next)
      {
	c_next = c->nextfree;
	xfree (c);
      }
  }

741
  current_thread = NULL;
742 743
  sys_cond_broadcast (&self->thread_condvar);

Tom Tromey's avatar
Tom Tromey committed
744 745 746 747 748 749 750 751
  /* Unlink this thread from the list of all threads.  Note that we
     have to do this very late, after broadcasting our death.
     Otherwise the GC may decide to reap the thread_state object,
     leading to crashes.  */
  for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
    ;
  *iter = (*iter)->next_thread;

752 753 754 755 756
  release_global_lock ();

  return NULL;
}

757
void
758
finalize_one_thread (struct thread_state *state)
759
{
760 761 762 763 764 765
  sys_cond_destroy (&state->thread_condvar);
}

DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
       doc: /* Start a new thread and run FUNCTION in it.
When the function exits, the thread dies.
766
If NAME is given, it must be a string; it names the new thread.  */)
767 768 769 770 771
  (Lisp_Object function, Lisp_Object name)
{
  sys_thread_t thr;
  struct thread_state *new_thread;
  Lisp_Object result;
772
  const char *c_name = NULL;
773
  size_t offset = offsetof (struct thread_state, m_stack_bottom);
774 775 776

  /* Can't start a thread in temacs.  */
  if (!initialized)
Eli Zaretskii's avatar
Eli Zaretskii committed
777
    emacs_abort ();
778

779 780 781
  if (!NILP (name))
    CHECK_STRING (name);

782
  new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom,
783
				      PVEC_THREAD);
Ken Raeburn's avatar
Ken Raeburn committed
784 785
  memset ((char *) new_thread + offset, 0,
	  sizeof (struct thread_state) - offset);
786 787 788 789 790 791 792 793

  new_thread->function = function;
  new_thread->name = name;
  new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
  new_thread->m_saved_last_thing_searched = Qnil;
  new_thread->m_current_buffer = current_thread->m_current_buffer;
  new_thread->error_symbol = Qnil;
  new_thread->error_data = Qnil;
794
  new_thread->event_object = Qnil;
795 796

  new_thread->m_specpdl_size = 50;
Tom Tromey's avatar
Tom Tromey committed
797 798 799 800
  new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
				   * sizeof (union specbinding));
  /* Skip the dummy entry.  */
  ++new_thread->m_specpdl;
801 802 803 804 805 806 807 808
  new_thread->m_specpdl_ptr = new_thread->m_specpdl;

  sys_cond_init (&new_thread->thread_condvar);

  /* We'll need locking here eventually.  */
  new_thread->next_thread = all_threads;
  all_threads = new_thread;

809 810 811 812
  if (!NILP (name))
    c_name = SSDATA (ENCODE_UTF_8 (name));

  if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
813 814 815
    {
      /* Restore the previous situation.  */
      all_threads = all_threads->next_thread;
Eli Zaretskii's avatar
Eli Zaretskii committed
816
#ifdef THREADS_ENABLED
817
      error ("Could not start a new thread");
Eli Zaretskii's avatar
Eli Zaretskii committed
818 819 820
#else
      error ("Concurrency is not supported in this configuration");
#endif
821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860
    }

  /* FIXME: race here where new thread might not be filled in?  */
  XSETTHREAD (result, new_thread);
  return result;
}

DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
       doc: /* Return the current thread.  */)
  (void)
{
  Lisp_Object result;
  XSETTHREAD (result, current_thread);
  return result;
}

DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
       doc: /* Return the name of the THREAD.
The name is the same object that was passed to `make-thread'.  */)
     (Lisp_Object thread)
{
  struct thread_state *tstate;

  CHECK_THREAD (thread);
  tstate = XTHREAD (thread);

  return tstate->name;
}

static void
thread_signal_callback (void *arg)
{
  struct thread_state *tstate = arg;
  struct thread_state *self = current_thread;

  sys_cond_broadcast (tstate->wait_condvar);
  post_acquire_global_lock (self);
}

DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
861 862 863
       doc: /* Signal an error in a thread.
This acts like `signal', but arranges for the signal to be raised
in THREAD.  If THREAD is the current thread, acts just like `signal'.
Tom Tromey's avatar
Tom Tromey committed
864 865
This will interrupt a blocked call to `mutex-lock', `condition-wait',
or `thread-join' in the target thread.  */)
866 867 868 869 870 871 872 873 874 875
  (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
{
  struct thread_state *tstate;

  CHECK_THREAD (thread);
  tstate = XTHREAD (thread);

  if (tstate == current_thread)
    Fsignal (error_symbol, data);

Paul Eggert's avatar
Paul Eggert committed
876
  /* What to do if thread is already signaled?  */
877 878 879 880 881 882 883 884 885 886 887
  /* What if error_symbol is Qnil?  */
  tstate->error_symbol = error_symbol;
  tstate->error_data = data;

  if (tstate->wait_condvar)
    flush_stack_call_func (thread_signal_callback, tstate);

  return Qnil;
}

DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
888
       doc: /* Return t if THREAD is alive, or nil if it has exited.  */)
889 890 891 892 893 894 895
  (Lisp_Object thread)
{
  struct thread_state *tstate;

  CHECK_THREAD (thread);
  tstate = XTHREAD (thread);

Tom Tromey's avatar
Tom Tromey committed
896
  return thread_alive_p (tstate) ? Qt : Qnil;
897 898
}

899
DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
900 901 902 903
       doc: /* Return the object that THREAD is blocking on.
If THREAD is blocked in `thread-join' on a second thread, return that
thread.
If THREAD is blocked in `mutex-lock', return the mutex.
Tom Tromey's avatar
Tom Tromey committed
904
If THREAD is blocked in `condition-wait', return the condition variable.
905
Otherwise, if THREAD is not blocked, return nil.  */)
906 907 908 909 910 911 912 913 914 915
  (Lisp_Object thread)
{
  struct thread_state *tstate;

  CHECK_THREAD (thread);
  tstate = XTHREAD (thread);

  return tstate->event_object;
}

916 917 918 919 920
static void
thread_join_callback (void *arg)
{
  struct thread_state *tstate = arg;
  struct thread_state *self = current_thread;
921
  Lisp_Object thread;
922

923 924
  XSETTHREAD (thread, tstate);
  self->event_object = thread;
925
  self->wait_condvar = &tstate->thread_condvar;
926
  while (thread_alive_p (tstate) && NILP (self->error_symbol))
927 928 929
    sys_cond_wait (self->wait_condvar, &global_lock);

  self->wait_condvar = NULL;
930
  self->event_object = Qnil;
931 932 933 934
  post_acquire_global_lock (self);
}

DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
935 936 937
       doc: /* Wait for THREAD to exit.
This blocks the current thread until THREAD exits or until
the current thread is signaled.
938
It is an error for a thread to try to join itself.  */)
939 940 941 942 943 944 945
  (Lisp_Object thread)
{
  struct thread_state *tstate;

  CHECK_THREAD (thread);
  tstate = XTHREAD (thread);

946
  if (tstate == current_thread)
Eli Zaretskii's avatar
Eli Zaretskii committed
947
    error ("Cannot join current thread");
948

949
  if (thread_alive_p (tstate))
950 951 952 953 954 955
    flush_stack_call_func (thread_join_callback, tstate);

  return Qnil;
}

DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
956
       doc: /* Return a list of all the live threads.  */)
957
  (void)
958 959 960 961 962 963
{
  Lisp_Object result = Qnil;
  struct thread_state *iter;

  for (iter = all_threads; iter; iter = iter->next_thread)
    {
Tom Tromey's avatar
Tom Tromey committed
964 965 966
      if (thread_alive_p (iter))
	{
	  Lisp_Object thread;
967

Tom Tromey's avatar
Tom Tromey committed
968 969 970
	  XSETTHREAD (thread, iter);
	  result = Fcons (thread, result);
	}
971 972 973 974 975
    }

  return result;
}

976 977 978 979 980 981 982
DEFUN ("thread-last-error", Fthread_last_error, Sthread_last_error, 0, 0, 0,
       doc: /* Return the last error form recorded by a dying thread.  */)
  (void)
{
  return last_thread_error;
}

983 984


985
bool
986 987 988 989 990 991 992 993 994 995
thread_check_current_buffer (struct buffer *buffer)
{
  struct thread_state *iter;

  for (iter = all_threads; iter; iter = iter->next_thread)
    {
      if (iter == current_thread)
	continue;

      if (iter->m_current_buffer == buffer)
996
	return true;
997 998
    }

999
  return false;
1000 1001 1002 1003
}



1004
static void
1005
init_main_thread (void)
1006
{
1007
  main_thread.header.size
1008
    = PSEUDOVECSIZE (struct thread_state, m_stack_bottom);
1009 1010 1011 1012 1013 1014 1015 1016
  XSETPVECTYPE (&main_thread, PVEC_THREAD);
  main_thread.m_last_thing_searched = Qnil;
  main_thread.m_saved_last_thing_searched = Qnil;
  main_thread.name = Qnil;
  main_thread.function = Qnil;
  main_thread.error_symbol = Qnil;
  main_thread.error_data = Qnil;
  main_thread.event_object = Qnil;
1017 1018
}

1019
bool
1020
main_thread_p (void *ptr)
1021
{
1022
  return ptr == &main_thread;
1023 1024
}

1025 1026 1027
void
init_threads_once (void)
{
1028
  init_main_thread ();
1029 1030
}

1031 1032 1033
void
init_threads (void)
{
1034 1035
  init_main_thread ();
  sys_cond_init (&main_thread.thread_condvar);
1036 1037
  sys_mutex_init (&global_lock);
  sys_mutex_lock (&global_lock);
1038 1039
  current_thread = &main_thread;
  main_thread.thread_id = sys_thread_self ();
1040
}
1041 1042 1043 1044

void
syms_of_threads (void)
{
1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066
#ifndef THREADS_ENABLED
  if (0)
#endif
    {
      defsubr (&Sthread_yield);
      defsubr (&Smake_thread);
      defsubr (&Scurrent_thread);
      defsubr (&Sthread_name);
      defsubr (&Sthread_signal);
      defsubr (&Sthread_alive_p);
      defsubr (&Sthread_join);
      defsubr (&Sthread_blocker);
      defsubr (&Sall_threads);
      defsubr (&Smake_mutex);
      defsubr (&Smutex_lock);
      defsubr (&Smutex_unlock);
      defsubr (&Smutex_name);
      defsubr (&Smake_condition_variable);
      defsubr (&Scondition_wait);
      defsubr (&Scondition_notify);
      defsubr (&Scondition_mutex);
      defsubr (&Scondition_name);
1067 1068 1069 1070
      defsubr (&Sthread_last_error);

      staticpro (&last_thread_error);
      last_thread_error = Qnil;
1071
    }
1072

Ken Raeburn's avatar
Ken Raeburn committed
1073 1074 1075
  DEFSYM (Qthreadp, "threadp");
  DEFSYM (Qmutexp, "mutexp");
  DEFSYM (Qcondition_variable_p, "condition-variable-p");
1076
}