src/hpc/threadapi.c

/****************************************************************************
**
**  This file is part of GAP, a system for computational discrete algebra.
**
**  Copyright of GAP belongs to its developers, whose names are too numerous
**  to list here. Please refer to the COPYRIGHT file for details.
**
**  SPDX-License-Identifier: GPL-2.0-or-later
**
**  This file contains the GAP interface for thread primitives.
*/

#include "hpc/threadapi.h"

#include "bool.h"
#include "calls.h"
#include "code.h"
#include "error.h"
#include "funcs.h"
#include "gapstate.h"
#include "gvars.h"
#include "intrprtr.h"
#include "io.h"
#include "lists.h"
#include "modules.h"
#include "objects.h"
#include "plist.h"
#include "read.h"
#include "records.h"
#include "set.h"
#include "stats.h"
#include "stringobj.h"

#include "hpc/guards.h"
#include "hpc/misc.h"
#include "hpc/region.h"
#include "hpc/thread.h"
#include "hpc/tls.h"
#include "hpc/traverse.h"

#include <stdio.h>
#include <signal.h>
#include <sys/time.h>

#include <pthread.h>


#define RequireThread(funcname, op, argname)                                 \
    RequireArgumentConditionEx(funcname, op, "<" argname ">",                \
                               TNUM_OBJ(op) == T_THREAD,                     \
                               "must be a thread object")

#define RequireChannel(funcname, op)                                         \
    RequireArgumentCondition(funcname, op, IsChannel(op), "must be a channel")

#define RequireSemaphore(funcname, op)                                       \
    RequireArgumentCondition(funcname, op, TNUM_OBJ(op) == T_SEMAPHORE,      \
                             "must be a semaphore")

#define RequireBarrier(funcname, op)                                         \
    RequireArgumentCondition(funcname, op, IsBarrier(op), "must be a barrier")

#define RequireSyncVar(funcname, op)                                         \
    RequireArgumentCondition(funcname, op, IsSyncVar(op),                    \
                             "must be a synchronization variable")


struct WaitList {
    struct WaitList *    prev;
    struct WaitList *    next;
    ThreadLocalStorage * thread;
};

typedef struct {
  pthread_mutex_t lock;
  struct WaitList *head, *tail;
} Monitor;

typedef struct Channel {
    Obj  monitor;
    Obj  queue;
    int  waiting;
    int  dynamic;
    UInt head, tail;
    UInt size, capacity;
} Channel;

typedef struct Semaphore {
    Obj  monitor;
    UInt count;
    int  waiting;
} Semaphore;

typedef struct Barrier {
    Obj  monitor;
    UInt count;
    UInt phase;
    int  waiting;
} Barrier;

typedef struct SyncVar {
    Obj monitor;
    Obj value;
    int written;
} SyncVar;


static void AddWaitList(Monitor * monitor, struct WaitList * node)
{
    if (monitor->tail) {
        monitor->tail->next = node;
        node->prev = monitor->tail;
        node->next = NULL;
        monitor->tail = node;
    }
    else {
        monitor->head = monitor->tail = node;
        node->next = node->prev = NULL;
    }
}

static void RemoveWaitList(Monitor * monitor, struct WaitList * node)
{
    if (monitor->head) {
        if (node->prev)
            node->prev->next = node->next;
        else
            monitor->head = node->next;
        if (node->next)
            node->next->prev = node->prev;
        else
            monitor->tail = node->prev;
    }
}

#ifndef WARD_ENABLED
static inline void * ObjPtr(Obj obj)
{
    return PTR_BAG(obj);
}
#endif

Obj NewThreadObject(UInt id)
{
    Obj result = NewBag(T_THREAD, sizeof(ThreadObject));
    ThreadObject *thread = (ThreadObject *)ADDR_OBJ(result);
    thread->id = id;
    return result;
}

static inline Int ThreadID(Obj obj)
{
    GAP_ASSERT(TNUM_OBJ(obj) == T_THREAD);
    const ThreadObject *thread = (const ThreadObject *)CONST_ADDR_OBJ(obj);
    return thread->id;
}

Obj NewMonitor(void)
{
    Bag       monitorBag;
    Monitor * monitor;
    monitorBag = NewBag(T_MONITOR, sizeof(Monitor));
    monitor = ObjPtr(monitorBag);
    pthread_mutex_init(&monitor->lock, 0);
    monitor->head = monitor->tail = NULL;
    return monitorBag;
}

static void LockThread(ThreadLocalStorage * thread)
{
    pthread_mutex_lock(thread->threadLock);
}

static void UnlockThread(ThreadLocalStorage * thread)
{
    pthread_mutex_unlock(thread->threadLock);
}

static void SignalThread(ThreadLocalStorage * thread)
{
    pthread_cond_signal(thread->threadSignal);
}

static void WaitThreadSignal(void)
{
    int id = TLS(threadID);
    if (!UpdateThreadState(id, TSTATE_RUNNING, TSTATE_BLOCKED))
        HandleInterrupts(1, 0);
    pthread_cond_wait(TLS(threadSignal), TLS(threadLock));
    if (!UpdateThreadState(id, TSTATE_BLOCKED, TSTATE_RUNNING) &&
        GetThreadState(id) != TSTATE_RUNNING)
        HandleInterrupts(1, 0);
}

void LockMonitor(Monitor * monitor)
{
    pthread_mutex_lock(&monitor->lock);
}

int TryLockMonitor(Monitor * monitor)
{
    return !pthread_mutex_trylock(&monitor->lock);
}

static void UnlockMonitor(Monitor * monitor)
{
    pthread_mutex_unlock(&monitor->lock);
}

/****************************************************************************
 **
 *F WaitForMonitor(monitor) . . . . . .. . wait for a monitor to be ready
 **
 ** 'WaitForMonitor' waits for the monitor to be signaled by another
 ** thread. The monitor must be locked upon entry and will be locked
 ** again upon exit.
 */

static void WaitForMonitor(Monitor * monitor)
{
    struct WaitList node;
    node.thread = GetTLS();
    AddWaitList(monitor, &node);
    UnlockMonitor(monitor);
    LockThread(GetTLS());
    while (!TLS(acquiredMonitor))
        WaitThreadSignal();
    if (!TryLockMonitor(monitor)) {
        UnlockThread(GetTLS());
        LockMonitor(monitor);
        LockThread(GetTLS());
    }
    TLS(acquiredMonitor) = NULL;
    RemoveWaitList(monitor, &node);
    UnlockThread(GetTLS());
}

static int ChannelOrder(const void * c1, const void * c2)
{
    const char * p1 = (const char *)ObjPtr((*(Channel **)c1)->monitor);
    const char * p2 = (const char *)ObjPtr((*(Channel **)c2)->monitor);
    return p1 < p2;
}

static void SortChannels(UInt count, Channel ** channels)
{
    MergeSort(channels, count, sizeof(Channel *), ChannelOrder);
}

static int MonitorsAreSorted(UInt count, Monitor ** monitors)
{
    UInt i;
    for (i = 1; i < count; i++)
        if ((char *)(monitors[i - 1]) > (char *)(monitors[i]))
            return 0;
    return 1;
}

void LockMonitors(UInt count, Monitor ** monitors)
{
    UInt i;
    assert(MonitorsAreSorted(count, monitors));
    for (i = 0; i < count; i++)
        LockMonitor(monitors[i]);
}

void UnlockMonitors(UInt count, Monitor ** monitors)
{
    UInt i;
    for (i = 0; i < count; i++)
        UnlockMonitor(monitors[i]);
}


/****************************************************************************
 **
 *F WaitForAnyMonitor(count, monitors) . . wait for a monitor to be ready
 **
 ** 'WaitForAnyMonitor' waits for any one of the monitors in the list to
 ** be signaled. The function returns when any of them is signaled via
 ** 'SignalMonitor'. The first argument is the number of monitors in the
 ** list, the second argument is an array of monitor pointers.
 **
 ** The list must be sorted by 'MonitorOrder' before passing it to the
 ** function; all monitors must also be locked before calling the function
 ** by calling 'LockMonitors'.
 **
 ** Upon return, all monitors but the one that was signaled will be
 ** unlocked.
 */

UInt WaitForAnyMonitor(UInt count, Monitor ** monitors)
{
    struct WaitList * nodes;
    Monitor *         monitor;
    UInt              i;
    Int               result;
    assert(MonitorsAreSorted(count, monitors));
    nodes = alloca(sizeof(struct WaitList) * count);
    for (i = 0; i < count; i++)
        nodes[i].thread = GetTLS();
    for (i = 0; i < count; i++)
        AddWaitList(monitors[i], &nodes[i]);
    for (i = 0; i < count; i++)
        UnlockMonitor(monitors[i]);
    LockThread(GetTLS());
    while (!TLS(acquiredMonitor))
        WaitThreadSignal();
    monitor = TLS(acquiredMonitor);
    UnlockThread(GetTLS());

    // The following loops will initialize <result>, but the compiler
    // cannot know this; to avoid warnings, we set result to an
    // initial nonsense value.
    result = -1;
    for (i = 0; i < count; i++) {
        LockMonitor(monitors[i]);
        if (monitors[i] == monitor) {
            RemoveWaitList(monitors[i], &nodes[i]);
            result = i;
            /* keep it locked for further processing by caller */
        }
        else {
            RemoveWaitList(monitors[i], &nodes[i]);
            UnlockMonitor(monitors[i]);
        }
    }
    LockThread(GetTLS());
    TLS(acquiredMonitor) = NULL;
    UnlockThread(GetTLS());
    return result;
}

/****************************************************************************
 **
 *F SignalMonitor(monitor) . . . . . . . . . . send a signal to a monitor
 **
 ** Sends a signal to a monitor that is being waited for by another thread.
 ** The monitor must be locked upon entry and will be locked again upon
 ** exit. If no thread is waiting for the monitor, no operation will occur.
 */

void SignalMonitor(Monitor * monitor)
{
    struct WaitList * queue = monitor->head;
    while (queue != NULL) {
        ThreadLocalStorage * thread = queue->thread;
        LockThread(thread);
        if (!thread->acquiredMonitor) {
            thread->acquiredMonitor = monitor;
            SignalThread(thread);
            UnlockThread(thread);
            break;
        }
        UnlockThread(thread);
        queue = queue->next;
    }
}

static Obj ArgumentError(const char * message)
{
    ErrorQuit(message, 0, 0);
    return 0;
}

/* TODO: register globals */
static Obj             FirstKeepAlive;
static Obj             LastKeepAlive;
static pthread_mutex_t KeepAliveLock;

#define KEPTALIVE(obj) (ADDR_OBJ(obj)[1])
#define PREV_KEPT(obj) (ADDR_OBJ(obj)[2])
#define NEXT_KEPT(obj) (ADDR_OBJ(obj)[3])

