summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-11-16 00:49:20 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-11-16 00:49:20 (GMT)
commit10ef733f12d8356c8149674542195b702741fb57 (patch)
tree0ca93a479ec4c1eb68a2482ff755d5591112baeb
parentecebf970f39a0b05f31b112c01c6d5b41434eed9 (diff)
downloadtcl-10ef733f12d8356c8149674542195b702741fb57.zip
tcl-10ef733f12d8356c8149674542195b702741fb57.tar.gz
tcl-10ef733f12d8356c8149674542195b702741fb57.tar.bz2
Miguel Sofer's patch (with small revisions) to make sure the bytecode engine
checks for async events fairly frequently. [Bug 746722]
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclExecute.c37
-rw-r--r--generic/tclTest.c63
-rw-r--r--tests/async.test80
4 files changed, 176 insertions, 14 deletions
diff --git a/ChangeLog b/ChangeLog
index 201daf3..0008179 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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: