thread.c 28.2 KB
Newer Older
1
/* Threading code.
Paul Eggert's avatar
Paul Eggert committed
2
Copyright (C) 2012-2019 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
/* m_specpdl is set when the thread is created and cleared when the
   thread dies.  */
44
#define thread_live_p(STATE) ((STATE)->m_specpdl != NULL)
Tom Tromey's avatar
Tom Tromey committed
45 46 47



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)
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))
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))
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
    {
      Lisp_Object thread_obj;

      XSETTHREAD (thread_obj, iter);
648
      mark_object (thread_obj);
649 650
      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
void
unmark_main_thread (void)
{
  main_thread.header.size &= ~ARRAY_MARK_FLAG;
}

665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687


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)
{
688
  ptrdiff_t count = SPECPDL_INDEX ();
689 690 691 692 693

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

694 695
static Lisp_Object last_thread_error;

696
static Lisp_Object
697
record_thread_error (Lisp_Object error_form)
698
{
699 700
  last_thread_error = error_form;
  return error_form;
701 702 703 704 705
}

static void *
run_thread (void *state)
{
706 707
  /* Make sure stack_top and m_stack_bottom are properly aligned as GC
     expects.  */
708
  max_align_t stack_pos;
709

710 711 712
  struct thread_state *self = state;
  struct thread_state **iter;

713
  self->m_stack_bottom = self->stack_top = (char *) &stack_pos;
714 715 716 717
  self->thread_id = sys_thread_self ();

  acquire_global_lock (self);

718 719 720 721 722 723 724 725 726
  /* 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
727

728
  /* It might be nice to do something with errors here.  */
729
  internal_condition_case (invoke_thread_function, Qt, record_thread_error);
730

Tom Tromey's avatar
Tom Tromey committed
731 732
  update_processes_for_thread_death (Fcurrent_thread ());

Tom Tromey's avatar
Tom Tromey committed
733
  xfree (self->m_specpdl - 1);
734 735 736 737
  self->m_specpdl = NULL;
  self->m_specpdl_ptr = NULL;
  self->m_specpdl_size = 0;

Ken Raeburn's avatar
Ken Raeburn committed
738 739 740 741 742 743 744 745 746
  {
    struct handler *c, *c_next;
    for (c = handlerlist_sentinel; c; c = c_next)
      {
	c_next = c->nextfree;
	xfree (c);
      }
  }

747
  current_thread = NULL;
748 749
  sys_cond_broadcast (&self->thread_condvar);

Tom Tromey's avatar
Tom Tromey committed
750 751 752 753 754 755 756 757
  /* 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;

758 759 760 761 762
  release_global_lock ();

  return NULL;
}

763
void
764
finalize_one_thread (struct thread_state *state)
765
{
766 767 768 769 770 771
  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.
772
If NAME is given, it must be a string; it names the new thread.  */)
773 774 775 776 777
  (Lisp_Object function, Lisp_Object name)
{
  sys_thread_t thr;
  struct thread_state *new_thread;
  Lisp_Object result;
778
  const char *c_name = NULL;
779
  size_t offset = offsetof (struct thread_state, m_stack_bottom);
780 781 782

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

785 786 787
  if (!NILP (name))
    CHECK_STRING (name);

788
  new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_stack_bottom,
789
				      PVEC_THREAD);
Ken Raeburn's avatar
Ken Raeburn committed
790 791
  memset ((char *) new_thread + offset, 0,
	  sizeof (struct thread_state) - offset);
792 793 794 795 796 797 798 799

  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;
800
  new_thread->event_object = Qnil;
801 802

  new_thread->m_specpdl_size = 50;
Tom Tromey's avatar
Tom Tromey committed
803 804 805 806
  new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
				   * sizeof (union specbinding));
  /* Skip the dummy entry.  */
  ++new_thread->m_specpdl;
807 808 809 810 811 812 813 814
  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;

815 816 817 818
  if (!NILP (name))
    c_name = SSDATA (ENCODE_UTF_8 (name));

  if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
