From dfc40f3d564655d674701e3838a1822491ef26a4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 28 Sep 2025 11:21:03 +0000 Subject: Add mutex lock and cv tests. Refactor mutex test C into separate file --- generic/tclInt.h | 1 + generic/tclMutexTest.c | 574 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclTest.c | 3 + generic/tclThreadTest.c | 512 +----------------------------------------- tests/mutex.test | 80 +++++++ unix/Makefile.in | 7 +- win/Makefile.in | 1 + win/makefile.vc | 1 + 8 files changed, 666 insertions(+), 513 deletions(-) create mode 100644 generic/tclMutexTest.c create mode 100644 tests/mutex.test diff --git a/generic/tclInt.h b/generic/tclInt.h index ac296fa..cd18e46 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4777,6 +4777,7 @@ MODULE_SCOPE Tcl_LibraryInitProc TclTommath_Init; MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; +MODULE_SCOPE Tcl_LibraryInitProc TclMutex_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; diff --git a/generic/tclMutexTest.c b/generic/tclMutexTest.c new file mode 100644 index 0000000..1192e01 --- /dev/null +++ b/generic/tclMutexTest.c @@ -0,0 +1,574 @@ +/* + * tclMutexTest.c -- + * + * This file implements the testmutex command. + * + * Copyright (c) 2025 Ashok P. Nadkarni. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#undef BUILD_tcl +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include "tclInt.h" + +#ifdef HAVE_UNISTD_H +# include +# ifdef _POSIX_PRIORITY_SCHEDULING +# include +# endif +#endif + +#if TCL_THREADS +/* + * Types related to Tcl_Mutex tests. + */ +TCL_DECLARE_MUTEX(testContextMutex) +static inline void LockTestContext(int numRecursions) { + for (int j = 0; j < numRecursions; ++j) { + Tcl_MutexLock(&testContextMutex); + } +} +static inline void UnlockTestContext(int numRecursions) { + for (int j = 0; j < numRecursions; ++j) { + Tcl_MutexUnlock(&testContextMutex); + } +} + +/* + * ProducerConsumerContext is used in producer consumer tests to + * simulate a resource queue. + */ +typedef struct { + Tcl_Condition canEnqueue; /* Signal producer if queue not full */ + Tcl_Condition canDequeue; /* Signal consumer if queue not empty */ + Tcl_WideUInt totalEnqueued; /* Total enqueued so far */ + Tcl_WideUInt totalDequeued; /* Total dequeued so far */ + int available; /* Number of "resources" available */ + int capacity; /* Max number allowed in queue */ +} ProducerConsumerQueue; +#define CONDITION_TIMEOUT_SECS 5 + +/* + * MutexSharedContext holds context shared amongst all threads in a test. + * Should only be modified under testContextMutex lock unless only single + * thread has access. + */ +typedef struct { + int numThreads; /* Number of threads in test run */ + int numRecursions; /* Number of mutex lock recursions */ + int numIterations; /* Number of times each thread should loop */ + int yield; /* Whether threads should yield when looping */ + union { + Tcl_WideUInt counter; /* Used in lock tests */ + ProducerConsumerQueue queue; /* Used in condition variable tests */ + } u; +} MutexSharedContext; + +/* + * MutexThreadContext holds context specific to each test thread. This + * is passed as the clientData argument to each test thread. + */ +typedef struct { + MutexSharedContext *sharedContextPtr; /* Pointer to shared context */ + Tcl_ThreadId threadId; /* Only access in creator */ + Tcl_WideUInt numOperations; /* Use is dependent on the test */ + Tcl_WideUInt timeouts; /* Timeouts on condition variables */ +} MutexThreadContext; + +/* Used to track how many test threads running. Also used as trigger */ +static volatile int mutexThreadCount; + +static Tcl_ThreadCreateType CounterThreadProc(void *clientData); +static int TestMutexLock(Tcl_Interp *interp, + MutexSharedContext *contextPtr); +static int TestConditionVariable(Tcl_Interp *interp, + MutexSharedContext *contextPtr); +static Tcl_ThreadCreateType ConsumerThreadProc(void *clientData); +static Tcl_ThreadCreateType ProducerThreadProc(void *clientData); + + +#if defined(_WIN32) +static inline void YieldToOtherThreads() { + Sleep(0); +} +#elif defined(_POSIX_PRIORITY_SCHEDULING) +static inline void YieldToOtherThreads() { + (void)sched_yield(); +} +#else +static inline void YieldToOtherThreads() { + volatile int i; + for (i = 0; i < 1000; ++i) { + /* Just some random delay */ + } +} +#endif + + +#ifdef __cplusplus +extern "C" { +#endif +extern int Tcltest_Init(Tcl_Interp *interp); +#ifdef __cplusplus +} +#endif + + +/* + *---------------------------------------------------------------------- + * + * TestMutexCmd -- + * + * This procedure is invoked to process the "testmutex" Tcl command. + * + * testmutex counter ?numthreads? ?numrecursions? ?numiterations? + * testmutex conditionvariable ?numthreads? ?numrecursions? ?numiterations? + * + * Results: + * A standard Tcl result. + * + *---------------------------------------------------------------------- + */ + +static int +TestMutexObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const mutexOptions[] = { + "lock", "condition", NULL + }; + enum options { + LOCK, CONDITION + } option; + MutexSharedContext context = { + 2, /* numThreads */ + 1, /* numRecursions */ + 1000000, /* numIterations */ + 1, /* yield */ + {0}, /* u.counter */ + }; + + if (objc < 2 || objc > 6) { + Tcl_WrongNumArgs(interp, 1, objv, + "option ?numthreads? ?numrecursions? ?numiterations? ?yield?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], mutexOptions, "option", 0, + &option) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 2) { + if (Tcl_GetIntFromObj(interp, objv[2], + &context.numThreads) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 3) { + if (Tcl_GetIntFromObj(interp, objv[3], + &context.numRecursions) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 4) { + if (Tcl_GetIntFromObj(interp, objv[4], + &context.numIterations) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 5) { + if (Tcl_GetIntFromObj( + interp, objv[5], &context.yield) != TCL_OK) { + return TCL_ERROR; + } + } + } + } + } + + if (context.numIterations <= 0 || context.numRecursions <= 0 || + context.numThreads <= 0) { + Tcl_SetResult(interp, + "Thread, recursion and iteration counts must not be 0.", + TCL_STATIC); + } + + int result = TCL_OK; + switch (option) { + case LOCK: + result = TestMutexLock(interp, &context); + break; + case CONDITION: + result = TestConditionVariable(interp, &context); + break; + } + return result; +} + +/* + *------------------------------------------------------------------------ + * + * TestMutexLock -- + * + * Implements the "testmutex lock" command to test Tcl_MutexLock. + * + * Results: + * A Tcl result code. + * + * Side effects: + * Stores a result in the interpreter. + * + *------------------------------------------------------------------------ + */ +static int +TestMutexLock( + Tcl_Interp *interp, + MutexSharedContext *contextPtr) +{ + MutexThreadContext *threadContextsPtr = + (MutexThreadContext *)Tcl_Alloc( + sizeof(*threadContextsPtr) * contextPtr->numThreads); + + contextPtr->u.counter = 0; + mutexThreadCount = 0; + for (int i = 0; i < contextPtr->numThreads; i++) { + threadContextsPtr[i].sharedContextPtr = contextPtr; + threadContextsPtr[i].numOperations = 0; /* Init though not used */ + + if (Tcl_CreateThread(&threadContextsPtr[i].threadId, + CounterThreadProc, + &threadContextsPtr[i], + TCL_THREAD_STACK_DEFAULT, + TCL_THREAD_JOINABLE) != TCL_OK) { + Tcl_Panic("Failed to create %d'th thread\n", i); + } + } + mutexThreadCount = contextPtr->numThreads; /* Will fire off all test threads */ + + /* Wait for all threads */ + for (int i = 0; i < contextPtr->numThreads; i++) { + int threadResult; + Tcl_JoinThread(threadContextsPtr[i].threadId, &threadResult); + } + Tcl_Free(threadContextsPtr); + + Tcl_SetObjResult(interp, Tcl_NewWideUIntObj(contextPtr->u.counter)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * CounterThreadProc -- + * + * Increments a shared counter a specified number of times and exits + * the thread. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + static Tcl_ThreadCreateType + CounterThreadProc(void *clientData) +{ + MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData; + MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr; + + /* Spin wait until given the run signal */ + while (mutexThreadCount < contextPtr->numThreads) { + YieldToOtherThreads(); + } + + for (int i = 0; i < contextPtr->numIterations; i++) { + LockTestContext(contextPtr->numRecursions); + Tcl_WideUInt temp = contextPtr->u.counter; + if (contextPtr->yield) { + /* Some delay. No one else is supposed to modify the counter */ + YieldToOtherThreads(); + } + contextPtr->u.counter = temp + 1; /* Increment original value read */ + UnlockTestContext(contextPtr->numRecursions); + } + + Tcl_ExitThread(0); + TCL_THREAD_CREATE_RETURN; +} + +/* + *------------------------------------------------------------------------ + * + * TestConditionVariable -- + * + * Implements the "testmutex condition" command to test Tcl_Condition*. + * The test emulates a producer-consumer scenario. + * + * Results: + * A Tcl result code. + * + * Side effects: + * Stores a result in the interpreter. + * + *------------------------------------------------------------------------ + */ +static int +TestConditionVariable( + Tcl_Interp *interp, + MutexSharedContext *contextPtr) +{ + Tcl_SetResult(interp, "Not implemented", TCL_STATIC); + if (contextPtr->numThreads < 2) { + Tcl_SetResult(interp, "Need at least 2 threads.", TCL_STATIC); + return TCL_ERROR; + } + int numProducers = contextPtr->numThreads / 2; + int numConsumers = contextPtr->numThreads - numProducers; + + contextPtr->u.queue.canDequeue = NULL; + contextPtr->u.queue.canEnqueue = NULL; + + /* + * available tracks how many elements in the virtual queue + * capacity is max length of virtual queue. + */ + contextPtr->u.queue.totalEnqueued = 0; + contextPtr->u.queue.totalDequeued = 0; + contextPtr->u.queue.available = 0; + contextPtr->u.queue.capacity = 3; /* Arbitrary for now */ + + MutexThreadContext *consumerContextsPtr = (MutexThreadContext *)Tcl_Alloc( + sizeof(*consumerContextsPtr) * numConsumers); + MutexThreadContext *producerContextsPtr = (MutexThreadContext *)Tcl_Alloc( + sizeof(*producerContextsPtr) * numProducers); + + mutexThreadCount = 0; + + for (int i = 0; i < numConsumers; i++) { + consumerContextsPtr[i].sharedContextPtr = contextPtr; + consumerContextsPtr[i].numOperations = 0; + consumerContextsPtr[i].timeouts = 0; + + if (Tcl_CreateThread(&consumerContextsPtr[i].threadId, + ConsumerThreadProc, &consumerContextsPtr[i], + TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { + Tcl_Panic("Failed to create %d'th thread\n", (int) i); + } + } + + for (int i = 0; i < numProducers; i++) { + producerContextsPtr[i].sharedContextPtr = contextPtr; + producerContextsPtr[i].numOperations = 0; + producerContextsPtr[i].timeouts = 0; + + if (Tcl_CreateThread(&producerContextsPtr[i].threadId, + ProducerThreadProc, &producerContextsPtr[i], + TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { + Tcl_Panic("Failed to create %d'th thread\n", (int) i); + } + } + + mutexThreadCount = contextPtr->numThreads; /* Will trigger all threads */ + + /* Producer total, thread, timeouts, Consumer total, thread, timeouts */ + Tcl_Obj *results[6]; + results[1] = Tcl_NewListObj(numProducers, NULL); + results[4] = Tcl_NewListObj(numConsumers, NULL); + + Tcl_WideUInt producerTimeouts = 0; + Tcl_WideUInt producerOperations = 0; + Tcl_WideUInt consumerTimeouts = 0; + Tcl_WideUInt consumerOperations = 0; + for (int i = 0; i < numProducers; i++) { + int threadResult; + Tcl_JoinThread(producerContextsPtr[i].threadId, &threadResult); + producerOperations += producerContextsPtr[i].numOperations; + Tcl_ListObjAppendElement(NULL, results[1], + Tcl_NewWideUIntObj(producerContextsPtr[i].numOperations)); + producerTimeouts += producerContextsPtr[i].timeouts; + } + for (int i = 0; i < numConsumers; i++) { + int threadResult; + Tcl_JoinThread(consumerContextsPtr[i].threadId, &threadResult); + consumerOperations += consumerContextsPtr[i].numOperations; + Tcl_ListObjAppendElement(NULL, results[4], + Tcl_NewWideUIntObj(consumerContextsPtr[i].numOperations)); + consumerTimeouts += consumerContextsPtr[i].timeouts; + } + + results[0] = Tcl_NewWideUIntObj(producerOperations); + results[2] = Tcl_NewWideUIntObj(producerTimeouts); + results[3] = Tcl_NewWideUIntObj(consumerOperations); + results[5] = Tcl_NewWideUIntObj(consumerTimeouts); + Tcl_SetObjResult(interp, Tcl_NewListObj(6, results)); + + Tcl_Free(producerContextsPtr); + Tcl_Free(consumerContextsPtr); + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * ProducerThreadProc -- + * + * Acts as a "producer" that enqueues to the virtual resource queue. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +static Tcl_ThreadCreateType +ProducerThreadProc(void *clientData) +{ + MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData; + MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr; + + /* Limit on total number of operations across all threads */ + Tcl_WideUInt limit; + limit = contextPtr->numThreads * (Tcl_WideUInt) contextPtr->numIterations; + + /* Spin wait until given the run signal */ + while (mutexThreadCount < contextPtr->numThreads) { + YieldToOtherThreads(); + } + + LockTestContext(contextPtr->numRecursions); + while (contextPtr->u.queue.totalEnqueued < limit) { + if (contextPtr->u.queue.available == contextPtr->u.queue.capacity) { + Tcl_Time before, after; + Tcl_Time timeout = {CONDITION_TIMEOUT_SECS, 0}; + Tcl_GetTime(&before); + Tcl_ConditionWait( + &contextPtr->u.queue.canEnqueue, &testContextMutex, &timeout); + Tcl_GetTime(&after); + if ((1000000 * (after.sec - before.sec) + + (after.usec - before.usec)) >= + 1000000 * CONDITION_TIMEOUT_SECS) { + threadContextPtr->timeouts += 1; + } + } else { + contextPtr->u.queue.available += 1; /* Enqueue operation */ + contextPtr->u.queue.totalEnqueued += 1; + threadContextPtr->numOperations += 1; + Tcl_ConditionNotify(&contextPtr->u.queue.canDequeue); + if (contextPtr->yield) { + /* Simulate real work by unlocking before yielding */ + UnlockTestContext(contextPtr->numRecursions); + YieldToOtherThreads(); + LockTestContext(contextPtr->numRecursions); + } + } + } + UnlockTestContext(contextPtr->numRecursions); + + Tcl_ExitThread(0); + TCL_THREAD_CREATE_RETURN; +} + +/* + *------------------------------------------------------------------------ + * + * ConsumerThreadProc -- + * + * Acts as a "consumer" that dequeues from the virtual resource queue. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +static Tcl_ThreadCreateType +ConsumerThreadProc(void *clientData) +{ + MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData; + MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr; + + /* Limit on total number of operations across all threads */ + Tcl_WideUInt limit; + limit = contextPtr->numThreads * (Tcl_WideUInt) contextPtr->numIterations; + + /* Spin wait until given the run signal */ + while (mutexThreadCount < contextPtr->numThreads) { + YieldToOtherThreads(); + } + + LockTestContext(contextPtr->numRecursions); + while (contextPtr->u.queue.totalDequeued < limit) { + if (contextPtr->u.queue.available == 0) { + Tcl_Time before, after; + Tcl_Time timeout = {CONDITION_TIMEOUT_SECS, 0}; + Tcl_GetTime(&before); + Tcl_ConditionWait( + &contextPtr->u.queue.canDequeue, &testContextMutex, &timeout); + Tcl_GetTime(&after); + if ((1000000 * (after.sec - before.sec) + + (after.usec - before.usec)) >= + 1000000 * CONDITION_TIMEOUT_SECS) { + threadContextPtr->timeouts += 1; + } + } else { + contextPtr->u.queue.totalDequeued += 1; + threadContextPtr->numOperations += 1; + contextPtr->u.queue.available -= 1; + Tcl_ConditionNotify(&contextPtr->u.queue.canEnqueue); + if (contextPtr->yield) { + /* Simulate real work by unlocking before yielding */ + UnlockTestContext(contextPtr->numRecursions); + YieldToOtherThreads(); + LockTestContext(contextPtr->numRecursions); + } + } + } + UnlockTestContext(contextPtr->numRecursions); + + Tcl_ExitThread(0); + TCL_THREAD_CREATE_RETURN; +} + +/* + *---------------------------------------------------------------------- + * + * TclMutex_Init -- + * + * Initialize the testmutex command. + * + * Results: + * TCL_OK if the package was properly initialized. + * + * Side effects: + * Add the "testmutex" command to the interp. + * + *---------------------------------------------------------------------- + */ + +int +TclMutex_Init( + Tcl_Interp *interp) /* The current Tcl interpreter */ +{ + Tcl_CreateObjCommand(interp, "testmutex", TestMutexObjCmd, NULL, NULL); + return TCL_OK; +} +#endif /* TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 8857bd7..dcbcca8 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -754,6 +754,9 @@ Tcltest_Init( if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } + if (TclMutex_Init(interp) != TCL_OK) { + return TCL_ERROR; + } #endif if (Tcl_ABSListTest_Init(interp) != TCL_OK) { diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index ae52070..faaf92a 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -20,13 +20,6 @@ #endif #include "tclInt.h" -#ifdef HAVE_UNISTD_H -# include -# ifdef _POSIX_PRIORITY_SCHEDULING -# include -# endif -#endif - #if TCL_THREADS /* * Each thread has an single instance of the following structure. There is one @@ -146,95 +139,6 @@ static void ThreadFreeProc(void *clientData); static int ThreadDeleteEvent(Tcl_Event *eventPtr, void *clientData); static void ThreadExitProc(void *clientData); - - -/* - * Types related to Tcl_Mutex tests. - */ -TCL_DECLARE_MUTEX(testContextMutex) -static inline void LockTestContext(int numRecursions) { - for (int j = 0; j < numRecursions; ++j) { - Tcl_MutexLock(&testContextMutex); - } -} -static inline void UnlockTestContext(int numRecursions) { - for (int j = 0; j < numRecursions; ++j) { - Tcl_MutexUnlock(&testContextMutex); - } -} - -/* - * ProducerConsumerContext is used in producer consumer tests to - * simulate a resource queue. - */ -typedef struct { - Tcl_Condition canEnqueue; /* Signal producer if queue not full */ - Tcl_Condition canDequeue; /* Signal consumer if queue not empty */ - Tcl_WideUInt totalEnqueued; /* Total enqueued so far */ - Tcl_WideUInt totalDequeued; /* Total dequeued so far */ - int available; /* Number of "resources" available */ - int capacity; /* Max number allowed in queue */ -} ProducerConsumerQueue; -#define CONDITION_TIMEOUT_SECS 1 - -/* - * MutexSharedContext holds context shared amongst all threads in a test. - * Should only be modified under testContextMutex lock unless only single - * thread has access. - */ -typedef struct { - int numThreads; /* Number of threads in test run */ - int numRecursions; /* Number of mutex lock recursions */ - int numIterations; /* Number of times each thread should loop */ - int yield; /* Whether threads should yield when looping */ - union { - Tcl_WideUInt counter; /* Used in lock tests */ - ProducerConsumerQueue queue; /* Used in condition variable tests */ - } u; -} MutexSharedContext; - -/* - * MutexThreadContext holds context specific to each test thread. This - * is passed as the clientData argument to each test thread. - */ -typedef struct { - MutexSharedContext *sharedContextPtr; /* Pointer to shared context */ - Tcl_ThreadId threadId; /* Only access in creator */ - Tcl_WideUInt numOperations; /* Use is dependent on the test */ - Tcl_WideUInt timeouts; /* Timeouts on condition variables */ -} MutexThreadContext; - -/* Used to track how many test threads running. Also used as trigger */ -static volatile int mutexThreadCount; - -static Tcl_ObjCmdProc TestMutexCmd; -static Tcl_ThreadCreateType CounterThreadProc(void *clientData); -static int TestMutexLock(Tcl_Interp *interp, - MutexSharedContext *contextPtr); -static int TestConditionVariable(Tcl_Interp *interp, - MutexSharedContext *contextPtr); -static Tcl_ThreadCreateType ConsumerThreadProc(void *clientData); -static Tcl_ThreadCreateType ProducerThreadProc(void *clientData); - - -#if defined(_WIN32) -static inline void YieldToOtherThreads() { - Sleep(0); -} -#elif defined(_POSIX_PRIORITY_SCHEDULING) -static inline void YieldToOtherThreads() { - (void)sched_yield(); -} -#else -static inline void YieldToOtherThreads() { - volatile int i; - for (i = 0; i < 1000; ++i) { - /* Just some random delay */ - } -} -#endif - - #ifdef __cplusplus extern "C" { #endif @@ -242,7 +146,6 @@ extern int Tcltest_Init(Tcl_Interp *interp); #ifdef __cplusplus } #endif - /* *---------------------------------------------------------------------- @@ -275,7 +178,6 @@ TclThread_Init( Tcl_MutexUnlock(&threadMutex); Tcl_CreateObjCommand(interp, "testthread", ThreadCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testmutex", TestMutexCmd, NULL, NULL); return TCL_OK; } @@ -1178,6 +1080,7 @@ ThreadEventProc( * *------------------------------------------------------------------------ */ + static void ThreadFreeProc( void *clientData) @@ -1304,422 +1207,9 @@ ThreadExitProc( } Tcl_MutexUnlock(&threadMutex); } - #endif /* TCL_THREADS */ /* - *---------------------------------------------------------------------- - * - * TestMutexCmd -- - * - * This procedure is invoked to process the "testmutex" Tcl command. - * - * testmutex counter ?numthreads? ?numrecursions? ?numiterations? - * testmutex conditionvariable ?numthreads? ?numrecursions? ?numiterations? - * - * Results: - * A standard Tcl result. - * - *---------------------------------------------------------------------- - */ - -static int -TestMutexCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const mutexOptions[] = { - "lock", "condition", NULL - }; - enum options { - LOCK, CONDITION - } option; - MutexSharedContext context = { - 2, /* numThreads */ - 1, /* numRecursions */ - 1000000, /* numIterations */ - 1, /* yield */ - {0}, /* u.counter */ - }; - - if (objc < 2 || objc > 6) { - Tcl_WrongNumArgs(interp, 1, objv, - "option ?numthreads? ?numrecursions? ?numiterations? ?yield?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], mutexOptions, "option", 0, - &option) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 2) { - if (Tcl_GetIntFromObj(interp, objv[2], - &context.numThreads) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 3) { - if (Tcl_GetIntFromObj(interp, objv[3], - &context.numRecursions) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 4) { - if (Tcl_GetIntFromObj(interp, objv[4], - &context.numIterations) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 5) { - if (Tcl_GetIntFromObj( - interp, objv[5], &context.yield) != TCL_OK) { - return TCL_ERROR; - } - } - } - } - } - - if (context.numIterations <= 0 || context.numRecursions <= 0 || - context.numThreads <= 0) { - Tcl_SetResult(interp, - "Thread, recursion and iteration counts must not be 0.", - TCL_STATIC); - } - - int result = TCL_OK; - switch (option) { - case LOCK: - result = TestMutexLock(interp, &context); - break; - case CONDITION: - result = TestConditionVariable(interp, &context); - break; - } - return result; -} - -/* - *------------------------------------------------------------------------ - * - * TestMutexLock -- - * - * Implements the "testmutex lock" command to test Tcl_MutexLock. - * - * Results: - * A Tcl result code. - * - * Side effects: - * Stores a result in the interpreter. - * - *------------------------------------------------------------------------ - */ -static int -TestMutexLock( - Tcl_Interp *interp, - MutexSharedContext *contextPtr) -{ - MutexThreadContext *threadContextsPtr = - (MutexThreadContext *)Tcl_Alloc( - sizeof(*threadContextsPtr) * contextPtr->numThreads); - - contextPtr->u.counter = 0; - mutexThreadCount = 0; - for (int i = 0; i < contextPtr->numThreads; i++) { - threadContextsPtr[i].sharedContextPtr = contextPtr; - threadContextsPtr[i].numOperations = 0; /* Init though not used */ - - if (Tcl_CreateThread(&threadContextsPtr[i].threadId, - CounterThreadProc, - &threadContextsPtr[i], - TCL_THREAD_STACK_DEFAULT, - TCL_THREAD_JOINABLE) != TCL_OK) { - Tcl_Panic("Failed to create %d'th thread\n", i); - } - } - mutexThreadCount = contextPtr->numThreads; /* Will fire off all test threads */ - - /* Wait for all threads */ - for (int i = 0; i < contextPtr->numThreads; i++) { - int threadResult; - Tcl_JoinThread(threadContextsPtr[i].threadId, &threadResult); - } - Tcl_Free(threadContextsPtr); - - Tcl_SetObjResult(interp, Tcl_NewWideUIntObj(contextPtr->u.counter)); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------ - * - * CounterThreadProc -- - * - * Increments a shared counter a specified number of times and exits - * the thread. - * - * Results: - * None. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ - static Tcl_ThreadCreateType - CounterThreadProc(void *clientData) -{ - MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData; - MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr; - - /* Spin wait until given the run signal */ - while (mutexThreadCount < contextPtr->numThreads) { - YieldToOtherThreads(); - } - - for (int i = 0; i < contextPtr->numIterations; i++) { - for (int j = 0; j < contextPtr->numRecursions; ++j) { - Tcl_MutexLock(&testContextMutex); - } - Tcl_WideUInt temp = contextPtr->u.counter; - if (contextPtr->yield) { - /* Some delay. No one else is supposed to modify the counter */ - YieldToOtherThreads(); - } - contextPtr->u.counter = temp + 1; /* Increment original value read */ - for (int j = 0; j < contextPtr->numRecursions; ++j) { - Tcl_MutexUnlock(&testContextMutex); - } - } - - Tcl_ExitThread(0); - TCL_THREAD_CREATE_RETURN; -} - -/* - *------------------------------------------------------------------------ - * - * TestConditionVariable -- - * - * Implements the "testmutex condition" command to test Tcl_Condition*. - * The test emulates a producer-consumer scenario. - * - * Results: - * A Tcl result code. - * - * Side effects: - * Stores a result in the interpreter. - * - *------------------------------------------------------------------------ - */ -static int -TestConditionVariable( - Tcl_Interp *interp, - MutexSharedContext *contextPtr) -{ - Tcl_SetResult(interp, "Not implemented", TCL_STATIC); - if (contextPtr->numThreads < 2) { - Tcl_SetResult(interp, "Need at least 2 threads.", TCL_STATIC); - return TCL_ERROR; - } - int numProducers = contextPtr->numThreads / 2; - int numConsumers = contextPtr->numThreads - numProducers; - - contextPtr->u.queue.canDequeue = NULL; - contextPtr->u.queue.canEnqueue = NULL; - - /* - * available tracks how many elements in the virtual queue - * capacity is max length of virtual queue. - */ - contextPtr->u.queue.totalEnqueued = 0; - contextPtr->u.queue.totalDequeued = 0; - contextPtr->u.queue.available = 0; - contextPtr->u.queue.capacity = 3; /* Arbitrary for now */ - - MutexThreadContext *consumerContextsPtr = (MutexThreadContext *)Tcl_Alloc( - sizeof(*consumerContextsPtr) * numConsumers); - MutexThreadContext *producerContextsPtr = (MutexThreadContext *)Tcl_Alloc( - sizeof(*producerContextsPtr) * numProducers); - - mutexThreadCount = 0; - - for (int i = 0; i < numConsumers; i++) { - consumerContextsPtr[i].sharedContextPtr = contextPtr; - consumerContextsPtr[i].numOperations = 0; - consumerContextsPtr[i].timeouts = 0; - - if (Tcl_CreateThread(&consumerContextsPtr[i].threadId, - ConsumerThreadProc, &consumerContextsPtr[i], - TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { - Tcl_Panic("Failed to create %d'th thread\n", (int) i); - } - } - - for (int i = 0; i < numProducers; i++) { - producerContextsPtr[i].sharedContextPtr = contextPtr; - producerContextsPtr[i].numOperations = 0; - producerContextsPtr[i].timeouts = 0; - - if (Tcl_CreateThread(&producerContextsPtr[i].threadId, - ProducerThreadProc, &producerContextsPtr[i], - TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { - Tcl_Panic("Failed to create %d'th thread\n", (int) i); - } - } - - mutexThreadCount = contextPtr->numThreads; /* Will trigger all threads */ - - /* Producer total, thread, timeouts, Consumer total, thread, timeouts */ - Tcl_Obj *results[6]; - results[1] = Tcl_NewListObj(numProducers, NULL); - results[4] = Tcl_NewListObj(numConsumers, NULL); - - Tcl_WideUInt producerTimeouts = 0; - Tcl_WideUInt producerOperations = 0; - Tcl_WideUInt consumerTimeouts = 0; - Tcl_WideUInt consumerOperations = 0; - for (int i = 0; i < numProducers; i++) { - int threadResult; - Tcl_JoinThread(producerContextsPtr[i].threadId, &threadResult); - producerOperations += producerContextsPtr[i].numOperations; - Tcl_ListObjAppendElement(NULL, results[1], - Tcl_NewWideUIntObj(producerContextsPtr[i].numOperations)); - producerTimeouts += producerContextsPtr[i].timeouts; - } - for (int i = 0; i < numConsumers; i++) { - int threadResult; - Tcl_JoinThread(consumerContextsPtr[i].threadId, &threadResult); - consumerOperations += consumerContextsPtr[i].numOperations; - Tcl_ListObjAppendElement(NULL, results[4], - Tcl_NewWideUIntObj(consumerContextsPtr[i].numOperations)); - consumerTimeouts += consumerContextsPtr[i].timeouts; - } - - results[0] = Tcl_NewWideUIntObj(producerOperations); - results[2] = Tcl_NewWideUIntObj(producerTimeouts); - results[3] = Tcl_NewWideUIntObj(consumerOperations); - results[5] = Tcl_NewWideUIntObj(consumerTimeouts); - Tcl_SetObjResult(interp, Tcl_NewListObj(6, results)); - - Tcl_Free(producerContextsPtr); - Tcl_Free(consumerContextsPtr); - - return TCL_OK; -} - -/* - *------------------------------------------------------------------------ - * - * ProducerThreadProc -- - * - * Acts as a "producer" that enqueues to the virtual resource queue. - * - * Results: - * None. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ -static Tcl_ThreadCreateType -ProducerThreadProc(void *clientData) -{ - MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData; - MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr; - - /* Limit on total number of operations across all threads */ - Tcl_WideUInt limit; - limit = contextPtr->numThreads * (Tcl_WideUInt) contextPtr->numIterations; - - /* Spin wait until given the run signal */ - while (mutexThreadCount < contextPtr->numThreads) { - YieldToOtherThreads(); - } - - LockTestContext(contextPtr->numRecursions); - while (contextPtr->u.queue.totalEnqueued < limit) { - if (contextPtr->u.queue.available < contextPtr->u.queue.capacity) { - contextPtr->u.queue.available += 1; /* Enqueue operation */ - contextPtr->u.queue.totalEnqueued += 1; - threadContextPtr->numOperations += 1; - Tcl_ConditionNotify(&contextPtr->u.queue.canDequeue); - } - Tcl_Time before, after; - Tcl_Time timeout = {CONDITION_TIMEOUT_SECS, 0}; - Tcl_GetTime(&before); - Tcl_ConditionWait( - &contextPtr->u.queue.canEnqueue, &testContextMutex, &timeout); - Tcl_GetTime(&after); - if ((1000000 * (after.sec - before.sec) + (after.usec - before.usec)) - >= 1000000 * CONDITION_TIMEOUT_SECS) { - threadContextPtr->timeouts += 1; - } - } - UnlockTestContext(contextPtr->numRecursions); - - Tcl_ExitThread(0); - TCL_THREAD_CREATE_RETURN; -} - -/* - *------------------------------------------------------------------------ - * - * ConsumerThreadProc -- - * - * Acts as a "consumer" that dequeues from the virtual resource queue. - * - * Results: - * None. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ -static Tcl_ThreadCreateType -ConsumerThreadProc(void *clientData) -{ - MutexThreadContext *threadContextPtr = (MutexThreadContext *)clientData; - MutexSharedContext *contextPtr = threadContextPtr->sharedContextPtr; - - /* Limit on total number of operations across all threads */ - Tcl_WideUInt limit; - limit = contextPtr->numThreads * (Tcl_WideUInt) contextPtr->numIterations; - - /* Spin wait until given the run signal */ - while (mutexThreadCount < contextPtr->numThreads) { - YieldToOtherThreads(); - } - - LockTestContext(contextPtr->numRecursions); - while (contextPtr->u.queue.totalDequeued < limit) { - if (contextPtr->u.queue.available > 0) { - contextPtr->u.queue.available -= 1; /* Enqueue operation */ - contextPtr->u.queue.totalDequeued += 1; - threadContextPtr->numOperations += 1; - Tcl_ConditionNotify(&contextPtr->u.queue.canEnqueue); - } - if (contextPtr->u.queue.totalDequeued == limit) { - break; - } - Tcl_Time before, after; - Tcl_Time timeout = {CONDITION_TIMEOUT_SECS, 0}; - Tcl_GetTime(&before); - Tcl_ConditionWait( - &contextPtr->u.queue.canDequeue, &testContextMutex, &timeout); - Tcl_GetTime(&after); - if ((1000000 * (after.sec - before.sec) + (after.usec - before.usec)) - >= 1000000 * CONDITION_TIMEOUT_SECS) { - threadContextPtr->timeouts += 1; - } - } - UnlockTestContext(contextPtr->numRecursions); - - Tcl_ExitThread(0); - TCL_THREAD_CREATE_RETURN; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/mutex.test b/tests/mutex.test new file mode 100644 index 0000000..3ff2702 --- /dev/null +++ b/tests/mutex.test @@ -0,0 +1,80 @@ +# Commands covered: (test)mutex +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2025 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +source [file join [file dirname [info script]] tcltests.tcl] + +::tcltest::loadTestedCommands + +testConstraint testmutex [expr {[info commands testmutex] ne {}}] + +namespace eval testmutex { + namespace import ::tcltest::test + + proc testlock {id nthreads recursion iters yield} { + test $id "mutex lock $nthreads/$recursion/$iters/$yield" \ + -constraints testmutex \ + -body "testmutex lock $nthreads $recursion $iters $yield" \ + -result [expr {$nthreads*$iters}] + } + # threads recursions iterations yield + testlock mutex-lock-1 2 1 1000000 0 + testlock mutex-lock-2 2 1 1000000 1 + testlock mutex-lock-3 10 1 200000 0 + testlock mutex-lock-4 10 1 200000 1 + testlock mutex-lock-5 4 5 400000 0 + testlock mutex-lock-6 4 5 400000 1 + + proc fairness {totalOps perThreadOps} { + set errors {} + set threadTotal [tcl::mathop::+ {*}$perThreadOps] + if {$threadTotal ne $totalOps} { + append errors "Thread total $threadTotal != expected $totalOps\n" + } + # Each thread should get at least half of fair share + set fairShare [expr {$totalOps / [llength $perThreadOps]}] + foreach share $perThreadOps { + if {$fairShare > 2*$share} { + append errors "Thread share $share < 0.5 fair share $fairShare" + } + } + return $errors + } + proc testcondition {id nthreads recursion iters yield} { + set totalOps [expr {$nthreads*$iters}] + test $id "mutex condition $nthreads/$recursion/$iters/$yield" \ + -constraints testmutex \ + -body { + lassign \ + [testmutex condition $nthreads $recursion $iters $yield] \ + enqTotal enqPerThread enqTimeouts \ + deqTotal deqPerThread deqTimeouts + list \ + $enqTotal [fairness $totalOps $enqPerThread] $enqTimeouts \ + $deqTotal [fairness $totalOps $deqPerThread] $deqTimeouts + } -result [list $totalOps {} 0 $totalOps {} 0] + } + testcondition mutex-condition-1 2 1 100000 0 + testcondition mutex-condition-2 2 1 100000 1 + testcondition mutex-condition-3 10 1 20000 0 + testcondition mutex-condition-4 10 1 20000 1 + testcondition mutex-condition-5 4 5 40000 0 + testcondition mutex-condition-6 4 5 40000 1 + +} + +# cleanup +::tcltest::cleanupTests +return diff --git a/unix/Makefile.in b/unix/Makefile.in index 82ca62e..53f7c28 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -293,10 +293,10 @@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o tclTestABSList.o + tclMutexTest.o tclThreadTest.o tclUnixTest.o tclTestABSList.o XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \ + tclMutexTest.o tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \ tclTestABSList.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ @@ -1611,6 +1611,9 @@ tclThreadJoin.o: $(GENERIC_DIR)/tclThreadJoin.c tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c +tclMutexTest.o: $(GENERIC_DIR)/tclMutexTest.c + $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclMutexTest.c + tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c diff --git a/win/Makefile.in b/win/Makefile.in index b7a143e..3db48f0 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -282,6 +282,7 @@ TCLTEST_OBJS = \ tclTestABSList.$(OBJEXT) \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ + tclMutexTest.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ tclWinTest.$(OBJEXT) diff --git a/win/makefile.vc b/win/makefile.vc index ae859ba..45dba92 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -232,6 +232,7 @@ TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ + $(TMP_DIR)\tclMutexTest.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ $(TMP_DIR)\tclTestABSList.obj \ -- cgit v0.12