--- /dev/null
+/*
+ * 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)
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 */
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SpCondvNotify --
+ *
+ * Signalizes the condition variable.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SpCondvNotify(SpCondv *condvPtr)
+{
+ if (condvPtr->cond) {
+ Tcl_ConditionNotify(&condvPtr->cond);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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: */
OSDN Git Service
