/**************************************************************************/
/*                                                                        */
/*                                 OCaml                                  */
/*                                                                        */
/*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt           */
/*                                                                        */
/*   Copyright 1995 Institut National de Recherche en Informatique et     */
/*     en Automatique.                                                    */
/*                                                                        */
/*   All rights reserved.  This file is distributed under the terms of    */
/*   the GNU Lesser General Public License version 2.1, with the          */
/*   special exception on linking described in the file LICENSE.          */
/*                                                                        */
/**************************************************************************/

#define CAML_INTERNALS
#define _GNU_SOURCE /* helps to find pthread_setname_np() */
#include "caml/config.h"

#if defined(_WIN32)
#  define WIN32_LEAN_AND_MEAN
#  include <windows.h>
#  include <process.h>
#  include <processthreadsapi.h>
#  include "caml/osdeps.h"

#  if defined(HAS_SETTHREADDESCRIPTION) && \
      !defined(HAS_DECL_SETTHREADDESCRIPTION)
WINBASEAPI HRESULT WINAPI
SetThreadDescription(HANDLE hThread, PCWSTR lpThreadDescription);
#  endif

#elif defined(HAS_PRCTL)
#  include <sys/prctl.h>
#elif defined(HAVE_PTHREAD_SETNAME_NP) || defined(HAVE_PTHREAD_SET_NAME_NP)
#  include <pthread.h>

#  if defined(HAS_PTHREAD_NP_H)
#    include <pthread_np.h>
#  endif
#endif

#include <stdbool.h>

#include "caml/alloc.h"
#include "caml/backtrace.h"
#include "caml/backtrace_prim.h"
#include "caml/callback.h"
#include "caml/custom.h"
#include "caml/debugger.h"
#include "caml/domain.h"
#include "caml/fail.h"
#include "caml/fiber.h"
#include "caml/io.h"
#include "caml/memory.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/printexc.h"
#include "caml/roots.h"
#include "caml/signals.h"
#include "caml/startup_aux.h"
#include "caml/sync.h"
#include "caml/sys.h"
#include "caml/memprof.h"

/* "caml/threads.h" is *not* included since it contains the _external_
   declarations for the caml_c_thread_register, caml_c_thread_register_in_domain
   and caml_c_thread_unregister functions. */

/* Max computation time before rescheduling, in milliseconds */
#define Thread_timeout_msec 50

typedef int st_retcode;

static void st_bt_lock_acquire(void) {

  /* We do not want to signal the backup thread if it is not "working"
     as it may very well not be, because we could have just resumed
     execution from another thread right away. */
  if (caml_bt_is_in_blocking_section()) {
    caml_bt_enter_ocaml();
  }

  caml_acquire_domain_lock();

  return;
}

static void st_bt_lock_release(bool other_threads_waiting) {

  /* Here we do want to signal the backup thread iff there's
     no thread waiting to be scheduled, and the backup thread is currently
     idle. */
  if (other_threads_waiting && caml_bt_is_in_blocking_section() == 0) {
    caml_bt_exit_ocaml();
  }

  caml_release_domain_lock();

  return;
}

/* OS-specific code */
#ifdef _WIN32
#include "st_win32.h"
#else
#include "st_posix.h"
#endif

/* The ML value describing a thread (heap-allocated) */

#define Ident(v) Field(v, 0)
#define Start_closure(v) Field(v, 1)
#define Terminated(v) Field(v, 2)

/* The infos on threads (allocated via caml_stat_alloc()) */

struct caml_thread_struct {

  value descr;              /* The heap-allocated descriptor (root) */
  struct caml_thread_struct * next; /* Doubly-linked list of running threads */
  struct caml_thread_struct * prev;
  int domain_id;      /* The id of the domain to which this thread belongs */
  struct stack_info* current_stack;      /* saved Caml_state->current_stack */
  struct c_stack_link* c_stack;          /* saved Caml_state->c_stack */
  /* Note: we do not save Caml_state->stack_cache, because it can
     safely be shared between all threads on the same domain. */
  struct caml__roots_block *local_roots; /* saved value of local_roots */
  int backtrace_pos;           /* saved value of Caml_state->backtrace_pos */
  backtrace_slot * backtrace_buffer;
    /* saved value of Caml_state->backtrace_buffer */
  value backtrace_last_exn;
    /* saved value of Caml_state->backtrace_last_exn (root) */
  value * gc_regs;           /* saved value of Caml_state->gc_regs */
  value * gc_regs_buckets;   /* saved value of Caml_state->gc_regs_buckets */
  void * exn_handler;        /* saved value of Caml_state->exn_handler */
  memprof_thread_t memprof;  /* memprof's internal thread data structure */
  void * signal_stack;       /* this thread's signal stack */

#ifndef NATIVE_CODE
  intnat trap_sp_off;      /* saved value of Caml_state->trap_sp_off */
  intnat trap_barrier_off; /* saved value of Caml_state->trap_barrier_off */
  struct caml_exception_context* external_raise;
    /* saved value of Caml_state->external_raise */
#endif
};