Obj KeepAlive(Obj obj)
{
    Obj newKeepAlive = NEW_PLIST(T_PLIST, 4);
    SET_REGION(newKeepAlive, NULL);    // public region
    pthread_mutex_lock(&KeepAliveLock);
    SET_LEN_PLIST(newKeepAlive, 3);
    KEPTALIVE(newKeepAlive) = obj;
    PREV_KEPT(newKeepAlive) = LastKeepAlive;
    NEXT_KEPT(newKeepAlive) = (Obj)0;
    if (LastKeepAlive)
        NEXT_KEPT(LastKeepAlive) = newKeepAlive;
    else
        FirstKeepAlive = LastKeepAlive = newKeepAlive;
    pthread_mutex_unlock(&KeepAliveLock);
    return newKeepAlive;
}

void StopKeepAlive(Obj node)
{
#ifndef WARD_ENABLED
    Obj pred, succ;
    pthread_mutex_lock(&KeepAliveLock);
    pred = PREV_KEPT(node);
    succ = NEXT_KEPT(node);
    if (pred)
        NEXT_KEPT(pred) = succ;
    else
        FirstKeepAlive = succ;
    if (succ)
        PREV_KEPT(succ) = pred;
    else
        LastKeepAlive = pred;
    pthread_mutex_unlock(&KeepAliveLock);
#endif
}

static GVarDescriptor GVarTHREAD_INIT;
static GVarDescriptor GVarTHREAD_EXIT;

static void ThreadedInterpreter(void * funcargs)
{
    Obj tmp, func;
    int i;

    /* initialize everything and begin an interpreter                       */
    STATE(NrError) = 0;
    STATE(ThrownObject) = 0;

    IntrBegin(STATE(BottomLVars));
    tmp = KEPTALIVE(funcargs);
    StopKeepAlive(funcargs);
    func = ELM_PLIST(tmp, 1);
    for (i = 2; i <= LEN_PLIST(tmp); i++) {
        Obj item = ELM_PLIST(tmp, i);
        SET_ELM_PLIST(tmp, i - 1, item);
    }
    SET_LEN_PLIST(tmp, LEN_PLIST(tmp) - 1);

    TRY_IF_NO_ERROR
    {
        Obj init, exit;
        if (sySetjmp(TLS(threadExit)))
            return;
        init = GVarOptFunction(&GVarTHREAD_INIT);
        if (init)
            CALL_0ARGS(init);
        CallFuncList(func, tmp);
        exit = GVarOptFunction(&GVarTHREAD_EXIT);
        if (exit)
            CALL_0ARGS(exit);
        PushVoidObj();
        /* end the interpreter */
        IntrEnd(0, NULL);
    }
    CATCH_ERROR
    {
        IntrEnd(1, NULL);
        ClearError();
    }
}


/****************************************************************************
**
*F FuncCreateThread  ... create a new thread
**
** The function creates a new thread with a new interpreter and executes
** the function passed as an argument in it. It returns an integer that
** is a unique identifier for the thread.
*/

static Obj FuncCreateThread(Obj self, Obj funcargs)
{
    Int  i, n;
    Obj  thread;
    Obj  templist;
    n = LEN_PLIST(funcargs);
    if (n == 0 || !IS_FUNC(ELM_PLIST(funcargs, 1)))
        return ArgumentError(
            "CreateThread: Needs at least one function argument");
    templist = NEW_PLIST(T_PLIST, n);
    SET_LEN_PLIST(templist, n);
    SET_REGION(templist, NULL); /* make it public */
    for (i = 1; i <= n; i++)
        SET_ELM_PLIST(templist, i, ELM_PLIST(funcargs, i));
    thread = RunThread(ThreadedInterpreter, KeepAlive(templist));
    if (!thread)
        return Fail;
    return thread;
}

/****************************************************************************
**
*F FuncWaitThread  ... wait for a created thread to finish.
**
** The function waits for an existing thread to finish.
*/

static Obj FuncWaitThread(Obj self, Obj obj)
{
    const char * error = NULL;
    RequireThread("WaitThread", obj, "thread");
    LockThreadControl(1);
    ThreadObject *thread = (ThreadObject *)ADDR_OBJ(obj);
    if (thread->status & THREAD_JOINED)
        error = "ThreadObject is already being waited for";
    thread->status |= THREAD_JOINED;
    UnlockThreadControl();
    if (error)
        ErrorQuit("WaitThread: %s", (UInt)error, 0L);
    if (!JoinThread(thread->id))
        ErrorQuit("WaitThread: Invalid thread id", 0L, 0L);
    return (Obj)0;
}

/****************************************************************************
**
*F FuncCurrentThread ... return thread object of current thread.
**
*/

static Obj FuncCurrentThread(Obj self)
{
    return TLS(threadObject);
}

/****************************************************************************
**
*F FuncThreadID ... return numerical thread id of thread.
**
*/

static Obj FuncThreadID(Obj self, Obj thread)
{
    RequireThread("ThreadID", thread, "thread");
    return INTOBJ_INT(ThreadID(thread));
}

/****************************************************************************
**
*F FuncKillThread ... kill a given thread
**
*/

static Obj FuncKillThread(Obj self, Obj thread)
{
    int id;
    if (IS_INTOBJ(thread)) {
        id = INT_INTOBJ(thread);
        if (id < 0 || id >= MAX_THREADS)
            return ArgumentError("KillThread: Thread ID out of range");
    }
    else if (TNUM_OBJ(thread) == T_THREAD) {
        id = ThreadID(thread);
    }
    else
        return ArgumentError("KillThread: Argument must be a thread object");
    KillThread(id);
    return (Obj)0;
}


/****************************************************************************
**
*F FuncInterruptThread ... interrupt a given thread
**
*/

#define AS_STRING(s) #s


static Obj FuncInterruptThread(Obj self, Obj thread, Obj handler)
{
    int id;
    if (IS_INTOBJ(thread)) {
        id = INT_INTOBJ(thread);
        if (id < 0 || id >= MAX_THREADS)
            return ArgumentError("InterruptThread: Thread ID out of range");
    }
    else if (TNUM_OBJ(thread) == T_THREAD) {
        id = ThreadID(thread);
    }
    else
        return ArgumentError(
            "InterruptThread: First argument must identify a thread");
    if (!IS_INTOBJ(handler) || INT_INTOBJ(handler) < 0 ||
        INT_INTOBJ(handler) > MAX_INTERRUPT)
        return ArgumentError(
            "InterruptThread: Second argument must be an integer "
            "between 0 and " AS_STRING(MAX_INTERRUPT));
    InterruptThread(id, (int)(INT_INTOBJ(handler)));
    return (Obj)0;
}

/****************************************************************************
**
*F FuncSetInterruptHandler ... set interrupt handler for current thread
**
*/

static Obj FuncSetInterruptHandler(Obj self, Obj handler, Obj func)
{
    if (!IS_INTOBJ(handler) || INT_INTOBJ(handler) < 1 ||
        INT_INTOBJ(handler) > MAX_INTERRUPT)
        return ArgumentError(
            "SetInterruptHandler: First argument must be an integer "
            "between 1 and " AS_STRING(MAX_INTERRUPT));
    if (func == Fail) {
        SetInterruptHandler((int)(INT_INTOBJ(handler)), (Obj)0);
        return (Obj)0;
    }
    if (TNUM_OBJ(func) != T_FUNCTION || NARG_FUNC(func) != 0 ||
        !BODY_FUNC(func))
        return ArgumentError("SetInterruptHandler: Second argument must be a "
                             "parameterless function or 'fail'");
    SetInterruptHandler((int)(INT_INTOBJ(handler)), func);
    return (Obj)0;
}

#undef AS_STRING


/****************************************************************************
**
*F FuncPauseThread ... pause a given thread
**
*/


static Obj FuncPauseThread(Obj self, Obj thread)
{
    int id;
    if (IS_INTOBJ(thread)) {
        id = INT_INTOBJ(thread);
        if (id < 0 || id >= MAX_THREADS)
            return ArgumentError("PauseThread: Thread ID out of range");
    }
    else if (TNUM_OBJ(thread) == T_THREAD) {
        id = ThreadID(thread);
    }
    else
        return ArgumentError("PauseThread: Argument must be a thread object");
    PauseThread(id);
    return (Obj)0;
}


/****************************************************************************
**
*F FuncResumeThread ... resume a given thread
**
*/


static Obj FuncResumeThread(Obj self, Obj thread)
{
    int id;
    if (IS_INTOBJ(thread)) {
        id = INT_INTOBJ(thread);
        if (id < 0 || id >= MAX_THREADS)
            return ArgumentError("ResumeThread: Thread ID out of range");
    }
    else if (TNUM_OBJ(thread) == T_THREAD) {
        id = ThreadID(thread);
    }
    else
        return ArgumentError(
            "ResumeThread: Argument must be a thread object");
    ResumeThread(id);
    return (Obj)0;
}


/****************************************************************************
**
*F FuncRegionOf ... return region of an object
**
*/
static Obj PublicRegion;

static Obj FuncRegionOf(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    return region == NULL ? PublicRegion : region->obj;
}


/****************************************************************************
**
*F FuncSetRegionName ... set the name of an object's region
*F FuncClearRegionName ... clear the name of an object's region
*F FuncRegionName ... get the name of an object's region
**
*/


static Obj FuncSetRegionName(Obj self, Obj obj, Obj name)
{
    Region * region = GetRegionOf(obj);
    if (!region)
        return ArgumentError(
            "SetRegionName: Cannot change name of the public region");
    if (!IsStringConv(name))
        return ArgumentError("SetRegionName: Region name must be a string");
    SetRegionName(region, name);
    return (Obj)0;
}

static Obj FuncClearRegionName(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    if (!region)
        return ArgumentError(
            "ClearRegionName: Cannot change name of the public region");
    SetRegionName(region, (Obj)0);
    return (Obj)0;
}

static Obj FuncRegionName(Obj self, Obj obj)
{
    Obj      result;
    Region * region = GetRegionOf(obj);
    result = GetRegionName(region);
    if (!result)
        result = Fail;
    return result;
}


/****************************************************************************
**
*F FuncIsShared ... return whether a region is shared
**
*/

static Obj FuncIsShared(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    return (region && !region->fixed_owner) ? True : False;
}

/****************************************************************************
**
*F FuncIsPublic ... return whether a region is public
**
*/

static Obj FuncIsPublic(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    return region == NULL ? True : False;
}

/****************************************************************************
**
*F FuncIsThreadLocal ... return whether a region is thread-local
**
*/

static Obj FuncIsThreadLocal(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    return (region && region->fixed_owner && region->owner == GetTLS())
               ? True
               : False;
}

/****************************************************************************
**
*F FuncHaveWriteAccess ... return if we have a write lock on the region
**
*/

static Obj FuncHaveWriteAccess(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    if (region != NULL &&
        (region->owner == GetTLS() || region->alt_owner == GetTLS()))
        return True;
    else
        return False;
}

/****************************************************************************
**
*F FuncHaveReadAccess ... return if we have a read lock on the region
**
*/

static Obj FuncHaveReadAccess(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    if (region != NULL && CheckReadAccess(obj))
        return True;
    else
        return False;
}


/****************************************************************************
**
*F FuncHASH_LOCK ........... acquire write lock on an object.
*F FuncHASH_UNLOCK ......... release write lock on an object.
*F FuncHASH_LOCK_SHARED ..... acquire read lock on an object.
*F FuncHASH_UNLOCK_SHARED ... release read lock on an object.
**
*/