819 820 821
    {
      /* Restore the previous situation.  */
      all_threads = all_threads->next_thread;
Eli Zaretskii's avatar
Eli Zaretskii committed
822
#ifdef THREADS_ENABLED
823
      error ("Could not start a new thread");
Eli Zaretskii's avatar
Eli Zaretskii committed
824 825 826
#else
      error ("Concurrency is not supported in this configuration");
#endif
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 861 862 863 864 865 866
    }

  /* 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,
867 868 869
       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
870 871
This will interrupt a blocked call to `mutex-lock', `condition-wait',
or `thread-join' in the target thread.  */)
872 873 874 875 876 877 878 879 880 881
  (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
882
  /* What to do if thread is already signaled?  */
883 884 885 886 887 888 889 890 891 892
  /* 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;
}

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 896 897 898 899 900 901
  (Lisp_Object thread)
{
  struct thread_state *tstate;

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

902
  return thread_live_p (tstate) ? Qt : Qnil;
903 904
}

905
DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
906 907 908 909
       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
910
If THREAD is blocked in `condition-wait', return the condition variable.
911
Otherwise, if THREAD is not blocked, return nil.  */)
912 913 914 915 916 917 918 919 920 921
  (Lisp_Object thread)
{
  struct thread_state *tstate;

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

  return tstate->event_object;
}

922 923 924 925 926
static void
thread_join_callback (void *arg)
{
  struct thread_state *tstate = arg;
  struct thread_state *self = current_thread;
927
  Lisp_Object thread;
928

929 930
  XSETTHREAD (thread, tstate);
  self->event_object = thread;
931
  self->wait_condvar = &tstate->thread_condvar;
932
  while (thread_live_p (tstate) && NILP (self->error_symbol))
933 934 935
    sys_cond_wait (self->wait_condvar, &global_lock);

  self->wait_condvar = NULL;
936
  self->event_object = Qnil;
937 938 939 940
  post_acquire_global_lock (self);
}

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

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

952
  if (tstate == current_thread)
953
    error ("Cannot join current thread");
954

955
  if (thread_live_p (tstate))
956 957 958 959 960 961
    flush_stack_call_func (thread_join_callback, tstate);

  return Qnil;
}

DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
962
       doc: /* Return a list of all the live threads.  */)
963
  (void)
964 965 966 967 968 969
{
  Lisp_Object result = Qnil;
  struct thread_state *iter;

  for (iter = all_threads; iter; iter = iter->next_thread)
    {
970
      if (thread_live_p (iter))
Tom Tromey's avatar
Tom Tromey committed
971 972
	{
	  Lisp_Object thread;
973

Tom Tromey's avatar
Tom Tromey committed
974 975 976
	  XSETTHREAD (thread, iter);
	  result = Fcons (thread, result);
	}
977 978 979 980 981
    }

  return result;
}

982 983 984 985 986 987 988
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;
}

989 990


991
bool
992 993 994 995 996 997 998 999 1000 1001
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)
1002
	return true;
1003 1004
    }

1005
  return false;
1006 1007 1008 1009
}



1010
static void
1011
init_main_thread (void)
1012
{
1013
  main_thread.header.size
1014
    = PSEUDOVECSIZE (struct thread_state, m_stack_bottom);
1015 1016 1017 1018 1019 1020 1021 1022
  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;
1023 1024
}

1025
bool
1026
main_thread_p (void *ptr)
1027
{
1028
  return ptr == &main_thread;
1029 1030
}

1031 1032 1033
void
init_threads_once (void)
{
1034
  init_main_thread ();
1035 1036
}

1037 1038 1039
void
init_threads (void)
{
1040 1041
  init_main_thread ();
  sys_cond_init (&main_thread.thread_condvar);
1042 1043
  sys_mutex_init (&global_lock);
  sys_mutex_lock (&global_lock);
1044 1045
  current_thread = &main_thread;
  main_thread.thread_id = sys_thread_self ();
1046
}
1047 1048 1049 1050

void
syms_of_threads (void)
{
1051 1052 1053 1054 1055 1056 1057 1058 1059
#ifndef THREADS_ENABLED
  if (0)
#endif
    {
      defsubr (&Sthread_yield);
      defsubr (&Smake_thread);
      defsubr (&Scurrent_thread);
      defsubr (&Sthread_name);
      defsubr (&Sthread_signal);
1060
      defsubr (&Sthread_live_p);
1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072
      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);
1073 1074 1075 1076
      defsubr (&Sthread_last_error);

      staticpro (&last_thread_error);
      last_thread_error = Qnil;
Michael Albinus's avatar
Michael Albinus committed
1077

1078 1079 1080
      Fdefalias (intern_c_string ("thread-alive-p"),
		 intern_c_string ("thread-live-p"), Qnil);

Michael Albinus's avatar
Michael Albinus committed
1081
      Fprovide (intern_c_string ("threads"), Qnil);
1082
    }
1083

Ken Raeburn's avatar
Ken Raeburn committed
1084 1085 1086
  DEFSYM (Qthreadp, "threadp");
  DEFSYM (Qmutexp, "mutexp");
  DEFSYM (Qcondition_variable_p, "condition-variable-p");
1087
}