typedef struct caml_thread_struct* caml_thread_t;

/* Thread-local key for accessing the current thread's [caml_thread_t] */
st_tlskey caml_thread_key;

#define This_thread ((caml_thread_t) st_tls_get(caml_thread_key))

/* overall table for threads across domains */
struct caml_thread_table {
  caml_thread_t active_thread;
  st_masterlock thread_lock;
  int tick_thread_running;
  st_thread_id tick_thread_id;
  atomic_uintnat tick_thread_stop;
};

/* thread_table instance, up to caml_params->max_domains */
static struct caml_thread_table* thread_table;

#define Thread_lock(dom_id) &thread_table[dom_id].thread_lock

static void thread_lock_acquire(int dom_id)
{
  st_masterlock_acquire(Thread_lock(dom_id));
}

static void thread_lock_release(int dom_id)
{
  st_masterlock_release(Thread_lock(dom_id));
}

/* Used to signal that the "tick" thread for this domain should be stopped. */
#define Tick_thread_stop thread_table[Caml_state->id].tick_thread_stop

/* The remaining fields are accessed while holding the domain lock */

/* The descriptor for the currently executing thread for this domain;
   also the head of a circular list of thread descriptors for this
   domain. Invariant: at every safe point, either Active_thread is
   NULL, or Caml_state is setup for Active_thread. */
#define Active_thread thread_table[Caml_state->id].active_thread

/* Whether the "tick" thread is already running for this domain */
#define Tick_thread_running thread_table[Caml_state->id].tick_thread_running

/* The thread identifier of the "tick" thread for this domain */
#define Tick_thread_id thread_table[Caml_state->id].tick_thread_id

/* Identifier for next thread creation */
static atomic_uintnat thread_next_id = 0;

/* Forward declarations */
static value caml_threadstatus_new_exn (void);
static void caml_threadstatus_terminate (value);
static st_retcode caml_threadstatus_wait (value);

/* Hook for scanning the stacks of the other threads */

static scan_roots_hook prev_scan_roots_hook;

static void caml_thread_scan_roots(
  scanning_action action, scanning_action_flags fflags, void *fdata,
  caml_domain_state *domain_state)
{
  const caml_thread_t active = thread_table[domain_state->id].active_thread;
  caml_thread_t th = active;

  /* The GC could be triggered before [active_thread] is initialized,
     or after [caml_thread_domain_stop_hook] has been called; in this
     case do nothing. */
  if (active != NULL) {
    do {
      (*action)(fdata, th->descr, &th->descr);
      (*action)(fdata, th->backtrace_last_exn, &th->backtrace_last_exn);
      /* Don't rescan the stack of the current thread, it was done already */
      if (th != active) {
        if (th->current_stack != NULL)
          caml_do_local_roots(action, fflags, fdata,
                              th->local_roots, th->current_stack, th->gc_regs);
      }
      th = th->next;
    } while (th != active);
  }

  /* Hook */
  if (prev_scan_roots_hook != NULL)
    (*prev_scan_roots_hook)(action, fflags, fdata, domain_state);

  return;
}

/* Saving and restoring runtime state in this_thread */

static void save_runtime_state(void)
{
  CAMLassert(This_thread != NULL);
  caml_thread_t this_thread = This_thread;
  this_thread->current_stack = Caml_state->current_stack;
  this_thread->c_stack = Caml_state->c_stack;
  this_thread->gc_regs = Caml_state->gc_regs;
  this_thread->gc_regs_buckets = Caml_state->gc_regs_buckets;
  this_thread->exn_handler = Caml_state->exn_handler;
  this_thread->local_roots = Caml_state->local_roots;
  this_thread->backtrace_pos = Caml_state->backtrace_pos;
  this_thread->backtrace_buffer = Caml_state->backtrace_buffer;
  this_thread->backtrace_last_exn = Caml_state->backtrace_last_exn;
#ifndef NATIVE_CODE
  this_thread->trap_sp_off = Caml_state->trap_sp_off;
  this_thread->trap_barrier_off = Caml_state->trap_barrier_off;
  this_thread->external_raise = Caml_state->external_raise;
#endif
}

static void restore_runtime_state(caml_thread_t th)
{
  CAMLassert(th != NULL);
  Active_thread = th;
  Caml_state->current_stack = th->current_stack;
  Caml_state->c_stack = th->c_stack;
  Caml_state->gc_regs = th->gc_regs;
  Caml_state->gc_regs_buckets = th->gc_regs_buckets;
  Caml_state->exn_handler = th->exn_handler;
  Caml_state->local_roots = th->local_roots;
  Caml_state->backtrace_pos = th->backtrace_pos;
  Caml_state->backtrace_buffer = th->backtrace_buffer;
  caml_modify_generational_global_root
    (&Caml_state->backtrace_last_exn, th->backtrace_last_exn);
#ifndef NATIVE_CODE
  Caml_state->trap_sp_off = th->trap_sp_off;
  Caml_state->trap_barrier_off = th->trap_barrier_off;
  Caml_state->external_raise = th->external_raise;
#endif
  caml_memprof_enter_thread(th->memprof);
}

CAMLprim value caml_thread_cleanup(value unit);

static void reset_active(void)
{
  Active_thread = NULL;
  /* If no other OCaml thread remains, ask the tick thread to stop
     so that it does not prevent the whole process from exiting (#9971) */
  caml_thread_cleanup(Val_unit);
}

/* Hooks for caml_enter_blocking_section and caml_leave_blocking_section */

static void caml_thread_enter_blocking_section(void)
{
  /* Save the current runtime state in the thread descriptor
     of the current thread */
  save_runtime_state();
  /* Tell other threads that the runtime is free */
  thread_lock_release(Caml_state->id);
}

static void caml_thread_leave_blocking_section(void)
{
#ifdef _WIN32
  /* TlsGetValue (called in This_thread) calls SetLastError which will mask any
     error which occurred prior to the caml_thread_leave_blocking_section call.
     EnterCriticalSection does not do this. */
  DWORD error = GetLastError();
#endif
  caml_thread_t th = This_thread;
  /* Wait until the runtime is free */
  thread_lock_acquire(th->domain_id);
  /* Update Active_thread to point to the thread descriptor
     corresponding to the thread currently executing and restore the
     runtime state */
  restore_runtime_state(th);
#ifdef _WIN32
  SetLastError(error);
#endif
}

/* Create and setup a new thread info block.
   This block has no associated thread descriptor and
   is not inserted in the list of threads. */
static caml_thread_t caml_thread_new_info(void)
{
  caml_thread_t th = NULL;
  caml_domain_state *domain_state = Caml_state;
  uintnat stack_wsize = caml_get_init_stack_wsize();

  th = (caml_thread_t)caml_stat_alloc_noexc(sizeof(struct caml_thread_struct));
  if (th == NULL) return NULL;

  th->descr = Val_unit;
  th->next = NULL;
  th->prev = NULL;

  th->domain_id = domain_state->id;
  th->signal_stack = NULL;

  /* The remaining fields which store the values of the domain state
     must be initialized to a valid value, as in [domain_create]. */

  th->current_stack = caml_alloc_main_stack(stack_wsize);
  if (th->current_stack == NULL) goto out_err1;

  th->memprof = caml_memprof_new_thread(domain_state);
  if (th->memprof == NULL) goto out_err2;

  th->c_stack = NULL;
  th->local_roots = NULL;
  th->backtrace_pos = 0;
  th->backtrace_buffer = NULL;
  th->backtrace_last_exn = Val_unit;
  th->gc_regs = NULL;
  th->gc_regs_buckets = NULL;
  th->exn_handler = NULL;

#ifndef NATIVE_CODE
  th->trap_sp_off = 1;
  th->trap_barrier_off = 2; /* TODO: 0? trap_barrier_block? */
  th->external_raise = NULL;
#endif
  return th;

 out_err2:
  caml_free_stack(th->current_stack);
 out_err1:
  caml_stat_free(th);
  return NULL;
}

/* Free the resources held by a thread. */
void caml_thread_free_info(caml_thread_t th)
{
  /* the following fields do not need any specific cleanup:
     descr: heap-allocated
     c_stack: stack-allocated
     local_roots: stack-allocated
     backtrace_last_exn: heap-allocated
     gc_regs:
       must be empty for a terminated thread
       (we assume that the C call stack must be empty at
        thread-termination point, so there are no gc_regs buckets in
        use in this variable nor on the stack)
     exn_handler: stack-allocated
     external_raise: stack-allocated
     init_mask: stack-allocated
  */
  caml_memprof_delete_thread(th->memprof);
  caml_free_stack(th->current_stack);
  caml_free_backtrace_buffer(th->backtrace_buffer);

  /* Remark: we could share gc_regs_buckets between threads on a same
     domain, but this might break the invariant that it is always
     non-empty at the point where we switch from OCaml to C, so we
     would need to do something more complex when activating a thread
     to restore this invariant. */
  caml_free_gc_regs_buckets(th->gc_regs_buckets);

  caml_stat_free(th);
}