static Obj FuncHASH_LOCK(Obj self, Obj target)
{
    HashLock(target);
    return (Obj)0;
}

static Obj FuncHASH_UNLOCK(Obj self, Obj target)
{
    HashUnlock(target);
    return (Obj)0;
}

static Obj FuncHASH_LOCK_SHARED(Obj self, Obj target)
{
    HashLockShared(target);
    return (Obj)0;
}
static Obj FuncHASH_UNLOCK_SHARED(Obj self, Obj target)
{
    HashUnlockShared(target);
    return (Obj)0;
}

/****************************************************************************
**
*F FuncHASH_SYNCHRONIZED ......... execute a function while holding a write
*lock.
*F FuncHASH_SYNCHRONIZED_SHARED ... execute a function while holding a read
*lock.
**
*/

static Obj FuncHASH_SYNCHRONIZED(Obj self, Obj target, Obj function)
{
    volatile int locked = 0;
    jmp_buf      readJmpError;
    memcpy(readJmpError, STATE(ReadJmpError), sizeof(jmp_buf));
    TRY_IF_NO_ERROR
    {
        HashLock(target);
        locked = 1;
        CALL_0ARGS(function);
        locked = 0;
        HashUnlock(target);
    }
    if (locked)
        HashUnlock(target);
    memcpy(STATE(ReadJmpError), readJmpError, sizeof(jmp_buf));
    return (Obj)0;
}

static Obj FuncHASH_SYNCHRONIZED_SHARED(Obj self, Obj target, Obj function)
{
    volatile int locked = 0;
    jmp_buf      readJmpError;
    memcpy(readJmpError, STATE(ReadJmpError), sizeof(jmp_buf));
    TRY_IF_NO_ERROR
    {
        HashLockShared(target);
        locked = 1;
        CALL_0ARGS(function);
        locked = 0;
        HashUnlockShared(target);
    }
    if (locked)
        HashUnlockShared(target);
    memcpy(STATE(ReadJmpError), readJmpError, sizeof(jmp_buf));
    return (Obj)0;
}

/****************************************************************************
**
*F FuncCREATOR_OF ... return function that created an object
**
*/

static Obj FuncCREATOR_OF(Obj self, Obj obj)
{
#ifdef TRACK_CREATOR
    Obj result = NEW_PLIST_IMM(T_PLIST, 2);
    SET_LEN_PLIST(result, 2);
    if (!IS_BAG_REF(obj)) {
        SET_ELM_PLIST(result, 1, Fail);
        SET_ELM_PLIST(result, 2, Fail);
        return result;
    }
    if (obj[2])
        SET_ELM_PLIST(result, 1, (Obj)(obj[2]));
    else
        SET_ELM_PLIST(result, 1, Fail);
    if (obj[3])
        SET_ELM_PLIST(result, 2, (Obj)(obj[3]));
    else
        SET_ELM_PLIST(result, 2, Fail);
    return result;
#else
    return Fail;
#endif
}

static Obj FuncDISABLE_GUARDS(Obj self, Obj flag)
{
    if (flag == False)
        TLS(DisableGuards) = 0;
    else if (flag == True)
        TLS(DisableGuards) = 1;
    else if (IS_INTOBJ(flag))
        TLS(DisableGuards) = (int)(INT_INTOBJ(flag));
    else
        ErrorQuit("DISABLE_GUARDS: Argument must be boolean or integer", 0L,
                  0L);
    return (Obj)0;
}

static Obj FuncWITH_TARGET_REGION(Obj self, Obj obj, Obj func)
{
    Region * volatile oldRegion = TLS(currentRegion);
    Region * volatile region = GetRegionOf(obj);
    syJmp_buf readJmpError;

    RequireFunction("WITH_TARGET_REGION", func);
    if (!region || !CheckExclusiveWriteAccess(obj))
        return ArgumentError(
            "WITH_TARGET_REGION: Requires write access to target region");
    memcpy(readJmpError, STATE(ReadJmpError), sizeof(syJmp_buf));
    if (sySetjmp(STATE(ReadJmpError))) {
        memcpy(STATE(ReadJmpError), readJmpError, sizeof(syJmp_buf));
        TLS(currentRegion) = oldRegion;
        syLongjmp(&(STATE(ReadJmpError)), 1);
    }
    TLS(currentRegion) = region;
    CALL_0ARGS(func);
    memcpy(STATE(ReadJmpError), readJmpError, sizeof(syJmp_buf));
    TLS(currentRegion) = oldRegion;
    return (Obj)0;
}


static Obj TYPE_THREAD;
static Obj TYPE_SEMAPHORE;
static Obj TYPE_CHANNEL;
static Obj TYPE_BARRIER;
static Obj TYPE_SYNCVAR;
static Obj TYPE_REGION;

static Obj TypeThread(Obj obj)
{
    return TYPE_THREAD;
}

static Obj TypeSemaphore(Obj obj)
{
    return TYPE_SEMAPHORE;
}

static Obj TypeChannel(Obj obj)
{
    return TYPE_CHANNEL;
}

static Obj TypeBarrier(Obj obj)
{
    return TYPE_BARRIER;
}

static Obj TypeSyncVar(Obj obj)
{
    return TYPE_SYNCVAR;
}

static Obj TypeRegion(Obj obj)
{
    return TYPE_REGION;
}

#ifdef USE_GASMAN
static void MarkSemaphoreBag(Bag);
static void MarkChannelBag(Bag);
static void MarkBarrierBag(Bag);
static void MarkSyncVarBag(Bag);
#endif
static void FinalizeMonitor(Bag);
static void PrintThread(Obj);
static void PrintSemaphore(Obj);
static void PrintChannel(Obj);
static void PrintBarrier(Obj);
static void PrintSyncVar(Obj);
static void PrintRegion(Obj);

GVarDescriptor LastInaccessibleGVar;
static GVarDescriptor MAX_INTERRUPTGVar;

static UInt RNAM_SIGINT;
static UInt RNAM_SIGCHLD;
static UInt RNAM_SIGVTALRM;
#ifdef SIGWINCH
static UInt RNAM_SIGWINCH;
#endif

#ifndef WARD_ENABLED
#ifdef USE_GASMAN
static void MarkSemaphoreBag(Bag bag)
{
    Semaphore * sem = (Semaphore *)(PTR_BAG(bag));
    MarkBag(sem->monitor);
}

static void MarkChannelBag(Bag bag)
{
    Channel * channel = (Channel *)(PTR_BAG(bag));
    MarkBag(channel->queue);
    MarkBag(channel->monitor);
}

static void MarkBarrierBag(Bag bag)
{
    Barrier * barrier = (Barrier *)(PTR_BAG(bag));
    MarkBag(barrier->monitor);
}

static void MarkSyncVarBag(Bag bag)
{
    SyncVar * syncvar = (SyncVar *)(PTR_BAG(bag));
    MarkBag(syncvar->queue);
    MarkBag(syncvar->monitor);
}
#endif

static void FinalizeMonitor(Bag bag)
{
    Monitor * monitor = (Monitor *)(PTR_BAG(bag));
    pthread_mutex_destroy(&monitor->lock);
}

static void LockChannel(Channel * channel)
{
    LockMonitor(ObjPtr(channel->monitor));
}

static void UnlockChannel(Channel * channel)
{
    UnlockMonitor(ObjPtr(channel->monitor));
}

static void SignalChannel(Channel * channel)
{
    if (channel->waiting)
        SignalMonitor(ObjPtr(channel->monitor));
}

static void WaitChannel(Channel * channel)
{
    channel->waiting++;
    WaitForMonitor(ObjPtr(channel->monitor));
    channel->waiting--;
}

static void ExpandChannel(Channel * channel)
{
    /* Growth ratio should be less than the golden ratio */
    const UInt oldCapacity = channel->capacity;
    const UInt newCapacity = ((oldCapacity * 25 / 16) | 1) + 1;
    GAP_ASSERT(newCapacity > oldCapacity);

    UInt i, tail;
    Obj  newqueue;
    newqueue = NEW_PLIST(T_PLIST, newCapacity);
    SET_LEN_PLIST(newqueue, newCapacity);
    SET_REGION(newqueue, REGION(channel->queue));
    channel->capacity = newCapacity;
    for (i = channel->head; i < oldCapacity; i++)
        ADDR_OBJ(newqueue)[i + 1] = ADDR_OBJ(channel->queue)[i + 1];
    for (i = 0; i < channel->tail; i++) {
        UInt d = oldCapacity + i;
        if (d >= newCapacity)
            d -= newCapacity;
        ADDR_OBJ(newqueue)[d + 1] = ADDR_OBJ(channel->queue)[i + 1];
    }
    tail = channel->head + oldCapacity;
    if (tail >= newCapacity)
        tail -= newCapacity;
    channel->tail = tail;
    channel->queue = newqueue;
}

static void AddToChannel(Channel * channel, Obj obj, int migrate)
{
    Obj      children;
    Region * region = REGION(channel->queue);
    UInt     i, len;
    if (migrate && IS_BAG_REF(obj) && REGION(obj) &&
        REGION(obj)->owner == GetTLS() && REGION(obj)->fixed_owner) {
        children = ReachableObjectsFrom(obj);
        len = children ? LEN_PLIST(children) : 0;
    }
    else {
        children = 0;
        len = 0;
    }
    for (i = 1; i <= len; i++) {
        Obj item = ELM_PLIST(children, i);
        SET_REGION(item, region);
    }
    ADDR_OBJ(channel->queue)[++channel->tail] = obj;
    ADDR_OBJ(channel->queue)[++channel->tail] = children;
    if (channel->tail == channel->capacity)
        channel->tail = 0;
    channel->size += 2;
}

static Obj RetrieveFromChannel(Channel * channel)
{
    Obj      obj = ADDR_OBJ(channel->queue)[++channel->head];
    Obj      children = ADDR_OBJ(channel->queue)[++channel->head];
    Region * region = TLS(currentRegion);
    UInt     i, len = children ? LEN_PLIST(children) : 0;
    ADDR_OBJ(channel->queue)[channel->head - 1] = 0;
    ADDR_OBJ(channel->queue)[channel->head] = 0;
    if (channel->head == channel->capacity)
        channel->head = 0;
    for (i = 1; i <= len; i++) {
        Obj item = ELM_PLIST(children, i);
        SET_REGION(item, region);
    }
    channel->size -= 2;
    return obj;
}

static Int TallyChannel(Channel * channel)
{
    Int result;
    LockChannel(channel);
    result = channel->size / 2;
    UnlockChannel(channel);
    return result;
}

static void SendChannel(Channel * channel, Obj obj, int migrate)
{
    LockChannel(channel);
    if (channel->size == channel->capacity && channel->dynamic)
        ExpandChannel(channel);
    while (channel->size == channel->capacity)
        WaitChannel(channel);
    AddToChannel(channel, obj, migrate);
    SignalChannel(channel);
    UnlockChannel(channel);
}

static void MultiSendChannel(Channel * channel, Obj list, int migrate)
{
    int listsize = LEN_LIST(list);
    int i;
    Obj obj;
    LockChannel(channel);
    for (i = 1; i <= listsize; i++) {
        if (channel->size == channel->capacity && channel->dynamic)
            ExpandChannel(channel);
        while (channel->size == channel->capacity)
            WaitChannel(channel);
        obj = ELM_LIST(list, i);
        AddToChannel(channel, obj, migrate);
    }
    SignalChannel(channel);
    UnlockChannel(channel);
}

static int TryMultiSendChannel(Channel * channel, Obj list, int migrate)
{
    int result = 0;
    int listsize = LEN_LIST(list);
    int i;
    Obj obj;
    LockChannel(channel);
    for (i = 1; i <= listsize; i++) {
        if (channel->size == channel->capacity && channel->dynamic)
            ExpandChannel(channel);
        if (channel->size == channel->capacity)
            break;
        obj = ELM_LIST(list, i);
        AddToChannel(channel, obj, migrate);
        result++;
    }
    SignalChannel(channel);
    UnlockChannel(channel);
    return result;
}

static int TrySendChannel(Channel * channel, Obj obj, int migrate)
{
    LockChannel(channel);
    if (channel->size == channel->capacity && channel->dynamic)
        ExpandChannel(channel);
    if (channel->size == channel->capacity) {
        UnlockChannel(channel);
        return 0;
    }
    AddToChannel(channel, obj, migrate);
    SignalChannel(channel);
    UnlockChannel(channel);
    return 1;
}

static Obj ReceiveChannel(Channel * channel)
{
    Obj result;
    LockChannel(channel);
    while (channel->size == 0)
        WaitChannel(channel);
    result = RetrieveFromChannel(channel);
    SignalChannel(channel);
    UnlockChannel(channel);
    return result;
}

static Obj ReceiveAnyChannel(Obj channelList, int with_index)
{
    UInt       count = LEN_PLIST(channelList);
    UInt       i, p;
    Monitor ** monitors = alloca(count * sizeof(Monitor *));
    Channel ** channels = alloca(count * sizeof(Channel *));
    Obj        result;
    Channel *  channel;
    for (i = 0; i < count; i++)
        channels[i] = ObjPtr(ELM_PLIST(channelList, i + 1));
    SortChannels(count, channels);
    for (i = 0; i < count; i++)
        monitors[i] = ObjPtr(channels[i]->monitor);
    LockMonitors(count, monitors);
    p = TLS(multiplexRandomSeed);
    p = (p * 5 + 1);
    TLS(multiplexRandomSeed) = p;
    p %= count;
    for (i = 0; i < count; i++) {
        channel = channels[p];
        if (channel->size > 0)
            break;
        p++;
        if (p >= count)
            p = 0;
    }
    if (i < count) /* found a channel with data */
    {
        p = i;
        for (i = 0; i < count; i++)
            if (i != p)
                UnlockMonitor(monitors[i]);
    }
    else /* all channels are empty */
        for (;;) {
            for (i = 0; i < count; i++)
                channels[i]->waiting++;
            p = WaitForAnyMonitor(count, monitors);
            for (i = 0; i < count; i++)
                channels[i]->waiting--;
            channel = channels[p];
            if (channel->size > 0)
                break;
            UnlockMonitor(monitors[p]);
            LockMonitors(count, monitors);
        }
    result = RetrieveFromChannel(channel);
    SignalChannel(channel);
    UnlockMonitor(monitors[p]);
    if (with_index) {
        Obj list = NEW_PLIST(T_PLIST, 2);
        SET_LEN_PLIST(list, 2);
        SET_ELM_PLIST(list, 1, result);
        for (i = 1; i <= count; i++)
            if (ObjPtr(ELM_PLIST(channelList, i)) == channel) {
                SET_ELM_PLIST(list, 2, INTOBJ_INT(i));
                break;
            }
        return list;
    }
    else
        return result;
}

static Obj MultiReceiveChannel(Channel * channel, UInt max)
{
    Obj  result;
    UInt count;
    UInt i;
    LockChannel(channel);
    if (max > channel->size / 2)
        count = channel->size / 2;
    else
        count = max;
    result = NEW_PLIST(T_PLIST, count);
    SET_LEN_PLIST(result, count);
    for (i = 0; i < count; i++) {
        Obj item = RetrieveFromChannel(channel);
        SET_ELM_PLIST(result, i + 1, item);
    }
    SignalChannel(channel);
    UnlockChannel(channel);
    return result;
}

static Obj InspectChannel(Channel * channel)
{
    LockChannel(channel);
    const UInt count = channel->size / 2;
    Obj result = NEW_PLIST(T_PLIST, count);
    SET_LEN_PLIST(result, count);
    for (UInt i = 0, p = channel->head; i < count; i++) {
        SET_ELM_PLIST(result, i + 1, ELM_PLIST(channel->queue, p + 1));
        p += 2;
        if (p == channel->capacity)
            p = 0;
    }
    UnlockChannel(channel);
    return result;
}

static Obj TryReceiveChannel(Channel * channel, Obj defaultobj)
{
    Obj result;
    LockChannel(channel);
    if (channel->size == 0) {
        UnlockChannel(channel);
        return defaultobj;
    }
    result = RetrieveFromChannel(channel);
    SignalChannel(channel);
    UnlockChannel(channel);
    return result;
}

static Obj CreateChannel(int capacity)
{
    Channel * channel;
    Bag       channelBag;
    channelBag = NewBag(T_CHANNEL, sizeof(Channel));
    channel = ObjPtr(channelBag);
    channel->monitor = NewMonitor();
    channel->size = channel->head = channel->tail = 0;
    channel->capacity = (capacity < 0) ? 20 : capacity * 2;
    channel->dynamic = (capacity < 0);
    channel->waiting = 0;
    channel->queue = NEW_PLIST(T_PLIST, channel->capacity);
    SET_REGION(channel->queue, LimboRegion);
    SET_LEN_PLIST(channel->queue, channel->capacity);
    return channelBag;
}

static int DestroyChannel(Channel * channel)
{
    return 1;
}
#endif

static Obj FuncCreateChannel(Obj self, Obj args)
{
    int capacity;
    switch (LEN_PLIST(args)) {
    case 0:
        capacity = -1;
        break;
    case 1:
        if (IS_INTOBJ(ELM_PLIST(args, 1))) {
            capacity = INT_INTOBJ(ELM_PLIST(args, 1));
            if (capacity <= 0)
                return ArgumentError(
                    "CreateChannel: Capacity must be positive");
            break;
        }
        return ArgumentError(
            "CreateChannel: Argument must be capacity of the channel");
    default:
        return ArgumentError(
            "CreateChannel: Function takes up to two arguments");
    }
    return CreateChannel(capacity);
}

static int IsChannel(Obj obj)
{
    return obj && TNUM_OBJ(obj) == T_CHANNEL;
}

static Obj FuncDestroyChannel(Obj self, Obj channel)
{
    RequireChannel("DestroyChannel", channel);
    if (!DestroyChannel(ObjPtr(channel)))
        return ArgumentError("DestroyChannel: Channel is in use");
    return (Obj)0;
}

static Obj FuncTallyChannel(Obj self, Obj channel)
{
    RequireChannel("TallyChannel", channel);
    return INTOBJ_INT(TallyChannel(ObjPtr(channel)));
}

static Obj FuncSendChannel(Obj self, Obj channel, Obj obj)
{
    RequireChannel("SendChannel", channel);
    SendChannel(ObjPtr(channel), obj, 1);
    return (Obj)0;
}

static Obj FuncTransmitChannel(Obj self, Obj channel, Obj obj)
{
    RequireChannel("TransmitChannel", channel);
    SendChannel(ObjPtr(channel), obj, 0);
    return (Obj)0;
}

static Obj FuncMultiSendChannel(Obj self, Obj channel, Obj list)
{
    RequireChannel("MultiSendChannel", channel);
    RequireDenseList("MultiSendChannel", list);
    MultiSendChannel(ObjPtr(channel), list, 1);
    return (Obj)0;
}

static Obj FuncMultiTransmitChannel(Obj self, Obj channel, Obj list)
{
    RequireChannel("MultiTransmitChannel", channel);
    RequireDenseList("MultiTransmitChannel", list);
    MultiSendChannel(ObjPtr(channel), list, 0);
    return (Obj)0;
}

static Obj FuncTryMultiSendChannel(Obj self, Obj channel, Obj list)
{
    RequireChannel("TryMultiSendChannel", channel);
    RequireDenseList("TryMultiSendChannel", list);
    return INTOBJ_INT(TryMultiSendChannel(ObjPtr(channel), list, 1));
}


static Obj FuncTryMultiTransmitChannel(Obj self, Obj channel, Obj list)
{
    RequireChannel("TryMultiTransmitChannel", channel);
    RequireDenseList("TryMultiTransmitChannel", list);
    return INTOBJ_INT(TryMultiSendChannel(ObjPtr(channel), list, 0));
}


static Obj FuncTrySendChannel(Obj self, Obj channel, Obj obj)
{
    RequireChannel("TrySendChannel", channel);
    return TrySendChannel(ObjPtr(channel), obj, 1) ? True : False;
}

static Obj FuncTryTransmitChannel(Obj self, Obj channel, Obj obj)
{
    RequireChannel("TryTransmitChannel", channel);
    return TrySendChannel(ObjPtr(channel), obj, 0) ? True : False;
}

static Obj FuncReceiveChannel(Obj self, Obj channel)
{
    RequireChannel("ReceiveChannel", channel);
    return ReceiveChannel(ObjPtr(channel));
}

static int IsChannelList(Obj list)
{
    int len = LEN_PLIST(list);
    int i;
    for (i = 1; i <= len; i++)
        if (!IsChannel(ELM_PLIST(list, i)))
            return 0;
    return 1;
}

static Obj FuncReceiveAnyChannel(Obj self, Obj args)
{
    if (IsChannelList(args))
        return ReceiveAnyChannel(args, 0);
    else {
        if (LEN_PLIST(args) == 1 && IS_PLIST(ELM_PLIST(args, 1)) &&
            IsChannelList(ELM_PLIST(args, 1)))
            return ReceiveAnyChannel(ELM_PLIST(args, 1), 0);
        else
            return ArgumentError(
                "ReceiveAnyChannel: Argument list must be channels");
    }
}

static Obj FuncReceiveAnyChannelWithIndex(Obj self, Obj args)
{
    if (IsChannelList(args))
        return ReceiveAnyChannel(args, 1);
    else {
        if (LEN_PLIST(args) == 1 && IS_PLIST(ELM_PLIST(args, 1)) &&
            IsChannelList(ELM_PLIST(args, 1)))
            return ReceiveAnyChannel(ELM_PLIST(args, 1), 1);
        else
            return ArgumentError(
                "ReceiveAnyChannel: Argument list must be channels");
    }
}

static Obj FuncMultiReceiveChannel(Obj self, Obj channel, Obj count)
{
    RequireChannel("MultiReceiveChannel", channel);
    RequireNonnegativeSmallInt("MultiReceiveChannel", count);
    return MultiReceiveChannel(ObjPtr(channel), INT_INTOBJ(count));
}

