1/*
2 * threadSpCmd.c --
3 *
4 * This file implements commands for script-level access to thread
5 * synchronization primitives. Currently, the exclusive mutex, the
6 * recursive mutex. the reader/writer mutex and condition variable
7 * objects are exposed to the script programmer.
8 *
9 * Additionaly, a locked eval is also implemented. This is a practical
10 * convenience function which relieves the programmer from the need
11 * to take care about unlocking some mutex after evaluating a protected
12 * part of code. The locked eval is recursive-savvy since it used the
13 * recursive mutex for internal locking.
14 *
15 * The Tcl interface to the locking and synchronization primitives
16 * attempts to catch some very common problems in thread programming
17 * like attempting to lock an exclusive mutex twice from the same
18 * thread (deadlock), waiting on the condition variable without
19 * locking the mutex, destroying primitives while being used, etc...
20 * This all comes with some additional internal locking costs but
21 * the benefits outweight the costs, especially considering overall
22 * performance (or lack of it) of an interpreted laguage like Tcl is.
23 *
24 * Copyright (c) 2002 by Zoran Vasiljevic.
25 *
26 * See the file "license.terms" for information on usage and redistribution
27 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
28 *
29 * RCS: @(#) $Id: threadSpCmd.c,v 1.33 2010/05/26 20:10:10 andreas_kupries Exp $
30 * ----------------------------------------------------------------------------
31 */
32
33#include "tclThread.h"
34#include "threadSpCmd.h"
35
36/*
37 * Types of synchronization variables we support.
38 */
39
40#define EMUTEXID  'm' /* First letter of the exclusive mutex name */
41#define RMUTEXID  'r' /* First letter of the recursive mutex name */
42#define WMUTEXID  'w' /* First letter of the read/write mutex name */
43#define CONDVID   'c' /* First letter of the condition variable name */
44
45#define SP_MUTEX   1  /* Any kind of mutex */
46#define SP_CONDV   2  /* The condition variable sync type */
47
48/*
49 * Handle hiding of errorLine in 8.6
50 */
51#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
52#define ERRORLINE(interp) ((interp)->errorLine)
53#else
54#define ERRORLINE(interp) (Tcl_GetErrorLine(interp))
55#endif
56
57/*
58 * Structure representing one sync primitive (mutex, condition variable).
59 * We use buckets to manage Tcl names of sync primitives. Each bucket
60 * is associated with a mutex. Each time we process the Tcl name of an
61 * sync primitive, we compute it's (trivial) hash and use this hash to
62 * address one of pre-allocated buckets.
63 * The bucket internally utilzes a hash-table to store item pointers.
64 * Item pointers are identified by a simple xid1, xid2... counting
65 * handle. This format is chosen to simplify distribution of handles
66 * across buckets (natural distribution vs. hash-one as in shared vars).
67 */
68
69typedef struct _SpItem {
70    int refcnt;            /* Number of threads operating on the item */
71    SpBucket *bucket;      /* Bucket where this item is stored */
72    Tcl_HashEntry *hentry; /* Hash table entry where this item is stored */
73} SpItem;
74
75/*
76 * Structure representing a mutex.
77 */
78
79typedef struct _SpMutex {
80    int refcnt;            /* Number of threads operating on the mutex */
81    SpBucket *bucket;      /* Bucket where mutex is stored */
82    Tcl_HashEntry *hentry; /* Hash table entry where mutex is stored */
83    /* --- */
84    char type;             /* Type of the mutex */
85    Sp_AnyMutex *lock;     /* Exclusive, recursive or read/write mutex */
86} SpMutex;
87
88/*
89 * Structure representing a condition variable.
90 */
91
92typedef struct _SpCondv {
93    int refcnt;            /* Number of threads operating on the variable */
94    SpBucket *bucket;      /* Bucket where this variable is stored */
95    Tcl_HashEntry *hentry; /* Hash table entry where variable is stored */
96    /* --- */
97    SpMutex *mutex;        /* Set when waiting on the variable  */
98    Tcl_Condition cond;    /* The condition variable itself */
99} SpCondv;
100
101/*
102 * This global data is used to map opaque Tcl-level names
103 * to pointers of their corresponding synchronization objects.
104 */
105
106static int        initOnce;    /* Flag for initializing tables below */
107static Tcl_Mutex  initMutex;   /* Controls initialization of primitives */
108static SpBucket*  muxBuckets;  /* Maps mutex names/handles */
109static SpBucket*  varBuckets;  /* Maps condition variable names/handles */
110
111/*
112 * Functions implementing Tcl commands
113 */
114
115static Tcl_ObjCmdProc ThreadMutexObjCmd;
116static Tcl_ObjCmdProc ThreadRWMutexObjCmd;
117static Tcl_ObjCmdProc ThreadCondObjCmd;
118static Tcl_ObjCmdProc ThreadEvalObjCmd;
119
120/*
121 * Forward declaration of functions used only within this file
122 */
123
124static int       SpMutexLock       (SpMutex *);
125static int       SpMutexUnlock     (SpMutex *);
126static int       SpMutexFinalize   (SpMutex *);
127
128static int       SpCondvWait       (SpCondv *, SpMutex *, int);
129static void      SpCondvNotify     (SpCondv *);
130static int       SpCondvFinalize   (SpCondv *);
131
132static void      AddAnyItem        (int, const char *, int, SpItem *);
133static SpItem*   GetAnyItem        (int, const char *, int);
134static void      PutAnyItem        (SpItem *);
135static SpItem *  RemoveAnyItem     (int, const char*, int);
136
137static int       RemoveMutex       (const char *, int);
138static int       RemoveCondv       (const char *, int);
139
140static Tcl_Obj*  GetName           (int, void *);
141static SpBucket* GetBucket         (int, const char *, int);
142
143static int       AnyMutexIsLocked  (Sp_AnyMutex *mPtr, Tcl_ThreadId);
144
145/*
146 * Function-like macros for some frequently used calls
147 */
148
149#define AddMutex(a,b,c)  AddAnyItem(SP_MUTEX, (a), (b), (SpItem*)(c))
150#define GetMutex(a,b)    (SpMutex*)GetAnyItem(SP_MUTEX, (a), (b))
151#define PutMutex(a)      PutAnyItem((SpItem*)(a))
152
153#define AddCondv(a,b,c)  AddAnyItem(SP_CONDV, (a), (b), (SpItem*)(c))
154#define GetCondv(a,b)    (SpCondv*)GetAnyItem(SP_CONDV, (a), (b))
155#define PutCondv(a)      PutAnyItem((SpItem*)(a))
156
157#define IsExclusive(a)   ((a)->type == EMUTEXID)
158#define IsRecursive(a)   ((a)->type == RMUTEXID)
159#define IsReadWrite(a)   ((a)->type == WMUTEXID)
160
161/*
162 * This macro produces a hash-value for table-lookups given a handle
163 * and its length. It is implemented as macro just for speed.
164 * It is actually a trivial thing because the handles are simple
165 * counting values with a small three-letter prefix.
166 */
167
168#define GetHash(a,b) (atoi((a)+((b) < 4 ? 0 : 3)) % NUMSPBUCKETS)
169
170
171/*
172 *----------------------------------------------------------------------
173 *
174 * ThreadMutexObjCmd --
175 *
176 *    This procedure is invoked to process "thread::mutex" Tcl command.
177 *    See the user documentation for details on what it does.
178 *
179 * Results:
180 *    A standard Tcl result.
181 *
182 * Side effects:
183 *    See the user documentation.
184 *
185 *----------------------------------------------------------------------
186 */
187
188static int
189ThreadMutexObjCmd(dummy, interp, objc, objv)
190    ClientData dummy;                   /* Not used. */
191    Tcl_Interp *interp;                 /* Current interpreter. */
192    int objc;                           /* Number of arguments. */
193    Tcl_Obj *const objv[];              /* Argument objects. */
194{
195    int opt, ret, nameLen;
196    const char *mutexName;
197    char type;
198    SpMutex *mutexPtr;
199
200    static const char *cmdOpts[] = {
201        "create", "destroy", "lock", "unlock", NULL
202    };
203    enum options {
204        m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK
205    };
206
207    /*
208     * Syntax:
209     *
210     *     thread::mutex create ?-recursive?
211     *     thread::mutex destroy <mutexHandle>
212     *     thread::mutex lock <mutexHandle>
213     *     thread::mutex unlock <mutexHandle>
214     */
215
216    if (objc < 2) {
217        Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
218        return TCL_ERROR;
219    }
220    ret = Tcl_GetIndexFromObj(interp, objv[1], cmdOpts, "option", 0, &opt);
221    if (ret != TCL_OK) {
222        return TCL_ERROR;
223    }
224
225    /*
226     * Cover the "create" option first. It needs no existing handle.
227     */
228
229    if (opt == (int)m_CREATE) {
230        Tcl_Obj *nameObj;
231        const char *arg;
232
233        /*
234         * Parse out which type of mutex to create
235         */
236
237        if (objc == 2) {
238            type = EMUTEXID;
239        } else if (objc > 3) {
240            Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?");
241            return TCL_ERROR;
242        } else {
243            arg = Tcl_GetStringFromObj(objv[2], NULL);
244            if (OPT_CMP(arg, "-recursive")) {
245                type = RMUTEXID;
246            } else {
247                Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?");
248                return TCL_ERROR;
249            }
250        }
251
252        /*
253         * Create the requested mutex
254         */
255
256        mutexPtr = (SpMutex*)Tcl_Alloc(sizeof(SpMutex));
257        mutexPtr->type   = type;
258        mutexPtr->bucket = NULL;
259        mutexPtr->hentry = NULL;
260        mutexPtr->lock   = NULL; /* Will be auto-initialized */
261
262        /*
263         * Generate Tcl name for this mutex
264         */
265
266        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);
267        mutexName = Tcl_GetStringFromObj(nameObj, &nameLen);
268        AddMutex(mutexName, nameLen, mutexPtr);
269        Tcl_SetObjResult(interp, nameObj);
270        return TCL_OK;
271    }
272
273    /*
274     * All other options require a valid name.
275     */
276
277    if (objc != 3) {
278        Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle");
279        return TCL_ERROR;
280    }
281
282    mutexName = Tcl_GetStringFromObj(objv[2], &nameLen);
283
284    /*
285     * Try mutex destroy
286     */
287
288    if (opt == (int)m_DESTROY) {
289        ret = RemoveMutex(mutexName, nameLen);
290        if (ret <= 0) {
291            if (ret == -1) {
292            notfound:
293                Tcl_AppendResult(interp, "no such mutex \"", mutexName,
294                                 "\"", NULL);
295                return TCL_ERROR;
296            } else {
297                Tcl_AppendResult(interp, "mutex is in use", NULL);
298                return TCL_ERROR;
299            }
300        }
301        return TCL_OK;
302    }
303
304    /*
305     * Try all other options
306     */
307
308    mutexPtr = GetMutex(mutexName, nameLen);
309    if (mutexPtr == NULL) {
310        goto notfound;
311    }
312    if (!IsExclusive(mutexPtr) && !IsRecursive(mutexPtr)) {
313        PutMutex(mutexPtr);
314        Tcl_AppendResult(interp, "wrong mutex type, must be either"
315                         " exclusive or recursive", NULL);
316        return TCL_ERROR;
317    }
318
319    switch ((enum options)opt) {
320    case m_LOCK:
321        if (!SpMutexLock(mutexPtr)) {
322            PutMutex(mutexPtr);
323            Tcl_AppendResult(interp, "locking the same exclusive mutex "
324                             "twice from the same thread", NULL);
325            return TCL_ERROR;
326        }
327        break;
328    case m_UNLOCK:
329        if (!SpMutexUnlock(mutexPtr)) {
330            PutMutex(mutexPtr);
331            Tcl_AppendResult(interp, "mutex is not locked", NULL);
332            return TCL_ERROR;
333        }
334        break;
335    default:
336        break;
337    }
338
339    PutMutex(mutexPtr);
340
341    return TCL_OK;
342}
343
344/*
345 *----------------------------------------------------------------------
346 *
347 * ThreadRwMutexObjCmd --
348 *
349 *    This procedure is invoked to process "thread::rwmutex" Tcl command.
350 *    See the user documentation for details on what it does.
351 *
352 * Results:
353 *    A standard Tcl result.
354 *
355 * Side effects:
356 *    See the user documentation.
357 *
358 *----------------------------------------------------------------------
359 */
360
361static int
362ThreadRWMutexObjCmd(dummy, interp, objc, objv)
363    ClientData dummy;                   /* Not used. */
364    Tcl_Interp *interp;                 /* Current interpreter. */
365    int objc;                           /* Number of arguments. */
366    Tcl_Obj *const objv[];              /* Argument objects. */
367{
368    int opt, ret, nameLen;
369    const char *mutexName;
370    SpMutex *mutexPtr;
371    Sp_ReadWriteMutex *rwPtr;
372    Sp_AnyMutex **lockPtr;
373
374    static const char *cmdOpts[] = {
375        "create", "destroy", "rlock", "wlock", "unlock", NULL
376    };
377    enum options {
378        w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK
379    };
380
381    /*
382     * Syntax:
383     *
384     *     thread::rwmutex create
385     *     thread::rwmutex destroy <mutexHandle>
386     *     thread::rwmutex rlock <mutexHandle>
387     *     thread::rwmutex wlock <mutexHandle>
388     *     thread::rwmutex unlock <mutexHandle>
389     */
390
391    if (objc < 2) {
392        Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
393        return TCL_ERROR;
394    }
395    ret = Tcl_GetIndexFromObj(interp, objv[1], cmdOpts, "option", 0, &opt);
396    if (ret != TCL_OK) {
397        return TCL_ERROR;
398    }
399
400    /*
401     * Cover the "create" option first, since it needs no existing name.
402     */
403
404    if (opt == (int)w_CREATE) {
405        Tcl_Obj *nameObj;
406        if (objc > 2) {
407            Tcl_WrongNumArgs(interp, 1, objv, "create");
408            return TCL_ERROR;
409        }
410        mutexPtr = (SpMutex*)Tcl_Alloc(sizeof(SpMutex));
411        mutexPtr->type   = WMUTEXID;
412        mutexPtr->refcnt = 0;
413        mutexPtr->bucket = NULL;
414        mutexPtr->hentry = NULL;
415        mutexPtr->lock   = NULL; /* Will be auto-initialized */
416
417        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);
418        mutexName = Tcl_GetStringFromObj(nameObj, &nameLen);
419        AddMutex(mutexName, nameLen, mutexPtr);
420        Tcl_SetObjResult(interp, nameObj);
421        return TCL_OK;
422    }
423
424    /*
425     * All other options require a valid name.
426     */
427
428    if (objc != 3) {
429        Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle");
430        return TCL_ERROR;
431    }
432
433    mutexName = Tcl_GetStringFromObj(objv[2], &nameLen);
434
435    /*
436     * Try mutex destroy
437     */
438
439    if (opt == (int)w_DESTROY) {
440        ret = RemoveMutex(mutexName, nameLen);
441        if (ret <= 0) {
442            if (ret == -1) {
443            notfound:
444                Tcl_AppendResult(interp, "no such mutex \"", mutexName,
445                                 "\"", NULL);
446                return TCL_ERROR;
447            } else {
448                Tcl_AppendResult(interp, "mutex is in use", NULL);
449                return TCL_ERROR;
450            }
451        }
452        return TCL_OK;
453    }
454
455    /*
456     * Try all other options
457     */
458
459    mutexPtr = GetMutex(mutexName, nameLen);
460    if (mutexPtr == NULL) {
461        goto notfound;
462    }
463    if (!IsReadWrite(mutexPtr)) {
464        PutMutex(mutexPtr);
465        Tcl_AppendResult(interp, "wrong mutex type, must be readwrite", NULL);
466        return TCL_ERROR;
467    }
468
469    lockPtr = &mutexPtr->lock;
470    rwPtr = (Sp_ReadWriteMutex*) lockPtr;
471
472    switch ((enum options)opt) {
473    case w_RLOCK:
474        if (!Sp_ReadWriteMutexRLock(rwPtr)) {
475            PutMutex(mutexPtr);
476            Tcl_AppendResult(interp, "read-locking already write-locked mutex ",
477                             "from the same thread", NULL);
478            return TCL_ERROR;
479        }
480        break;
481    case w_WLOCK:
482        if (!Sp_ReadWriteMutexWLock(rwPtr)) {
483            PutMutex(mutexPtr);
484            Tcl_AppendResult(interp, "write-locking the same read-write "
485                             "mutex twice from the same thread", NULL);
486            return TCL_ERROR;
487        }
488        break;
489    case w_UNLOCK:
490        if (!Sp_ReadWriteMutexUnlock(rwPtr)) {
491            PutMutex(mutexPtr);
492            Tcl_AppendResult(interp, "mutex is not locked", NULL);
493            return TCL_ERROR;
494        }
495        break;
496    default:
497        break;
498    }
499
500    PutMutex(mutexPtr);
501
502    return TCL_OK;
503}
504
505
506/*
507 *----------------------------------------------------------------------
508 *
509 * ThreadCondObjCmd --
510 *
511 *    This procedure is invoked to process "thread::cond" Tcl command.
512 *    See the user documentation for details on what it does.
513 *
514 * Results:
515 *    A standard Tcl result.
516 *
517 * Side effects:
518 *    See the user documentation.
519 *
520 *----------------------------------------------------------------------
521 */
522
523static int
524ThreadCondObjCmd(dummy, interp, objc, objv)
525    ClientData dummy;                   /* Not used. */
526    Tcl_Interp *interp;                 /* Current interpreter. */
527    int objc;                           /* Number of arguments. */
528    Tcl_Obj *const objv[];              /* Argument objects. */
529{
530    int opt, ret, nameLen, timeMsec = 0;
531    const char *condvName, *mutexName;
532    SpMutex *mutexPtr;
533    SpCondv *condvPtr;
534
535    static const char *cmdOpts[] = {
536        "create", "destroy", "notify", "wait", NULL
537    };
538    enum options {
539        c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT
540    };
541
542    /*
543     * Syntax:
544     *
545     *    thread::cond create
546     *    thread::cond destroy <condHandle>
547     *    thread::cond notify <condHandle>
548     *    thread::cond wait <condHandle> <mutexHandle> ?timeout?
549     */
550
551    if (objc < 2) {
552        Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
553        return TCL_ERROR;
554    }
555    ret = Tcl_GetIndexFromObj(interp, objv[1], cmdOpts, "option", 0, &opt);
556    if (ret != TCL_OK) {
557        return TCL_ERROR;
558    }
559
560    /*
561     * Cover the "create" option since it needs no existing name.
562     */
563
564    if (opt == (int)c_CREATE) {
565        Tcl_Obj *nameObj;
566        if (objc > 2) {
567            Tcl_WrongNumArgs(interp, 1, objv, "create");
568            return TCL_ERROR;
569        }
570        condvPtr = (SpCondv*)Tcl_Alloc(sizeof(SpCondv));
571        condvPtr->refcnt = 0;
572        condvPtr->bucket = NULL;
573        condvPtr->hentry = NULL;
574        condvPtr->mutex  = NULL;
575        condvPtr->cond   = NULL; /* Will be auto-initialized */
576
577        nameObj = GetName(CONDVID, (void*)condvPtr);
578        condvName = Tcl_GetStringFromObj(nameObj, &nameLen);
579        AddCondv(condvName, nameLen, condvPtr);
580        Tcl_SetObjResult(interp, nameObj);
581        return TCL_OK;
582    }
583
584    /*
585     * All others require at least a valid handle.
586     */
587
588    if (objc < 3) {
589        Tcl_WrongNumArgs(interp, 2, objv, "condHandle ?args?");
590        return TCL_ERROR;
591    }
592
593    condvName = Tcl_GetStringFromObj(objv[2], &nameLen);
594
595    /*
596     * Try variable destroy.
597     */
598
599    if (opt == (int)c_DESTROY) {
600        ret = RemoveCondv(condvName, nameLen);
601        if (ret <= 0) {
602            if (ret == -1) {
603            notfound:
604                Tcl_AppendResult(interp, "no such condition variable \"",
605                                 condvName, "\"", NULL);
606                return TCL_ERROR;
607            } else {
608                Tcl_AppendResult(interp, "condition variable is in use", NULL);
609                return TCL_ERROR;
610            }
611        }
612        return TCL_OK;
613    }
614
615    /*
616     * Try all other options
617     */
618
619    condvPtr = GetCondv(condvName, nameLen);
620    if (condvPtr == NULL) {
621        goto notfound;
622    }
623
624    switch ((enum options)opt) {
625    case c_WAIT:
626
627        /*
628         * May improve the Tcl_ConditionWait() to report timeouts so we can
629         * inform script programmer about this interesting fact. I think
630         * there is still a place for something like Tcl_ConditionWaitEx()
631         * or similar in the core.
632         */
633
634        if (objc < 4 || objc > 5) {
635            PutCondv(condvPtr);
636            Tcl_WrongNumArgs(interp, 2, objv, "condHandle mutexHandle ?timeout?");
637            return TCL_ERROR;
638        }
639        if (objc == 5) {
640            if (Tcl_GetIntFromObj(interp, objv[4], &timeMsec) != TCL_OK) {
641                PutCondv(condvPtr);
642                return TCL_ERROR;
643            }
644        }
645        mutexName = Tcl_GetStringFromObj(objv[3], &nameLen);
646        mutexPtr  = GetMutex(mutexName, nameLen);
647        if (mutexPtr == NULL) {
648            PutCondv(condvPtr);
649            Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", NULL);
650            return TCL_ERROR;
651        }
652        if (!IsExclusive(mutexPtr)
653            || SpCondvWait(condvPtr, mutexPtr, timeMsec) == 0) {
654            PutCondv(condvPtr);
655            PutMutex(mutexPtr);
656            Tcl_AppendResult(interp, "mutex not locked or wrong type", NULL);
657            return TCL_ERROR;
658        }
659        PutMutex(mutexPtr);
660        break;
661    case c_NOTIFY:
662        SpCondvNotify(condvPtr);
663        break;
664    default:
665        break;
666    }
667
668    PutCondv(condvPtr);
669
670    return TCL_OK;
671}
672/*
673 *----------------------------------------------------------------------
674 *
675 * ThreadEvalObjCmd --
676 *
677 *    This procedure is invoked to process "thread::eval" Tcl command.
678 *    See the user documentation for details on what it does.
679 *
680 * Results:
681 *    A standard Tcl result.
682 *
683 * Side effects:
684 *    See the user documentation.
685 *
686 *----------------------------------------------------------------------
687 */
688
689static int
690ThreadEvalObjCmd(dummy, interp, objc, objv)
691    ClientData dummy;                   /* Not used. */
692    Tcl_Interp *interp;                 /* Current interpreter. */
693    int objc;                           /* Number of arguments. */
694    Tcl_Obj *const objv[];              /* Argument objects. */
695{
696    int ret, optx, internal, nameLen;
697    const char *mutexName;
698    Tcl_Obj *scriptObj;
699    SpMutex *mutexPtr = NULL;
700    static Sp_RecursiveMutex evalMutex;
701
702    /*
703     * Syntax:
704     *
705     *     thread::eval ?-lock <mutexHandle>? arg ?arg ...?
706     */
707
708    if (objc < 2) {
709      syntax:
710        Tcl_AppendResult(interp, "wrong # args: should be \"",
711                         Tcl_GetString(objv[0]),
712                         " ?-lock <mutexHandle>? arg ?arg...?\"", NULL);
713        return TCL_ERROR;
714    }
715
716    /*
717     * Find out wether to use the internal (recursive) mutex
718     * or external mutex given on the command line, and lock
719     * the corresponding mutex immediately.
720     *
721     * We are using recursive internal mutex so we can easily
722     * support the recursion w/o danger of deadlocking. If
723     * however, user gives us an exclusive mutex, we will
724     * throw error on attempt to recursively call us.
725     */
726
727    if (OPT_CMP(Tcl_GetString(objv[1]), "-lock") == 0) {
728        internal = 1;
729        optx = 1;
730        Sp_RecursiveMutexLock(&evalMutex);
731    } else {
732        internal = 0;
733        optx = 3;
734        if ((objc - optx) < 1) {
735            goto syntax;
736        }
737        mutexName = Tcl_GetStringFromObj(objv[2], &nameLen);
738        mutexPtr  = GetMutex(mutexName, nameLen);
739        if (mutexPtr == NULL) {
740            Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", NULL);
741            return TCL_ERROR;
742        }
743        if (IsReadWrite(mutexPtr)) {
744            Tcl_AppendResult(interp, "wrong mutex type, must be exclusive "
745                             "or recursive", NULL);
746            return TCL_ERROR;
747        }
748        if (!SpMutexLock(mutexPtr)) {
749            Tcl_AppendResult(interp, "locking the same exclusive mutex "
750                             "twice from the same thread", NULL);
751            return TCL_ERROR;
752        }
753    }
754
755    objc -= optx;
756
757    /*
758     * Evaluate passed arguments as Tcl script. Note that
759     * Tcl_EvalObjEx throws away the passed object by
760     * doing an decrement reference count on it. This also
761     * means we need not build object bytecode rep.
762     */
763
764    if (objc == 1) {
765        scriptObj = Tcl_DuplicateObj(objv[optx]);
766    } else {
767        scriptObj = Tcl_ConcatObj(objc, objv + optx);
768    }
769
770    Tcl_IncrRefCount(scriptObj);
771    ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);
772    Tcl_DecrRefCount(scriptObj);
773
774    if (ret == TCL_ERROR) {
775        char msg[32 + TCL_INTEGER_SPACE];
776        sprintf(msg, "\n    (\"eval\" body line %d)", ERRORLINE(interp));
777        Tcl_AddObjErrorInfo(interp, msg, -1);
778    }
779
780    /*
781     * Unlock the mutex.
782     */
783
784    if (internal) {
785        Sp_RecursiveMutexUnlock(&evalMutex);
786    } else {
787        SpMutexUnlock(mutexPtr);
788    }
789
790    return ret;
791}
792
793/*
794 *----------------------------------------------------------------------
795 *
796 * GetName --
797 *
798 *      Construct a Tcl name for the given sync primitive.
799 *      The name is in the simple counted form: XidN
800 *      where "X" designates the type of the primitive
801 *      and "N" is a increasing integer.
802 *
803 * Results:
804 *      Tcl string object with the constructed name.
805 *
806 * Side effects:
807 *      None.
808 *
809 *----------------------------------------------------------------------
810 */
811
812static Tcl_Obj*
813GetName(int type, void *addrPtr)
814{
815    char name[32];
816    unsigned int id;
817    static unsigned int idcounter;
818
819    Tcl_MutexLock(&initMutex);
820    id = idcounter++;
821    Tcl_MutexUnlock(&initMutex);
822
823    sprintf(name, "%cid%d", type, id);
824
825    return Tcl_NewStringObj(name, -1);
826}
827
828/*
829 *----------------------------------------------------------------------
830 *
831 * GetBucket --
832 *
833 *      Returns the bucket for the given name.
834 *
835 * Results:
836 *      Pointer to the bucket.
837 *
838 * Side effects:
839 *      None.
840 *
841 *----------------------------------------------------------------------
842 */
843
844static SpBucket*
845GetBucket(int type, const char *name, int len)
846{
847    switch (type) {
848    case SP_MUTEX: return &muxBuckets[GetHash(name, len)];
849    case SP_CONDV: return &varBuckets[GetHash(name, len)];
850    }
851
852    return NULL; /* Never reached */
853}
854
855/*
856 *----------------------------------------------------------------------
857 *
858 * GetAnyItem --
859 *
860 *      Retrieves the item structure from it's corresponding bucket.
861 *
862 * Results:
863 *      Item pointer or NULL
864 *
865 * Side effects:
866 *      Increment the item's ref count preventing it's deletion.
867 *
868 *----------------------------------------------------------------------
869 */
870
871static SpItem*
872GetAnyItem(int type, const char *name, int len)
873{
874    SpItem *itemPtr = NULL;
875    SpBucket *bucketPtr = GetBucket(type, name, len);
876    Tcl_HashEntry *hashEntryPtr = NULL;
877
878    Tcl_MutexLock(&bucketPtr->lock);
879    hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name);
880    if (hashEntryPtr != (Tcl_HashEntry*)NULL) {
881        itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr);
882        itemPtr->refcnt++;
883    }
884    Tcl_MutexUnlock(&bucketPtr->lock);
885
886    return itemPtr;
887}
888
889/*
890 *----------------------------------------------------------------------
891 *
892 * PutAnyItem --
893 *
894 *      Current thread detaches from the item.
895 *
896 * Results:
897 *      None.
898 *
899 * Side effects:
900 *      Decrement item's ref count allowing for it's deletion
901 *      and signalize any threads waiting to delete the item.
902 *
903 *----------------------------------------------------------------------
904 */
905
906static void
907PutAnyItem(SpItem *itemPtr)
908{
909    Tcl_MutexLock(&itemPtr->bucket->lock);
910    itemPtr->refcnt--;
911    Tcl_ConditionNotify(&itemPtr->bucket->cond);
912    Tcl_MutexUnlock(&itemPtr->bucket->lock);
913}
914
915/*
916 *----------------------------------------------------------------------
917 *
918 * AddAnyItem --
919 *
920 *      Puts any item in the corresponding bucket.
921 *
922 * Results:
923 *      None.
924 *
925 * Side effects:
926 *      None.
927 *
928 *----------------------------------------------------------------------
929 */
930
931static void
932AddAnyItem(int type, const char *handle, int len, SpItem *itemPtr)
933{
934    int new;
935    SpBucket *bucketPtr = GetBucket(type, handle, len);
936    Tcl_HashEntry *hashEntryPtr;
937
938    Tcl_MutexLock(&bucketPtr->lock);
939
940    hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &new);
941    Tcl_SetHashValue(hashEntryPtr, (ClientData)itemPtr);
942
943    itemPtr->refcnt = 0;
944    itemPtr->bucket = bucketPtr;
945    itemPtr->hentry = hashEntryPtr;
946
947    Tcl_MutexUnlock(&bucketPtr->lock);
948}
949
950/*
951 *----------------------------------------------------------------------
952 *
953 * RemoveAnyItem --
954 *
955 *      Removes the item from it's bucket.
956 *
957 * Results:
958 *      Item's pointer or NULL if none found.
959 *
960 * Side effects:
961 *      None.
962 *
963 *----------------------------------------------------------------------
964 */
965
966static SpItem *
967RemoveAnyItem(int type, const char *name, int len)
968{
969    SpItem *itemPtr = NULL;
970    SpBucket *bucketPtr = GetBucket(type, name, len);
971    Tcl_HashEntry *hashEntryPtr = NULL;
972
973    Tcl_MutexLock(&bucketPtr->lock);
974    hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name);
975    if (hashEntryPtr == (Tcl_HashEntry*)NULL) {
976        Tcl_MutexUnlock(&bucketPtr->lock);
977        return NULL;
978    }
979    itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr);
980    Tcl_DeleteHashEntry(hashEntryPtr);
981    while (itemPtr->refcnt > 0) {
982        Tcl_ConditionWait(&bucketPtr->cond, &bucketPtr->lock, NULL);
983    }
984    Tcl_MutexUnlock(&bucketPtr->lock);
985
986    return itemPtr;
987}
988
989/*
990 *----------------------------------------------------------------------
991 *
992 * RemoveMutex --
993 *
994 *      Removes the mutex from it's bucket and finalizes it.
995 *
996 * Results:
997 *      1 - mutex is finalized and removed
998 *      0 - mutex is not finalized
999 +     -1 - mutex is not found
1000 *
1001 * Side effects:
1002 *      None.
1003 *
1004 *----------------------------------------------------------------------
1005 */
1006
1007static int
1008RemoveMutex(const char *name, int len)
1009{
1010    SpMutex *mutexPtr = GetMutex(name, len);
1011    if (mutexPtr == NULL) {
1012        return -1;
1013    }
1014    if (!SpMutexFinalize(mutexPtr)) {
1015        PutMutex(mutexPtr);
1016        return 0;
1017    }
1018    PutMutex(mutexPtr);
1019    RemoveAnyItem(SP_MUTEX, name, len);
1020    Tcl_Free((char*)mutexPtr);
1021
1022    return 1;
1023}
1024
1025/*
1026 *----------------------------------------------------------------------
1027 *
1028 * RemoveCondv --
1029 *
1030 *      Removes the cond variable from it's bucket and finalizes it.
1031 *
1032 * Results:
1033 *      1 - variable is finalized and removed
1034 *      0 - variable is not finalized
1035 +     -1 - variable is not found
1036 *
1037 * Side effects:
1038 *      None.
1039 *
1040 *----------------------------------------------------------------------
1041 */
1042
1043static int
1044RemoveCondv(const char *name, int len)
1045{
1046    SpCondv *condvPtr = GetCondv(name, len);
1047    if (condvPtr == NULL) {
1048        return -1;
1049    }
1050    if (!SpCondvFinalize(condvPtr)) {
1051        PutCondv(condvPtr);
1052        return 0;
1053    }
1054    PutCondv(condvPtr);
1055    RemoveAnyItem(SP_CONDV, name, len);
1056    Tcl_Free((char*)condvPtr);
1057
1058    return 1;
1059}
1060
1061/*
1062 *----------------------------------------------------------------------
1063 *
1064 * Sp_Init --
1065 *
1066 *      Create commands in current interpreter.
1067 *
1068 * Results:
1069 *      Standard Tcl result.
1070 *
1071 * Side effects:
1072 *      Initializes shared hash table for storing sync primitive
1073 *      handles and pointers.
1074 *
1075 *----------------------------------------------------------------------
1076 */
1077
1078int
1079Sp_Init (interp)
1080    Tcl_Interp *interp;                 /* Interp where to create cmds */
1081{
1082    SpBucket *bucketPtr;
1083
1084    if (!initOnce) {
1085        Tcl_MutexLock(&initMutex);
1086        if (!initOnce) {
1087            int ii, buflen = sizeof(SpBucket) * (NUMSPBUCKETS);
1088            char *buf  = Tcl_Alloc(2 * buflen);
1089            muxBuckets = (SpBucket*)(buf);
1090            varBuckets = (SpBucket*)(buf + buflen);
1091            for (ii = 0; ii < 2 * (NUMSPBUCKETS); ii++) {
1092                bucketPtr = &muxBuckets[ii];
1093                memset(bucketPtr, 0, sizeof(SpBucket));
1094                Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS);
1095            }
1096            initOnce = 1;
1097        }
1098        Tcl_MutexUnlock(&initMutex);
1099    }
1100
1101    TCL_CMD(interp, THREAD_CMD_PREFIX"::mutex",   ThreadMutexObjCmd);
1102    TCL_CMD(interp, THREAD_CMD_PREFIX"::rwmutex", ThreadRWMutexObjCmd);
1103    TCL_CMD(interp, THREAD_CMD_PREFIX"::cond",    ThreadCondObjCmd);
1104    TCL_CMD(interp, THREAD_CMD_PREFIX"::eval",    ThreadEvalObjCmd);
1105
1106    return TCL_OK;
1107}
1108
1109/*
1110 *----------------------------------------------------------------------
1111 *
1112 * SpMutexLock --
1113 *
1114 *      Locks the typed mutex.
1115 *
1116 * Results:
1117 *      1 - mutex is locked
1118 *      0 - mutex is not locked (pending deadlock?)
1119 *
1120 * Side effects:
1121 *      None.
1122 *
1123 *----------------------------------------------------------------------
1124 */
1125
1126static int
1127SpMutexLock(SpMutex *mutexPtr)
1128{
1129    Sp_AnyMutex **lockPtr = &mutexPtr->lock;
1130
1131    switch (mutexPtr->type) {
1132    case EMUTEXID:
1133        return Sp_ExclusiveMutexLock((Sp_ExclusiveMutex*)lockPtr);
1134        break;
1135    case RMUTEXID:
1136        return Sp_RecursiveMutexLock((Sp_RecursiveMutex*)lockPtr);
1137        break;
1138    }
1139
1140    return 0;
1141}
1142
1143/*
1144 *----------------------------------------------------------------------
1145 *
1146 * SpMutexUnlock --
1147 *
1148 *      Unlocks the typed mutex.
1149 *
1150 * Results:
1151 *      1 - mutex is unlocked
1152 *      0 - mutex was not locked
1153 *
1154 * Side effects:
1155 *      None.
1156 *
1157 *----------------------------------------------------------------------
1158 */
1159
1160static int
1161SpMutexUnlock(SpMutex *mutexPtr)
1162{
1163    Sp_AnyMutex **lockPtr = &mutexPtr->lock;
1164
1165    switch (mutexPtr->type) {
1166    case EMUTEXID:
1167        return Sp_ExclusiveMutexUnlock((Sp_ExclusiveMutex*)lockPtr);
1168        break;
1169    case RMUTEXID:
1170        return Sp_RecursiveMutexUnlock((Sp_RecursiveMutex*)lockPtr);
1171        break;
1172    }
1173
1174    return 0;
1175}
1176
1177/*
1178 *----------------------------------------------------------------------
1179 *
1180 * SpMutexFinalize --
1181 *
1182 *      Finalizes the typed mutex. This should never be called without
1183 *      some external mutex protection.
1184 *
1185 * Results:
1186 *      1 - mutex is finalized
1187 *      0 - mutex is still in use
1188 *
1189 * Side effects:
1190 *      None.
1191 *
1192 *----------------------------------------------------------------------
1193 */
1194
1195static int
1196SpMutexFinalize(SpMutex *mutexPtr)
1197{
1198    Sp_AnyMutex **lockPtr = &mutexPtr->lock;
1199
1200    if (AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, (Tcl_ThreadId)0)) {
1201        return 0;
1202    }
1203
1204    /*
1205     * At this point, the mutex could be locked again, hence it
1206     * is important never to call this function unprotected.
1207     */
1208
1209    switch (mutexPtr->type) {
1210    case EMUTEXID:
1211        Sp_ExclusiveMutexFinalize((Sp_ExclusiveMutex*)lockPtr);
1212        break;
1213    case RMUTEXID:
1214        Sp_RecursiveMutexFinalize((Sp_RecursiveMutex*)lockPtr);
1215        break;
1216    case WMUTEXID:
1217        Sp_ReadWriteMutexFinalize((Sp_ReadWriteMutex*)lockPtr);
1218        break;
1219    default:
1220        break;
1221    }
1222
1223    return 1;
1224}
1225
1226/*
1227 *----------------------------------------------------------------------
1228 *
1229 * SpCondvWait --
1230 *
1231 *      Waits on the condition variable.
1232 *
1233 * Results:
1234 *      1 - wait ok
1235 *      0 - not waited as mutex is not locked in the same thread
1236 *
1237 * Side effects:
1238 *      None.
1239 *
1240 *----------------------------------------------------------------------
1241 */
1242
1243static int
1244SpCondvWait(SpCondv *condvPtr, SpMutex *mutexPtr, int msec)
1245{
1246	Sp_AnyMutex **lock = &mutexPtr->lock;
1247    Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)lock;
1248    Tcl_Time waitTime, *wt = NULL;
1249    Tcl_ThreadId threadId = Tcl_GetCurrentThread();
1250
1251    if (msec > 0) {
1252        wt = &waitTime;
1253        wt->sec  = (msec/1000);
1254        wt->usec = (msec%1000) * 1000;
1255    }
1256    if (!AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, threadId)) {
1257        return 0; /* Mutex not locked by the current thread */
1258    }
1259
1260    /*
1261     * It is safe to operate on mutex struct because caller
1262     * is holding the emPtr->mutex locked before we enter
1263     * the Tcl_ConditionWait and after we return out of it.
1264     */
1265
1266    condvPtr->mutex = mutexPtr;
1267
1268    emPtr->owner = (Tcl_ThreadId)0;
1269    emPtr->lockcount = 0;
1270
1271    Tcl_ConditionWait(&condvPtr->cond, &emPtr->mutex, wt);
1272
1273    emPtr->owner = threadId;
1274    emPtr->lockcount = 1;
1275
1276    condvPtr->mutex = NULL;
1277
1278    return 1;
1279}
1280
1281/*
1282 *----------------------------------------------------------------------
1283 *
1284 * SpCondvNotify --
1285 *
1286 *      Signalizes the condition variable.
1287 *
1288 * Results:
1289 *      None.
1290 *
1291 * Side effects:
1292 *      None.
1293 *
1294 *----------------------------------------------------------------------
1295 */
1296
1297static void
1298SpCondvNotify(SpCondv *condvPtr)
1299{
1300    if (condvPtr->cond) {
1301        Tcl_ConditionNotify(&condvPtr->cond);
1302    }
1303}
1304
1305/*
1306 *----------------------------------------------------------------------
1307 *
1308 * SpCondvFinalize --
1309 *
1310 *      Finalizes the condition variable.
1311 *
1312 * Results:
1313 *      1 - variable is finalized
1314 *      0 - variable is in use
1315 *
1316 * Side effects:
1317 *      None.
1318 *
1319 *----------------------------------------------------------------------
1320 */
1321
1322static int
1323SpCondvFinalize(SpCondv *condvPtr)
1324{
1325    if (condvPtr->mutex != NULL) {
1326        return 0; /* Somebody is waiting on the variable */
1327    }
1328
1329    if (condvPtr->cond) {
1330        Tcl_ConditionFinalize(&condvPtr->cond);
1331    }
1332
1333    return 1;
1334}
1335
1336/*
1337 *----------------------------------------------------------------------
1338 *
1339 * Sp_ExclusiveMutexLock --
1340 *
1341 *      Locks the exclusive mutex.
1342 *
1343 * Results:
1344 *      1 - mutex is locked
1345 *      0 - mutex is not locked; same thread tries to locks twice
1346 *
1347 * Side effects:
1348 *      None.
1349 *
1350 *----------------------------------------------------------------------
1351 */
1352
1353int
1354Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *muxPtr)
1355{
1356    Sp_ExclusiveMutex_ *emPtr;
1357    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();
1358
1359    /*
1360     * Allocate the mutex structure on first access
1361     */
1362
1363    if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
1364        Tcl_MutexLock(&initMutex);
1365        if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
1366            *muxPtr = (Sp_ExclusiveMutex_*)
1367                Tcl_Alloc(sizeof(Sp_ExclusiveMutex_));
1368            memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_));
1369        }
1370        Tcl_MutexUnlock(&initMutex);
1371    }
1372
1373    /*
1374     * Try locking if not currently locked by anybody.
1375     */
1376
1377    emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
1378    Tcl_MutexLock(&emPtr->lock);
1379    if (emPtr->lockcount && emPtr->owner == thisThread) {
1380        Tcl_MutexUnlock(&emPtr->lock);
1381        return 0; /* Already locked by the same thread */
1382    }
1383    Tcl_MutexUnlock(&emPtr->lock);
1384
1385    /*
1386     * Many threads can come to this point.
1387     * Only one will succeed locking the
1388     * mutex. Others will block...
1389     */
1390
1391    Tcl_MutexLock(&emPtr->mutex);
1392
1393    Tcl_MutexLock(&emPtr->lock);
1394    emPtr->owner = thisThread;
1395    emPtr->lockcount = 1;
1396    Tcl_MutexUnlock(&emPtr->lock);
1397
1398    return 1;
1399}
1400
1401/*
1402 *----------------------------------------------------------------------
1403 *
1404 * Sp_ExclusiveMutexIsLocked --
1405 *
1406 *      Checks wether the mutex is locked or not.
1407 *
1408 * Results:
1409 *      1 - mutex is locked
1410 *      0 - mutex is not locked
1411 *
1412 * Side effects:
1413 *      None.
1414 *
1415 *----------------------------------------------------------------------
1416 */
1417
1418int
1419Sp_ExclusiveMutexIsLocked(Sp_ExclusiveMutex *muxPtr)
1420{
1421    return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, (Tcl_ThreadId)0);
1422}
1423
1424/*
1425 *----------------------------------------------------------------------
1426 *
1427 * Sp_ExclusiveMutexUnlock --
1428 *
1429 *      Unlock the exclusive mutex.
1430 *
1431 * Results:
1432 *      1 - mutex is unlocked
1433 ?      0 - mutex was never locked
1434 *
1435 * Side effects:
1436 *      None.
1437 *
1438 *----------------------------------------------------------------------
1439 */
1440
1441int
1442Sp_ExclusiveMutexUnlock(Sp_ExclusiveMutex *muxPtr)
1443{
1444    Sp_ExclusiveMutex_ *emPtr;
1445
1446    if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
1447        return 0; /* Never locked before */
1448    }
1449
1450    emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
1451
1452    Tcl_MutexLock(&emPtr->lock);
1453    if (emPtr->lockcount == 0) {
1454        Tcl_MutexUnlock(&emPtr->lock);
1455        return 0; /* Not locked */
1456    }
1457    emPtr->owner = (Tcl_ThreadId)0;
1458    emPtr->lockcount = 0;
1459    Tcl_MutexUnlock(&emPtr->lock);
1460
1461    /*
1462     * Only one thread should be able
1463     * to come to this point and unlock...
1464     */
1465
1466    Tcl_MutexUnlock(&emPtr->mutex);
1467
1468    return 1;
1469}
1470
1471/*
1472 *----------------------------------------------------------------------
1473 *
1474 * Sp_ExclusiveMutexFinalize --
1475 *
1476 *      Finalize the exclusive mutex. It is not safe for two or
1477 *      more threads to finalize the mutex at the same time.
1478 *
1479 * Results:
1480 *      None.
1481 *
1482 * Side effects:
1483 *      Mutex is destroyed.
1484 *
1485 *----------------------------------------------------------------------
1486 */
1487
1488void
1489Sp_ExclusiveMutexFinalize(Sp_ExclusiveMutex *muxPtr)
1490{
1491    if (*muxPtr != (Sp_ExclusiveMutex_*)0) {
1492        Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
1493        if (emPtr->lock) {
1494            Tcl_MutexFinalize(&emPtr->lock);
1495        }
1496        if (emPtr->mutex) {
1497            Tcl_MutexFinalize(&emPtr->mutex);
1498        }
1499        Tcl_Free((char*)*muxPtr);
1500    }
1501}
1502
1503/*
1504 *----------------------------------------------------------------------
1505 *
1506 * Sp_RecursiveMutexLock --
1507 *
1508 *      Locks the recursive mutex.
1509 *
1510 * Results:
1511 *      1 - mutex is locked (as it always should be)
1512 *
1513 * Side effects:
1514 *      None.
1515 *
1516 *----------------------------------------------------------------------
1517 */
1518
1519int
1520Sp_RecursiveMutexLock(Sp_RecursiveMutex *muxPtr)
1521{
1522    Sp_RecursiveMutex_ *rmPtr;
1523    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();
1524
1525    /*
1526     * Allocate the mutex structure on first access
1527     */
1528
1529    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
1530        Tcl_MutexLock(&initMutex);
1531        if (*muxPtr == (Sp_RecursiveMutex_*)0) {
1532            *muxPtr = (Sp_RecursiveMutex_*)
1533                Tcl_Alloc(sizeof(Sp_RecursiveMutex_));
1534            memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_));
1535        }
1536        Tcl_MutexUnlock(&initMutex);
1537    }
1538
1539    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
1540    Tcl_MutexLock(&rmPtr->lock);
1541
1542    if (rmPtr->owner == thisThread) {
1543        /*
1544         * We are already holding the mutex
1545         * so just count one more lock.
1546         */
1547    	rmPtr->lockcount++;
1548    } else {
1549    	if (rmPtr->owner == (Tcl_ThreadId)0) {
1550            /*
1551             * Nobody holds the mutex, we do now.
1552             */
1553    		rmPtr->owner = thisThread;
1554    		rmPtr->lockcount = 1;
1555    	} else {
1556            /*
1557             * Somebody else holds the mutex; wait.
1558             */
1559    		while (1) {
1560                Tcl_ConditionWait(&rmPtr->cond, &rmPtr->lock, NULL);
1561    			if (rmPtr->owner == (Tcl_ThreadId)0) {
1562    				rmPtr->owner = thisThread;
1563    				rmPtr->lockcount = 1;
1564    				break;
1565    			}
1566    		}
1567    	}
1568    }
1569
1570    Tcl_MutexUnlock(&rmPtr->lock);
1571
1572    return 1;
1573}
1574
1575/*
1576 *----------------------------------------------------------------------
1577 *
1578 * Sp_RecursiveMutexIsLocked --
1579 *
1580 *      Checks wether the mutex is locked or not.
1581 *
1582 * Results:
1583 *      1 - mutex is locked
1584 *      0 - mutex is not locked
1585 *
1586 * Side effects:
1587 *      None.
1588 *
1589 *----------------------------------------------------------------------
1590 */
1591
1592int
1593Sp_RecursiveMutexIsLocked(Sp_RecursiveMutex *muxPtr)
1594{
1595    return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, (Tcl_ThreadId)0);
1596}
1597
1598/*
1599 *----------------------------------------------------------------------
1600 *
1601 * Sp_RecursiveMutexUnlock --
1602 *
1603 *      Unlock the recursive mutex.
1604 *
1605 * Results:
1606 *      1 - mutex unlocked
1607 *      0 - mutex never locked
1608 *
1609 * Side effects:
1610 *      None.
1611 *
1612 *----------------------------------------------------------------------
1613 */
1614
1615int
1616Sp_RecursiveMutexUnlock(Sp_RecursiveMutex *muxPtr)
1617{
1618    Sp_RecursiveMutex_ *rmPtr;
1619
1620    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
1621        return 0; /* Never locked before */
1622    }
1623
1624    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
1625    Tcl_MutexLock(&rmPtr->lock);
1626    if (rmPtr->lockcount == 0) {
1627        Tcl_MutexUnlock(&rmPtr->lock);
1628        return 0; /* Not locked now */
1629    }
1630    if (--rmPtr->lockcount <= 0) {
1631        rmPtr->lockcount = 0;
1632        rmPtr->owner = (Tcl_ThreadId)0;
1633        if (rmPtr->cond) {
1634            Tcl_ConditionNotify(&rmPtr->cond);
1635        }
1636    }
1637    Tcl_MutexUnlock(&rmPtr->lock);
1638
1639    return 1;
1640}
1641
1642/*
1643 *----------------------------------------------------------------------
1644 *
1645 * Sp_RecursiveMutexFinalize --
1646 *
1647 *      Finalize the recursive mutex. It is not safe for two or
1648 *      more threads to finalize the mutex at the same time.
1649 *
1650 * Results:
1651 *      None.
1652 *
1653 * Side effects:
1654 *      Mutex is destroyed.
1655 *
1656 *----------------------------------------------------------------------
1657 */
1658
1659void
1660Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *muxPtr)
1661{
1662    if (*muxPtr != (Sp_RecursiveMutex_*)0) {
1663        Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
1664        if (rmPtr->lock) {
1665            Tcl_MutexFinalize(&rmPtr->lock);
1666        }
1667        if (rmPtr->cond) {
1668            Tcl_ConditionFinalize(&rmPtr->cond);
1669        }
1670        Tcl_Free((char*)*muxPtr);
1671    }
1672}
1673
1674/*
1675 *----------------------------------------------------------------------
1676 *
1677 * Sp_ReadWriteMutexRLock --
1678 *
1679 *      Read-locks the reader/writer mutex.
1680 *
1681 * Results:
1682 *      1 - mutex is locked
1683 *      0 - mutex is not locked as we already hold the write lock
1684 *
1685 * Side effects:
1686 *      None.
1687 *
1688 *----------------------------------------------------------------------
1689 */
1690
1691int
1692Sp_ReadWriteMutexRLock(Sp_ReadWriteMutex *muxPtr)
1693{
1694    Sp_ReadWriteMutex_ *rwPtr;
1695    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();
1696
1697    /*
1698     * Allocate the mutex structure on first access
1699     */
1700
1701    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
1702        Tcl_MutexLock(&initMutex);
1703        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
1704            *muxPtr = (Sp_ReadWriteMutex_*)
1705                Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
1706            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
1707        }
1708        Tcl_MutexUnlock(&initMutex);
1709    }
1710
1711    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
1712    Tcl_MutexLock(&rwPtr->lock);
1713    if (rwPtr->lockcount == -1 && rwPtr->owner == thisThread) {
1714        Tcl_MutexUnlock(&rwPtr->lock);
1715        return 0; /* We already hold the write lock */
1716    }
1717    while (rwPtr->lockcount < 0) {
1718        rwPtr->numrd++;
1719        Tcl_ConditionWait(&rwPtr->rcond, &rwPtr->lock, NULL);
1720        rwPtr->numrd--;
1721    }
1722    rwPtr->lockcount++;
1723    rwPtr->owner = (Tcl_ThreadId)0; /* Many threads can read-lock */
1724    Tcl_MutexUnlock(&rwPtr->lock);
1725
1726    return 1;
1727}
1728
1729/*
1730 *----------------------------------------------------------------------
1731 *
1732 * Sp_ReadWriteMutexWLock --
1733 *
1734 *      Write-locks the reader/writer mutex.
1735 *
1736 * Results:
1737 *      1 - mutex is locked
1738 *      0 - same thread attempts to write-lock the mutex twice
1739 *
1740 * Side effects:
1741 *      None.
1742 *
1743 *----------------------------------------------------------------------
1744 */
1745
1746int
1747Sp_ReadWriteMutexWLock(Sp_ReadWriteMutex *muxPtr)
1748{
1749    Sp_ReadWriteMutex_ *rwPtr;
1750    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();
1751
1752    /*
1753     * Allocate the mutex structure on first access
1754     */
1755
1756    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
1757        Tcl_MutexLock(&initMutex);
1758        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
1759            *muxPtr = (Sp_ReadWriteMutex_*)
1760                Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
1761            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
1762        }
1763        Tcl_MutexUnlock(&initMutex);
1764    }
1765
1766    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
1767    Tcl_MutexLock(&rwPtr->lock);
1768    if (rwPtr->owner == thisThread && rwPtr->lockcount == -1) {
1769        Tcl_MutexUnlock(&rwPtr->lock);
1770        return 0; /* The same thread attempts to write-lock again */
1771    }
1772    while (rwPtr->lockcount != 0) {
1773        rwPtr->numwr++;
1774        Tcl_ConditionWait(&rwPtr->wcond, &rwPtr->lock, NULL);
1775        rwPtr->numwr--;
1776    }
1777    rwPtr->lockcount = -1;     /* This designates the sole writer */
1778    rwPtr->owner = thisThread; /* which is our current thread     */
1779    Tcl_MutexUnlock(&rwPtr->lock);
1780
1781    return 1;
1782}
1783
1784/*
1785 *----------------------------------------------------------------------
1786 *
1787 * Sp_ReadWriteMutexIsLocked --
1788 *
1789 *      Checks wether the mutex is locked or not.
1790 *
1791 * Results:
1792 *      1 - mutex is locked
1793 *      0 - mutex is not locked
1794 *
1795 * Side effects:
1796 *      None.
1797 *
1798 *----------------------------------------------------------------------
1799 */
1800
1801int
1802Sp_ReadWriteMutexIsLocked(Sp_ReadWriteMutex *muxPtr)
1803{
1804    return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, (Tcl_ThreadId)0);
1805}
1806
1807/*
1808 *----------------------------------------------------------------------
1809 *
1810 * Sp_ReadWriteMutexUnlock --
1811 *
1812 *      Unlock the reader/writer mutex.
1813 *
1814 * Results:
1815 *      None.
1816 *
1817 * Side effects:
1818 *
1819 *----------------------------------------------------------------------
1820 */
1821
1822int
1823Sp_ReadWriteMutexUnlock(Sp_ReadWriteMutex *muxPtr)
1824{
1825    Sp_ReadWriteMutex_ *rwPtr;
1826
1827    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
1828        return 0; /* Never locked before */
1829    }
1830
1831    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
1832    Tcl_MutexLock(&rwPtr->lock);
1833    if (rwPtr->lockcount == 0) {
1834        Tcl_MutexUnlock(&rwPtr->lock);
1835        return 0; /* Not locked now */
1836    }
1837    if (--rwPtr->lockcount <= 0) {
1838        rwPtr->lockcount = 0;
1839        rwPtr->owner = (Tcl_ThreadId)0;
1840    }
1841    if (rwPtr->numwr) {
1842        Tcl_ConditionNotify(&rwPtr->wcond);
1843    } else if (rwPtr->numrd) {
1844        Tcl_ConditionNotify(&rwPtr->rcond);
1845    }
1846
1847    Tcl_MutexUnlock(&rwPtr->lock);
1848
1849    return 1;
1850}
1851
1852/*
1853 *----------------------------------------------------------------------
1854 *
1855 * Sp_ReadWriteMutexFinalize --
1856 *
1857 *      Finalize the reader/writer mutex. It is not safe for two or
1858 *      more threads to finalize the mutex at the same time.
1859 *
1860 * Results:
1861 *      None.
1862 *
1863 * Side effects:
1864 *      Mutex is destroyed.
1865 *
1866 *----------------------------------------------------------------------
1867 */
1868
1869void
1870Sp_ReadWriteMutexFinalize(Sp_ReadWriteMutex *muxPtr)
1871{
1872    if (*muxPtr != (Sp_ReadWriteMutex_*)0) {
1873        Sp_ReadWriteMutex_ *rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
1874        if (rwPtr->lock) {
1875            Tcl_MutexFinalize(&rwPtr->lock);
1876        }
1877        if (rwPtr->rcond) {
1878            Tcl_ConditionFinalize(&rwPtr->rcond);
1879        }
1880        if (rwPtr->wcond) {
1881            Tcl_ConditionFinalize(&rwPtr->wcond);
1882        }
1883        Tcl_Free((char*)*muxPtr);
1884    }
1885}
1886
1887/*
1888 *----------------------------------------------------------------------
1889 *
1890 * AnyMutexIsLocked --
1891 *
1892 *      Checks wether the mutex is locked. If optional threadId
1893 *      is given (i.e. != 0) it checks if the given thread also
1894 *      holds the lock.
1895 *
1896 * Results:
1897 *      1 - mutex is locked (optionally by the given thread)
1898 *      0 - mutex is not locked (optionally by the given thread)
1899 *
1900 * Side effects:
1901 *      None.
1902 *
1903 *----------------------------------------------------------------------
1904 */
1905static int
1906AnyMutexIsLocked(Sp_AnyMutex *mPtr, Tcl_ThreadId threadId)
1907{
1908    int locked = 0;
1909
1910    if (mPtr != NULL) {
1911        Tcl_MutexLock(&mPtr->lock);
1912        locked = mPtr->lockcount != 0;
1913        if (locked && threadId != (Tcl_ThreadId)0) {
1914            locked = mPtr->owner == threadId;
1915        }
1916        Tcl_MutexUnlock(&mPtr->lock);
1917    }
1918
1919    return locked;
1920}
1921
1922
1923/* EOF $RCSfile: threadSpCmd.c,v $ */
1924
1925/* Emacs Setup Variables */
1926/* Local Variables:      */
1927/* mode: C               */
1928/* indent-tabs-mode: nil */
1929/* c-basic-offset: 4     */
1930/* End:                  */
1931