/* Allocate a thread descriptor block. */

static value caml_thread_new_descriptor_exn(value clos)
{
  CAMLparam1(clos);
  CAMLlocal1(mu);
  value descr;
  /* Create and initialize the termination semaphore */
  mu = caml_threadstatus_new_exn();
  if (Is_exception_result(mu)) CAMLreturn(mu);
  /* Create a descriptor for the new thread */
  descr = caml_alloc_3(0, Val_long(atomic_fetch_add(&thread_next_id, +1)),
                       clos, mu);
  CAMLreturn(descr);
}

/* Allocate a thread info block and add it to the list of threads */
static caml_thread_t thread_alloc_and_add(void)
{
  caml_thread_t th = caml_thread_new_info();

  if (th == NULL) return NULL;

  CAMLassert(Active_thread != NULL);
  th->next = Active_thread->next;
  th->prev = Active_thread;

  Active_thread->next->prev = th;
  Active_thread->next = th;

  return th;
}

/* Remove a thread info block from the list of threads
   and free its resources. */
static void thread_remove_and_free(caml_thread_t th)
{
  /* The main domain thread does not go through
     [thread_remove_and_free]. There is always one more thread in
     the chain at this point in time. */
  CAMLassert(th->next != th);

  if (Active_thread == th)
    restore_runtime_state(th->next); /* PR#5295 */
  th->next->prev = th->prev;
  th->prev->next = th->next;

  caml_thread_free_info(th);
  return;
}

/* Reinitialize the thread machinery after a fork() (PR#4577) */
/* TODO(engil): more work on the multicore fork machinery. */

static void caml_thread_reinitialize(void)
{
  /* caml_thread_reinitialize is called as part of the
     caml_atfork_hook, and therefore this function is executed right
     after a fork.

     Note: "If a multi-threaded process calls fork() [...] the child
     process may only execute async-signal-safe operations until such
     time as one of the exec functions is called." (POSIX fork())

     Keeping OCaml+threads running after a fork is best-effort, and
     relies on having a single domain whose domain lock ensures some
     consistency of state. (If there are other C threads running we
     are hopeless.)
  */

  caml_thread_t th, next;

  th = Active_thread->next;
  while (th != Active_thread) {
    next = th->next;
    caml_thread_free_info(th);
    th = next;
  }
  Active_thread->next = Active_thread;
  Active_thread->prev = Active_thread;

  /* Within the child, the domain_lock needs to be reset and acquired. */
  caml_reset_domain_lock();
  caml_acquire_domain_lock();
  /* The master lock needs to be initialized again. This process will also be
     the effective owner of the lock. So there is no need to run
     st_masterlock_acquire (busy = 1) */
  st_masterlock *m = Thread_lock(Caml_state->id);
  m->init = false; /* force reinitialization */
  /* Note: initializing an already-initialized mutex and cond variable
     is UB (especially mutexes that are locked). This is best
     effort. */
  if (st_masterlock_init(m) != 0)
    caml_fatal_error("Unix.fork: failed to reinitialize master lock");

  /* Reinitialize IO mutexes, in case the fork happened while another thread
     had locked the channel. If so, we're likely in an inconsistent state,
     but we may be able to proceed anyway. */
  for (struct channel *chan = caml_all_opened_channels;
       chan != NULL;
       chan = chan->next) {
    caml_plat_mutex_reinit(&chan->mutex);
  }
}

CAMLprim value caml_thread_join(value th);

/* This hook is run when a domain shuts down (see domains.c).

   When a domain shuts down, the state must be cleared to allow proper reuse of
   the domain slot the next time a domain is started on this slot. If a program
   is single-domain, we mimic OCaml 4's behavior and do not care about ongoing
   thread: the program will exit. */
static void caml_thread_domain_stop_hook(void) {
  /* If the program runs multiple domains, we should not let systhreads to hang
     around when a domain exits. If the domain is not the last one (and the last
     one will always be domain 0) we force the domain to join on every thread
     on its chain before wrapping up. */
  if (!caml_domain_alone()) {

    while (Active_thread->next != Active_thread) {
      caml_thread_join(Active_thread->next->descr);
    }

    /* Note: The rest of this function must not release the domain/thread lock:
     * The domain has joined with all active threads and no new ones
     * may be allowed to register at this point.
     */

    /* another domain thread may be joining on this domain's descriptor */
    caml_threadstatus_terminate(Terminated(Active_thread->descr));
    /* Shut down the tick thread */
    reset_active();
    /* We free the thread info but not its resources: they are owned
       by Caml_state at this point, and will be cleaned-up later. */
    caml_stat_free(This_thread);
  };
}

