diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclExecute.c | 37 | ||||
| -rw-r--r-- | generic/tclTest.c | 63 | ||||
| -rw-r--r-- | tests/async.test | 80 |
4 files changed, 176 insertions, 14 deletions
@@ -1,3 +1,13 @@ +2003-11-16 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/tclExecute.c (TclExecuteByteCode): Make sure that + Tcl_AsyncInvoke is called regularly when processing bytecodes. + * generic/tclTest.c (AsyncThreadProc, TestasyncCmd): Extended + testing harness to send an asynchronous marking without relying on + UNIX signals. + * tests/async.test (async-4.*): Tests to check that async events + are handled by the bytecode core. [Bug 746722] + 2003-11-15 Donal K. Fellows <donal.k.fellows@man.ac.uk> * generic/tclTest.c (TestHashSystemHashCmd): Removed 'const' diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c642112..41f01fd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.114 2003/11/14 20:44:44 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.115 2003/11/16 00:49:20 dkf Exp $ */ #include "tclInt.h" @@ -62,6 +62,16 @@ int errno; #endif /* !DBL_MAX */ /* + * A mask (should be 2**n-1) that is used to work out when the + * bytecode engine should call Tcl_AsyncReady() to see whether there + * is a signal that needs handling. + */ + +#ifndef ASYNC_CHECK_COUNT_MASK +# define ASYNC_CHECK_COUNT_MASK 15 +#endif /* !ASYNC_CHECK_COUNT_MASK */ + +/* * Boolean flag indicating whether the Tcl bytecode interpreter has been * initialized. */ @@ -1088,6 +1098,7 @@ TclExecuteByteCode(interp, codePtr) int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif + int instructionCount = 0; /* * The execution uses a unified stack: first the catch stack, immediately @@ -1202,6 +1213,21 @@ TclExecuteByteCode(interp, codePtr) #ifdef TCL_COMPILE_STATS iPtr->stats.instructionCount[*pc]++; #endif + + /* + * Check for asynchronous handlers [Bug 746722]; we + * do the check every 16th instruction. + */ + + if (!(instructionCount++ & ~ASYNC_CHECK_COUNT_MASK) && Tcl_AsyncReady()) { + DECACHE_STACK_INFO(); + result = Tcl_AsyncInvoke(interp, result); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + goto checkForCatch; + } + } + switch (*pc) { case INST_RETURN: if (iPtr->returnOpts != iPtr->defaultReturnOpts) { @@ -1210,6 +1236,7 @@ TclExecuteByteCode(interp, codePtr) Tcl_IncrRefCount(iPtr->returnOpts); } result = TCL_RETURN; + case INST_DONE: if (tosPtr <= eePtr->stackPtr + initStackTop) { tosPtr--; @@ -1493,6 +1520,14 @@ TclExecuteByteCode(interp, codePtr) ++*preservedStackRefCountPtr; /* + * Reset the instructionCount variable, since we're about + * to check for async stuff anyway while processing + * TclEvalObjvInternal. + */ + + instructionCount = 0; + + /* * Finally, let TclEvalObjvInternal handle the command. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 794f7e3..69ead5b 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.72 2003/11/15 23:42:42 dkf Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.73 2003/11/16 00:49:20 dkf Exp $ */ #define TCL_TEST @@ -129,6 +129,9 @@ typedef struct TestEvent { int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); +#ifdef TCL_THREADS +static Tcl_ThreadCreateType AsyncThreadProc _ANSI_ARGS_((ClientData)); +#endif static void CleanupTestSetassocdataTests _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); @@ -840,11 +843,39 @@ TestasyncCmd(dummy, interp, argc, argv) } Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE); return code; +#ifdef TCL_THREADS + } else if (strcmp(argv[1], "marklater") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_ThreadId threadID; + if (Tcl_CreateThread(&threadID, AsyncThreadProc, + (ClientData) asyncPtr, TCL_THREAD_STACK_DEFAULT, + TCL_THREAD_NOFLAGS) != TCL_OK) { + Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + return TCL_ERROR; + } + break; + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, mark, or marklater", + (char *) NULL); + return TCL_ERROR; +#else /* !TCL_THREADS */ } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, or mark", (char *) NULL); return TCL_ERROR; +#endif } return TCL_OK; } @@ -882,6 +913,36 @@ AsyncHandlerProc(clientData, interp, code) /* *---------------------------------------------------------------------- * + * AsyncThreadProc -- + * + * Delivers an asynchronous event to a handler in another thread. + * + * Results: + * None. + * + * Side effects: + * Invokes Tcl_AsyncMark on the handler + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_THREADS +static Tcl_ThreadCreateType +AsyncThreadProc(clientData) + ClientData clientData; /* Parameter is a pointer to a + * TestAsyncHandler, defined above. */ +{ + TestAsyncHandler* asyncPtr = clientData; + Tcl_Sleep(1); + Tcl_AsyncMark(asyncPtr->handler); + Tcl_ExitThread(TCL_OK); + TCL_THREAD_CREATE_RETURN; +} +#endif + +/* + *---------------------------------------------------------------------- + * * TestcmdinfoCmd -- * * This procedure implements the "testcmdinfo" command. It is used diff --git a/tests/async.test b/tests/async.test index af63413..863be98 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: async.test,v 1.6 2003/07/24 16:05:24 dgp Exp $ +# RCS: @(#) $Id: async.test,v 1.7 2003/11/16 00:49:20 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -25,6 +25,10 @@ if {[info commands testasync] == {}} { return } +tcltest::testConstraint threaded [expr { + [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) +}] + proc async1 {result code} { global aresult acode set aresult $result @@ -146,19 +150,71 @@ test async-3.1 {deleting handlers} { list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x } {3 del2 {0 0 0 del1 del2}} +proc nothing {} { + # empty proc +} +proc hang1 {handle} { + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + for {set i 0} { + $i < 2500000 && $aresult eq "Async event not delivered" + } {incr i} { + nothing + } + return $aresult +} +proc hang2 {handle} { + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + for {set i 0} { + $i < 2500000 && $aresult eq "Async event not delivered" + } {incr i} {} + return $aresult +} +proc hang3 {handle} [concat { + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + set i 0 +} [string repeat {;incr i;} 1500000] { + return $aresult +}] + +test async-4.1 {async interrupting bytecode sequence} -constraints { + threaded +} -setup { + set hm [testasync create async3] +} -body { + hang1 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} +test async-4.2 {async interrupting straight bytecode sequence} -constraints { + threaded +} -setup { + set hm [testasync create async3] +} -body { + hang2 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} +test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { + threaded +} -setup { + set hm [testasync create async3] +} -body { + hang3 $hm +} -result {test pattern} -cleanup { + testasync delete $hm +} + # cleanup testasync delete ::tcltest::cleanupTests return - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |