/*
 * threadSpCmd.c --
 *
 * This file implements commands for script-level access to thread
 * synchronization primitives. Currently, the exclusive mutex, the
 * recursive mutex. the reader/writer mutex and condition variable
 * objects are exposed to the script programmer.
 *
 * Additionaly, a locked eval is also implemented. This is a practical
 * convenience function which relieves the programmer from the need
 * to take care about unlocking some mutex after evaluating a protected
 * part of code. The locked eval is recursive-savvy since it used the
 * recursive mutex for internal locking.
 *
 * The Tcl interface to the locking and synchronization primitives
 * attempts to catch some very common problems in thread programming
 * like attempting to lock an exclusive mutex twice from the same
 * thread (deadlock), waiting on the condition variable without
 * locking the mutex, destroying primitives while being used, etc...
 * This all comes with some additional internal locking costs but
 * the benefits outweight the costs, especially considering overall
 * performance (or lack of it) of an interpreted laguage like Tcl is.
 *
 * Copyright (c) 2002 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"
#include "threadSpCmd.h"

/*
 * Types of synchronization variables we support.
 */

#define EMUTEXID  'm' /* First letter of the exclusive mutex name */
#define RMUTEXID  'r' /* First letter of the recursive mutex name */
#define WMUTEXID  'w' /* First letter of the read/write mutex name */
#define CONDVID   'c' /* First letter of the condition variable name */

#define SP_MUTEX   1  /* Any kind of mutex */
#define SP_CONDV   2  /* The condition variable sync type */

/*
 * Structure representing one sync primitive (mutex, condition variable).
 * We use buckets to manage Tcl names of sync primitives. Each bucket
 * is associated with a mutex. Each time we process the Tcl name of an
 * sync primitive, we compute it's (trivial) hash and use this hash to
 * address one of pre-allocated buckets.
 * The bucket internally utilzes a hash-table to store item pointers.
 * Item pointers are identified by a simple xid1, xid2... counting
 * handle. This format is chosen to simplify distribution of handles
 * across buckets (natural distribution vs. hash-one as in shared vars).
 */

typedef struct _SpItem {
    int refcnt;            /* Number of threads operating on the item */
    SpBucket *bucket;      /* Bucket where this item is stored */
    Tcl_HashEntry *hentry; /* Hash table entry where this item is stored */
} SpItem;

/*
 * Structure representing a mutex.
 */

typedef struct _SpMutex {
    int refcnt;            /* Number of threads operating on the mutex */
    SpBucket *bucket;      /* Bucket where mutex is stored */
    Tcl_HashEntry *hentry; /* Hash table entry where mutex is stored */
    /* --- */
    char type;             /* Type of the mutex */
    Sp_AnyMutex *lock;     /* Exclusive, recursive or read/write mutex */
} SpMutex;

/*
 * Structure representing a condition variable.
 */

typedef struct _SpCondv {
    int refcnt;            /* Number of threads operating on the variable */
    SpBucket *bucket;      /* Bucket where this variable is stored */
    Tcl_HashEntry *hentry; /* Hash table entry where variable is stored */
    /* --- */
    SpMutex *mutex;        /* Set when waiting on the variable  */
    Tcl_Condition cond;    /* The condition variable itself */
} SpCondv;

/*
 * This global data is used to map opaque Tcl-level names
 * to pointers of their corresponding synchronization objects.
 */

static int        initOnce;    /* Flag for initializing tables below */
static Tcl_Mutex  initMutex;   /* Controls initialization of primitives */
static SpBucket  muxBuckets[NUMSPBUCKETS];  /* Maps mutex names/handles */
static SpBucket  varBuckets[NUMSPBUCKETS];  /* Maps condition variable
                                             * names/handles */

/*
 * Functions implementing Tcl commands
 */

static Tcl_ObjCmdProc ThreadMutexObjCmd;
static Tcl_ObjCmdProc ThreadRWMutexObjCmd;
static Tcl_ObjCmdProc ThreadCondObjCmd;
static Tcl_ObjCmdProc ThreadEvalObjCmd;

/*
 * Forward declaration of functions used only within this file
 */

static int       SpMutexLock       (SpMutex *);
static int       SpMutexUnlock     (SpMutex *);
static int       SpMutexFinalize   (SpMutex *);

static int       SpCondvWait       (SpCondv *, SpMutex *, int);
static void      SpCondvNotify     (SpCondv *);
static int       SpCondvFinalize   (SpCondv *);

static void      AddAnyItem        (int, const char *, size_t, SpItem *);
static SpItem*   GetAnyItem        (int, const char *, size_t);
static void      PutAnyItem        (SpItem *);
static SpItem *  RemoveAnyItem     (int, const char*, size_t);

static int       RemoveMutex       (const char *, size_t);
static int       RemoveCondv       (const char *, size_t);

static Tcl_Obj*  GetName           (int, void *);
static SpBucket* GetBucket         (int, const char *, size_t);

static int       AnyMutexIsLocked  (Sp_AnyMutex *mPtr, Tcl_ThreadId);

/*
 * Function-like macros for some frequently used calls
 */

