#line 1 "/build/ecl/src/ecl-26.3.27/src/c/threads/mutex.d"
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * mutex.d - mutually exclusive locks.
 *
 * Copyright (c) 2003, Juan Jose Garcia Ripoll
 * Copyright (c) 2020, Marius Gerbershagen
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#ifndef __sun__ /* See unixinit.d for this */
#define _XOPEN_SOURCE 600	/* For pthread mutex attributes */
#endif
#include <errno.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>

/*----------------------------------------------------------------------
 * LOCKS or MUTEX
 */


/* THREAD SAFETY
 *
 * mp:lock-owner, mp:holding-lock-p and mp:lock-count will return
 * wrong values in the following scenarios:
 * 1. Another thread is in the process of locking/unlocking the mutex.
 *    This in unavoidable since count and owner cannot both be stored
 *    atomically.
 * 2. A call to mp:get-lock-wait is interrupted after the mutex has
 *    been locked but before count and owner have been set. In this
 *    case, the mutex will appear to be unlocked even though it is
 *    already locked. If the interrupting code performs a nonlocal
 *    jump up the call stack, this will persist even after the
 *    interrupt. However, the mutex can still be unlocked by
 *    mp:giveup-lock since the check whether the mutex is locked or
 *    not is done by OS level functions.
 * 3. A call to mp:condition-variable-(timed)wait is interrupted after
 *    the mutex has been unlocked/relocked but after/before count and
 *    owner have been set. The consequences are equivalent to scenario 2.
 * In summary, owner can be nil and count 0 even though the mutex is
 * locked but the converse (owner != nil and count != 0 when the mutex
 * is unlocked) cannot happen.
 *
 */

static void FEerror_not_a_recursive_lock(cl_object lock) ecl_attr_noreturn;

static void
FEerror_not_a_recursive_lock(cl_object lock)
{
  FEerror("Attempted to recursively lock ~S which is already owned by ~S",
          2, lock, lock->lock.owner);
}

cl_object
ecl_make_lock(cl_object name, bool recursive)
{
  cl_env_ptr env = ecl_process_env();
  cl_object output = ecl_alloc_object(t_lock);
  output->lock.name = name;
  output->lock.owner = ECL_NIL;
  output->lock.counter = 0;
  output->lock.recursive = recursive;
  ecl_disable_interrupts_env(env);
  ecl_mutex_init(&output->lock.mutex, recursive);
  ecl_set_finalizer_unprotected(output, ECL_T);
  ecl_enable_interrupts_env(env);
  return output;
}

#line 75
cl_object mp_make_lock(cl_narg narg, ...)
{
#line 75

  #line 77
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 77
	static cl_object KEYS[2] = {(cl_object)(cl_symbols+1309), (cl_object)(cl_symbols+1456)};
	cl_object name;
	cl_object recursive;
#line 77
	cl_object KEY_VARS[4];
#line 77
	ecl_va_list ARGS;
	ecl_va_start(ARGS, narg, narg, 0);
#line 77
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(1455));
#line 77
	cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, 0);
#line 77
	if (KEY_VARS[2]==ECL_NIL) {
#line 77
	  name = ECL_NIL;
	} else {
#line 77
	  name = KEY_VARS[0];
	}
#line 77
	if (KEY_VARS[3]==ECL_NIL) {
#line 77
	  recursive = ECL_NIL;
	} else {
#line 77
	  recursive = KEY_VARS[1];
	}
#line 77
  {
#line 77
	#line 77
	cl_object __value0 = ecl_make_lock(name, !Null(recursive));
#line 77
	the_env->nvalues = 1;
#line 77
	the_env->values[0] = __value0;
#line 77
	ecl_va_end(ARGS);
#line 77
	return __value0;
#line 77
}

  }

cl_object
mp_recursive_lock_p(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_only_arg(ecl_make_fixnum(/*MP::RECURSIVE-LOCK-P*/1457), lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
  ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL);
}

