+++ /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(dummy, interp, objc, objv)
- 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
- };
-
- /*
- * 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(dummy, interp, objc, objv)
- 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
- };
-
- /*
- * 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(dummy, interp, objc, objv)
- 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
- };
-
- /*
- * 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(dummy, interp, objc, objv)
- 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;
-
- /*
- * 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 *addrPtr)
-{
- char name[32];
- unsigned int id;
- static unsigned int idcounter;
-
- 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 != (Tcl_HashEntry*)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 new;
- SpBucket *bucketPtr = GetBucket(type, handle, len);
- Tcl_HashEntry *hashEntryPtr;
-
- Tcl_MutexLock(&bucketPtr->lock);
-
- hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &new);
- Tcl_SetHashValue(hashEntryPtr, (ClientData)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 == (Tcl_HashEntry*)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
-/*
- *----------------------------------------------------------------------
- *
- * Sp_Init --
- *
- * Create commands in current interpreter.
- *
- * Results:
- * Standard Tcl result.
- *
- * Side effects:
- * Initializes shared hash table for storing sync primitive
- * handles and pointers.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Sp_Init (interp)
- 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 TCL_OK;
-}
-\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, (Tcl_ThreadId)0)) {
- 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 = (Tcl_ThreadId)0;
- 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, (Tcl_ThreadId)0);
-}
-\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 = (Tcl_ThreadId)0;
- 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 == (Tcl_ThreadId)0) {
- /*
- * 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 == (Tcl_ThreadId)0) {
- 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, (Tcl_ThreadId)0);
-}
-\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 = (Tcl_ThreadId)0;
- 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 = (Tcl_ThreadId)0; /* 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, (Tcl_ThreadId)0);
-}
-\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 = (Tcl_ThreadId)0;
- }
- 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 != (Tcl_ThreadId)0) {
- 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