static Obj FuncInspectChannel(Obj self, Obj channel)
{
    RequireChannel("InspectChannel", channel);
    return InspectChannel(ObjPtr(channel));
}

static Obj FuncTryReceiveChannel(Obj self, Obj channel, Obj obj)
{
    RequireChannel("TryReceiveChannel", channel);
    return TryReceiveChannel(ObjPtr(channel), obj);
}

static Obj CreateSemaphore(UInt count)
{
    Semaphore * sem;
    Bag         semBag;
    semBag = NewBag(T_SEMAPHORE, sizeof(Semaphore));
    sem = ObjPtr(semBag);
    sem->monitor = NewMonitor();
    sem->count = count;
    sem->waiting = 0;
    return semBag;
}

static Obj FuncCreateSemaphore(Obj self, Obj args)
{
    Int count;
    switch (LEN_PLIST(args)) {
    case 0:
        count = 0;
        break;
    case 1:
        if (IS_INTOBJ(ELM_PLIST(args, 1))) {
            count = INT_INTOBJ(ELM_PLIST(args, 1));
            if (count < 0)
                return ArgumentError(
                    "CreateSemaphore: Initial count must be non-negative");
            break;
        }
        return ArgumentError(
            "CreateSemaphore: Argument must be initial count");
    default:
        return ArgumentError(
            "CreateSemaphore: Function takes up to two arguments");
    }
    return CreateSemaphore(count);
}

static Obj FuncSignalSemaphore(Obj self, Obj semaphore)
{
    Semaphore * sem;
    RequireSemaphore("SignalSemaphore", semaphore);
    sem = ObjPtr(semaphore);
    LockMonitor(ObjPtr(sem->monitor));
    sem->count++;
    if (sem->waiting)
        SignalMonitor(ObjPtr(sem->monitor));
    UnlockMonitor(ObjPtr(sem->monitor));
    return (Obj)0;
}

static Obj FuncWaitSemaphore(Obj self, Obj semaphore)
{
    Semaphore * sem;
    RequireSemaphore("WaitSemaphore", semaphore);
    sem = ObjPtr(semaphore);
    LockMonitor(ObjPtr(sem->monitor));
    sem->waiting++;
    while (sem->count == 0)
        WaitForMonitor(ObjPtr(sem->monitor));
    sem->count--;
    sem->waiting--;
    if (sem->waiting && sem->count > 0)
        SignalMonitor(ObjPtr(sem->monitor));
    UnlockMonitor(ObjPtr(sem->monitor));
    return (Obj)0;
}

static Obj FuncTryWaitSemaphore(Obj self, Obj semaphore)
{
    Semaphore * sem;
    int         success;
    RequireSemaphore("TryWaitSemaphore", semaphore);
    sem = ObjPtr(semaphore);
    LockMonitor(ObjPtr(sem->monitor));
    success = (sem->count > 0);
    if (success)
        sem->count--;
    sem->waiting--;
    if (sem->waiting && sem->count > 0)
        SignalMonitor(ObjPtr(sem->monitor));
    UnlockMonitor(ObjPtr(sem->monitor));
    return success ? True : False;
}

static void LockBarrier(Barrier * barrier)
{
    LockMonitor(ObjPtr(barrier->monitor));
}

static void UnlockBarrier(Barrier * barrier)
{
    UnlockMonitor(ObjPtr(barrier->monitor));
}

static void JoinBarrier(Barrier * barrier)
{
    barrier->waiting++;
    WaitForMonitor(ObjPtr(barrier->monitor));
    barrier->waiting--;
}

static void SignalBarrier(Barrier * barrier)
{
    if (barrier->waiting)
        SignalMonitor(ObjPtr(barrier->monitor));
}

static Obj CreateBarrier(void)
{
    Bag       barrierBag;
    Barrier * barrier;
    barrierBag = NewBag(T_BARRIER, sizeof(Barrier));
    barrier = ObjPtr(barrierBag);
    barrier->monitor = NewMonitor();
    barrier->count = 0;
    barrier->phase = 0;
    barrier->waiting = 0;
    return barrierBag;
}

static void StartBarrier(Barrier * barrier, UInt count)
{
    LockBarrier(barrier);
    barrier->count = count;
    barrier->phase++;
    UnlockBarrier(barrier);
}

static void WaitBarrier(Barrier * barrier)
{
    UInt phaseDelta;
    LockBarrier(barrier);
    phaseDelta = barrier->phase;
    if (--barrier->count > 0)
        JoinBarrier(barrier);
    SignalBarrier(barrier);
    phaseDelta -= barrier->phase;
    UnlockBarrier(barrier);
    if (phaseDelta != 0)
        ArgumentError("WaitBarrier: Barrier was reset");
}

static Obj FuncCreateBarrier(Obj self)
{
    return CreateBarrier();
}

static int IsBarrier(Obj obj)
{
    return obj && TNUM_OBJ(obj) == T_BARRIER;
}

static Obj FuncStartBarrier(Obj self, Obj barrier, Obj count)
{
    RequireBarrier("StartBarrier", barrier);
    Int c = GetSmallInt("StartBarrier", count);
    StartBarrier(ObjPtr(barrier), c);
    return (Obj)0;
}

static Obj FuncWaitBarrier(Obj self, Obj barrier)
{
    RequireBarrier("WaitBarrier", barrier);
    WaitBarrier(ObjPtr(barrier));
    return (Obj)0;
}

static void SyncWrite(SyncVar * var, Obj value)
{
    Monitor * monitor = ObjPtr(var->monitor);
    LockMonitor(monitor);
    if (var->written) {
        UnlockMonitor(monitor);
        ArgumentError("SyncWrite: Variable already has a value");
        return;
    }
    var->written = 1;
    var->value = value;
    SignalMonitor(monitor);
    UnlockMonitor(monitor);
}

static int SyncTryWrite(SyncVar * var, Obj value)
{
    Monitor * monitor = ObjPtr(var->monitor);
    LockMonitor(monitor);
    if (var->written) {
        UnlockMonitor(monitor);
        return 0;
    }
    var->written = 1;
    var->value = value;
    SignalMonitor(monitor);
    UnlockMonitor(monitor);
    return 1;
}

static Obj CreateSyncVar(void)
{
    Bag       syncvarBag;
    SyncVar * syncvar;
    syncvarBag = NewBag(T_SYNCVAR, sizeof(SyncVar));
    syncvar = ObjPtr(syncvarBag);
    syncvar->monitor = NewMonitor();
    syncvar->written = 0;
    syncvar->value = (Obj)0;
    return syncvarBag;
}


static Obj SyncRead(SyncVar * var)
{
    Monitor * monitor = ObjPtr(var->monitor);
    LockMonitor(monitor);
    while (!var->written)
        WaitForMonitor(monitor);
    if (monitor->head != NULL)
        SignalMonitor(monitor);
    UnlockMonitor(monitor);
    return var->value;
}

static Obj SyncIsBound(SyncVar * var)
{
    return var->value ? True : False;
}

static int IsSyncVar(Obj var)
{
    return var && TNUM_OBJ(var) == T_SYNCVAR;
}

static Obj FuncCreateSyncVar(Obj self)
{
    return CreateSyncVar();
}

static Obj FuncSyncWrite(Obj self, Obj syncvar, Obj value)
{
    RequireSyncVar("SyncWrite", syncvar);
    SyncWrite(ObjPtr(syncvar), value);
    return (Obj)0;
}

static Obj FuncSyncTryWrite(Obj self, Obj syncvar, Obj value)
{
    RequireSyncVar("SyncTryWrite", syncvar);
    return SyncTryWrite(ObjPtr(syncvar), value) ? True : False;
}

static Obj FuncSyncRead(Obj self, Obj syncvar)
{
    RequireSyncVar("SyncRead", syncvar);
    return SyncRead(ObjPtr(syncvar));
}

static Obj FuncSyncIsBound(Obj self, Obj syncvar)
{
    RequireSyncVar("SyncIsBound", syncvar);
    return SyncIsBound(ObjPtr(syncvar));
}


static void PrintThread(Obj obj)
{
    char         buf[100];
    const char * status_message;
    LockThreadControl(0);
    const ThreadObject *thread = (const ThreadObject *)CONST_ADDR_OBJ(obj);
    switch (thread->status) {
    case 0:
        status_message = "running";
        break;
    case THREAD_TERMINATED:
        status_message = "terminated";
        break;
    case THREAD_JOINED:
        status_message = "running, waited for";
        break;
    case THREAD_TERMINATED | THREAD_JOINED:
        status_message = "terminated, waited for";
        break;
    default:
        status_message = "unknown status";
        break;
    }
    sprintf(buf, "<thread #%ld: %s>", (long)thread->id, status_message);
    UnlockThreadControl();
    Pr("%s", (Int)buf, 0L);
}

static void PrintSemaphore(Obj obj)
{
    Semaphore * sem = ObjPtr(obj);
    Int         count;
    char        buffer[100];
    LockMonitor(ObjPtr(sem->monitor));
    count = sem->count;
    UnlockMonitor(ObjPtr(sem->monitor));
    sprintf(buffer, "<semaphore %p: count = %ld>", (void *)sem, (long)count);
    Pr("%s", (Int)buffer, 0L);
}

static void PrintChannel(Obj obj)
{
    Channel * channel = ObjPtr(obj);
    Int       size, waiting, capacity;
    char      buffer[20];
    Pr("<channel ", 0L, 0L);
    sprintf(buffer, "%p: ", (void *)channel);
    Pr(buffer, 0L, 0L);
    LockChannel(channel);
    size = channel->size;
    waiting = channel->waiting;
    if (channel->dynamic)
        capacity = -1;
    else
        capacity = channel->capacity;
    UnlockChannel(channel);
    if (capacity < 0)
        Pr("%d elements, %d waiting>", size / 2, waiting);
    else {
        Pr("%d/%d elements, ", size / 2, capacity / 2);
        Pr("%d waiting>", waiting, 0L);
    }
}

static void PrintBarrier(Obj obj)
{
    Barrier * barrier = ObjPtr(obj);
    Int       count, waiting;
    char      buffer[20];
    Pr("<barrier ", 0L, 0L);
    sprintf(buffer, "%p: ", (void *)barrier);
    Pr(buffer, 0L, 0L);
    LockBarrier(barrier);
    count = barrier->count;
    waiting = barrier->waiting;
    UnlockBarrier(barrier);
    Pr("%d of %d threads arrived>", waiting, count);
}

static void PrintSyncVar(Obj obj)
{
    SyncVar * syncvar = ObjPtr(obj);
    char      buffer[20];
    int       written;
    LockMonitor(ObjPtr(syncvar->monitor));
    written = syncvar->written;
    UnlockMonitor(ObjPtr(syncvar->monitor));
    if (written)
        Pr("<initialized syncvar ", 0L, 0L);
    else
        Pr("<uninitialized syncvar ", 0L, 0L);
    sprintf(buffer, "%p>", (void *)syncvar);
    Pr(buffer, 0L, 0L);
}