static value caml_thread_domain_initialize_hook_exn(void)
{
  value res = Val_unit;
  caml_thread_t new_thread;

  atomic_store_release(&Tick_thread_stop, 0);

  int ret = st_masterlock_init(Thread_lock(Caml_state->id));
  if (ret != 0)
    return caml_check_error_exn(ret, "caml_thread_domain_initialize_hook");

  new_thread =
    (caml_thread_t) caml_stat_alloc_noexc(sizeof(struct caml_thread_struct));
  if (new_thread == NULL) {
    res = Make_exception_result(caml_exception_out_of_memory());
    goto err1;
  }

  new_thread->domain_id = Caml_state->id;

  res = caml_thread_new_descriptor_exn(Val_unit);
  if (Is_exception_result(res)) goto err2;
  new_thread->descr = res;

  new_thread->next = new_thread;
  new_thread->prev = new_thread;
  new_thread->backtrace_last_exn = Val_unit;
  new_thread->memprof = caml_memprof_main_thread(Caml_state);
  new_thread->signal_stack = NULL;

  st_tls_set(caml_thread_key, new_thread);

  Active_thread = new_thread;
  caml_memprof_enter_thread(new_thread->memprof);
  return Val_unit;

 err2:
  caml_stat_free(new_thread);
 err1:
  st_masterlock_destroy(Thread_lock(Caml_state->id));
  return res;
}

static void thread_yield(void);

void caml_thread_interrupt_hook(void)
{
  /* Do not attempt to yield from the backup thread */
  if (caml_bt_is_self()) return;

  uintnat is_on = 1;
  atomic_uintnat* req_external_interrupt =
    &Caml_state->requested_external_interrupt;

  if (atomic_compare_exchange_strong(req_external_interrupt, &is_on, 0)) {
    thread_yield();
  }

  return;
}

static atomic_bool threads_initialized = false;

/* [caml_thread_initialize] initialises the systhreads infrastructure. This
   function first sets up the chain for systhreads on this domain, then setup
   the global variables and hooks for systhreads to cooperate with the runtime
   system. */
CAMLprim value caml_thread_initialize(value unit)
{
  /* Protect against repeated initialization (PR#3532) */
  if (threads_initialized) return Val_unit;

  if (!caml_domain_alone())
    caml_failwith("caml_thread_initialize: cannot initialize Thread "
                  "while several domains are running.");

  thread_table = caml_stat_calloc_noexc(caml_params->max_domains,
                                        sizeof(struct caml_thread_table));
  if (thread_table == NULL)
    caml_fatal_error("caml_thread_initialize: failed to allocate thread"
                     " table");

  /* Initialize the key to the [caml_thread_t] structure */
  st_tls_newkey(&caml_thread_key);

  /* First initialise the systhread chain on this domain */
  value res = caml_thread_domain_initialize_hook_exn();
  if (Is_exception_result(res)) caml_raise(Extract_exception(res));

  prev_scan_roots_hook = atomic_exchange(&caml_scan_roots_hook,
                                         caml_thread_scan_roots);
  caml_enter_blocking_section_hook = caml_thread_enter_blocking_section;
  caml_leave_blocking_section_hook = caml_thread_leave_blocking_section;
  caml_domain_external_interrupt_hook = caml_thread_interrupt_hook;
  caml_domain_initialize_hook_exn = caml_thread_domain_initialize_hook_exn;
  caml_domain_stop_hook = caml_thread_domain_stop_hook;
  caml_atfork_hook = caml_thread_reinitialize;

  threads_initialized = true;

  return Val_unit;
}

/* Cleanup the thread machinery when the runtime is shut down. Joining the tick
   thread take 25ms on average / 50ms in the worst case, so we don't do it on
   program exit. (FIXME: not implemented in OCaml 5 yet) */

CAMLprim value caml_thread_cleanup(value unit)
{
  if (Tick_thread_running){
    atomic_store_release(&Tick_thread_stop, 1);
    st_thread_join(Tick_thread_id);
    atomic_store_release(&Tick_thread_stop, 0);
    Tick_thread_running = 0;
  }

  return Val_unit;
}

static void thread_destroy_current(caml_thread_t th);