#define AddMutex(a,b,c)  AddAnyItem(SP_MUTEX, (a), (b), (SpItem*)(c))
#define GetMutex(a,b)    (SpMutex*)GetAnyItem(SP_MUTEX, (a), (b))
#define PutMutex(a)      PutAnyItem((SpItem*)(a))

#define AddCondv(a,b,c)  AddAnyItem(SP_CONDV, (a), (b), (SpItem*)(c))
#define GetCondv(a,b)    (SpCondv*)GetAnyItem(SP_CONDV, (a), (b))
#define PutCondv(a)      PutAnyItem((SpItem*)(a))

#define IsExclusive(a)   ((a)->type == EMUTEXID)
#define IsRecursive(a)   ((a)->type == RMUTEXID)
#define IsReadWrite(a)   ((a)->type == WMUTEXID)

/*
 * This macro produces a hash-value for table-lookups given a handle
 * and its length. It is implemented as macro just for speed.
 * It is actually a trivial thing because the handles are simple
 * counting values with a small three-letter prefix.
 */

#define GetHash(a,b) (atoi((a)+((b) < 4 ? 0 : 3)) % NUMSPBUCKETS)


/*
 *----------------------------------------------------------------------
 *
 * ThreadMutexObjCmd --
 *
 *    This procedure is invoked to process "thread::mutex" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadMutexObjCmd(
    ClientData dummy,                  /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    int objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    char type;
    SpMutex *mutexPtr;
    static const char *cmdOpts[] = {
        "create", "destroy", "lock", "unlock", NULL
    };
    enum options {
        m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK
    };
    (void)dummy;

    /*
     * Syntax:
     *
     *     thread::mutex create ?-recursive?
     *     thread::mutex destroy <mutexHandle>
     *     thread::mutex lock <mutexHandle>
     *     thread::mutex unlock <mutexHandle>
     */

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
        return TCL_ERROR;
    }
    ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     * Cover the "create" option first. It needs no existing handle.
     */

    if (opt == (int)m_CREATE) {
        Tcl_Obj *nameObj;
        const char *arg;

        /*
         * Parse out which type of mutex to create
         */

        if (objc == 2) {
            type = EMUTEXID;
        } else if (objc > 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?");
            return TCL_ERROR;
        } else {
            arg = Tcl_GetString(objv[2]);
            if (OPT_CMP(arg, "-recursive")) {
                type = RMUTEXID;
            } else {
                Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?");
                return TCL_ERROR;
            }
        }

        /*
         * Create the requested mutex
         */

        mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex));
        mutexPtr->type   = type;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        /*
         * Generate Tcl name for this mutex
         */

        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);
        mutexName = Tcl_GetString(nameObj);
        nameLen = nameObj->length;
        AddMutex(mutexName, nameLen, mutexPtr);
        Tcl_SetObjResult(interp, nameObj);
        return TCL_OK;
    }

    /*
     * All other options require a valid name.
     */

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle");
        return TCL_ERROR;
    }

    mutexName = Tcl_GetString(objv[2]);
    nameLen = objv[2]->length;

    /*
     * Try mutex destroy
     */

    if (opt == (int)m_DESTROY) {
        ret = RemoveMutex(mutexName, nameLen);
        if (ret <= 0) {
            if (ret == -1) {
            notfound:
                Tcl_AppendResult(interp, "no such mutex \"", mutexName,
                                 "\"", NULL);
                return TCL_ERROR;
            } else {
                Tcl_AppendResult(interp, "mutex is in use", NULL);
                return TCL_ERROR;
            }
        }
        return TCL_OK;
    }

    /*
     * Try all other options
     */

    mutexPtr = GetMutex(mutexName, nameLen);
    if (mutexPtr == NULL) {
        goto notfound;
    }
    if (!IsExclusive(mutexPtr) && !IsRecursive(mutexPtr)) {
        PutMutex(mutexPtr);
        Tcl_AppendResult(interp, "wrong mutex type, must be either"
                         " exclusive or recursive", NULL);
        return TCL_ERROR;
    }

    switch ((enum options)opt) {
    case m_LOCK:
        if (!SpMutexLock(mutexPtr)) {
            PutMutex(mutexPtr);
            Tcl_AppendResult(interp, "locking the same exclusive mutex "
                             "twice from the same thread", NULL);
            return TCL_ERROR;
        }
        break;
    case m_UNLOCK:
        if (!SpMutexUnlock(mutexPtr)) {
            PutMutex(mutexPtr);
            Tcl_AppendResult(interp, "mutex is not locked", NULL);
            return TCL_ERROR;
        }
        break;
    default:
        break;
    }

    PutMutex(mutexPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadRwMutexObjCmd --
 *
 *    This procedure is invoked to process "thread::rwmutex" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadRWMutexObjCmd(
    ClientData dummy,                  /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    int objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    SpMutex *mutexPtr;
    Sp_ReadWriteMutex *rwPtr;
    Sp_AnyMutex **lockPtr;

    static const char *cmdOpts[] = {
        "create", "destroy", "rlock", "wlock", "unlock", NULL
    };
    enum options {
        w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK
    };
    (void)dummy;

    /*
     * Syntax:
     *
     *     thread::rwmutex create
     *     thread::rwmutex destroy <mutexHandle>
     *     thread::rwmutex rlock <mutexHandle>
     *     thread::rwmutex wlock <mutexHandle>
     *     thread::rwmutex unlock <mutexHandle>
     */

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
        return TCL_ERROR;
    }
    ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     * Cover the "create" option first, since it needs no existing name.
     */

    if (opt == (int)w_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex));
        mutexPtr->type   = WMUTEXID;
        mutexPtr->refcnt = 0;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);
        mutexName = Tcl_GetString(nameObj);
        AddMutex(mutexName, nameObj->length, mutexPtr);
        Tcl_SetObjResult(interp, nameObj);
        return TCL_OK;
    }

    /*
     * All other options require a valid name.
     */

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle");
        return TCL_ERROR;
    }

    mutexName = Tcl_GetString(objv[2]);
    nameLen = objv[2]->length;

    /*
     * Try mutex destroy
     */

    if (opt == (int)w_DESTROY) {
        ret = RemoveMutex(mutexName, nameLen);
        if (ret <= 0) {
            if (ret == -1) {
            notfound:
                Tcl_AppendResult(interp, "no such mutex \"", mutexName,
                                 "\"", NULL);
                return TCL_ERROR;
            } else {
                Tcl_AppendResult(interp, "mutex is in use", NULL);
                return TCL_ERROR;
            }
        }
        return TCL_OK;
    }

    /*
     * Try all other options
     */

    mutexPtr = GetMutex(mutexName, nameLen);
    if (mutexPtr == NULL) {
        goto notfound;
    }
    if (!IsReadWrite(mutexPtr)) {
        PutMutex(mutexPtr);
        Tcl_AppendResult(interp, "wrong mutex type, must be readwrite", NULL);
        return TCL_ERROR;
    }

    lockPtr = &mutexPtr->lock;
    rwPtr = (Sp_ReadWriteMutex*) lockPtr;

    switch ((enum options)opt) {
    case w_RLOCK:
        if (!Sp_ReadWriteMutexRLock(rwPtr)) {
            PutMutex(mutexPtr);
            Tcl_AppendResult(interp, "read-locking already write-locked mutex ",
                             "from the same thread", NULL);
            return TCL_ERROR;
        }
        break;
    case w_WLOCK:
        if (!Sp_ReadWriteMutexWLock(rwPtr)) {
            PutMutex(mutexPtr);
            Tcl_AppendResult(interp, "write-locking the same read-write "
                             "mutex twice from the same thread", NULL);
            return TCL_ERROR;
        }
        break;
    case w_UNLOCK:
        if (!Sp_ReadWriteMutexUnlock(rwPtr)) {
            PutMutex(mutexPtr);
            Tcl_AppendResult(interp, "mutex is not locked", NULL);
            return TCL_ERROR;
        }
        break;
    default:
        break;
    }

    PutMutex(mutexPtr);

    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * ThreadCondObjCmd --
 *
 *    This procedure is invoked to process "thread::cond" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCondObjCmd(
    ClientData dummy,                  /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    int objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int opt, ret, timeMsec = 0;
    size_t nameLen;
    const char *condvName, *mutexName;
    SpMutex *mutexPtr;
    SpCondv *condvPtr;

    static const char *cmdOpts[] = {
        "create", "destroy", "notify", "wait", NULL
    };
    enum options {
        c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT
    };
    (void)dummy;

    /*
     * Syntax:
     *
     *    thread::cond create
     *    thread::cond destroy <condHandle>
     *    thread::cond notify <condHandle>
     *    thread::cond wait <condHandle> <mutexHandle> ?timeout?
     */

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
        return TCL_ERROR;
    }
    ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     * Cover the "create" option since it needs no existing name.
     */

    if (opt == (int)c_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        condvPtr = (SpCondv*)ckalloc(sizeof(SpCondv));
        condvPtr->refcnt = 0;
        condvPtr->bucket = NULL;
        condvPtr->hentry = NULL;
        condvPtr->mutex  = NULL;
        condvPtr->cond   = NULL; /* Will be auto-initialized */

        nameObj = GetName(CONDVID, (void*)condvPtr);
        condvName = Tcl_GetString(nameObj);
        AddCondv(condvName, nameObj->length, condvPtr);
        Tcl_SetObjResult(interp, nameObj);
        return TCL_OK;
    }

    /*
     * All others require at least a valid handle.
     */

    if (objc < 3) {
        Tcl_WrongNumArgs(interp, 2, objv, "condHandle ?args?");
        return TCL_ERROR;
    }

    condvName = Tcl_GetString(objv[2]);
    nameLen = objv[2]->length;

    /*
     * Try variable destroy.
     */

    if (opt == (int)c_DESTROY) {
        ret = RemoveCondv(condvName, nameLen);
        if (ret <= 0) {
            if (ret == -1) {
            notfound:
                Tcl_AppendResult(interp, "no such condition variable \"",
                                 condvName, "\"", NULL);
                return TCL_ERROR;
            } else {
                Tcl_AppendResult(interp, "condition variable is in use", NULL);
                return TCL_ERROR;
            }
        }
        return TCL_OK;
    }

    /*
     * Try all other options
     */

    condvPtr = GetCondv(condvName, nameLen);
    if (condvPtr == NULL) {
        goto notfound;
    }

    switch ((enum options)opt) {
    case c_WAIT:

        /*
         * May improve the Tcl_ConditionWait() to report timeouts so we can
         * inform script programmer about this interesting fact. I think
         * there is still a place for something like Tcl_ConditionWaitEx()
         * or similar in the core.
         */

        if (objc < 4 || objc > 5) {
            PutCondv(condvPtr);
            Tcl_WrongNumArgs(interp, 2, objv, "condHandle mutexHandle ?timeout?");
            return TCL_ERROR;
        }
        if (objc == 5) {
            if (Tcl_GetIntFromObj(interp, objv[4], &timeMsec) != TCL_OK) {
                PutCondv(condvPtr);
                return TCL_ERROR;
            }
        }
        mutexName = Tcl_GetString(objv[3]);
        mutexPtr  = GetMutex(mutexName, objv[3]->length);
        if (mutexPtr == NULL) {
            PutCondv(condvPtr);
            Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", NULL);
            return TCL_ERROR;
        }
        if (!IsExclusive(mutexPtr)
            || SpCondvWait(condvPtr, mutexPtr, timeMsec) == 0) {
            PutCondv(condvPtr);
            PutMutex(mutexPtr);
            Tcl_AppendResult(interp, "mutex not locked or wrong type", NULL);
            return TCL_ERROR;
        }
        PutMutex(mutexPtr);
        break;
    case c_NOTIFY:
        SpCondvNotify(condvPtr);
        break;
    default:
        break;
    }

    PutCondv(condvPtr);

    return TCL_OK;
}
/*
 *----------------------------------------------------------------------
 *
 * ThreadEvalObjCmd --
 *
 *    This procedure is invoked to process "thread::eval" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadEvalObjCmd(
    ClientData dummy,                  /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    int objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret, optx, internal;
    const char *mutexName;
    Tcl_Obj *scriptObj;
    SpMutex *mutexPtr = NULL;
    static Sp_RecursiveMutex evalMutex;
    (void)dummy;

    /*
     * Syntax:
     *
     *     thread::eval ?-lock <mutexHandle>? arg ?arg ...?
     */

    if (objc < 2) {
      syntax:
        Tcl_WrongNumArgs(interp, 1, objv,
                         "?-lock <mutexHandle>? arg ?arg...?");
        return TCL_ERROR;
    }

    /*
     * Find out wether to use the internal (recursive) mutex
     * or external mutex given on the command line, and lock
     * the corresponding mutex immediately.
     *
     * We are using recursive internal mutex so we can easily
     * support the recursion w/o danger of deadlocking. If
     * however, user gives us an exclusive mutex, we will
     * throw error on attempt to recursively call us.
     */

    if (OPT_CMP(Tcl_GetString(objv[1]), "-lock") == 0) {
        internal = 1;
        optx = 1;
        Sp_RecursiveMutexLock(&evalMutex);
    } else {
        internal = 0;
        optx = 3;
        if ((objc - optx) < 1) {
            goto syntax;
        }
        mutexName = Tcl_GetString(objv[2]);
        mutexPtr  = GetMutex(mutexName, objv[2]->length);
        if (mutexPtr == NULL) {
            Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", NULL);
            return TCL_ERROR;
        }
        if (IsReadWrite(mutexPtr)) {
            Tcl_AppendResult(interp, "wrong mutex type, must be exclusive "
                             "or recursive", NULL);
            return TCL_ERROR;
        }
        if (!SpMutexLock(mutexPtr)) {
            Tcl_AppendResult(interp, "locking the same exclusive mutex "
                             "twice from the same thread", NULL);
            return TCL_ERROR;
        }
    }

    objc -= optx;

    /*
     * Evaluate passed arguments as Tcl script. Note that
     * Tcl_EvalObjEx throws away the passed object by
     * doing an decrement reference count on it. This also
     * means we need not build object bytecode rep.
     */

    if (objc == 1) {
        scriptObj = Tcl_DuplicateObj(objv[optx]);
    } else {
        scriptObj = Tcl_ConcatObj(objc, objv + optx);
    }

    Tcl_IncrRefCount(scriptObj);
    ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);
    Tcl_DecrRefCount(scriptObj);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AddErrorInfo(interp, msg);
    }

    /*
     * Unlock the mutex.
     */

    if (internal) {
        Sp_RecursiveMutexUnlock(&evalMutex);
    } else {
        SpMutexUnlock(mutexPtr);
    }

    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * GetName --
 *
 *      Construct a Tcl name for the given sync primitive.
 *      The name is in the simple counted form: XidN
 *      where "X" designates the type of the primitive
 *      and "N" is a increasing integer.
 *
 * Results:
 *      Tcl string object with the constructed name.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