static void PrintRegion(Obj obj)
{
    char     buffer[32];
    Region * region = GetRegionOf(obj);
    Obj      name = GetRegionName(region);

    if (name) {
        Pr("<region: %g", (Int)name, 0L);
    }
    else {
        snprintf(buffer, 32, "<region %p", (void *)GetRegionOf(obj));
        Pr(buffer, 0L, 0L);
    }
    if (region && region->count_active) {
        snprintf(buffer, 32, " (locked %zu/contended %zu)",
                 region->locks_acquired, region->locks_contended);
        Pr(buffer, 0L, 0L);
    }
    Pr(">", 0L, 0L);
}

static Obj FuncIS_LOCKED(Obj self, Obj obj)
{
    Region * region = IS_BAG_REF(obj) ? REGION(obj) : NULL;
    if (!region)
        return INTOBJ_INT(0);
    return INTOBJ_INT(IsLocked(region));
}

static Obj FuncLOCK(Obj self, Obj args)
{
    int   numargs = LEN_PLIST(args);
    int   count = 0;
    Obj * objects;
    LockMode * modes;
    LockMode   mode = LOCK_MODE_DEFAULT;
    int   i;
    int   result;

    if (numargs > 1024)
        return ArgumentError("LOCK: Too many arguments");
    objects = alloca(sizeof(Obj) * numargs);
    modes = alloca(sizeof(LockMode) * numargs);
    for (i = 1; i <= numargs; i++) {
        Obj obj;
        obj = ELM_PLIST(args, i);
        if (obj == True)
            mode = LOCK_MODE_READWRITE;
        else if (obj == False)
            mode = LOCK_MODE_READONLY;
        else {
            objects[count] = obj;
            modes[count] = mode;
            count++;
        }
    }
    result = LockObjects(count, objects, modes);
    if (result >= 0)
        return INTOBJ_INT(result);
    return Fail;
}

static Obj FuncDO_LOCK(Obj self, Obj args)
{
    Obj result = FuncLOCK(self, args);
    if (result == Fail)
        ErrorMayQuit("Cannot lock required regions", 0L, 0L);
    return result;
}

static Obj FuncWRITE_LOCK(Obj self, Obj obj)
{
    const LockMode modes[] = { LOCK_MODE_READWRITE };
    int result = LockObjects(1, &obj, modes);
    if (result < 0)
      ErrorMayQuit("Cannot lock required regions", 0L, 0L);
    return INTOBJ_INT(result);
}

static Obj FuncREAD_LOCK(Obj self, Obj obj)
{
    const LockMode modes[] = { LOCK_MODE_READONLY };
    int result = LockObjects(1, &obj, modes);
    if (result < 0)
      ErrorMayQuit("Cannot lock required regions", 0L, 0L);
    return INTOBJ_INT(result);
}

static Obj FuncTRYLOCK(Obj self, Obj args)
{
    int   numargs = LEN_PLIST(args);
    int   count = 0;
    Obj * objects;
    LockMode * modes;
    LockMode   mode = LOCK_MODE_DEFAULT;
    int   i;
    int   result;

    if (numargs > 1024)
        return ArgumentError("TRYLOCK: Too many arguments");
    objects = alloca(sizeof(Obj) * numargs);
    modes = alloca(sizeof(int) * numargs);
    for (i = 1; i <= numargs; i++) {
        Obj obj;
        obj = ELM_PLIST(args, i);
        if (obj == True)
            mode = LOCK_MODE_READWRITE;
        else if (obj == False)
            mode = LOCK_MODE_READONLY;
        else {
            objects[count] = obj;
            modes[count] = mode;
            count++;
        }
    }
    result = TryLockObjects(count, objects, modes);
    if (result >= 0)
        return INTOBJ_INT(result);
    return Fail;
}

static Obj FuncUNLOCK(Obj self, Obj sp)
{
    RequireNonnegativeSmallInt("UNLOCK", sp);
    PopRegionLocks(INT_INTOBJ(sp));
    return (Obj)0;
}

static Obj FuncCURRENT_LOCKS(Obj self)
{
    UInt i, len = TLS(lockStackPointer);
    Obj  result = NEW_PLIST(T_PLIST, len);
    SET_LEN_PLIST(result, len);
    for (i = 1; i <= len; i++)
        SET_ELM_PLIST(result, i, ELM_PLIST(TLS(lockStack), i));
    return result;
}

static int AutoRetyping = 0;

static int
MigrateObjects(int count, Obj * objects, Region * target, int retype)
{
    int i;
    if (count && retype && IS_BAG_REF(objects[0]) &&
        REGION(objects[0])->owner == GetTLS() && AutoRetyping) {
        for (i = 0; i < count; i++)
            if (REGION(objects[i])->owner == GetTLS())
                CLEAR_OBJ_FLAG(objects[i], TESTED);
        for (i = 0; i < count; i++) {
            if (REGION(objects[i])->owner == GetTLS() &&
                IS_PLIST(objects[i])) {
                if (!TEST_OBJ_FLAG(objects[i], TESTED))
                    TYPE_OBJ(objects[i]);
                if (retype >= 2)
                    IsSet(objects[i]);
            }
        }
    }
    for (i = 0; i < count; i++) {
        Region * region;
        if (IS_BAG_REF(objects[i])) {
            region = REGION(objects[i]);
            if (!region || region->owner != GetTLS())
                return 0;
        }
    }
    for (i = 0; i < count; i++)
        SET_REGION(objects[i], target);
    return 1;
}

static Obj FuncREFINE_TYPE(Obj self, Obj obj)
{
    if (IS_BAG_REF(obj) && CheckExclusiveWriteAccess(obj)) {
        TYPE_OBJ(obj);
    }
    return obj;
}

static Obj FuncMAKE_PUBLIC_NORECURSE(Obj self, Obj obj)
{
    if (!MigrateObjects(1, &obj, NULL, 0))
        return ArgumentError("MAKE_PUBLIC_NORECURSE: Thread does not have "
                             "exclusive access to objects");
    return obj;
}

static Obj FuncFORCE_MAKE_PUBLIC(Obj self, Obj obj)
{
    if (!IS_BAG_REF(obj))
        return ArgumentError("FORCE_MAKE_PUBLIC: Argument is a small integer "
                             "or finite-field element");
    MakeBagPublic(obj);
    return obj;
}

static Obj FuncSHARE_NORECURSE(Obj self, Obj obj, Obj name, Obj prec)
{
    Region * region = NewRegion();
    if (name != Fail && !IsStringConv(name))
        return ArgumentError(
            "SHARE_NORECURSE: Second argument must be a string or fail");
    Int p = GetSmallInt("SHARE_NORECURSE", prec);
    region->prec = p;
    if (!MigrateObjects(1, &obj, region, 0))
        return ArgumentError("SHARE_NORECURSE: Thread does not have "
                             "exclusive access to objects");
    if (name != Fail)
        SetRegionName(region, name);
    return obj;
}

static Obj FuncMIGRATE_NORECURSE(Obj self, Obj obj, Obj target)
{
    Region * target_region = GetRegionOf(target);
    if (!target_region ||
        IsLocked(target_region) != LOCK_STATUS_READWRITE_LOCKED)
        return ArgumentError("MIGRATE_NORECURSE: Thread does not have "
                             "exclusive access to target region");
    if (!MigrateObjects(1, &obj, target_region, 0))
        return ArgumentError("MIGRATE_NORECURSE: Thread does not have "
                             "exclusive access to object");
    return obj;
}

static Obj FuncADOPT_NORECURSE(Obj self, Obj obj)
{
    if (!MigrateObjects(1, &obj, TLS(threadRegion), 0))
        return ArgumentError("ADOPT_NORECURSE: Thread does not have "
                             "exclusive access to objects");
    return obj;
}

static Obj FuncREACHABLE(Obj self, Obj obj)
{
    Obj result = ReachableObjectsFrom(obj);
    if (result == NULL) {
        result = NEW_PLIST(T_PLIST, 1);
        SET_LEN_PLIST(result, 1);
        SET_ELM_PLIST(result, 1, obj);
    }
    return result;
}

static Obj FuncCLONE_REACHABLE(Obj self, Obj obj)
{
    return CopyReachableObjectsFrom(obj, 0, 0, 0);
}

static Obj FuncCLONE_DELIMITED(Obj self, Obj obj)
{
    return CopyReachableObjectsFrom(obj, 1, 0, 0);
}

static Obj FuncNEW_REGION(Obj self, Obj name, Obj prec)
{
    Region * region = NewRegion();
    if (name != Fail && !IsStringConv(name))
        return ArgumentError(
            "NEW_REGION: Second argument must be a string or fail");
    Int p = GetSmallInt("NEW_REGION", prec);
    region->prec = p;
    if (name != Fail)
        SetRegionName(region, name);
    return region->obj;
}

static Obj FuncREGION_PRECEDENCE(Obj self, Obj regobj)
{
    Region * region = GetRegionOf(regobj);
    return region == NULL ? INTOBJ_INT(0) : INTOBJ_INT(region->prec);
}

static Obj FuncSHARE(Obj self, Obj obj, Obj name, Obj prec)
{
    Region * region = NewRegion();
    Obj      reachable;
    if (name != Fail && !IsStringConv(name))
        return ArgumentError(
            "SHARE: Second argument must be a string or fail");
    Int p = GetSmallInt("SHARE", prec);
    region->prec = p;
    reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1, region,
                        1))
        return ArgumentError(
            "SHARE: Thread does not have exclusive access to objects");
    if (name != Fail)
        SetRegionName(region, name);
    return obj;
}

static Obj FuncSHARE_RAW(Obj self, Obj obj, Obj name, Obj prec)
{
    Region * region = NewRegion();
    Obj      reachable;
    if (name != Fail && !IsStringConv(name))
        return ArgumentError(
            "SHARE_RAW: Second argument must be a string or fail");
    Int p = GetSmallInt("SHARE_RAW", prec);
    region->prec = p;
    reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1, region,
                        0))
        return ArgumentError(
            "SHARE_RAW: Thread does not have exclusive access to objects");
    if (name != Fail)
        SetRegionName(region, name);
    return obj;
}

static Obj FuncADOPT(Obj self, Obj obj)
{
    Obj reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1,
                        TLS(threadRegion), 0))
        return ArgumentError(
            "ADOPT: Thread does not have exclusive access to objects");
    return obj;
}

static Obj FuncMAKE_PUBLIC(Obj self, Obj obj)
{
    Obj reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1, NULL,
                        0))
        return ArgumentError(
            "MAKE_PUBLIC: Thread does not have exclusive access to objects");
    return obj;
}

static Obj FuncMIGRATE(Obj self, Obj obj, Obj target)
{
    Region * target_region = GetRegionOf(target);
    Obj      reachable;
    if (!target_region ||
        IsLocked(target_region) != LOCK_STATUS_READWRITE_LOCKED)
        return ArgumentError("MIGRATE: Thread does not have exclusive access "
                             "to target region");
    reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1,
                        target_region, 1))
        return ArgumentError(
            "MIGRATE: Thread does not have exclusive access to objects");
    return obj;
}