static void thread_detach_from_runtime(void)
{
  caml_thread_t th = This_thread;
  CAMLassert(th == Active_thread);
  /* Signal that the thread has terminated */
  caml_threadstatus_terminate(Terminated(th->descr));
  /* Undo thread_init_current */
  thread_destroy_current(th);
  /* The following also sets Active_thread to a sane value in case the
     backup thread does a GC before the domain lock is acquired
     again. */
  thread_remove_and_free(th);
  /* Release domain lock */
  thread_lock_release(Caml_state->id);
}

/* Register current thread */
static void thread_init_current(caml_thread_t th)
{
  st_tls_set(caml_thread_key, th);
  restore_runtime_state(th);
  /* FIXME: deal with NULL error case */
  th->signal_stack = caml_init_signal_stack();
}

/* Undo thread_init_current */
static void thread_destroy_current(caml_thread_t th)
{
  CAMLassert(th->signal_stack != NULL);
  caml_free_signal_stack(th->signal_stack);
  /* PR#5188, PR#7220: some of the global runtime state may have
     changed as the thread was running, so we save it in the
     This_thread data to make sure that the cleanup logic
     uses accurate information. */
  save_runtime_state();
  st_tls_set(caml_thread_key, NULL);
}

/* Create a thread */

/* the thread lock is not held when entering */
static CAML_THREAD_FUNCTION
caml_thread_start(void * v)
{
  caml_thread_t th = (caml_thread_t) v;
  int dom_id = th->domain_id;
  value clos;

  /* Acquire lock of domain */
  caml_init_domain_self(dom_id);
  thread_lock_acquire(dom_id);

  thread_init_current(th);

  clos = Start_closure(Active_thread->descr);
  caml_modify(&(Start_closure(Active_thread->descr)), Val_unit);
  caml_callback_exn(clos, Val_unit);
  thread_detach_from_runtime();
  return 0;
}

struct caml_thread_tick_args {
  int domain_id;
  atomic_uintnat* stop;
};

/* The tick thread: interrupt the domain periodically to force preemption  */
static CAML_THREAD_FUNCTION caml_thread_tick(void * arg)
{
  struct caml_thread_tick_args* tick_thread_args =
    (struct caml_thread_tick_args*) arg;
  int domain_id = tick_thread_args->domain_id;
  atomic_uintnat* stop = tick_thread_args->stop;
  st_timeout t = st_timeout_of_msec(Thread_timeout_msec);
  caml_stat_free(tick_thread_args);

  caml_init_domain_self(domain_id);
  caml_domain_state *domain = Caml_state;

  while(! atomic_load_acquire(stop)) {
    st_msleep(&t);

    atomic_store_release(&domain->requested_external_interrupt, 1);
    caml_interrupt_self();
  }
  return 0;
}

static st_retcode create_tick_thread(void)
{
  if (Tick_thread_running) return 0;

#ifdef POSIX_SIGNALS
  sigset_t mask, old_mask;

  /* Block all signals, so that we do not try to execute a C signal
     handler in the new tick thread. */
  sigfillset(&mask);
  pthread_sigmask(SIG_BLOCK, &mask, &old_mask);
#endif

  struct caml_thread_tick_args* tick_thread_args =
    caml_stat_alloc_noexc(sizeof(struct caml_thread_tick_args));
  if (tick_thread_args == NULL)
    caml_fatal_error("create_tick_thread: failed to allocate thread args");

  tick_thread_args->domain_id = Caml_state->id;
  tick_thread_args->stop = &Tick_thread_stop;

  st_retcode err = st_thread_create(&Tick_thread_id, caml_thread_tick,
                                    (void *)tick_thread_args);

#ifdef POSIX_SIGNALS
  pthread_sigmask(SIG_SETMASK, &old_mask, NULL);
#endif

  if (err != 0) {
    caml_stat_free(tick_thread_args);
    return err;
  }

  Tick_thread_running = 1;
  return 0;
}

CAMLprim value caml_thread_new(value clos)
{
  CAMLparam1(clos);
  CAMLlocal1(exn);

#ifndef NATIVE_CODE
  if (caml_debugger_in_use)
    caml_fatal_error("ocamldebug does not support multithreaded programs");
#endif

  /* Create the tick thread if not already done.
     Because of PR#4666, we start the tick thread late, only when we create
     the first additional thread in the current process */
  st_retcode err = create_tick_thread();
  caml_check_error(err, "Thread.create");

  /* Create a thread info block */
  caml_thread_t th = thread_alloc_and_add();
  if (th == NULL) caml_raise_out_of_memory();

  value res = caml_thread_new_descriptor_exn(clos);
  if (Is_exception_result(res)) goto err;
  th->descr = res;

  err = st_thread_create(NULL, caml_thread_start, (void *) th);
  res = caml_check_error_exn(err, "Thread.create");
  if (Is_exception_result(res)) goto err;

  CAMLreturn(th->descr);

 err:
  exn = Extract_exception(res);
  thread_remove_and_free(th);
  caml_raise(exn);
}

