/*
 * 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_ObjCmdProc2 ThreadMutexObjCmd;
static Tcl_ObjCmdProc2 ThreadRWMutexObjCmd;
static Tcl_ObjCmdProc2 ThreadCondObjCmd;
static Tcl_ObjCmdProc2 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(
    TCL_UNUSED(void *),                /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret;
    Tcl_Size nameLen;
    const char *mutexName;
    char type;
    SpMutex *mutexPtr;
    static const char *const cmdOpts[] = {
	"create", "destroy", "lock", "unlock", NULL
    };
    enum options {
	m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK
    } opt;

    /*
     * 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 *)Tcl_Alloc(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_GetStringFromObj(nameObj, &nameLen);
	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_GetStringFromObj(objv[2], &nameLen);

    /*
     * Try mutex destroy
     */

    if (opt == m_DESTROY) {
	ret = RemoveMutex(mutexName, nameLen);
	if (ret <= 0) {
	    if (ret == -1) {
	    notfound:
		Tcl_AppendResult(interp, "no such mutex \"", mutexName,
				 "\"", (void *)NULL);
		return TCL_ERROR;
	    } else {
		Tcl_AppendResult(interp, "mutex is in use", (void *)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", (void *)NULL);
	return TCL_ERROR;
    }

    switch (opt) {
    case m_LOCK:
	if (!SpMutexLock(mutexPtr)) {
	    PutMutex(mutexPtr);
	    Tcl_AppendResult(interp, "locking the same exclusive mutex "
			     "twice from the same thread", (void *)NULL);
	    return TCL_ERROR;
	}
	break;
    case m_UNLOCK:
	if (!SpMutexUnlock(mutexPtr)) {
	    PutMutex(mutexPtr);
	    Tcl_AppendResult(interp, "mutex is not locked", (void *)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(
    TCL_UNUSED(void *),                /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret;
    Tcl_Size nameLen;
    const char *mutexName;
    SpMutex *mutexPtr;
    Sp_ReadWriteMutex *rwPtr;
    Sp_AnyMutex **lockPtr;

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

    /*
     * 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 == w_CREATE) {
	Tcl_Obj *nameObj;
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 1, objv, "create");
	    return TCL_ERROR;
	}
	mutexPtr = (SpMutex *)Tcl_Alloc(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_GetStringFromObj(nameObj, &nameLen);
	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_GetStringFromObj(objv[2], &nameLen);

    /*
     * Try mutex destroy
     */

    if (opt == w_DESTROY) {
	ret = RemoveMutex(mutexName, nameLen);
	if (ret <= 0) {
	    if (ret == -1) {
	    notfound:
		Tcl_AppendResult(interp, "no such mutex \"", mutexName,
				 "\"", (void *)NULL);
		return TCL_ERROR;
	    } else {
		Tcl_AppendResult(interp, "mutex is in use", (void *)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", (void *)NULL);
	return TCL_ERROR;
    }

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

    switch (opt) {
    case w_RLOCK:
	if (!Sp_ReadWriteMutexRLock(rwPtr)) {
	    PutMutex(mutexPtr);
	    Tcl_AppendResult(interp, "read-locking already write-locked mutex ",
			     "from the same thread", (void *)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", (void *)NULL);
	    return TCL_ERROR;
	}
	break;
    case w_UNLOCK:
	if (!Sp_ReadWriteMutexUnlock(rwPtr)) {
	    PutMutex(mutexPtr);
	    Tcl_AppendResult(interp, "mutex is not locked", (void *)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(
    TCL_UNUSED(void *),                /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret, timeMsec = 0;
    Tcl_Size nameLen;
    const char *condvName, *mutexName;
    SpMutex *mutexPtr;
    SpCondv *condvPtr;

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

    /*
     * 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 == c_CREATE) {
	Tcl_Obj *nameObj;
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 1, objv, "create");
	    return TCL_ERROR;
	}
	condvPtr = (SpCondv *)Tcl_Alloc(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_GetStringFromObj(objv[2], &nameLen);

    /*
     * Try variable destroy.
     */

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

    /*
     * Try all other options
     */

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

    switch (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,"\"", (void *)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", (void *)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(
    TCL_UNUSED(void *),                /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret, internal;
    Tcl_Size optx;
    const char *mutexName;
    Tcl_Obj *scriptObj;
    SpMutex *mutexPtr = NULL;
    static Sp_RecursiveMutex evalMutex;

    /*
     * 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 whether 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 < 1 + optx) {
	    goto syntax;
	}
	mutexName = Tcl_GetString(objv[2]);
	mutexPtr  = GetMutex(mutexName, objv[2]->length);
	if (mutexPtr == NULL) {
	    Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL);
	    return TCL_ERROR;
	}
	if (IsReadWrite(mutexPtr)) {
            PutMutex(mutexPtr);
	    Tcl_AppendResult(interp, "wrong mutex type, must be exclusive "
			     "or recursive", (void *)NULL);
	    return TCL_ERROR;
	}
	if (!SpMutexLock(mutexPtr)) {
            PutMutex(mutexPtr);
	    Tcl_AppendResult(interp, "locking the same exclusive mutex "
			     "twice from the same thread", (void *)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];
	snprintf(msg, sizeof(msg), "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE));
    }

    /*
     * Unlock the mutex.
     */

    if (internal) {
	Sp_RecursiveMutexUnlock(&evalMutex);
    } else {
	SpMutexUnlock(mutexPtr);
        PutMutex(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,
    TCL_UNUSED(void *))
{
    char name[32];
    size_t id;
    static size_t idcounter;

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

    snprintf(name, sizeof(name), "%cid%" TCL_Z_MODIFIER "u", type, id);

    return Tcl_NewStringObj(name, TCL_INDEX_NONE);
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
    Tcl_Free(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);
    Tcl_Free(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 == NULL) {
	Tcl_MutexLock(&initMutex);
	if (*muxPtr == NULL) {
	    *muxPtr = (Sp_ExclusiveMutex_ *)Tcl_Alloc(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);
	}
	Tcl_Free(*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_ *)
		Tcl_Alloc(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);
	}
	Tcl_Free(*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_ *)
		Tcl_Alloc(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_ *)
		Tcl_Alloc(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);
	}
	Tcl_Free(*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:                  */