static Obj FuncMIGRATE_RAW(Obj self, Obj obj, Obj target)
{
    Region * target_region = GetRegionOf(target);
    Obj      reachable;
    if (!target_region ||
        IsLocked(target_region) != LOCK_STATUS_READWRITE_LOCKED)
        return ArgumentError("MIGRATE: Thread does not have exclusive access "
                             "to target region");
    reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1,
                        target_region, 0))
        return ArgumentError(
            "MIGRATE: Thread does not have exclusive access to objects");
    return obj;
}

static Obj FuncMakeThreadLocal(Obj self, Obj var)
{
    char * name;
    UInt   gvar;
    if (!IsStringConv(var) || GET_LEN_STRING(var) == 0)
        return ArgumentError(
            "MakeThreadLocal: Argument must be a variable name");
    name = CSTR_STRING(var);
    gvar = GVarName(name);
    name = CSTR_STRING(NameGVar(gvar)); /* to apply namespace scopes where needed. */
    MakeThreadLocalVar(gvar, RNamName(name));
    return (Obj)0;
}

static Obj FuncMakeReadOnlyObj(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    Obj      reachable;
    if (!region || region == ReadOnlyRegion)
        return obj;
    reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1,
                        ReadOnlyRegion, 1))
        return ArgumentError(
            "MakeReadOnlyObj: Thread does not have exclusive access to objects");
    return obj;
}

static Obj FuncMakeReadOnlyRaw(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    Obj      reachable;
    if (!region || region == ReadOnlyRegion)
        return obj;
    reachable = ReachableObjectsFrom(obj);
    if (!MigrateObjects(LEN_PLIST(reachable), ADDR_OBJ(reachable) + 1,
                        ReadOnlyRegion, 0))
        return ArgumentError(
            "MakeReadOnlyObj: Thread does not have exclusive access to objects");
    return obj;
}

static Obj FuncMakeReadOnlySingleObj(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    if (!region || region == ReadOnlyRegion)
        return obj;
    if (!MigrateObjects(1, &obj, ReadOnlyRegion, 0))
        return ArgumentError("MakeReadOnlySingleObj: Thread does not have "
                             "exclusive access to object");
    return obj;
}

static Obj FuncIsReadOnlyObj(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);
    return (region == ReadOnlyRegion) ? True : False;
}

static Obj FuncENABLE_AUTO_RETYPING(Obj self)
{
    AutoRetyping = 1;
    return (Obj)0;
}

static Obj FuncORDERED_READ(Obj self, Obj obj)
{
    MEMBAR_READ();
    return obj;
}

static Obj FuncORDERED_WRITE(Obj self, Obj obj)
{
    MEMBAR_WRITE();
    return obj;
}

static Obj FuncDEFAULT_SIGINT_HANDLER(Obj self)
{
    /* do nothing */
    return (Obj)0;
}

static UInt SigVTALRMCounter = 0;

static Obj FuncDEFAULT_SIGVTALRM_HANDLER(Obj self)
{
    SigVTALRMCounter++;
    return (Obj)0;
}

#ifdef SIGWINCH
    extern void syWindowChangeIntr(int signr);
#endif

static Obj FuncDEFAULT_SIGWINCH_HANDLER(Obj self)
{
#ifdef SIGWINCH
    syWindowChangeIntr(SIGWINCH);
#endif
    return (Obj)0;
}

static void HandleSignal(Obj handlers, UInt rnam)
{
    Obj func = ELM_REC(handlers, rnam);
    if (!func || TNUM_OBJ(func) != T_FUNCTION || NARG_FUNC(func) > 0)
        return;
    CALL_0ARGS(func);
}

static sigset_t GAPSignals;

static Obj FuncSIGWAIT(Obj self, Obj handlers)
{
    int sig;
    if (!IS_REC(handlers))
        return ArgumentError("SIGWAIT: Argument must be a record");
    if (sigwait(&GAPSignals, &sig) >= 0) {
        switch (sig) {
        case SIGINT:
            HandleSignal(handlers, RNAM_SIGINT);
            break;
        case SIGCHLD:
            HandleSignal(handlers, RNAM_SIGCHLD);
            break;
        case SIGVTALRM:
            HandleSignal(handlers, RNAM_SIGVTALRM);
            break;
#ifdef SIGWINCH
        case SIGWINCH:
            HandleSignal(handlers, RNAM_SIGWINCH);
            break;
#endif
        }
    }
    return (Obj)0;
}

void InitSignals(void)
{
    struct itimerval timer;
    sigemptyset(&GAPSignals);
    sigaddset(&GAPSignals, SIGINT);
    sigaddset(&GAPSignals, SIGCHLD);
    sigaddset(&GAPSignals, SIGVTALRM);
#ifdef SIGWINCH
    sigaddset(&GAPSignals, SIGWINCH);
#endif
    pthread_sigmask(SIG_BLOCK, &GAPSignals, NULL);
    /* Run a timer signal every 10 ms, i.e. 100 times per second */
    timer.it_interval.tv_sec = 0;
    timer.it_interval.tv_usec = 10000;
    timer.it_value.tv_sec = 0;
    timer.it_value.tv_usec = 10000;
    setitimer(ITIMER_VIRTUAL, &timer, NULL);
}

static Obj FuncPERIODIC_CHECK(Obj self, Obj count, Obj func)
{
    UInt n;
    RequireNonnegativeSmallInt("PERIODIC_CHECK", count);
    RequireFunction("PERIODIC_CHECK", func);
    /*
     * The following read of SigVTALRMCounter is a dirty read. We don't
     * need to synchronize access to it because it's a monotonically
     * increasing value and we only need it to succeed eventually.
     */
    n = INT_INTOBJ(count) / 10;
    if (TLS(PeriodicCheckCount) + n < SigVTALRMCounter) {
        TLS(PeriodicCheckCount) = SigVTALRMCounter;
        CALL_0ARGS(func);
    }
    return (Obj)0;
}


/*
 * Region lock performance counters
 */
static Obj FuncREGION_COUNTERS_ENABLE(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);

    if (!region)
        return ArgumentError(
            "REGION_COUNTERS_ENABLE: Cannot enable counters for this region");

    region->count_active = 1;
    return (Obj)0;
}

static Obj FuncREGION_COUNTERS_DISABLE(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);

    if (!region)
        return ArgumentError("REGION_COUNTERS_DISABLE: Cannot disable "
                             "counters for this region");

    region->count_active = 0;
    return (Obj)0;
}

static Obj FuncREGION_COUNTERS_GET_STATE(Obj self, Obj obj)
{
    Obj      result;
    Region * region = GetRegionOf(obj);

    if (!region)
        return ArgumentError(
            "REGION_COUNTERS_GET_STATE: Cannot get counters for this region");

    result = INTOBJ_INT(region->count_active);

    return result;
}

static Obj FuncREGION_COUNTERS_GET(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);

    if (!region)
        return ArgumentError(
            "REGION_COUNTERS_GET: Cannot get counters for this region");

    return GetRegionLockCounters(region);
}

static Obj FuncREGION_COUNTERS_RESET(Obj self, Obj obj)
{
    Region * region = GetRegionOf(obj);

    if (!region)
        return ArgumentError(
            "REGION_COUNTERS_RESET: Cannot reset counters for this region");

    ResetRegionLockCounters(region);

    return (Obj)0;
}

static Obj FuncTHREAD_COUNTERS_ENABLE(Obj self)
{
    TLS(CountActive) = 1;

    return (Obj)0;
}

static Obj FuncTHREAD_COUNTERS_DISABLE(Obj self)
{
    TLS(CountActive) = 0;

    return (Obj)0;
}

static Obj FuncTHREAD_COUNTERS_GET_STATE(Obj self)
{
    Obj result;

    result = INTOBJ_INT(TLS(CountActive));

    return result;
}

static Obj FuncTHREAD_COUNTERS_RESET(Obj self)
{
    TLS(LocksAcquired) = TLS(LocksContended) = 0;

    return (Obj)0;
}

static Obj FuncTHREAD_COUNTERS_GET(Obj self)
{
    Obj result;

    result = NEW_PLIST(T_PLIST, 2);
    SET_LEN_PLIST(result, 2);
    SET_ELM_PLIST(result, 1, INTOBJ_INT(TLS(LocksAcquired)));
    SET_ELM_PLIST(result, 2, INTOBJ_INT(TLS(LocksContended)));

    return result;
}


/****************************************************************************
**
*F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
*/


/****************************************************************************
**
*V  BagNames  . . . . . . . . . . . . . . . . . . . . . . . list of bag names
*/
static StructBagNames BagNames[] = {
    // install info string
    { T_THREAD, "thread" },
    { T_MONITOR, "monitor" },
    { T_REGION, "region" },
    { T_SEMAPHORE, "semaphore" },
    { T_CHANNEL, "channel" },
    { T_BARRIER, "barrier" },
    { T_SYNCVAR, "syncvar" },
    { -1,    "" }
};