/* Register a thread already created from C */

/* Once the domain/thread lock for the given domain index has been taken,
 * the unique ID of that domain index will be compared to [expected_unique_id].
 * If they are different, the function will return with error code 0. */
/* The thread lock is not held when entering */
int caml_c_thread_register_in_domain_index(uintnat domain_index,
                                           uintnat expected_unique_id)
{
  /* Systhreads initialized? */
  if (!threads_initialized) return 0;
  /* Already registered? */
  if (This_thread != NULL) return 0;
  /* Has the domain never been initialized? */
  st_masterlock *m = Thread_lock(domain_index);
  if (!m->init) return 0;

  /* At this point we should not hold any domain lock */
  CAMLassert(Caml_state_opt == NULL);

  /* Acquire lock of domain */
  caml_init_domain_self(domain_index);
  thread_lock_acquire(domain_index);

  /* Check that domain is currently active */
  if (Active_thread == NULL) goto out_err;
  /* Check that domain unique ID is as expected:
     - We got the domain we requested (given the inherently racy
       nature of [caml_find_index_of_running_domain]).
     - We were not previously registered on a different domain (for
       programs that currently store domain-specific data in
       thread-local storage). */
  if (!caml_thread_running_on_expected_domain(expected_unique_id)) goto out_err;

  /* Create tick thread if not already done */
  st_retcode err = create_tick_thread();
  if (err != 0) goto out_err;

  /* Set a thread info block */
  caml_thread_t th = thread_alloc_and_add();
  if (th == NULL) goto out_err;

  thread_init_current(th);

  /* We can now allocate the thread descriptor on the major heap */
  value res = caml_thread_new_descriptor_exn(Val_unit);  /* no closure */
  if (Is_exception_result(res)) goto out_err2;
  th->descr = res;

  caml_thread_record_domain_id(expected_unique_id);

  /* Release the domain lock the regular way. Note: we cannot receive
     an exception here. */
  caml_enter_blocking_section_no_pending();
  return 1;

 out_err2:
  thread_destroy_current(th);
  thread_remove_and_free(th);
 out_err:
  thread_lock_release(domain_index);
  /* Note: we cannot raise an exception here. */
  return 0;
}

CAMLexport int caml_c_thread_register_in_domain(uintnat dom_unique_id) {
  intnat domain_index = caml_find_index_of_running_domain(dom_unique_id);
  if (domain_index < 0) return 0;

  return caml_c_thread_register_in_domain_index(domain_index, dom_unique_id);
}

CAMLexport int caml_c_thread_register(void) {
  return caml_c_thread_register_in_domain_index(0L, 0L);
}

/* Unregister a thread that was created from C and registered with
   the two functions above */

/* the thread lock is not held when entering */
CAMLexport int caml_c_thread_unregister(void)
{
  /* If [This_thread] is not set, then the thread was not registered */
  if (This_thread == NULL) return 0;
  /* Acquire the domain lock the regular way */
  caml_leave_blocking_section();
  /* Detach thread from the OCaml runtime; note that this resets
     [Caml_state_opt] and [This_thread]. */
  thread_detach_from_runtime();
  return 1;
}

/* Return the current thread */

CAMLprim value caml_thread_self(value unit)
{
  return Active_thread->descr;
}

/* Return the identifier of a thread */

CAMLprim value caml_thread_id(value th)
{
  return Ident(th);
}

/* Print uncaught exception and backtrace */

CAMLprim value caml_thread_uncaught_exception(value exn)
{
  char * msg = caml_format_exception(exn);
  fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
          Int_val(Ident(Active_thread->descr)), msg);
  caml_stat_free(msg);
  if (Caml_state->backtrace_active) caml_print_exception_backtrace();
  fflush(stderr);
  return Val_unit;
}

/* Allow re-scheduling */

static void thread_yield(void)
{
  st_masterlock *m = Thread_lock(Caml_state->id);
  if (st_masterlock_waiters(m) == 0)
    return;

  /* Do all the parts of a blocking section enter&leave except lock
     manipulation, which we will do more efficiently in
     st_thread_yield, and executing signal handlers (which is already
     done at this point as part of the asynchronous actions mechanism
     when forcing a systhread yield). (Since our blocking section does
     not contain anything interesting, do not bother saving errno.)
  */

  save_runtime_state();
  st_thread_yield(m);
  restore_runtime_state(This_thread);

  /* Switching threads might have unmasked some signal. */
  if (caml_check_pending_signals())
    caml_set_action_pending(Caml_state);
}