GetName(int type, void *dummy)
{
    char name[32];
    unsigned int id;
    static unsigned int idcounter;
    (void)dummy;

    Tcl_MutexLock(&initMutex);
    id = idcounter++;
    Tcl_MutexUnlock(&initMutex);

    sprintf(name, "%cid%d", type, id);

    return Tcl_NewStringObj(name, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * GetBucket --
 *
 *      Returns the bucket for the given name.
 *
 * Results:
 *      Pointer to the bucket.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static SpBucket*
GetBucket(int type, const char *name, size_t len)
{
    switch (type) {
    case SP_MUTEX: return &muxBuckets[GetHash(name, len)];
    case SP_CONDV: return &varBuckets[GetHash(name, len)];
    }

    return NULL; /* Never reached */
}

/*
 *----------------------------------------------------------------------
 *
 * GetAnyItem --
 *
 *      Retrieves the item structure from it's corresponding bucket.
 *
 * Results:
 *      Item pointer or NULL
 *
 * Side effects:
 *      Increment the item's ref count preventing it's deletion.
 *
 *----------------------------------------------------------------------
 */

static SpItem*
GetAnyItem(int type, const char *name, size_t len)
{
    SpItem *itemPtr = NULL;
    SpBucket *bucketPtr = GetBucket(type, name, len);
    Tcl_HashEntry *hashEntryPtr = NULL;

    Tcl_MutexLock(&bucketPtr->lock);
    hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name);
    if (hashEntryPtr != NULL) {
        itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr);
        itemPtr->refcnt++;
    }
    Tcl_MutexUnlock(&bucketPtr->lock);

    return itemPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * PutAnyItem --
 *
 *      Current thread detaches from the item.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Decrement item's ref count allowing for it's deletion
 *      and signalize any threads waiting to delete the item.
 *
 *----------------------------------------------------------------------
 */

static void
PutAnyItem(SpItem *itemPtr)
{
    Tcl_MutexLock(&itemPtr->bucket->lock);
    itemPtr->refcnt--;
    Tcl_ConditionNotify(&itemPtr->bucket->cond);
    Tcl_MutexUnlock(&itemPtr->bucket->lock);
}

/*
 *----------------------------------------------------------------------
 *
 * AddAnyItem --
 *
 *      Puts any item in the corresponding bucket.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static void
AddAnyItem(int type, const char *handle, size_t len, SpItem *itemPtr)
{
    int isNew;
    SpBucket *bucketPtr = GetBucket(type, handle, len);
    Tcl_HashEntry *hashEntryPtr;

    Tcl_MutexLock(&bucketPtr->lock);

    hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &isNew);
    Tcl_SetHashValue(hashEntryPtr, itemPtr);

    itemPtr->refcnt = 0;
    itemPtr->bucket = bucketPtr;
    itemPtr->hentry = hashEntryPtr;

    Tcl_MutexUnlock(&bucketPtr->lock);
}

/*
 *----------------------------------------------------------------------
 *
 * RemoveAnyItem --
 *
 *      Removes the item from it's bucket.
 *
 * Results:
 *      Item's pointer or NULL if none found.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static SpItem *
RemoveAnyItem(int type, const char *name, size_t len)
{
    SpItem *itemPtr = NULL;
    SpBucket *bucketPtr = GetBucket(type, name, len);
    Tcl_HashEntry *hashEntryPtr = NULL;

    Tcl_MutexLock(&bucketPtr->lock);
    hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name);
    if (hashEntryPtr == NULL) {
        Tcl_MutexUnlock(&bucketPtr->lock);
        return NULL;
    }
    itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr);
    Tcl_DeleteHashEntry(hashEntryPtr);
    while (itemPtr->refcnt > 0) {
        Tcl_ConditionWait(&bucketPtr->cond, &bucketPtr->lock, NULL);
    }
    Tcl_MutexUnlock(&bucketPtr->lock);

    return itemPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * RemoveMutex --
 *
 *      Removes the mutex from it's bucket and finalizes it.
 *
 * Results:
 *      1 - mutex is finalized and removed
 *      0 - mutex is not finalized
 +     -1 - mutex is not found
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
RemoveMutex(const char *name, size_t len)
{
    SpMutex *mutexPtr = GetMutex(name, len);
    if (mutexPtr == NULL) {
        return -1;
    }
    if (!SpMutexFinalize(mutexPtr)) {
        PutMutex(mutexPtr);
        return 0;
    }
    PutMutex(mutexPtr);
    RemoveAnyItem(SP_MUTEX, name, len);
    ckfree((char*)mutexPtr);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * RemoveCondv --
 *
 *      Removes the cond variable from it's bucket and finalizes it.
 *
 * Results:
 *      1 - variable is finalized and removed
 *      0 - variable is not finalized
 +     -1 - variable is not found
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
RemoveCondv(const char *name, size_t len)
{
    SpCondv *condvPtr = GetCondv(name, len);
    if (condvPtr == NULL) {
        return -1;
    }
    if (!SpCondvFinalize(condvPtr)) {
        PutCondv(condvPtr);
        return 0;
    }
    PutCondv(condvPtr);
    RemoveAnyItem(SP_CONDV, name, len);
    ckfree((char*)condvPtr);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * SpInit --
 *
 *      Create commands in current interpreter.
 *
 * Results:
 *      NULL
 *
 * Side effects:
 *      Initializes shared hash table for storing sync primitive
 *      handles and pointers.
 *
 *----------------------------------------------------------------------
 */

const char *
SpInit (
    Tcl_Interp *interp                 /* Interp where to create cmds */
) {
    SpBucket *bucketPtr;

    if (!initOnce) {
        Tcl_MutexLock(&initMutex);
        if (!initOnce) {
            int ii;
            for (ii = 0; ii < NUMSPBUCKETS; ii++) {
                bucketPtr = &muxBuckets[ii];
                memset(bucketPtr, 0, sizeof(SpBucket));
                Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS);
            }
            for (ii = 0; ii < NUMSPBUCKETS; ii++) {
                bucketPtr = &varBuckets[ii];
                memset(bucketPtr, 0, sizeof(SpBucket));
                Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS);
            }
            initOnce = 1;
        }
        Tcl_MutexUnlock(&initMutex);
    }

    TCL_CMD(interp, THREAD_CMD_PREFIX"::mutex",   ThreadMutexObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"::rwmutex", ThreadRWMutexObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"::cond",    ThreadCondObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"::eval",    ThreadEvalObjCmd);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * SpMutexLock --
 *
 *      Locks the typed mutex.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - mutex is not locked (pending deadlock?)
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
SpMutexLock(SpMutex *mutexPtr)
{
    Sp_AnyMutex **lockPtr = &mutexPtr->lock;

    switch (mutexPtr->type) {
    case EMUTEXID:
        return Sp_ExclusiveMutexLock((Sp_ExclusiveMutex*)lockPtr);
        break;
    case RMUTEXID:
        return Sp_RecursiveMutexLock((Sp_RecursiveMutex*)lockPtr);
        break;
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * SpMutexUnlock --
 *
 *      Unlocks the typed mutex.
 *
 * Results:
 *      1 - mutex is unlocked
 *      0 - mutex was not locked
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
SpMutexUnlock(SpMutex *mutexPtr)
{
    Sp_AnyMutex **lockPtr = &mutexPtr->lock;

    switch (mutexPtr->type) {
    case EMUTEXID:
        return Sp_ExclusiveMutexUnlock((Sp_ExclusiveMutex*)lockPtr);
        break;
    case RMUTEXID:
        return Sp_RecursiveMutexUnlock((Sp_RecursiveMutex*)lockPtr);
        break;
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * SpMutexFinalize --
 *
 *      Finalizes the typed mutex. This should never be called without
 *      some external mutex protection.
 *
 * Results:
 *      1 - mutex is finalized
 *      0 - mutex is still in use
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
SpMutexFinalize(SpMutex *mutexPtr)
{
    Sp_AnyMutex **lockPtr = &mutexPtr->lock;

    if (AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, NULL)) {
        return 0;
    }

    /*
     * At this point, the mutex could be locked again, hence it
     * is important never to call this function unprotected.
     */

    switch (mutexPtr->type) {
    case EMUTEXID:
        Sp_ExclusiveMutexFinalize((Sp_ExclusiveMutex*)lockPtr);
        break;
    case RMUTEXID:
        Sp_RecursiveMutexFinalize((Sp_RecursiveMutex*)lockPtr);
        break;
    case WMUTEXID:
        Sp_ReadWriteMutexFinalize((Sp_ReadWriteMutex*)lockPtr);
        break;
    default:
        break;
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * SpCondvWait --
 *
 *      Waits on the condition variable.
 *
 * Results:
 *      1 - wait ok
 *      0 - not waited as mutex is not locked in the same thread
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
SpCondvWait(SpCondv *condvPtr, SpMutex *mutexPtr, int msec)
{
    Sp_AnyMutex **lock = &mutexPtr->lock;
    Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)lock;
    Tcl_Time waitTime, *wt = NULL;
    Tcl_ThreadId threadId = Tcl_GetCurrentThread();

    if (msec > 0) {
        wt = &waitTime;
        wt->sec  = (msec/1000);
        wt->usec = (msec%1000) * 1000;
    }
    if (!AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, threadId)) {
        return 0; /* Mutex not locked by the current thread */
    }

    /*
     * It is safe to operate on mutex struct because caller
     * is holding the emPtr->mutex locked before we enter
     * the Tcl_ConditionWait and after we return out of it.
     */

    condvPtr->mutex = mutexPtr;

    emPtr->owner = NULL;
    emPtr->lockcount = 0;

    Tcl_ConditionWait(&condvPtr->cond, &emPtr->mutex, wt);

    emPtr->owner = threadId;
    emPtr->lockcount = 1;

    condvPtr->mutex = NULL;

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * SpCondvNotify --
 *
 *      Signalizes the condition variable.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static void
SpCondvNotify(SpCondv *condvPtr)
{
    if (condvPtr->cond) {
        Tcl_ConditionNotify(&condvPtr->cond);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SpCondvFinalize --
 *
 *      Finalizes the condition variable.
 *
 * Results:
 *      1 - variable is finalized
 *      0 - variable is in use
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
SpCondvFinalize(SpCondv *condvPtr)
{
    if (condvPtr->mutex != NULL) {
        return 0; /* Somebody is waiting on the variable */
    }

    if (condvPtr->cond) {
        Tcl_ConditionFinalize(&condvPtr->cond);
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ExclusiveMutexLock --
 *
 *      Locks the exclusive mutex.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - mutex is not locked; same thread tries to locks twice
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *muxPtr)
{
    Sp_ExclusiveMutex_ *emPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
            *muxPtr = (Sp_ExclusiveMutex_*)
                ckalloc(sizeof(Sp_ExclusiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    /*
     * Try locking if not currently locked by anybody.
     */

    emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
    Tcl_MutexLock(&emPtr->lock);
    if (emPtr->lockcount && emPtr->owner == thisThread) {
        Tcl_MutexUnlock(&emPtr->lock);
        return 0; /* Already locked by the same thread */
    }
    Tcl_MutexUnlock(&emPtr->lock);

    /*
     * Many threads can come to this point.
     * Only one will succeed locking the
     * mutex. Others will block...
     */

    Tcl_MutexLock(&emPtr->mutex);

    Tcl_MutexLock(&emPtr->lock);
    emPtr->owner = thisThread;
    emPtr->lockcount = 1;
    Tcl_MutexUnlock(&emPtr->lock);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ExclusiveMutexIsLocked --
 *
 *      Checks wether the mutex is locked or not.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - mutex is not locked
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_ExclusiveMutexIsLocked(Sp_ExclusiveMutex *muxPtr)
{
    return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ExclusiveMutexUnlock --
 *
 *      Unlock the exclusive mutex.
 *
 * Results:
 *      1 - mutex is unlocked
 ?      0 - mutex was never locked
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_ExclusiveMutexUnlock(Sp_ExclusiveMutex *muxPtr)
{
    Sp_ExclusiveMutex_ *emPtr;

    if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
        return 0; /* Never locked before */
    }

    emPtr = *(Sp_ExclusiveMutex_**)muxPtr;

    Tcl_MutexLock(&emPtr->lock);
    if (emPtr->lockcount == 0) {
        Tcl_MutexUnlock(&emPtr->lock);
        return 0; /* Not locked */
    }
    emPtr->owner = NULL;
    emPtr->lockcount = 0;
    Tcl_MutexUnlock(&emPtr->lock);

    /*
     * Only one thread should be able
     * to come to this point and unlock...
     */

    Tcl_MutexUnlock(&emPtr->mutex);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ExclusiveMutexFinalize --
 *
 *      Finalize the exclusive mutex. It is not safe for two or
 *      more threads to finalize the mutex at the same time.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Mutex is destroyed.
 *
 *----------------------------------------------------------------------
 */

void
Sp_ExclusiveMutexFinalize(Sp_ExclusiveMutex *muxPtr)
{
    if (*muxPtr != (Sp_ExclusiveMutex_*)0) {
        Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
        if (emPtr->lock) {
            Tcl_MutexFinalize(&emPtr->lock);
        }
        if (emPtr->mutex) {
            Tcl_MutexFinalize(&emPtr->mutex);
        }
        ckfree((char*)*muxPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexLock --
 *
 *      Locks the recursive mutex.
 *
 * Results:
 *      1 - mutex is locked (as it always should be)
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_RecursiveMutexLock(Sp_RecursiveMutex *muxPtr)
{
    Sp_RecursiveMutex_ *rmPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_RecursiveMutex_*)0) {
            *muxPtr = (Sp_RecursiveMutex_*)
                ckalloc(sizeof(Sp_RecursiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
    Tcl_MutexLock(&rmPtr->lock);

    if (rmPtr->owner == thisThread) {
        /*
         * We are already holding the mutex
         * so just count one more lock.
         */
        rmPtr->lockcount++;
    } else {
        if (rmPtr->owner == NULL) {
            /*
             * Nobody holds the mutex, we do now.
             */
            rmPtr->owner = thisThread;
            rmPtr->lockcount = 1;
        } else {
            /*
             * Somebody else holds the mutex; wait.
             */
            while (1) {
                Tcl_ConditionWait(&rmPtr->cond, &rmPtr->lock, NULL);
                if (rmPtr->owner == NULL) {
                    rmPtr->owner = thisThread;
                    rmPtr->lockcount = 1;
                    break;
                }
            }
        }
    }

    Tcl_MutexUnlock(&rmPtr->lock);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexIsLocked --
 *
 *      Checks wether the mutex is locked or not.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - mutex is not locked
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_RecursiveMutexIsLocked(Sp_RecursiveMutex *muxPtr)
{
    return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexUnlock --
 *
 *      Unlock the recursive mutex.
 *
 * Results:
 *      1 - mutex unlocked
 *      0 - mutex never locked
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_RecursiveMutexUnlock(Sp_RecursiveMutex *muxPtr)
{
    Sp_RecursiveMutex_ *rmPtr;

    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
        return 0; /* Never locked before */
    }

    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
    Tcl_MutexLock(&rmPtr->lock);
    if (rmPtr->lockcount == 0) {
        Tcl_MutexUnlock(&rmPtr->lock);
        return 0; /* Not locked now */
    }
    if (--rmPtr->lockcount <= 0) {
        rmPtr->lockcount = 0;
        rmPtr->owner = NULL;
        if (rmPtr->cond) {
            Tcl_ConditionNotify(&rmPtr->cond);
        }
    }
    Tcl_MutexUnlock(&rmPtr->lock);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexFinalize --
 *
 *      Finalize the recursive mutex. It is not safe for two or
 *      more threads to finalize the mutex at the same time.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Mutex is destroyed.
 *
 *----------------------------------------------------------------------
 */

void
Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *muxPtr)
{
    if (*muxPtr != (Sp_RecursiveMutex_*)0) {
        Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
        if (rmPtr->lock) {
            Tcl_MutexFinalize(&rmPtr->lock);
        }
        if (rmPtr->cond) {
            Tcl_ConditionFinalize(&rmPtr->cond);
        }
        ckfree((char*)*muxPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexRLock --
 *
 *      Read-locks the reader/writer mutex.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - mutex is not locked as we already hold the write lock
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_ReadWriteMutexRLock(Sp_ReadWriteMutex *muxPtr)
{
    Sp_ReadWriteMutex_ *rwPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr = (Sp_ReadWriteMutex_*)
                ckalloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
    if (rwPtr->lockcount == -1 && rwPtr->owner == thisThread) {
        Tcl_MutexUnlock(&rwPtr->lock);
        return 0; /* We already hold the write lock */
    }
    while (rwPtr->lockcount < 0) {
        rwPtr->numrd++;
        Tcl_ConditionWait(&rwPtr->rcond, &rwPtr->lock, NULL);
        rwPtr->numrd--;
    }
    rwPtr->lockcount++;
    rwPtr->owner = NULL; /* Many threads can read-lock */
    Tcl_MutexUnlock(&rwPtr->lock);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexWLock --
 *
 *      Write-locks the reader/writer mutex.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - same thread attempts to write-lock the mutex twice
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_ReadWriteMutexWLock(Sp_ReadWriteMutex *muxPtr)
{
    Sp_ReadWriteMutex_ *rwPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr = (Sp_ReadWriteMutex_*)
                ckalloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
    if (rwPtr->owner == thisThread && rwPtr->lockcount == -1) {
        Tcl_MutexUnlock(&rwPtr->lock);
        return 0; /* The same thread attempts to write-lock again */
    }
    while (rwPtr->lockcount != 0) {
        rwPtr->numwr++;
        Tcl_ConditionWait(&rwPtr->wcond, &rwPtr->lock, NULL);
        rwPtr->numwr--;
    }
    rwPtr->lockcount = -1;     /* This designates the sole writer */
    rwPtr->owner = thisThread; /* which is our current thread     */
    Tcl_MutexUnlock(&rwPtr->lock);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexIsLocked --
 *
 *      Checks wether the mutex is locked or not.
 *
 * Results:
 *      1 - mutex is locked
 *      0 - mutex is not locked
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Sp_ReadWriteMutexIsLocked(Sp_ReadWriteMutex *muxPtr)
{
    return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexUnlock --
 *
 *      Unlock the reader/writer mutex.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int
Sp_ReadWriteMutexUnlock(Sp_ReadWriteMutex *muxPtr)
{
    Sp_ReadWriteMutex_ *rwPtr;

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        return 0; /* Never locked before */
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
    if (rwPtr->lockcount == 0) {
        Tcl_MutexUnlock(&rwPtr->lock);
        return 0; /* Not locked now */
    }
    if (--rwPtr->lockcount <= 0) {
        rwPtr->lockcount = 0;
        rwPtr->owner = NULL;
    }
    if (rwPtr->numwr) {
        Tcl_ConditionNotify(&rwPtr->wcond);
    } else if (rwPtr->numrd) {
        Tcl_ConditionNotify(&rwPtr->rcond);
    }

    Tcl_MutexUnlock(&rwPtr->lock);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexFinalize --
 *
 *      Finalize the reader/writer mutex. It is not safe for two or
 *      more threads to finalize the mutex at the same time.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Mutex is destroyed.
 *
 *----------------------------------------------------------------------
 */

void
Sp_ReadWriteMutexFinalize(Sp_ReadWriteMutex *muxPtr)
{
    if (*muxPtr != (Sp_ReadWriteMutex_*)0) {
        Sp_ReadWriteMutex_ *rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
        if (rwPtr->lock) {
            Tcl_MutexFinalize(&rwPtr->lock);
        }
        if (rwPtr->rcond) {
            Tcl_ConditionFinalize(&rwPtr->rcond);
        }
        if (rwPtr->wcond) {
            Tcl_ConditionFinalize(&rwPtr->wcond);
        }
        ckfree((char*)*muxPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * AnyMutexIsLocked --
 *
 *      Checks wether the mutex is locked. If optional threadId
 *      is given (i.e. != 0) it checks if the given thread also
 *      holds the lock.
 *
 * Results:
 *      1 - mutex is locked (optionally by the given thread)
 *      0 - mutex is not locked (optionally by the given thread)
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
static int
AnyMutexIsLocked(Sp_AnyMutex *mPtr, Tcl_ThreadId threadId)
{
    int locked = 0;

    if (mPtr != NULL) {
        Tcl_MutexLock(&mPtr->lock);
        locked = mPtr->lockcount != 0;
        if (locked && threadId != NULL) {
            locked = mPtr->owner == threadId;
        }
        Tcl_MutexUnlock(&mPtr->lock);
    }

    return locked;
}


/* EOF $RCSfile: threadSpCmd.c,v $ */

/* Emacs Setup Variables */
/* Local Variables:      */
/* mode: C               */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4     */
/* End:                  */