cl_object
mp_lock_name(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_only_arg(ecl_make_fixnum(/*MP::LOCK-NAME*/1459), lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
  ecl_return1(env, lock->lock.name);
}

cl_object
mp_lock_owner(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_only_arg(ecl_make_fixnum(/*MP::LOCK-OWNER*/1460), lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
  ecl_return1(env, lock->lock.owner);
}

cl_object
mp_holding_lock_p(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_only_arg(ecl_make_fixnum(/*MP::HOLDING-LOCK-P*/1458), lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
  ecl_return1(env, (lock->lock.owner == mp_current_process())? ECL_T : ECL_NIL);
}

cl_object
mp_lock_count(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_only_arg(ecl_make_fixnum(/*MP::LOCK-COUNT*/1461), lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
  ecl_return1(env, ecl_make_fixnum(lock->lock.counter));
}

cl_object
mp_giveup_lock(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  int rc;
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_only_arg(ecl_make_fixnum(/*MP::GIVEUP-LOCK*/1463), lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
  ecl_disable_interrupts_env(env);
  if ((lock->lock.counter > 0 ? --lock->lock.counter : 0) == 0) {
    lock->lock.owner = ECL_NIL;
  }
  rc = ecl_mutex_unlock(&lock->lock.mutex);
  ecl_enable_interrupts_env(env);
  if (ecl_likely(rc == ECL_MUTEX_SUCCESS)) {
    ecl_return1(env, ECL_T);
  } else if (rc == ECL_MUTEX_NOT_OWNED) {
    FEerror_not_owned(lock);
  } else {
    FEunknown_lock_error(lock);
  }
}

cl_object
mp_get_lock_nowait(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  cl_object own_process = env->own_process;
  int rc;
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_nth_arg(ecl_make_fixnum(/*MP::GET-LOCK*/1462), 1, lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
#if !defined(ECL_MUTEX_DEADLOCK)
  if (ecl_unlikely(lock->lock.owner == own_process && !lock->lock.recursive)) {
    /* INV: owner != nil only if the mutex is locked */
    FEerror_not_a_recursive_lock(lock);
  }
#endif
  ecl_disable_interrupts_env(env);
  if ((rc = ecl_mutex_trylock(&lock->lock.mutex)) == ECL_MUTEX_SUCCESS) {
    lock->lock.counter++;
    lock->lock.owner = own_process;
  }
  ecl_enable_interrupts_env(env);
  if (rc == ECL_MUTEX_SUCCESS) {
    ecl_return1(env, ECL_T);
  } else if (rc == ECL_MUTEX_LOCKED) {
    ecl_return1(env, ECL_NIL);
#if defined(ECL_MUTEX_DEADLOCK)
  } else if (ecl_unlikely(rc == ECL_MUTEX_DEADLOCK)) {
    FEerror_not_a_recursive_lock(lock);
#endif
  } else {
    FEunknown_lock_error(lock);
  }
}

cl_object
mp_get_lock_wait(cl_object lock)
{
  cl_env_ptr env = ecl_process_env();
  cl_object own_process = env->own_process;
  int rc;
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_nth_arg(ecl_make_fixnum(/*MP::GET-LOCK*/1462), 1, lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
#if !defined(ECL_MUTEX_DEADLOCK)
  if (ecl_unlikely(lock->lock.owner == own_process && !lock->lock.recursive)) {
    /* INV: owner != nil only if the mutex is locked */
    FEerror_not_a_recursive_lock(lock);
  }
#endif
  rc = ecl_mutex_lock(&lock->lock.mutex);
  if (ecl_likely(rc == ECL_MUTEX_SUCCESS)) {
    ecl_disable_interrupts_env(env);
    lock->lock.counter++;
    lock->lock.owner = own_process;
    ecl_enable_interrupts_env(env);
    ecl_return1(env, ECL_T);
#if defined(ECL_MUTEX_DEADLOCK)
  } else if (ecl_unlikely(rc == ECL_MUTEX_DEADLOCK)) {
    FEerror_not_a_recursive_lock(lock);
#endif
  } else {
    FEunknown_lock_error(lock);
  }
}

static cl_object
si_abort_wait_on_mutex(cl_narg narg, ...)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object env = the_env->function->cclosure.env;
  cl_object lock = CAR(env);
  if (ECL_SYM_VAL(the_env, ECL_SYM("SI::MUTEX-TIMEOUT",1464)) == lock) {
    ECL_SETQ(the_env, ECL_SYM("SI::MUTEX-TIMEOUT",1464), ECL_T);
    cl_throw(ECL_SYM("SI::MUTEX-TIMEOUT",1464));
  }
  {
#line 228
	const cl_env_ptr the_env = ecl_process_env();
the_env->nvalues = 0; return ECL_NIL;
#line 228
}

}

cl_object
si_mutex_timeout(cl_object process, cl_object lock, cl_object timeout)
{
  const cl_env_ptr the_env = ecl_process_env();
  if (cl_plusp(timeout)) {
    cl_sleep(timeout);
  }
  ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &process->process.start_stop_lock) {
    if (ecl_likely(mp_process_active_p(process) != ECL_NIL)) {
      ecl_interrupt_process(process,
                            ecl_make_cclosure_va(si_abort_wait_on_mutex,
                                                 cl_list(1, lock),
                                                 ECL_SYM("SI::MUTEX-TIMEOUT",1464),
                                                 0));
    }
  } ECL_WITH_NATIVE_LOCK_END;
  {
#line 247
	const cl_env_ptr the_env = ecl_process_env();
the_env->nvalues = 0; return ECL_NIL;
#line 247
}

}

cl_object
mp_get_lock_timedwait(cl_object lock, cl_object timeout)
{
  cl_env_ptr env = ecl_process_env();
  cl_object own_process = env->own_process;
  if (ecl_unlikely(ecl_t_of(lock) != t_lock)) {
    FEwrong_type_nth_arg(ecl_make_fixnum(/*MP::GET-LOCK*/1462), 1, lock, ecl_make_fixnum(/*MP::LOCK*/1440));
  }
#if !defined(ECL_MUTEX_DEADLOCK)
  if (ecl_unlikely(lock->lock.owner == own_process && !lock->lock.recursive)) {
    /* INV: owner != nil only if the mutex is locked */
    FEerror_not_a_recursive_lock(lock);
  }
#endif
#if defined(ECL_WINDOWS_THREADS) || defined(HAVE_PTHREAD_MUTEX_TIMEDLOCK)
  int rc = ecl_mutex_timedlock(&lock->lock.mutex, ecl_to_double(timeout));
#else
  /* If we don't have pthread_mutex_timedlock available, we create a
   * timer thread which interrupts our thread after the specified
   * timeout. si::mutex-timeout serves a dual purpose below: the
   * symbol itself denotes a catchpoint and its value is used to
   * determine a) if the catchpoint is active and b) if the timer has
   * fired. */
  volatile int rc;
  volatile cl_object timer_thread;
  ecl_bds_bind(env, ECL_SYM("SI::MUTEX-TIMEOUT",1464), lock);
  ECL_CATCH_BEGIN(env, ECL_SYM("SI::MUTEX-TIMEOUT",1464)) {
    timer_thread = mp_process_run_function(5, ECL_SYM("SI::MUTEX-TIMEOUT",1464),
                                           ECL_SYM("SI::MUTEX-TIMEOUT",1464),
                                           env->own_process,
                                           lock,
                                           timeout);
    rc = ecl_mutex_lock(&lock->lock.mutex);
    ECL_SETQ(env, ECL_SYM("SI::MUTEX-TIMEOUT",1464), ECL_NIL);
  } ECL_CATCH_END;
  ECL_WITH_NATIVE_LOCK_BEGIN(env, &timer_thread->process.start_stop_lock) {
    if (mp_process_active_p(timer_thread)) {
      ecl_interrupt_process(timer_thread, ECL_SYM("MP::EXIT-PROCESS",1444));
    }
  } ECL_WITH_NATIVE_LOCK_END;
  if (ECL_SYM_VAL(env, ECL_SYM("SI::MUTEX-TIMEOUT",1464)) == ECL_T) {
    rc = ECL_MUTEX_TIMEOUT;
    /* The mutex might have been locked before we could kill the timer
     * thread. Therefore, we unconditionally try to unlock the mutex
     * again and treat the operation as having timed out. */
    ecl_mutex_unlock(&lock->lock.mutex);
  }
  ecl_bds_unwind1(env);
#endif
  if (rc == ECL_MUTEX_SUCCESS) {
    ecl_disable_interrupts_env(env);
    lock->lock.counter++;
    lock->lock.owner = own_process;
    ecl_enable_interrupts_env(env);
    ecl_return1(env, ECL_T);
  } else if (rc == ECL_MUTEX_TIMEOUT) {
    ecl_return1(env, ECL_NIL);
#if defined(ECL_MUTEX_DEADLOCK)
  } else if (ecl_unlikely(rc == ECL_MUTEX_DEADLOCK)) {
    FEerror_not_a_recursive_lock(lock);
#endif
  } else {
    FEunknown_lock_error(lock);
  }
}

#line 316
cl_object mp_get_lock(cl_narg narg, cl_object lock, ...)
{
#line 316

  #line 318
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 318
	cl_object wait;
#line 318
	va_list ARGS;
	va_start(ARGS, lock);
#line 318
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(1462));
#line 318
	if (narg > 1) {
#line 318
		wait = va_arg(ARGS,cl_object);
#line 318
	} else {
#line 318
		wait = ECL_T;
#line 318
	}
#line 318
  if (Null(wait)) {
    return mp_get_lock_nowait(lock);
  } else if (ecl_realp(wait)) {
    return mp_get_lock_timedwait(lock, wait);
  } else {
    return mp_get_lock_wait(lock);
  }
  }