CAMLprim value caml_thread_yield(value unit)
{
  caml_process_pending_actions();
  thread_yield();
  return Val_unit;
}

/* Suspend the current thread until another thread terminates */

CAMLprim value caml_thread_join(value th)
{
  st_retcode rc = caml_threadstatus_wait(Terminated(th));
  caml_check_error(rc, "Thread.join");
  return Val_unit;
}

/* Thread status blocks */

#define Threadstatus_val(v) (* ((st_event *) Data_custom_val(v)))

static void caml_threadstatus_finalize(value wrapper)
{
  st_event_destroy(Threadstatus_val(wrapper));
}

static int caml_threadstatus_compare(value wrapper1, value wrapper2)
{
  st_event ts1 = Threadstatus_val(wrapper1);
  st_event ts2 = Threadstatus_val(wrapper2);
  return ts1 == ts2 ? 0 : ts1 < ts2 ? -1 : 1;
}

static struct custom_operations caml_threadstatus_ops = {
  "_threadstatus",
  caml_threadstatus_finalize,
  caml_threadstatus_compare,
  custom_hash_default,
  custom_serialize_default,
  custom_deserialize_default,
  custom_compare_ext_default,
  custom_fixed_length_default
};

static value caml_threadstatus_new_exn(void)
{
  st_event ts = NULL;           /* suppress warning */
  value wrapper;
  value res = caml_check_error_exn(st_event_create(&ts), "Thread.create");
  if (Is_exception_result(res)) return res;

  /* this is a small allocation: no noexc version possible */
  wrapper = caml_alloc_custom(&caml_threadstatus_ops,
                              sizeof(st_event *),
                              0, 1);
  Threadstatus_val(wrapper) = ts;
  return wrapper;
}

static void caml_threadstatus_terminate (value wrapper)
{
  st_event_trigger(Threadstatus_val(wrapper));
}

static st_retcode caml_threadstatus_wait (value wrapper)
{
  CAMLparam1(wrapper); /* prevent deallocation of ts */
  st_event ts = Threadstatus_val(wrapper);
  st_retcode retcode;

  caml_enter_blocking_section();
  retcode = st_event_wait(ts);
  caml_leave_blocking_section();

  CAMLreturnT(st_retcode, retcode);
}

#define caml_set_current_thread_name_warning(w)                                \
  do {                                                                         \
    if (caml_runtime_warnings_active()) {                                      \
      fprintf(stderr, "[ocaml] error while setting thread name: %s\n", w);     \
      fflush(stderr);                                                          \
    }                                                                          \
  } while (0)

/* Set the current thread's name. */
CAMLprim value caml_set_current_thread_name(value name)
{
#if defined(_WIN32)
#if defined(HAS_SETTHREADDESCRIPTION)
  wchar_t *thread_name = caml_stat_strdup_to_utf16(String_val(name));
  HRESULT hr = SetThreadDescription(GetCurrentThread(), thread_name);
  caml_stat_free(thread_name);
  if (FAILED(hr))
    caml_set_current_thread_name_warning("SetThreadDescription failed!");
#else
  caml_set_current_thread_name_warning("set thread name not implemented");
#endif
#elif defined(HAS_PRCTL)
  char buf[1024];
  int ret = prctl(PR_SET_NAME, String_val(name));
  if (ret == -1)
    caml_set_current_thread_name_warning(
      caml_strerror(errno, buf, sizeof(buf)));
#elif defined(HAVE_PTHREAD_SETNAME_NP)
#  if defined(__APPLE__)
  // Darwin implementation does not return any error code.
  pthread_setname_np(String_val(name));
#  elif defined(__NetBSD__)
  char buf[1024];
  int ret = pthread_setname_np(pthread_self(), "%s", (void *)String_val(name));
  if (ret != 0)
    caml_set_current_thread_name_warning(caml_strerror(ret, buf, sizeof(buf)));
#  else
  char buf[1024];
  // Both linux and freebsd document return value as 0 or error
  // code.
  int ret = pthread_setname_np(pthread_self(), String_val(name));
  if (ret != 0)
    caml_set_current_thread_name_warning(caml_strerror(ret, buf, sizeof(buf)));
#  endif
#elif defined(HAVE_PTHREAD_SET_NAME_NP)
  // pthread_set_name_np seems to be the no-error alternative.
  pthread_set_name_np(pthread_self(), String_val(name));
#else
  caml_set_current_thread_name_warning("set thread name not implemented");
#endif

  return Val_unit;
}