/****************************************************************************
**
*V  GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
*/
static StructGVarFunc GVarFuncs[] = {

    GVAR_FUNC(CreateThread, -1, "function"),
    GVAR_FUNC(CurrentThread, 0, ""),
    GVAR_FUNC(ThreadID, 1, "thread"),
    GVAR_FUNC(WaitThread, 1, "thread"),
    GVAR_FUNC(KillThread, 1, "thread"),
    GVAR_FUNC(InterruptThread, 2, "thread, handler"),
    GVAR_FUNC(SetInterruptHandler, 2, "handler, function"),
    GVAR_FUNC(PauseThread, 1, "thread"),
    GVAR_FUNC(ResumeThread, 1, "thread"),
    GVAR_FUNC(HASH_LOCK, 1, "object"),
    GVAR_FUNC(HASH_LOCK_SHARED, 1, "object"),
    GVAR_FUNC(HASH_UNLOCK, 1, "object"),
    GVAR_FUNC(HASH_UNLOCK_SHARED, 1, "object"),
    GVAR_FUNC(HASH_SYNCHRONIZED, 2, "object, function"),
    GVAR_FUNC(HASH_SYNCHRONIZED_SHARED, 2, "object, function"),
    GVAR_FUNC(RegionOf, 1, "object"),
    GVAR_FUNC(SetRegionName, 2, "obj, name"),
    GVAR_FUNC(ClearRegionName, 1, "obj"),
    GVAR_FUNC(RegionName, 1, "obj"),
    GVAR_FUNC(WITH_TARGET_REGION, 2, "region, function"),
    GVAR_FUNC(IsShared, 1, "object"),
    GVAR_FUNC(IsPublic, 1, "object"),
    GVAR_FUNC(IsThreadLocal, 1, "object"),
    GVAR_FUNC(HaveWriteAccess, 1, "object"),
    GVAR_FUNC(HaveReadAccess, 1, "object"),
    GVAR_FUNC(CreateSemaphore, -1, "[count]"),
    GVAR_FUNC(SignalSemaphore, 1, "semaphore"),
    GVAR_FUNC(WaitSemaphore, 1, "semaphore"),
    GVAR_FUNC(TryWaitSemaphore, 1, "semaphore"),
    GVAR_FUNC(CreateChannel, -1, "[size]"),
    GVAR_FUNC(DestroyChannel, 1, "channel"),
    GVAR_FUNC(TallyChannel, 1, "channel"),
    GVAR_FUNC(SendChannel, 2, "channel, obj"),
    GVAR_FUNC(TransmitChannel, 2, "channel, obj"),
    GVAR_FUNC(ReceiveChannel, 1, "channel"),
    GVAR_FUNC(ReceiveAnyChannel, -1, "channel list"),
    GVAR_FUNC(ReceiveAnyChannelWithIndex, -1, "channel list"),
    GVAR_FUNC(MultiReceiveChannel, 2, "channel, count"),
    GVAR_FUNC(TryReceiveChannel, 2, "channel, obj"),
    GVAR_FUNC(MultiSendChannel, 2, "channel, list"),
    GVAR_FUNC(TryMultiSendChannel, 2, "channel, list"),
    GVAR_FUNC(TrySendChannel, 2, "channel, obj"),
    GVAR_FUNC(MultiTransmitChannel, 2, "channel, list"),
    GVAR_FUNC(TryMultiTransmitChannel, 2, "channel, list"),
    GVAR_FUNC(TryTransmitChannel, 2, "channel, obj"),
    GVAR_FUNC(InspectChannel, 1, "channel"),
    GVAR_FUNC(CreateBarrier, 0, ""),
    GVAR_FUNC(StartBarrier, 2, "barrier, count"),
    GVAR_FUNC(WaitBarrier, 1, "barrier"),
    GVAR_FUNC(CreateSyncVar, 0, ""),
    GVAR_FUNC(SyncWrite, 2, "syncvar, obj"),
    GVAR_FUNC(SyncTryWrite, 2, "syncvar, obj"),
    GVAR_FUNC(SyncRead, 1, "syncvar"),
    GVAR_FUNC(SyncIsBound, 1, "syncvar"),
    GVAR_FUNC(IS_LOCKED, 1, "obj"),
    GVAR_FUNC(LOCK, -1, "obj, ..."),
    GVAR_FUNC(DO_LOCK, -1, "obj, ..."),
    GVAR_FUNC(WRITE_LOCK, 1, "obj"),
    GVAR_FUNC(READ_LOCK, 1, "obj"),
    GVAR_FUNC(TRYLOCK, -1, "obj, ..."),
    GVAR_FUNC(UNLOCK, 1, "sp"),
    GVAR_FUNC(CURRENT_LOCKS, 0, ""),
    GVAR_FUNC(REFINE_TYPE, 1, "obj"),
    GVAR_FUNC(SHARE_NORECURSE, 3, "obj, string, integer"),
    GVAR_FUNC(ADOPT_NORECURSE, 1, "obj"),
    GVAR_FUNC(MIGRATE_NORECURSE, 2, "obj, target"),
    GVAR_FUNC(NEW_REGION, 2, "string, integer"),
    GVAR_FUNC(REGION_PRECEDENCE, 1, "obj"),
    GVAR_FUNC(SHARE, 3, "obj, string, integer"),
    GVAR_FUNC(SHARE_RAW, 3, "obj, string, integer"),
    GVAR_FUNC(ADOPT, 1, "obj"),
    GVAR_FUNC(MIGRATE, 2, "obj, target"),
    GVAR_FUNC(MIGRATE_RAW, 2, "obj, target"),
    GVAR_FUNC(MAKE_PUBLIC_NORECURSE, 1, "obj"),
    GVAR_FUNC(MAKE_PUBLIC, 1, "obj"),
    GVAR_FUNC(FORCE_MAKE_PUBLIC, 1, "obj"),
    GVAR_FUNC(REACHABLE, 1, "obj"),
    GVAR_FUNC(CLONE_REACHABLE, 1, "obj"),
    GVAR_FUNC(CLONE_DELIMITED, 1, "obj"),
    GVAR_FUNC(MakeThreadLocal, 1, "var"),
    GVAR_FUNC(MakeReadOnlyObj, 1, "obj"),
    GVAR_FUNC(MakeReadOnlyRaw, 1, "obj"),
    GVAR_FUNC(MakeReadOnlySingleObj, 1, "obj"),
    GVAR_FUNC(IsReadOnlyObj, 1, "obj"),
    GVAR_FUNC(ENABLE_AUTO_RETYPING, 0, ""),
    GVAR_FUNC(ORDERED_READ, 1, "obj"),
    GVAR_FUNC(ORDERED_WRITE, 1, "obj"),
    GVAR_FUNC(CREATOR_OF, 1, "obj"),
    GVAR_FUNC(DISABLE_GUARDS, 1, "flag"),
    GVAR_FUNC(DEFAULT_SIGINT_HANDLER, 0, ""),
    GVAR_FUNC(DEFAULT_SIGVTALRM_HANDLER, 0, ""),
    GVAR_FUNC(DEFAULT_SIGWINCH_HANDLER, 0, ""),
    GVAR_FUNC(SIGWAIT, 1, "record"),
    GVAR_FUNC(PERIODIC_CHECK, 2, "count, function"),
    GVAR_FUNC(REGION_COUNTERS_ENABLE, 1, "region"),
    GVAR_FUNC(REGION_COUNTERS_DISABLE, 1, "region"),
    GVAR_FUNC(REGION_COUNTERS_GET_STATE, 1, "region"),
    GVAR_FUNC(REGION_COUNTERS_GET, 1, "region"),
    GVAR_FUNC(REGION_COUNTERS_RESET, 1, "region"),
    GVAR_FUNC(THREAD_COUNTERS_ENABLE, 0, ""),
    GVAR_FUNC(THREAD_COUNTERS_DISABLE, 0, ""),
    GVAR_FUNC(THREAD_COUNTERS_GET_STATE, 0, ""),
    GVAR_FUNC(THREAD_COUNTERS_GET, 0, ""),
    GVAR_FUNC(THREAD_COUNTERS_RESET, 0, ""),
    { 0, 0, 0, 0, 0 }

};


/****************************************************************************
**
*F  InitKernel( <module> )  . . . . . . . . initialise kernel data structures
*/
static Int InitKernel(StructInitInfo * module)
{
    // set the bag type names (for error messages and debugging)
    InitBagNamesFromTable(BagNames);

    // install the type methods
    TypeObjFuncs[T_THREAD] = TypeThread;
    TypeObjFuncs[T_REGION] = TypeRegion;
    TypeObjFuncs[T_SEMAPHORE] = TypeSemaphore;
    TypeObjFuncs[T_CHANNEL] = TypeChannel;
    TypeObjFuncs[T_BARRIER] = TypeBarrier;
    TypeObjFuncs[T_SYNCVAR] = TypeSyncVar;

    // install global variables
    InitCopyGVar("TYPE_THREAD", &TYPE_THREAD);
    InitCopyGVar("TYPE_REGION", &TYPE_REGION);
    InitCopyGVar("TYPE_SEMAPHORE", &TYPE_SEMAPHORE);
    InitCopyGVar("TYPE_CHANNEL", &TYPE_CHANNEL);
    InitCopyGVar("TYPE_BARRIER", &TYPE_BARRIER);
    InitCopyGVar("TYPE_SYNCVAR", &TYPE_SYNCVAR);

    DeclareGVar(&LastInaccessibleGVar, "LastInaccessible");
    DeclareGVar(&MAX_INTERRUPTGVar, "MAX_INTERRUPT");

    // install mark functions
    InitMarkFuncBags(T_THREAD, MarkNoSubBags);
    InitMarkFuncBags(T_MONITOR, MarkNoSubBags);
    InitMarkFuncBags(T_REGION, MarkAllSubBags);
#ifdef USE_GASMAN
    InitMarkFuncBags(T_SEMAPHORE, MarkSemaphoreBag);
    InitMarkFuncBags(T_CHANNEL, MarkChannelBag);
    InitMarkFuncBags(T_BARRIER, MarkBarrierBag);
    InitMarkFuncBags(T_SYNCVAR, MarkSyncVarBag);
#endif

    // install finalizer functions
    InitFreeFuncBag(T_MONITOR, FinalizeMonitor);

    // install print functions
    PrintObjFuncs[T_THREAD] = PrintThread;
    PrintObjFuncs[T_REGION] = PrintRegion;
    PrintObjFuncs[T_SEMAPHORE] = PrintSemaphore;
    PrintObjFuncs[T_CHANNEL] = PrintChannel;
    PrintObjFuncs[T_BARRIER] = PrintBarrier;
    PrintObjFuncs[T_SYNCVAR] = PrintSyncVar;

    // install mutability functions
    IsMutableObjFuncs[T_THREAD] = AlwaysNo;
    IsMutableObjFuncs[T_REGION] = AlwaysYes;
    IsMutableObjFuncs[T_SEMAPHORE] = AlwaysYes;
    IsMutableObjFuncs[T_CHANNEL] = AlwaysYes;
    IsMutableObjFuncs[T_BARRIER] = AlwaysYes;
    IsMutableObjFuncs[T_SYNCVAR] = AlwaysYes;

    // make bag types public
    MakeBagTypePublic(T_THREAD);
    MakeBagTypePublic(T_REGION);
    MakeBagTypePublic(T_SEMAPHORE);
    MakeBagTypePublic(T_CHANNEL);
    MakeBagTypePublic(T_SYNCVAR);
    MakeBagTypePublic(T_BARRIER);

    PublicRegion = NewBag(T_REGION, sizeof(Region *));

#ifdef HPCGAP
    DeclareGVar(&GVarTHREAD_INIT, "THREAD_INIT");
    DeclareGVar(&GVarTHREAD_EXIT, "THREAD_EXIT");
#endif

    return 0;
}


/****************************************************************************
**
*F  InitLibrary( <module> ) . . . . . . .  initialise library data structures
*/
static Int InitLibrary(StructInitInfo * module)
{
    /* init filters and functions                                          */
    InitGVarFuncsFromTable(GVarFuncs);
    SetGVar(&MAX_INTERRUPTGVar, INTOBJ_INT(MAX_INTERRUPT));
    MakeReadOnlyGVar(GVarName("MAX_INTERRUPT"));
    /* define signal handler values */
    RNAM_SIGINT = RNamName("SIGINT");
    RNAM_SIGCHLD = RNamName("SIGCHLD");
    RNAM_SIGVTALRM = RNamName("SIGVTALRM");
#ifdef SIGWINCH
    RNAM_SIGWINCH = RNamName("SIGWINCH");
#endif

    /* synchronization */
    pthread_mutex_init(&KeepAliveLock, NULL);

    /* return success                                                      */
    return 0;
}


/****************************************************************************
**
*F  InitInfoThreadAPI() . . . . . . . . . . . . . . . table of init functions
*/
static StructInitInfo module = {
    // init struct using C99 designated initializers; for a full list of
    // fields, please refer to the definition of StructInitInfo
    .type = MODULE_BUILTIN,
    .name = "threadapi",
    .initKernel = InitKernel,
    .initLibrary = InitLibrary,
};

StructInitInfo * InitInfoThreadAPI(void)
{
    return &module;
}