summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h4
-rw-r--r--generic/tclBasic.c1
-rw-r--r--generic/tclClock.c45
-rw-r--r--generic/tclCmdMZ.c348
-rw-r--r--generic/tclCompile.h19
-rw-r--r--generic/tclEvent.c216
-rw-r--r--generic/tclIO.c108
-rw-r--r--generic/tclIO.h2
-rw-r--r--generic/tclIndexObj.c55
-rw-r--r--generic/tclInt.h233
-rw-r--r--generic/tclInterp.c65
-rw-r--r--generic/tclNotify.c910
-rw-r--r--generic/tclTimer.c1671
13 files changed, 2958 insertions, 719 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 759f824..c080e93 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -759,6 +759,7 @@ typedef void (Tcl_PanicProc) (const char *format, ...);
typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan,
char *address, int port);
typedef void (Tcl_TimerProc) (ClientData clientData);
+typedef void (Tcl_TimerDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr);
typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp,
@@ -1363,6 +1364,7 @@ typedef struct {
* events:
*/
+#define TCL_ASYNC_EVENTS (1<<0)
#define TCL_DONT_WAIT (1<<1)
#define TCL_WINDOW_EVENTS (1<<2)
#define TCL_FILE_EVENTS (1<<3)
@@ -1389,7 +1391,7 @@ struct Tcl_Event {
*/
typedef enum {
- TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
+ TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, TCL_QUEUE_RETARDED
} Tcl_QueuePosition;
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 14d67f6..9d866c6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -285,6 +285,7 @@ static const CmdInfo builtInCmds[] = {
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
{"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
{"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
diff --git a/generic/tclClock.c b/generic/tclClock.c
index bbfc83b..19635e0 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -184,6 +184,9 @@ static int ClockMicrosecondsObjCmd(
static int ClockMillisecondsObjCmd(
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+static int ClockMonotonicObjCmd(
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int ClockParseformatargsObjCmd(
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -257,6 +260,7 @@ TclClockInit(
{"format", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"microseconds", ClockMicrosecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(1), 0},
{"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
+ {"monotonic", ClockMonotonicObjCmd, NULL, NULL, NULL, 0},
{"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
@@ -1772,8 +1776,7 @@ ClockClicksObjCmd(
#endif
break;
case CLICKS_MICROS:
- Tcl_GetTime(&now);
- clicks = ((Tcl_WideInt) now.sec * 1000000) + now.usec;
+ clicks = TclpGetMicroseconds();
break;
}
@@ -1843,15 +1846,45 @@ ClockMicrosecondsObjCmd(
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
- Tcl_Time now;
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ClockMonotonicObjCmd -
+ *
+ * Returns a count of microseconds since some starting point.
+ * This represents monotonic time not affected from the time-jumps.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ * This function implements the 'clock monotonic' Tcl command. Refer to the
+ * user documentation for details on what it does.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+ClockMonotonicObjCmd(
+ ClientData clientData, /* Client data is unused */
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj* const* objv) /* Parameter values */
+{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
- Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
- ((Tcl_WideInt) now.sec * 1000000) + now.usec));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetUTimeMonotonic()));
return TCL_OK;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 3f79ca4..f1e977a 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -17,6 +17,7 @@
*/
#include "tclInt.h"
+#include "tclCompile.h"
#include "tclRegexp.h"
#include "tclStringTrim.h"
@@ -4146,7 +4147,7 @@ Tcl_TimeObjCmd(
start = TclpGetWideClicks();
#endif
while (i-- > 0) {
- result = Tcl_EvalObjEx(interp, objPtr, 0);
+ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
if (result != TCL_OK) {
return result;
}
@@ -4186,6 +4187,351 @@ Tcl_TimeObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_TimeRateObjCmd --
+ *
+ * This object-based procedure is invoked to process the "timerate" Tcl
+ * command.
+ * This is similar to command "time", except the execution limited by
+ * given time (in milliseconds) instead of repetition count.
+ *
+ * Example:
+ * timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]`
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_TimeRateObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static
+ double measureOverhead = 0; /* global measure-overhead */
+ double overhead = -1; /* given measure-overhead */
+ register Tcl_Obj *objPtr;
+ register int result, i;
+ Tcl_Obj *calibrate = NULL, *direct = NULL;
+ Tcl_WideInt count = 0; /* Holds repetition count */
+ Tcl_WideInt maxms = -0x7FFFFFFFFFFFFFFFL;
+ /* Maximal running time (in milliseconds) */
+ Tcl_WideInt threshold = 1; /* Current threshold for check time (faster
+ * repeat count without time check) */
+ Tcl_WideInt maxIterTm = 1; /* Max time of some iteration as max threshold
+ * additionally avoid divide to zero (never < 1) */
+ register Tcl_WideInt start, middle, stop;
+#ifndef TCL_WIDE_CLICKS
+ Tcl_Time now;
+#endif
+
+ static const char *const options[] = {
+ "-direct", "-overhead", "-calibrate", "--", NULL
+ };
+ enum options {
+ TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
+ };
+
+ NRE_callback *rootPtr;
+ ByteCode *codePtr = NULL;
+
+ for (i = 1; i < objc - 1; i++) {
+ int index;
+ if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
+ &index) != TCL_OK) {
+ break;
+ }
+ if (index == TMRT_LAST) {
+ i++;
+ break;
+ }
+ switch (index) {
+ case TMRT_EV_DIRECT:
+ direct = objv[i];
+ break;
+ case TMRT_OVERHEAD:
+ if (++i >= objc - 1) {
+ goto usage;
+ }
+ if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case TMRT_CALIBRATE:
+ calibrate = objv[i];
+ break;
+ }
+ }
+
+ if (i >= objc || i < objc-2) {
+usage:
+ Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time?");
+ return TCL_ERROR;
+ }
+ objPtr = objv[i++];
+ if (i < objc) {
+ result = TclGetWideIntFromObj(interp, objv[i], &maxms);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+
+ /* if calibrate */
+ if (calibrate) {
+
+ /* if no time specified for the calibration */
+ if (maxms == -0x7FFFFFFFFFFFFFFFL) {
+ Tcl_Obj *clobjv[6];
+ Tcl_WideInt maxCalTime = 5000;
+ double lastMeasureOverhead = measureOverhead;
+
+ clobjv[0] = objv[0];
+ i = 1;
+ if (direct) {
+ clobjv[i++] = direct;
+ }
+ clobjv[i++] = objPtr;
+
+ /* reset last measurement overhead */
+ measureOverhead = (double)0;
+
+ /* self-call with 100 milliseconds to warm-up,
+ * before entering the calibration cycle */
+ TclNewLongObj(clobjv[i], 100);
+ Tcl_IncrRefCount(clobjv[i]);
+ result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
+ Tcl_DecrRefCount(clobjv[i]);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ i--;
+ clobjv[i++] = calibrate;
+ clobjv[i++] = objPtr;
+
+ /* set last measurement overhead to max */
+ measureOverhead = (double)0x7FFFFFFFFFFFFFFFL;
+
+ /* calibration cycle until it'll be preciser */
+ maxms = -1000;
+ do {
+ lastMeasureOverhead = measureOverhead;
+ TclNewLongObj(clobjv[i], (int)maxms);
+ Tcl_IncrRefCount(clobjv[i]);
+ result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
+ Tcl_DecrRefCount(clobjv[i]);
+ if (result != TCL_OK) {
+ return result;
+ }
+ maxCalTime += maxms;
+ /* increase maxms for preciser calibration */
+ maxms -= (-maxms / 4);
+ /* as long as new value more as 0.05% better */
+ } while ( (measureOverhead >= lastMeasureOverhead
+ || measureOverhead / lastMeasureOverhead <= 0.9995)
+ && maxCalTime > 0
+ );
+
+ return result;
+ }
+ if (maxms == 0) {
+ /* reset last measurement overhead */
+ measureOverhead = 0;
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ return TCL_OK;
+ }
+
+ /* if time is negative - make current overhead more precise */
+ if (maxms > 0) {
+ /* set last measurement overhead to max */
+ measureOverhead = (double)0x7FFFFFFFFFFFFFFFL;
+ } else {
+ maxms = -maxms;
+ }
+
+ }
+
+ if (maxms == -0x7FFFFFFFFFFFFFFFL) {
+ maxms = 1000;
+ }
+ if (overhead == -1) {
+ overhead = measureOverhead;
+ }
+
+ /* be sure that resetting of result will not smudge the further measurement */
+ Tcl_ResetResult(interp);
+
+ /* compile object */
+ if (!direct) {
+ if (TclInterpReady(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ codePtr = TclCompileObj(interp, objPtr, NULL, 0);
+ TclPreserveByteCode(codePtr);
+ }
+
+ /* get start and stop time */
+#ifdef TCL_WIDE_CLICKS
+ start = middle = TclpGetWideClicks();
+ /* time to stop execution (in wide clicks) */
+ stop = start + (maxms * 1000 / TclpWideClickInMicrosec());
+#else
+ Tcl_GetTime(&now);
+ start = now.sec; start *= 1000000; start += now.usec;
+ middle = start;
+ /* time to stop execution (in microsecs) */
+ stop = start + maxms * 1000;
+#endif
+
+ /* start measurement */
+ while (1) {
+ /* eval single iteration */
+ count++;
+
+ if (!direct) {
+ /* precompiled */
+ rootPtr = TOP_CB(interp);
+ result = TclNRExecuteByteCode(interp, codePtr);
+ result = TclNRRunCallbacks(interp, result, rootPtr);
+ } else {
+ /* eval */
+ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
+ }
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /* don't check time up to threshold */
+ if (--threshold > 0) continue;
+
+ /* check stop time reached, estimate new threshold */
+ #ifdef TCL_WIDE_CLICKS
+ middle = TclpGetWideClicks();
+ #else
+ Tcl_GetTime(&now);
+ middle = now.sec; middle *= 1000000; middle += now.usec;
+ #endif
+ if (middle >= stop) {
+ break;
+ }
+
+ /* don't calculate threshold by few iterations, because sometimes
+ * first iteration(s) can be too fast (cached, delayed clean up, etc) */
+ if (count < 10) {
+ threshold = 1; continue;
+ }
+
+ /* average iteration time in microsecs */
+ threshold = (middle - start) / count;
+ if (threshold > maxIterTm) {
+ maxIterTm = threshold;
+ }
+ /* as relation between remaining time and time since last check */
+ threshold = ((stop - middle) / maxIterTm) / 4;
+ if (threshold > 100000) { /* fix for too large threshold */
+ threshold = 100000;
+ }
+ }
+
+ {
+ Tcl_Obj *objarr[8], **objs = objarr;
+ Tcl_WideInt val;
+ const char *fmt;
+
+ middle -= start; /* execution time in microsecs */
+
+ #ifdef TCL_WIDE_CLICKS
+ /* convert execution time in wide clicks to microsecs */
+ middle *= TclpWideClickInMicrosec();
+ #endif
+
+ /* if not calibrate */
+ if (!calibrate) {
+ /* minimize influence of measurement overhead */
+ if (overhead > 0) {
+ /* estimate the time of overhead (microsecs) */
+ Tcl_WideInt curOverhead = overhead * count;
+ if (middle > curOverhead) {
+ middle -= curOverhead;
+ } else {
+ middle = 1;
+ }
+ }
+ } else {
+ /* calibration - obtaining new measurement overhead */
+ if (measureOverhead > (double)middle / count) {
+ measureOverhead = (double)middle / count;
+ }
+ objs[0] = Tcl_NewDoubleObj(measureOverhead);
+ TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
+ objs += 2;
+ }
+
+ val = middle / count; /* microsecs per iteration */
+ if (val >= 1000000) {
+ objs[0] = Tcl_NewWideIntObj(val);
+ } else {
+ if (val < 10) { fmt = "%.6f"; } else
+ if (val < 100) { fmt = "%.4f"; } else
+ if (val < 1000) { fmt = "%.3f"; } else
+ if (val < 10000) { fmt = "%.2f"; } else
+ { fmt = "%.1f"; };
+ objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count);
+ }
+
+ objs[2] = Tcl_NewWideIntObj(count); /* iterations */
+
+ /* calculate speed as rate (count) per sec */
+ if (!middle) middle++; /* +1 ms, just to avoid divide by zero */
+ if (count < (0x7FFFFFFFFFFFFFFFL / 1000000)) {
+ val = (count * 1000000) / middle;
+ if (val < 100000) {
+ if (val < 100) { fmt = "%.3f"; } else
+ if (val < 1000) { fmt = "%.2f"; } else
+ { fmt = "%.1f"; };
+ objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle);
+ } else {
+ objs[4] = Tcl_NewWideIntObj(val);
+ }
+ } else {
+ objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
+ }
+
+ /* estimated net execution time (in millisecs) */
+ if (!calibrate) {
+ objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);
+ TclNewLiteralStringObj(objs[7], "nett-ms");
+ }
+
+ /*
+ * Construct the result as a list because many programs have always parsed
+ * as such (extracting the first element, typically).
+ */
+
+ TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */
+ TclNewLiteralStringObj(objs[3], "#");
+ TclNewLiteralStringObj(objs[5], "#/sec");
+ Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
+ }
+
+done:
+
+ if (codePtr != NULL) {
+ TclReleaseByteCode(codePtr);
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_TryObjCmd, TclNRTryObjCmd --
*
* This procedure is invoked to process the "try" Tcl command. See the
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c04fc0e..90edf07 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1159,6 +1159,25 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
int *isScalarPtr);
+
+static inline void
+TclPreserveByteCode(
+ register ByteCode *codePtr)
+{
+ codePtr->refCount++;
+}
+
+static inline void
+TclReleaseByteCode(
+ register ByteCode *codePtr)
+{
+ if (codePtr->refCount-- > 1) {
+ return;
+ }
+ /* Just dropped to refcount==0. Clean up. */
+ TclCleanupByteCode(codePtr);
+}
+
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
const char *name, Namespace *nsPtr);
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index b0b8188..bdc1b44 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1368,6 +1368,62 @@ TclInThreadExit(void)
}
return tsdPtr->inExit;
}
+
+
+static CONST char *updateEventOptions[] = {
+ "-idle", "-noidle", /* new options */
+ "-timer", "-notimer",
+ "-file", "-nofile",
+ "-window", "-nowindow",
+ "-async", "-noasync",
+ "-nowait", "-wait",
+ "idletasks", /* backwards compat. */
+ NULL
+};
+
+static int
+GetEventFlagsFromOpts(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[], /* Arguments containing the option to lookup. */
+ int *flagsPtr) /* Input and resulting flags. */
+{
+ int i, optionIndex, result = TCL_ERROR;
+ int flags = *flagsPtr; /* default flags */
+ static CONST struct {
+ int mask;
+ int flags;
+ } *updateFlag, updateFlags[] = {
+ {0, TCL_IDLE_EVENTS}, {TCL_IDLE_EVENTS, 0}, /* -idle, -noidle */
+ {0, TCL_TIMER_EVENTS}, {TCL_TIMER_EVENTS, 0}, /* -timer, -notimer */
+ {0, TCL_FILE_EVENTS}, {TCL_FILE_EVENTS, 0}, /* -file, -nofile */
+ {0, TCL_WINDOW_EVENTS}, {TCL_WINDOW_EVENTS, 0}, /* -window, -nowindow */
+ {0, TCL_ASYNC_EVENTS}, {TCL_ASYNC_EVENTS, 0}, /* -async, -noasync */
+ {0, TCL_DONT_WAIT}, {TCL_DONT_WAIT, 0}, /* -nowait, -wait */
+ {TCL_ALL_EVENTS, TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS}, /* idletasks */
+ {0, 0} /* dummy / place holder */
+ };
+
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], updateEventOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ goto done;
+ }
+ updateFlag = &updateFlags[optionIndex];
+ /* pure positive option and still default,
+ * reset all events (only this flag) */
+ if (!updateFlag->mask && flags == *flagsPtr) {
+ flags &= ~TCL_ALL_EVENTS;
+ }
+ flags &= ~updateFlag->mask;
+ flags |= updateFlag->flags;
+ }
+ result = TCL_OK;
+
+ done:
+ *flagsPtr = flags;
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -1394,45 +1450,129 @@ Tcl_VwaitObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int done, foundEvent;
+ int done = 0, foundEvent = 1, checktime = 0;
+ int flags = TCL_ALL_EVENTS; /* default flags */
const char *nameString;
+ int optc = objc - 2; /* options count without cmd and varname */
+ Tcl_WideInt usec = -1;
+ Tcl_WideInt now = 0, wakeup = 0;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? ?timeout? name");
return TCL_ERROR;
}
- nameString = Tcl_GetString(objv[1]);
+
+ /* if arguments available - wrap options to flags */
+ if (objc >= 3) {
+ /* first try to recognize options up to the possible end, thereby
+ * we assume that option is not an integer, try to get numeric timeout
+ */
+ if (!TclObjIsIndexOfTable(objv[optc], updateEventOptions)
+ && TclpGetUTimeFromObj(NULL, objv[optc], &usec, 1000) == TCL_OK) {
+ if (usec < 0) { usec = 0; };
+ optc--;
+ }
+
+ /* now try to parse options (if available) */
+ if ( optc > 0
+ && GetEventFlagsFromOpts(interp, optc, objv+1, &flags) != TCL_OK
+ ) {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * If timeout specified - create timer event or no-wait by 0ms.
+ * Note the time can be switched (time-jump), so use monotonic time here.
+ */
+ if (usec != -1) {
+ if (usec > 0) {
+ now = TclpGetUTimeMonotonic();
+ wakeup = now + usec;
+ } else {
+ flags |= TCL_DONT_WAIT;
+ }
+ }
+
+ nameString = Tcl_GetString(objv[objc-1]);
if (Tcl_TraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
- done = 0;
- foundEvent = 1;
- while (!done && foundEvent) {
- foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+
+ do {
+ /* if wait - set blocking time */
+ if (usec > 0) {
+ Tcl_Time blockTime;
+ Tcl_WideInt diff;
+
+ now = TclpGetUTimeMonotonic();
+
+ /* calculate blocking time */
+ diff = wakeup - now;
+ diff -= 1; /* overhead for this code (e. g. Tcl_TraceVar/Tcl_UntraceVar) */
+ /* be sure process at least one event */
+ if (diff <= 0) {
+ /* timeout occurs */
+ if (checktime) {
+ done = -1;
+ break;
+ }
+ /* expired, be sure non-negative values here */
+ diff = 0;
+ checktime = 1;
+ }
+ blockTime.sec = diff / 1000000;
+ blockTime.usec = diff % 1000000;
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+ if ((foundEvent = Tcl_DoOneEvent(flags)) <= 0) {
+ /*
+ * If don't wait flag set - no error, and two cases:
+ * option -nowait for vwait means - we don't wait for events;
+ * if no timeout (0) - just stop waiting (no more events)
+ */
+ if (foundEvent == 0 && (flags & TCL_DONT_WAIT || usec != -1)) {
+ foundEvent = 1;
+ if (usec == 0) { /* timeout occurs */
+ done = -1;
+ break;
+ }
+ }
+ /* don't stop wait - no event expected here
+ * (stop only on error case foundEvent <= 0). */
+ if (foundEvent < 0) {
+ done = -2;
+ }
+ }
+ /* check canceled or interpreter limit exceeded */
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ done = -3;
break;
}
if (Tcl_LimitExceeded(interp)) {
- Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+ done = -4;
break;
}
- }
+ } while (!done);
+
Tcl_UntraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done);
- if (!foundEvent) {
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't wait for variable \"%s\": would wait forever",
- nameString));
- Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
- return TCL_ERROR;
- }
- if (!done) {
+ /* if some error */
+ if (done <= -2) {
+
+ if (done == -2) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't wait for variable \"%s\": would wait forever",
+ nameString));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
+ return TCL_ERROR;
+ }
+
/*
* The interpreter's result was already set to the right error message
* prior to exiting the loop above.
@@ -1441,6 +1581,16 @@ Tcl_VwaitObjCmd(
return TCL_ERROR;
}
+ /* if timeout specified (and no errors) */
+ if (usec != -1) {
+ Tcl_Obj *objPtr;
+
+ /* done - true, timeout false */
+ TclNewLongObj(objPtr, (done > 0));
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+ }
+
/*
* Clear out the interpreter's result, since it may have been set by event
* handlers.
@@ -1492,28 +1642,13 @@ Tcl_UpdateObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int optionIndex;
- int flags = 0; /* Initialized to avoid compiler warning. */
- static const char *const updateOptions[] = {"idletasks", NULL};
- enum updateOptions {OPT_IDLETASKS};
-
- if (objc == 1) {
- flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
- } else if (objc == 2) {
- if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
- "option", 0, &optionIndex) != TCL_OK) {
+ int flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; /* default flags */
+
+ /* if arguments available - wrap options to flags */
+ if (objc > 1) {
+ if (GetEventFlagsFromOpts(interp, objc-1, objv+1, &flags) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum updateOptions) optionIndex) {
- case OPT_IDLETASKS:
- flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
- break;
- default:
- Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
- }
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
- return TCL_ERROR;
}
while (Tcl_DoOneEvent(flags) != 0) {
@@ -1525,6 +1660,9 @@ Tcl_UpdateObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
+
+ /* be sure not to produce infinite wait (wait only once) */
+ flags |= TCL_DONT_WAIT;
}
/*
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 64501fd..63f0afa 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -156,7 +156,7 @@ static void PreserveChannelBuffer(ChannelBuffer *bufPtr);
static void ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int IsShared(ChannelBuffer *bufPtr);
static void ChannelFree(Channel *chanPtr);
-static void ChannelTimerProc(ClientData clientData);
+static int ChannelScheduledProc(Tcl_Event *evPtr, int flags);
static int ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int CheckChannelErrors(ChannelState *statePtr,
int direction);
@@ -1693,7 +1693,7 @@ Tcl_CreateChannel(
statePtr->interestMask = 0;
statePtr->scriptRecordPtr = NULL;
statePtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE;
- statePtr->timer = NULL;
+ statePtr->schedEvent = NULL;
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
statePtr->outputStage = NULL;
@@ -3081,10 +3081,17 @@ CloseChannel(
}
/*
- * Cancel any outstanding timer.
+ * Cancel any outstanding scheduled event.
*/
- Tcl_DeleteTimerHandler(statePtr->timer);
+ if (statePtr->schedEvent) {
+ /* reset channel in event (cancel delayed) */
+ *(Channel**)(statePtr->schedEvent+1) = NULL;
+#if 0
+ TclpCancelEvent(statePtr->schedEvent);
+#endif
+ statePtr->schedEvent = NULL;
+ }
/*
* Mark the channel as deleted by clearing the type structure.
@@ -3877,10 +3884,17 @@ Tcl_ClearChannelHandlers(
chanPtr = statePtr->topChanPtr;
/*
- * Cancel any outstanding timer.
+ * Cancel any outstanding scheduled event.
*/
- Tcl_DeleteTimerHandler(statePtr->timer);
+ if (statePtr->schedEvent) {
+ /* reset channel in event (cancel delayed) */
+ *(Channel**)(statePtr->schedEvent+1) = NULL;
+#if 0
+ TclpCancelEvent(statePtr->schedEvent);
+#endif
+ statePtr->schedEvent = NULL;
+ }
/*
* Remove any references to channel handlers for this channel that may be
@@ -4816,7 +4830,7 @@ Tcl_GetsObj(
/*
* We didn't get a complete line so we need to indicate to UpdateInterest
* that the gets blocked. It will wait for more data instead of firing a
- * timer, avoiding a busy wait. This is where we are assuming that the
+ * event, avoiding a busy wait. This is where we are assuming that the
* next operation is a gets. No more file events will be delivered on this
* channel until new data arrives or some operation is performed on the
* channel (e.g. gets, read, fconfigure) that changes the blocking state.
@@ -5101,7 +5115,7 @@ TclGetsObjBinary(
/*
* We didn't get a complete line so we need to indicate to UpdateInterest
* that the gets blocked. It will wait for more data instead of firing a
- * timer, avoiding a busy wait. This is where we are assuming that the
+ * event, avoiding a busy wait. This is where we are assuming that the
* next operation is a gets. No more file events will be delivered on this
* channel until new data arrives or some operation is performed on the
* channel (e.g. gets, read, fconfigure) that changes the blocking state.
@@ -8385,6 +8399,21 @@ Tcl_NotifyChannel(
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
+static inline Tcl_Event *
+CreateChannelScheduledEvent(
+ Channel *chanPtr)
+{
+#ifdef SYNTHETIC_EVENT_TIME
+ Tcl_Time blckTime;
+
+ blckTime.sec = SYNTHETIC_EVENT_TIME / 1000000;
+ blckTime.usec = SYNTHETIC_EVENT_TIME % 1000000;
+ Tcl_SetMaxBlockTime(&blckTime);
+#endif
+ return TclpQueueEventClientData(ChannelScheduledProc, chanPtr,
+ TCL_QUEUE_RETARDED);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -8397,7 +8426,7 @@ Tcl_NotifyChannel(
* None.
*
* Side effects:
- * May schedule a timer or driver handler.
+ * May schedule a event or driver handler.
*
*----------------------------------------------------------------------
*/
@@ -8426,7 +8455,7 @@ UpdateInterest(
/*
* If there is data in the input queue, and we aren't waiting for more
- * data, then we need to schedule a timer so we don't block in the
+ * data, then we need to schedule an event so we don't block in the
* notifier. Also, cancel the read interest so we don't get duplicate
* events.
*/
@@ -8455,7 +8484,7 @@ UpdateInterest(
*
* - Tcl drops READABLE here, because it has data in its own
* buffers waiting to be read by the extension.
- * - A READABLE event is syntesized via timer.
+ * - A READABLE event is syntesized via tcl-event (on queue tail).
* - The OS still reports the EXCEPTION condition on the file.
* - And the extension gets the EXCPTION event first, and handles
* this as EOF.
@@ -8477,9 +8506,8 @@ UpdateInterest(
mask &= ~TCL_EXCEPTION;
- if (!statePtr->timer) {
- statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
- ChannelTimerProc, chanPtr);
+ if (!statePtr->schedEvent) {
+ statePtr->schedEvent = CreateChannelScheduledEvent(chanPtr);
}
}
}
@@ -8489,9 +8517,9 @@ UpdateInterest(
/*
*----------------------------------------------------------------------
*
- * ChannelTimerProc --
+ * ChannelScheduledProc --
*
- * Timer handler scheduled by UpdateInterest to monitor the channel
+ * Event handler scheduled by UpdateInterest to monitor the channel
* buffers until they are empty.
*
* Results:
@@ -8503,32 +8531,41 @@ UpdateInterest(
*----------------------------------------------------------------------
*/
-static void
-ChannelTimerProc(
- ClientData clientData)
+static int
+ChannelScheduledProc(
+ Tcl_Event *evPtr, int flags)
{
- Channel *chanPtr = clientData;
- ChannelState *statePtr = chanPtr->state;
- /* State info for channel */
+ Channel *chanPtr = *(Channel**)(evPtr+1);
+ ChannelState *statePtr; /* State info for channel */
+
+ if (!chanPtr) { /* channel deleted */
+ return 1;
+ }
+
+ statePtr = chanPtr->state;
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
+
/*
- * Restart the timer in case a channel handler reenters the event loop
+ * Prolong the event in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
- statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
- ChannelTimerProc,chanPtr);
+ statePtr->schedEvent = CreateChannelScheduledEvent(chanPtr);
+
Tcl_Preserve(statePtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
Tcl_Release(statePtr);
- } else {
- statePtr->timer = NULL;
- UpdateInterest(chanPtr);
+
+ return 1; /* next cycle */
}
+
+ statePtr->schedEvent = NULL; /* event done. */
+ UpdateInterest(chanPtr);
+ return 1;
}
/*
@@ -8983,9 +9020,9 @@ Tcl_FileEventObjCmd(
/*
*----------------------------------------------------------------------
*
- * ZeroTransferTimerProc --
+ * ZeroTransferEventProc --
*
- * Timer handler scheduled by TclCopyChannel so that -command is
+ * Event handler scheduled by TclCopyChannel so that -command is
* called asynchronously even when -size is 0.
*
* Results:
@@ -8997,14 +9034,17 @@ Tcl_FileEventObjCmd(
*----------------------------------------------------------------------
*/
-static void
-ZeroTransferTimerProc(
- ClientData clientData)
+static int
+ZeroTransferEventProc(
+ Tcl_Event *evPtr, int flags)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
*/
+ ClientData clientData = *(ClientData*)(evPtr+1);
CopyData(clientData, 0);
+
+ return 1;
}
/*
@@ -9149,7 +9189,7 @@ TclCopyChannel(
*/
if ((nonBlocking == CHANNEL_NONBLOCKING) && (toRead == 0)) {
- Tcl_CreateTimerHandler(0, ZeroTransferTimerProc, csPtr);
+ TclpQueueEventClientData(ZeroTransferEventProc, csPtr, TCL_QUEUE_TAIL);
return 0;
}
diff --git a/generic/tclIO.h b/generic/tclIO.h
index ffbfa31..a317061 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -187,7 +187,7 @@ typedef struct ChannelState {
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
int bufSize; /* What size buffers to allocate? */
- Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
+ Tcl_Event *schedEvent; /* Scheduler event to wakeup this channel. */
struct CopyState *csPtrR; /* State of background copy for which channel
* is input, or NULL. */
struct CopyState *csPtrW; /* State of background copy for which channel
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 0e0ddc9..6a66c55 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -43,7 +43,7 @@ static void PrintUsage(Tcl_Interp *interp,
* that can be invoked by generic object code.
*/
-static const Tcl_ObjType indexType = {
+const Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
@@ -79,6 +79,43 @@ typedef struct {
/*
*----------------------------------------------------------------------
*
+ * TclObjIsIndexOfStruct --
+ *
+ * This function looks up an object's is a index of given table.
+ *
+ * Used for fast lookup by dynamic options count to check for other
+ * object types.
+ *
+ * Results:
+ * 1 if object is an option of table, otherwise 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclObjIsIndexOfStruct(
+ Tcl_Obj *objPtr, /* Object containing the string to lookup. */
+ const void *tablePtr) /* Array of strings to compare against the
+ * value of objPtr; last entry must be NULL
+ * and there must not be duplicate entries. */
+{
+ IndexRep *indexRep;
+ if (objPtr->typePtr != &tclIndexType) {
+ return 0;
+ }
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+
+ if (indexRep->tablePtr != (void *) tablePtr) {
+ return 0;
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetIndexFromObj --
*
* This function looks up an object's value in a table of strings and
@@ -121,7 +158,7 @@ Tcl_GetIndexFromObj(
* the common case where the result is cached).
*/
- if (objPtr->typePtr == &indexType) {
+ if (objPtr->typePtr == &tclIndexType) {
IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
@@ -279,7 +316,7 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (objPtr->typePtr == &indexType) {
+ if (objPtr->typePtr == &tclIndexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
@@ -340,13 +377,13 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
- if (objPtr->typePtr == &indexType) {
+ if (objPtr->typePtr == &tclIndexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = ckalloc(sizeof(IndexRep));
objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->typePtr = &indexType;
+ objPtr->typePtr = &tclIndexType;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
@@ -488,7 +525,7 @@ DupIndex(
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
- dupPtr->typePtr = &indexType;
+ dupPtr->typePtr = &tclIndexType;
}
/*
@@ -959,7 +996,7 @@ Tcl_WrongNumArgs(
* Add the element, quoting it if necessary.
*/
- if (origObjv[i]->typePtr == &indexType) {
+ if (origObjv[i]->typePtr == &tclIndexType) {
register IndexRep *indexRep =
origObjv[i]->internalRep.twoPtrValue.ptr1;
@@ -1009,7 +1046,7 @@ Tcl_WrongNumArgs(
* Otherwise, just use the string rep.
*/
- if (objv[i]->typePtr == &indexType) {
+ if (objv[i]->typePtr == &tclIndexType) {
register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
@@ -1457,7 +1494,7 @@ TclGetCompletionCodeFromObj(
"ok", "error", "return", "break", "continue", NULL
};
- if ((value->typePtr != &indexType)
+ if ((value->typePtr != &tclIndexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ed867d8..6354de7 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -55,6 +55,16 @@
typedef int ptrdiff_t;
#endif
+/*
+ * [MSVC] fallback to replace C++ keyword "inline" with C keyword "__inline"
+ * Otherwise depending on the VC-version, context, include-order it can cause:
+ * error C2054: expected '(' to follow 'inline'
+ */
+#if defined(_MSC_VER) && !defined(inline)
+# define inline __inline
+#endif
+
+
/*
* Ensure WORDS_BIGENDIAN is defined correctly:
* Needs to happen here in addition to configure to work with fat compiles on
@@ -124,6 +134,58 @@ typedef int ptrdiff_t;
#endif
/*
+ *----------------------------------------------------------------
+ * Data structures related to timer / idle events.
+ *----------------------------------------------------------------
+ */
+
+#define TCL_TMREV_PROMPT (1 << 0) /* Mark immediate event (0 microseconds) */
+#define TCL_TMREV_AT (1 << 1) /* Mark timer event to execute verbatim
+ * at the due-time (regardless any
+ * time-jumps). */
+#define TCL_TMREV_IDLE (1 << 3) /* Mark idle event */
+#define TCL_TMREV_LISTED (1 << 5) /* Event listed (attached to queue). */
+#define TCL_TMREV_DELETE (1 << 7) /* Event will be deleted. */
+
+/*
+ * This structure used for handling of timer events (with or without time to
+ * invoke, e. g. created with "after 0") or declared in a call to Tcl_DoWhenIdle
+ * (created with "after idle"). All of the currently-active handlers are linked
+ * together into corresponding list.
+ *
+ * For each timer callback that's pending there is one record of the following
+ * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
+ * together in a list via TclTimerEvent sorted by time (earliest event first).
+ */
+
+typedef struct TclTimerEvent {
+ Tcl_TimerProc *proc; /* Function to call timer/idle event */
+ Tcl_TimerDeleteProc *deleteProc; /* Function to cleanup idle event */
+ ClientData clientData; /* Argument to pass to proc and deleteProc */
+ int flags; /* Flags, OR-ed combination of flags/states
+ * TCL_TMREV_PROMPT ... TCL_TMREV_DELETE */
+
+ Tcl_WideInt time; /* When timer is to fire (absolute/relative). */
+ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */
+
+ size_t generation; /* Used to distinguish older handlers from
+ * recently-created ones. */
+ size_t refCount; /* Used to preserve for deletion (nested exec
+ * resp. prolongation). */
+ struct TclTimerEvent *nextPtr;/* Next and prev event in idle queue, */
+ struct TclTimerEvent *prevPtr;/* or NULL for end/start of the queue. */
+ /* variable ExtraData */ /* If extraDataSize supplied to create event. */
+} TclTimerEvent;
+
+/*
+ * Macros to wrap ExtraData and TclTimerEvent (and vice versa)
+ */
+#define TclpTimerEvent2ExtraData(ptr) \
+ ( (ClientData)(((TclTimerEvent *)(ptr))+1) )
+#define TclpExtraData2TimerEvent(ptr) \
+ ( ((TclTimerEvent *)(ptr))-1 )
+
+/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
*/
@@ -1976,8 +2038,7 @@ typedef struct Interp {
* reached. */
int timeGranularity; /* Mod factor used to determine how often to
* evaluate the limit check. */
- Tcl_TimerToken timeEvent;
- /* Handle for a timer callback that will occur
+ TclTimerEvent *timeEvent;/* Handle for a timer callback that will occur
* when the time-limit is exceeded. */
Tcl_HashTable callbacks;/* Mapping from (interp,type) pair to data
@@ -2173,18 +2234,37 @@ typedef struct Interp {
* existence of struct items 'prevPtr' and 'nextPtr'.
*
* a = element to add or remove.
- * b = list head.
+ * b = list head (points to the first element).
+ * e = list tail (points to the last element).
*
* TclSpliceIn adds to the head of the list.
+ * TclSpliceTail adds to the tail of the list.
*/
#define TclSpliceIn(a,b) \
- (a)->nextPtr = (b); \
- if ((b) != NULL) { \
+ if (((a)->nextPtr = (b)) != NULL) { \
(b)->prevPtr = (a); \
} \
(a)->prevPtr = NULL, (b) = (a);
+#define TclSpliceInEx(a,b,e) \
+ TclSpliceIn(a,b); \
+ if ((e) == NULL) { \
+ (e) = (a); \
+ }
+
+#define TclSpliceTail(a,e) \
+ if (((a)->prevPtr = (e)) != NULL) { \
+ (e)->nextPtr = (a); \
+ } \
+ (a)->nextPtr = NULL, (e) = (a);
+
+#define TclSpliceTailEx(a,b,e) \
+ TclSpliceTail(a,e); \
+ if ((b) == NULL) { \
+ (b) = (a); \
+ }
+
#define TclSpliceOut(a,b) \
if ((a)->prevPtr != NULL) { \
(a)->prevPtr->nextPtr = (a)->nextPtr; \
@@ -2195,6 +2275,11 @@ typedef struct Interp {
(a)->nextPtr->prevPtr = (a)->prevPtr; \
}
+#define TclSpliceOutEx(a,b,e) \
+ TclSpliceOut(a,b) else { \
+ (e) = (e)->prevPtr; \
+ }
+
/*
* EvalFlag bits for Interp structures:
*
@@ -2682,6 +2767,7 @@ MODULE_SCOPE const Tcl_ObjType tclByteArrayType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
MODULE_SCOPE const Tcl_ObjType tclEndOffsetType;
+MODULE_SCOPE const Tcl_ObjType tclIndexType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
@@ -2836,6 +2922,12 @@ struct Tcl_LoadHandle_ {
*----------------------------------------------------------------
*/
+MODULE_SCOPE int TclObjIsIndexOfStruct(Tcl_Obj *objPtr,
+ const void *tablePtr);
+#define TclObjIsIndexOfTable(objPtr, tablePtr) \
+ ((objPtr->typePtr == &tclIndexType) \
+ && TclObjIsIndexOfStruct(objPtr, tablePtr))
+
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, int len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -3151,10 +3243,83 @@ MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer,
MODULE_SCOPE void TclInitThreadStorage(void);
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
+
#ifdef TCL_WIDE_CLICKS
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
+MODULE_SCOPE double TclpWideClickInMicrosec(void);
+#else
+# ifdef _WIN32
+# define TCL_WIDE_CLICKS 1
+MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
+MODULE_SCOPE double TclpWideClickInMicrosec(void);
+# define TclpWideClicksToNanoseconds(clicks) \
+ ((double)(clicks) * TclpWideClickInMicrosec() * 1000)
+ /* Tolerance (in percent), prevents entering busy wait, but has fewer accuracy
+ * because can wait a bit shorter as wanted. Currently experimental value
+ * (4.5% equivalent to 15600 / 15000 with small overhead) */
+# ifndef TMR_RES_TOLERANCE
+# define TMR_RES_TOLERANCE 4.5
+# endif
+# endif
#endif
+MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);
+MODULE_SCOPE Tcl_WideInt TclpGetUTimeMonotonic(void);
+
+MODULE_SCOPE int TclpGetUTimeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideInt *timePtr, int factor);
+MODULE_SCOPE void TclpScaleUTime(Tcl_WideInt *usec);
+
+MODULE_SCOPE void TclpUSleep(Tcl_WideInt usec);
+/*
+ * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write
+ * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS resp.
+ * TCL_TIME_DIFF_US compute the number of milliseconds or microseconds difference
+ * between two times. Both macros use both of their arguments multiple times,
+ * so make sure they are cheap and side-effect free.
+ * Macro TCL_TIME_TO_USEC converts Tcl_Time to microseconds.
+ * The "prototypes" for these macros are:
+ *
+ * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2);
+ * static Tcl_WideInt TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2);
+ * static Tcl_WideInt TCL_TIME_DIFF_US(Tcl_Time t1, Tcl_Time t2);
+ * static Tcl_WideInt TCL_TIME_TO_USEC(Tcl_Time t)
+ */
+
+#define TCL_TIME_BEFORE(t1, t2) \
+ (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec))
+
+#define TCL_TIME_DIFF_MS(t1, t2) \
+ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \
+ ((long)(t1).usec - (long)(t2).usec)/1000)
+#define TCL_TIME_DIFF_US(t1, t2) \
+ (1000000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \
+ ((long)(t1).usec - (long)(t2).usec))
+#define TCL_TIME_TO_USEC(t) \
+ (((Tcl_WideInt)(t).sec)*1000000 + (t).usec)
+
+static inline void
+TclTimeSetMilliseconds(
+ register Tcl_Time *timePtr,
+ register double ms
+) {
+ timePtr->sec = (long)(ms / 1000);
+ timePtr->usec = (((long)ms) % 1000) * 1000 + (((long)(ms*1000)) % 1000);
+}
+
+static inline void
+TclTimeAddMilliseconds(
+ register Tcl_Time *timePtr,
+ register double ms
+) {
+ timePtr->sec += (long)(ms / 1000);
+ timePtr->usec += (((long)ms) % 1000) * 1000 + (((long)(ms*1000)) % 1000);
+ if (timePtr->usec > 1000000) {
+ timePtr->usec -= 1000000;
+ timePtr->sec++;
+ }
+}
+
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
@@ -3216,9 +3381,53 @@ MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE void TclSetTimerEventMarker(int flags);
+MODULE_SCOPE int TclServiceTimerEvents(void);
+MODULE_SCOPE int TclServiceIdleEx(int flags, int count);
+MODULE_SCOPE void TclpCancelEvent(Tcl_Event *evPtr);
+static inline Tcl_Event*
+TclpQueueEventEx(
+ Tcl_EventProc *proc, /* Event function to call if it servicing. */
+ ClientData extraData, /* Event extra data to be included and its */
+ size_t extraDataSize, /* extra size (to allocate and copy into). */
+ Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
+ * TCL_QUEUE_MARK or TCL_QUEUE_RETARDED. */
+{
+ Tcl_Event *evPtr = ckalloc(sizeof(Tcl_Event) + extraDataSize);
+ evPtr->proc = proc;
+ memcpy((evPtr+1), extraData, extraDataSize);
+ Tcl_QueueEvent(evPtr, position);
+ return evPtr;
+}
+static inline Tcl_Event*
+TclpQueueEventClientData(
+ Tcl_EventProc *proc, /* Event function to call if it servicing. */
+ ClientData clientData, /* Event extra data to be included. */
+ Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
+ * TCL_QUEUE_MARK or TCL_QUEUE_RETARDED. */
+{
+ Tcl_Event *evPtr = ckalloc(sizeof(Tcl_Event) + sizeof(clientData));
+ evPtr->proc = proc;
+ *(ClientData*)(evPtr+1) = clientData;
+ Tcl_QueueEvent(evPtr, position);
+ return evPtr;
+}
+MODULE_SCOPE TclTimerEvent* TclpCreateTimerEvent(Tcl_WideInt usec,
+ Tcl_TimerProc *proc, Tcl_TimerDeleteProc *delProc,
+ size_t extraDataSize, int flags);
+MODULE_SCOPE TclTimerEvent* TclpCreatePromptTimerEvent(
+ Tcl_TimerProc *proc, Tcl_TimerDeleteProc *delProc,
+ size_t extraDataSize, int flags);
+MODULE_SCOPE Tcl_TimerToken TclCreateTimerHandler(
+ Tcl_Time *timePtr, Tcl_TimerProc *proc,
+ ClientData clientData, int flags);
MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler(
Tcl_Time *timePtr, Tcl_TimerProc *proc,
ClientData clientData);
+MODULE_SCOPE void TclpDeleteTimerEvent(TclTimerEvent *tmrEvent);
+MODULE_SCOPE TclTimerEvent* TclpProlongTimerEvent(TclTimerEvent *tmrEvent,
+ Tcl_WideInt usec, int flags);
+MODULE_SCOPE int TclPeekEventQueued(int flags);
MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -3424,6 +3633,9 @@ MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -4696,6 +4908,17 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
#define TclLimitExceeded(limit) ((limit).exceeded != 0)
+static inline int
+TclInlLimitExceeded(
+ register Tcl_Interp *interp)
+{
+ return (((Interp *)interp)->limit.exceeded != 0);
+}
+#ifdef Tcl_LimitExceeded
+# undef Tcl_LimitExceeded
+#endif
+#define Tcl_LimitExceeded(interp) TclInlLimitExceeded(interp)
+
#define TclLimitReady(limit) \
(((limit).active == 0) ? 0 : \
(++(limit).granularityTicker, \
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 8a0d653..6138d31 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -3276,6 +3276,8 @@ Tcl_MakeSafe(
*----------------------------------------------------------------------
*/
+#undef Tcl_LimitExceeded
+
int
Tcl_LimitExceeded(
Tcl_Interp *interp)
@@ -3747,7 +3749,7 @@ TclLimitRemoveAllHandlers(
*/
if (iPtr->limit.timeEvent != NULL) {
- Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
+ TclpDeleteTimerEvent(iPtr->limit.timeEvent);
iPtr->limit.timeEvent = NULL;
}
}
@@ -3917,15 +3919,26 @@ Tcl_LimitGetCommands(
return iPtr->limit.cmdCount;
}
+
+static void
+TimeLimitDeleteCallback(
+ ClientData clientData)
+{
+ Interp *iPtr = clientData;
+ iPtr->limit.timeEvent = NULL;
+}
/*
*----------------------------------------------------------------------
*
- * Tcl_LimitSetTime --
+ * Tcl_LimitSetTime --, TclpLimitSetTimeOffs --
*
* Set the time limit for an interpreter by copying it from the value
* pointed to by the timeLimitPtr argument.
*
+ * TclpLimitSetTimeOffs opposite to Tcl_LimitSetTime set the limit as
+ * relative time.
+ *
* Results:
* None.
*
@@ -3943,22 +3956,52 @@ Tcl_LimitSetTime(
Tcl_Time *timeLimitPtr)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Time nextMoment;
+ Tcl_WideInt nextMoment;
memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time));
+ nextMoment = TCL_TIME_TO_USEC(*timeLimitPtr) + 10;
if (iPtr->limit.timeEvent != NULL) {
- Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
+ iPtr->limit.timeEvent = TclpProlongTimerEvent(iPtr->limit.timeEvent,
+ nextMoment, TCL_TMREV_AT);
+ if (iPtr->limit.timeEvent) {
+ return;
+ }
}
- nextMoment.sec = timeLimitPtr->sec;
- nextMoment.usec = timeLimitPtr->usec+10;
- if (nextMoment.usec >= 1000000) {
- nextMoment.sec++;
- nextMoment.usec -= 1000000;
+ iPtr->limit.timeEvent = TclpCreateTimerEvent(nextMoment,
+ TimeLimitCallback, TimeLimitDeleteCallback, 0, TCL_TMREV_AT);
+ iPtr->limit.timeEvent->clientData = interp;
+ iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
+}
+#if 0
+void
+TclpLimitSetTimeOffs(
+ Tcl_Interp *interp,
+ Tcl_WideInt timeOffs)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ Tcl_GetTime(&iPtr->limit.time);
+ iPtr->limit.time.sec += timeOffs / 1000000;
+ iPtr->limit.time.usec += timeOffs % 1000000;
+ if (iPtr->limit.time.usec > 1000000) {
+ iPtr->limit.time.usec -= 1000000;
+ iPtr->limit.time.sec++;
+ }
+ timeOffs += 10;
+ /* we should use relative time (because of the timeout meaning) */
+ if (iPtr->limit.timeEvent != NULL) {
+ iPtr->limit.timeEvent = TclpProlongTimerEvent(iPtr->limit.timeEvent,
+ timeOffs, 0);
+ if (iPtr->limit.timeEvent) {
+ return;
+ }
}
- iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment,
- TimeLimitCallback, interp);
+ iPtr->limit.timeEvent = TclpCreateTimerEvent(timeOffs,
+ TimeLimitCallback, TimeLimitDeleteCallback, 0, 0);
+ iPtr->limit.timeEvent->clientData = interp;
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
}
+#endif
/*
*----------------------------------------------------------------------
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index e76bca8..9d7c225 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -39,6 +39,15 @@ typedef struct EventSource {
} EventSource;
/*
+ * Used for performance purposes, threshold to bypass check source (if don't wait)
+ * Value should be approximately correspond 100-ns ranges, if the wide-clicks
+ * supported, it is more precise so e. g. 5 is ca. 0.5 microseconds (500-ns).
+ */
+#ifndef TCL_CHECK_EVENT_SOURCE_THRESHOLD
+ #define TCL_CHECK_EVENT_SOURCE_THRESHOLD 5
+#endif
+
+/*
* The following structure keeps track of the state of the notifier on a
* per-thread basis. The first three elements keep track of the event queue.
* In addition to the first (next to be serviced) and last events in the
@@ -56,10 +65,18 @@ typedef struct ThreadSpecificData {
Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */
Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or NULL
* if none. */
+ Tcl_Event *timerMarkerPtr; /* Weak pointer to last event in the queue,
+ * before timer event generation */
+ Tcl_Event *firstRetardEv; /* First retarded event, or NULL if none. */
+ Tcl_Event *lastRetardEv; /* Last retarded event, or NULL if none. */
Tcl_Mutex queueMutex; /* Mutex to protect access to the previous
* three fields. */
+ size_t queueEpoch; /* Epoch of the queue (incremented if changed
+ * using TCL_QUEUE_HEAD or TCL_QUEUE_MARK). */
int serviceMode; /* One of TCL_SERVICE_NONE or
* TCL_SERVICE_ALL. */
+ size_t serviceLevel; /* Current (nested) level of event cycle. */
+ size_t blockTimeServLev; /* Level of the event cycle block time was set. */
int blockTimeSet; /* 0 means there is no maximum block time:
* block forever. */
Tcl_Time blockTime; /* If blockTimeSet is 1, gives the maximum
@@ -77,6 +94,15 @@ typedef struct ThreadSpecificData {
/* Next notifier in global list of notifiers.
* Access is controlled by the listLock global
* mutex. */
+#if TCL_CHECK_EVENT_SOURCE_THRESHOLD
+ /* Last "time" source checked, used as threshold
+ * to avoid checking for events too often */
+ #ifndef TCL_WIDE_CLICKS
+ unsigned long lastCheckClicks;
+ #else
+ Tcl_WideInt lastCheckClicks;
+ #endif
+#endif
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -96,7 +122,8 @@ TCL_DECLARE_MUTEX(listLock)
static void QueueEvent(ThreadSpecificData *tsdPtr,
Tcl_Event *evPtr, Tcl_QueuePosition position);
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -126,7 +153,7 @@ TclInitNotifier(void)
/* Empty loop body. */
}
- if (NULL == tsdPtr) {
+ if (NULL == tsdPtr || !tsdPtr->initialized) {
/*
* Notifier not yet initialized in this thread.
*/
@@ -140,7 +167,8 @@ TclInitNotifier(void)
}
Tcl_MutexUnlock(&listLock);
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -183,8 +211,17 @@ TclFinalizeNotifier(void)
evPtr = evPtr->nextPtr;
ckfree(hold);
}
+ for (evPtr = tsdPtr->firstRetardEv; evPtr != NULL; ) {
+ hold = evPtr;
+ evPtr = evPtr->nextPtr;
+ ckfree(hold);
+ }
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
+ tsdPtr->markerEventPtr = NULL;
+ tsdPtr->timerMarkerPtr = NULL;
+ tsdPtr->firstRetardEv = NULL;
+ tsdPtr->lastRetardEv = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
@@ -202,7 +239,8 @@ TclFinalizeNotifier(void)
Tcl_MutexUnlock(&listLock);
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -228,7 +266,8 @@ Tcl_SetNotifier(
{
tclNotifierHooks = *notifierProcPtr;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -284,7 +323,8 @@ Tcl_CreateEventSource(
sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
tsdPtr->firstEventSourcePtr = sourcePtr;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -334,7 +374,8 @@ Tcl_DeleteEventSource(
return;
}
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -359,13 +400,14 @@ Tcl_QueueEvent(
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ * TCL_QUEUE_MARK or TCL_QUEUE_RETARDED. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
QueueEvent(tsdPtr, evPtr, position);
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -391,7 +433,7 @@ Tcl_ThreadQueueEvent(
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ * TCL_QUEUE_MARK or TCL_QUEUE_RETARDED. */
{
ThreadSpecificData *tsdPtr;
@@ -416,7 +458,43 @@ Tcl_ThreadQueueEvent(
}
Tcl_MutexUnlock(&listLock);
}
-
+
+
+static inline void
+SpliceEventTail(
+ Tcl_Event *evPtr,
+ Tcl_Event **firstEvPtr,
+ Tcl_Event **lastEvPtr)
+{
+ evPtr->nextPtr = NULL;
+ if (*firstEvPtr == NULL) {
+ *firstEvPtr = evPtr;
+ } else {
+ (*lastEvPtr)->nextPtr = evPtr;
+ }
+ *lastEvPtr = evPtr;
+}
+
+
+static inline void
+LinkEvent(
+ ThreadSpecificData *tsdPtr,
+ Tcl_Event *evPtr,
+ Tcl_Event *prevPtr)
+{
+ if (prevPtr) {
+ evPtr->nextPtr = prevPtr->nextPtr;
+ prevPtr->nextPtr = evPtr;
+ } else {
+ evPtr->nextPtr = tsdPtr->firstEventPtr;
+ tsdPtr->firstEventPtr = evPtr;
+ }
+ if (evPtr->nextPtr == NULL) {
+ tsdPtr->lastEventPtr = evPtr;
+ }
+}
+
+
/*
*----------------------------------------------------------------------
*
@@ -448,22 +526,19 @@ QueueEvent(
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ * TCL_QUEUE_MARK or TCL_QUEUE_RETARDED. */
{
Tcl_MutexLock(&(tsdPtr->queueMutex));
- if (position == TCL_QUEUE_TAIL) {
+ switch (position) {
+ case TCL_QUEUE_TAIL:
/*
* Append the event on the end of the queue.
*/
- evPtr->nextPtr = NULL;
- if (tsdPtr->firstEventPtr == NULL) {
- tsdPtr->firstEventPtr = evPtr;
- } else {
- tsdPtr->lastEventPtr->nextPtr = evPtr;
- }
- tsdPtr->lastEventPtr = evPtr;
- } else if (position == TCL_QUEUE_HEAD) {
+ SpliceEventTail(evPtr, &tsdPtr->firstEventPtr, &tsdPtr->lastEventPtr);
+
+ break;
+ case TCL_QUEUE_HEAD:
/*
* Push the event on the head of the queue.
*/
@@ -473,27 +548,143 @@ QueueEvent(
tsdPtr->lastEventPtr = evPtr;
}
tsdPtr->firstEventPtr = evPtr;
- } else if (position == TCL_QUEUE_MARK) {
+
+ /* move timer event hereafter */
+ if (tsdPtr->timerMarkerPtr == INT2PTR(-1)) {
+ tsdPtr->timerMarkerPtr = evPtr;
+ }
+
+ tsdPtr->queueEpoch++; /* queue may be changed in the middle */
+
+ break;
+ case TCL_QUEUE_MARK:
/*
* Insert the event after the current marker event and advance the
* marker to the new event.
*/
- if (tsdPtr->markerEventPtr == NULL) {
- evPtr->nextPtr = tsdPtr->firstEventPtr;
- tsdPtr->firstEventPtr = evPtr;
- } else {
- evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr;
- tsdPtr->markerEventPtr->nextPtr = evPtr;
- }
+ LinkEvent(tsdPtr, evPtr, tsdPtr->markerEventPtr);
tsdPtr->markerEventPtr = evPtr;
- if (evPtr->nextPtr == NULL) {
- tsdPtr->lastEventPtr = evPtr;
+
+ /* move timer event hereafter */
+ if (tsdPtr->timerMarkerPtr == INT2PTR(-1)) {
+ tsdPtr->timerMarkerPtr = evPtr;
}
+
+ tsdPtr->queueEpoch++; /* queue may be changed in the middle */
+ break;
+ case TCL_QUEUE_RETARDED:
+ /*
+ * Append the event on the end of the retarded list.
+ * This guarantees the service earliest at the next event-cycle.
+ */
+
+ SpliceEventTail(evPtr, &tsdPtr->firstRetardEv, &tsdPtr->lastRetardEv);
+ break;
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}
-
+
+
+static Tcl_Event *
+SearchEventInQueue(
+ Tcl_Event *firstEvPtr,
+ Tcl_Event *evPtr,
+ Tcl_Event **prevEvPtr)
+{
+ Tcl_Event *prevPtr = NULL;
+
+ /*
+ * Search event in the queue (if not first one).
+ */
+
+ if (evPtr != firstEvPtr) {
+
+ for (prevPtr = firstEvPtr;
+ prevPtr && prevPtr->nextPtr != evPtr;
+ prevPtr = prevPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (!prevPtr) {
+ /* not in queue */
+ evPtr = NULL;
+ }
+ }
+ if (prevEvPtr) {
+ *prevEvPtr = prevPtr;
+ }
+ return evPtr;
+}
+
+
+static void
+UnlinkEvent(
+ ThreadSpecificData *tsdPtr,
+ Tcl_Event *evPtr,
+ Tcl_Event *prevPtr)
+{
+ /*
+ * Unlink it.
+ */
+
+ if (prevPtr == NULL) {
+ tsdPtr->firstEventPtr = evPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = evPtr->nextPtr;
+ }
+ if (evPtr->nextPtr == NULL) {
+ tsdPtr->lastEventPtr = prevPtr;
+ }
+
+ /* queue may be changed in the middle */
+ tsdPtr->queueEpoch++;
+
+ /*
+ * Update 'marker' events if either has been deleted.
+ */
+
+ if (tsdPtr->markerEventPtr == evPtr) {
+ tsdPtr->markerEventPtr = prevPtr;
+ }
+ if (tsdPtr->timerMarkerPtr == evPtr) {
+ tsdPtr->timerMarkerPtr = prevPtr ? prevPtr : INT2PTR(-1);
+ }
+}
+
+
+static void
+InvolveRetardedEvents(
+ ThreadSpecificData *tsdPtr)
+{
+ /* move retarded events at end of the queue */
+ if (tsdPtr->firstEventPtr == NULL) {
+ tsdPtr->firstEventPtr = tsdPtr->firstRetardEv;
+ } else {
+ tsdPtr->lastEventPtr->nextPtr = tsdPtr->firstRetardEv;
+ }
+ tsdPtr->lastEventPtr = tsdPtr->lastRetardEv;
+ /* reset retarded list */
+ tsdPtr->lastRetardEv = tsdPtr->firstRetardEv = NULL;
+}
+
+
+static void
+UnlinkRetardedEvent(
+ ThreadSpecificData *tsdPtr,
+ Tcl_Event *evPtr,
+ Tcl_Event *prevPtr)
+{
+ if (prevPtr == NULL) {
+ tsdPtr->firstRetardEv = evPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = evPtr->nextPtr;
+ }
+ if (evPtr->nextPtr == NULL) {
+ tsdPtr->lastRetardEv = prevPtr;
+ }
+}
+
+
/*
*----------------------------------------------------------------------
*
@@ -522,7 +713,6 @@ Tcl_DeleteEvents(
Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if
* evPtr designates the first event in the
* queue for the thread. */
- Tcl_Event *hold;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&(tsdPtr->queueMutex));
@@ -531,51 +721,71 @@ Tcl_DeleteEvents(
* Walk the queue of events for the thread, applying 'proc' to each to
* decide whether to eliminate the event.
*/
-
prevPtr = NULL;
evPtr = tsdPtr->firstEventPtr;
while (evPtr != NULL) {
+ Tcl_Event *nextPtr = evPtr->nextPtr;
if (proc(evPtr, clientData) == 1) {
- /*
- * This event should be deleted. Unlink it.
- */
+ /* This event should be deleted. Unlink and delete it. */
+ UnlinkEvent(tsdPtr, evPtr, prevPtr);
+ ckfree(evPtr);
+ } else {
+ /* Event is to be retained. */
+ prevPtr = evPtr;
+ }
+ evPtr = nextPtr;
+ }
+
+ /*
+ * Do the same for the retarded list.
+ */
+ prevPtr = NULL;
+ evPtr = tsdPtr->firstRetardEv;
+ while (evPtr != NULL) {
+ Tcl_Event *nextPtr = evPtr->nextPtr;
+ if (proc(evPtr, clientData) == 1) {
+ /* This event should be deleted. Unlink and delete it. */
+ UnlinkRetardedEvent(tsdPtr, evPtr, prevPtr);
+ ckfree(evPtr);
+ } else {
+ /* Event is to be retained. */
+ prevPtr = evPtr;
+ }
+ evPtr = nextPtr;
+ }
- if (prevPtr == NULL) {
- tsdPtr->firstEventPtr = evPtr->nextPtr;
- } else {
- prevPtr->nextPtr = evPtr->nextPtr;
- }
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
+}
- /*
- * Update 'last' and 'marker' events if either has been deleted.
- */
- if (evPtr->nextPtr == NULL) {
- tsdPtr->lastEventPtr = prevPtr;
- }
- if (tsdPtr->markerEventPtr == evPtr) {
- tsdPtr->markerEventPtr = prevPtr;
- }
+void
+TclpCancelEvent(
+ Tcl_Event *evPtr) /* Event to remove from queue. */
+{
+ Tcl_Event *prevPtr = NULL;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- /*
- * Delete the event data structure.
- */
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
- hold = evPtr;
- evPtr = evPtr->nextPtr;
- ckfree(hold);
- } else {
- /*
- * Event is to be retained.
- */
+ /*
+ * Search event to unlink from queue and delete it.
+ * Note the event can be in retarded list.
+ */
- prevPtr = evPtr;
- evPtr = evPtr->nextPtr;
- }
+ if (SearchEventInQueue(tsdPtr->firstEventPtr, evPtr, &prevPtr)) {
+ UnlinkEvent(tsdPtr, evPtr, prevPtr);
+ ckfree(evPtr);
+ }
+ else
+ if (!SearchEventInQueue(tsdPtr->firstRetardEv, evPtr, &prevPtr)) {
+ UnlinkRetardedEvent(tsdPtr, evPtr, prevPtr);
+ ckfree(evPtr);
}
+
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -608,35 +818,67 @@ Tcl_ServiceEvent(
Tcl_Event *evPtr, *prevPtr;
Tcl_EventProc *proc;
int result;
+ size_t queueEpoch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
+ * No event flags is equivalent to TCL_ALL_EVENTS.
+ */
+
+ if ((flags & TCL_ALL_EVENTS) == 0) {
+ flags |= TCL_ALL_EVENTS;
+ }
+
+ /*
* Asynchronous event handlers are considered to be the highest priority
* events, and so must be invoked before we process events on the event
* queue.
*/
- if (Tcl_AsyncReady()) {
- (void) Tcl_AsyncInvoke(NULL, 0);
- return 1;
+ if ((flags & TCL_ASYNC_EVENTS)) {
+ if (Tcl_AsyncReady()) {
+ (void) Tcl_AsyncInvoke(NULL, 0);
+ return 1;
+ }
+ /* Async only */
+ if ((flags & TCL_ALL_EVENTS) == TCL_ASYNC_EVENTS) {
+ return 0;
+ }
+ }
+
+ /* Fast bypass case */
+ if ( !tsdPtr->firstEventPtr /* no other events */
+ || ((flags & TCL_ALL_EVENTS) == TCL_TIMER_EVENTS) /* timers only */
+ ) {
+ goto timer;
}
/*
- * No event flags is equivalent to TCL_ALL_EVENTS.
+ * If timer marker reached, process timer events now.
*/
-
- if ((flags & TCL_ALL_EVENTS) == 0) {
- flags |= TCL_ALL_EVENTS;
+ if ((flags & TCL_TIMER_EVENTS) && (tsdPtr->timerMarkerPtr == INT2PTR(-1))) {
+ goto processTimer;
}
+ /* Lock queue to process events */
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
+
/*
* Loop through all the events in the queue until we find one that can
* actually be handled.
*/
- Tcl_MutexLock(&(tsdPtr->queueMutex));
- for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL;
- evPtr = evPtr->nextPtr) {
+ for (prevPtr = NULL, evPtr = tsdPtr->firstEventPtr;
+ evPtr != NULL && tsdPtr->timerMarkerPtr != INT2PTR(-1);
+ prevPtr = evPtr, evPtr = evPtr->nextPtr
+ ) {
+
+ repeatCycle:
+
+ if (tsdPtr->timerMarkerPtr == evPtr) {
+ tsdPtr->timerMarkerPtr = INT2PTR(-1); /* timer marker reached */
+ }
+
/*
* Call the handler for the event. If it actually handles the event
* then free the storage for the event. There are two tricky things
@@ -659,6 +901,9 @@ Tcl_ServiceEvent(
}
evPtr->proc = NULL;
+ /* Save current queue epoch (if unchanged - the same prevPtr) */
+ queueEpoch = tsdPtr->queueEpoch;
+
/*
* Release the lock before calling the event function. This allows
* other threads to post events if we enter a recursive event loop in
@@ -670,55 +915,337 @@ Tcl_ServiceEvent(
result = proc(evPtr, flags);
Tcl_MutexLock(&(tsdPtr->queueMutex));
- if (result) {
+ /* If event processed or scheduled to be executed later (retarding) */
+ if (result || evPtr->proc) {
+
/*
- * The event was processed, so remove it from the queue.
+ * Check the queue was changed.
*/
- if (tsdPtr->firstEventPtr == evPtr) {
- tsdPtr->firstEventPtr = evPtr->nextPtr;
- if (evPtr->nextPtr == NULL) {
- tsdPtr->lastEventPtr = NULL;
- }
- if (tsdPtr->markerEventPtr == evPtr) {
- tsdPtr->markerEventPtr = NULL;
- }
- } else {
- for (prevPtr = tsdPtr->firstEventPtr;
- prevPtr && prevPtr->nextPtr != evPtr;
- prevPtr = prevPtr->nextPtr) {
- /* Empty loop body. */
- }
- if (prevPtr) {
- prevPtr->nextPtr = evPtr->nextPtr;
- if (evPtr->nextPtr == NULL) {
- tsdPtr->lastEventPtr = prevPtr;
- }
- if (tsdPtr->markerEventPtr == evPtr) {
- tsdPtr->markerEventPtr = prevPtr;
- }
+ if (queueEpoch != tsdPtr->queueEpoch) {
+ /* queue may be changed in the middle */
+ queueEpoch = tsdPtr->queueEpoch;
+ /* try to find event */
+ evPtr = SearchEventInQueue(tsdPtr->firstEventPtr,
+ evPtr, &prevPtr);
+ }
+
+ /*
+ * If the handler set another function to process it later,
+ * do retarding of the event.
+ */
+ if (evPtr && evPtr->proc) {
+ /*
+ * Reattach the event on the end of the retarded list.
+ */
+ UnlinkEvent(tsdPtr, evPtr, prevPtr);
+ SpliceEventTail(evPtr,
+ &tsdPtr->firstRetardEv, &tsdPtr->lastRetardEv);
+
+ /* next event to service */
+ if (prevPtr == NULL) {
+ /* we stood on begin of list - just repeat from new begin */
+ evPtr = tsdPtr->firstEventPtr;
} else {
- evPtr = NULL;
+ /* continue from next of previous event */
+ evPtr = prevPtr->nextPtr;
}
+ goto repeatCycle;
}
+
+ /*
+ * The event was processed, so remove it.
+ */
if (evPtr) {
+ /* Detach event from queue */
+ UnlinkEvent(tsdPtr, evPtr, prevPtr);
+
+ /* Free event */
ckfree(evPtr);
}
+
+ /* event processed - return with 1 */
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
+
} else {
/*
* The event wasn't actually handled, so we have to restore the
* proc field to allow the event to be attempted again.
*/
-
evPtr->proc = proc;
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
+
+ timer:
+ /*
+ * Process timer queue, if alloved and timers are enabled.
+ */
+
+ if (flags & TCL_TIMER_EVENTS) {
+
+ /* If available pending timer-events of new generation */
+ if (tsdPtr->timerMarkerPtr == INT2PTR(-2)) { /* pending */
+ /* no other events - process timer-events (next cycle) */
+ if (!(tsdPtr->timerMarkerPtr = tsdPtr->lastEventPtr)) { /* no other events */
+ tsdPtr->timerMarkerPtr = INT2PTR(-1);
+ }
+ return 0;
+ }
+
+ if (tsdPtr->timerMarkerPtr == INT2PTR(-1)) {
+
+ processTimer:
+ /* reset marker */
+ tsdPtr->timerMarkerPtr = NULL;
+
+ result = TclServiceTimerEvents();
+ if (result < 0) {
+ /*
+ * Events processed, but still pending timers (of new generation)
+ * set marker to process timer, if setup- resp. check-proc will
+ * not generate new events.
+ */
+ if (tsdPtr->timerMarkerPtr == NULL) {
+ /* marker to last event in the queue */
+ if (!(tsdPtr->timerMarkerPtr = tsdPtr->lastEventPtr)) {
+ /*
+ * Marker as "pending" - queue is empty, so timers events are first,
+ * if setup-proc resp. check-proc will not generate new events.
+ */
+ tsdPtr->timerMarkerPtr = INT2PTR(-2);
+ };
+ }
+ result = 1;
+ }
+ return result;
+ }
+ }
+
return 0;
}
-
+
+
+#if TCL_CHECK_EVENT_SOURCE_THRESHOLD
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckSourceThreshold --
+ *
+ * Check whether we should iterate over event sources for availability.
+ *
+ * This is used to avoid too unneeded overhead (too often call checkProc).
+ *
+ * Results:
+ * Returns 1 if threshold reached (check event sources), 0 otherwise.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+CheckSourceThreshold(
+ ThreadSpecificData *tsdPtr)
+{
+ /* don't need to wait/check for events too often */
+#ifndef TCL_WIDE_CLICKS
+ unsigned long clickdiff, clicks = TclpGetClicks();
+#else
+ Tcl_WideInt clickdiff, clicks;
+ /* in 100-ns */
+ clicks = TclpGetWideClicks() * (TclpWideClickInMicrosec() * 10);
+#endif
+ /* considering possible clicks-jump */
+ if ( (clickdiff = (clicks - tsdPtr->lastCheckClicks)) >= 0
+ && clickdiff <= TCL_CHECK_EVENT_SOURCE_THRESHOLD) {
+ return 0;
+ }
+ tsdPtr->lastCheckClicks = clicks;
+ return 1;
+}
+#endif
+
+
+static int
+SetUpEventSources(
+ ThreadSpecificData *tsdPtr,
+ int flags)
+{
+ int res = 0;
+ EventSource *sourcePtr;
+
+ /*
+ * Set up all the event sources for new events. This will cause the
+ * block time to be updated if necessary.
+ */
+ tsdPtr->inTraversal++;
+ for (sourcePtr = tsdPtr->firstEventSourcePtr;
+ sourcePtr != NULL;
+ sourcePtr = sourcePtr->nextPtr
+ ) {
+ if (sourcePtr->checkProc) {
+ sourcePtr->setupProc(sourcePtr->clientData, flags);
+ res++;
+ }
+ }
+ tsdPtr->inTraversal--;
+
+ /*
+ * If we've some retarded events (from last event-cycle), wait non-blocking.
+ */
+ if ( tsdPtr->firstRetardEv
+ && ( !tsdPtr->blockTimeSet
+ || tsdPtr->blockTimeServLev < tsdPtr->serviceLevel )
+ ) {
+ tsdPtr->blockTime.sec = 0;
+ tsdPtr->blockTime.usec = 0;
+ tsdPtr->blockTimeSet = 1;
+ }
+
+ return res;
+}
+
+
+static int
+CheckEventSources(
+ ThreadSpecificData *tsdPtr,
+ int flags)
+{
+ int res = 0;
+ EventSource *sourcePtr;
+
+ /*
+ * Check all the event sources for new events.
+ */
+ for (sourcePtr = tsdPtr->firstEventSourcePtr;
+ sourcePtr != NULL;
+ sourcePtr = sourcePtr->nextPtr
+ ) {
+ if (sourcePtr->checkProc) {
+ sourcePtr->checkProc(sourcePtr->clientData, flags);
+ res++;
+ }
+ }
+
+ /*
+ * If we've some retarded events (from last event-cycle), attach they here
+ * to the tail of the event queue (new event-cycle).
+ */
+ if (tsdPtr->firstRetardEv) {
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
+ if (tsdPtr->firstRetardEv) {
+ InvolveRetardedEvents(tsdPtr);
+ res++;
+ }
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
+ }
+
+ return res;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPeekEventQueued --
+ *
+ * Check whether some event (except idle) available (async, queued, timer).
+ *
+ * This will be used e. g. in TclServiceIdle to stop the processing of the
+ * the idle events if some "normal" event occurred.
+ *
+ * Results:
+ * Returns 1 if some event queued, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPeekEventQueued(
+ int flags)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int repeat = 1;
+
+ do {
+ /*
+ * Events already pending ?
+ */
+ if ( Tcl_AsyncReady()
+ || (tsdPtr->firstEventPtr)
+ || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerMarkerPtr)
+ ) {
+ return 1;
+ }
+
+ /* once from here */
+ if (!repeat) {
+ break;
+ }
+
+ if (flags & TCL_DONT_WAIT) {
+ /* don't need to wait/check for events too often */
+ #if TCL_CHECK_EVENT_SOURCE_THRESHOLD
+ if (!CheckSourceThreshold(tsdPtr)) {
+ return 0;
+ }
+ #endif
+ }
+
+ /*
+ * Check all the event sources for new events.
+ */
+ if (!CheckEventSources(tsdPtr, flags)) {
+ return 0; /* no sources - no events could be created at all */
+ }
+
+ } while (repeat--);
+
+ return 0;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetTimerEventMarker --
+ *
+ * Set timer event marker to the last pending event in the queue.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetTimerEventMarker(
+ int flags)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->timerMarkerPtr == NULL || tsdPtr->timerMarkerPtr == INT2PTR(-2)) {
+ /* marker to last event in the queue */
+ if ( !(tsdPtr->timerMarkerPtr = tsdPtr->lastEventPtr) /* no other events */
+ || ((flags & TCL_ALL_EVENTS) == TCL_TIMER_EVENTS) /* timers only */
+ ) {
+ /*
+ * Marker as "pending" - queue is empty, so timers events are first,
+ * if setup-proc resp. check-proc will not generate new events.
+ * Force timer execution if flags specified (from checkProc).
+ */
+ tsdPtr->timerMarkerPtr = flags ? INT2PTR(-1) : INT2PTR(-2);
+ };
+ }
+}
+
+
/*
*----------------------------------------------------------------------
*
@@ -742,7 +1269,8 @@ Tcl_GetServiceMode(void)
return tsdPtr->serviceMode;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -772,7 +1300,8 @@ Tcl_SetServiceMode(
Tcl_ServiceModeHook(mode);
return oldMode;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -813,10 +1342,15 @@ Tcl_SetMaxBlockTime(
*/
if (!tsdPtr->inTraversal) {
+ if (tsdPtr->blockTimeServLev < tsdPtr->serviceLevel) {
+ /* avoid resetting the blockTime set outside of traversal. */
+ tsdPtr->blockTimeServLev = tsdPtr->serviceLevel;
+ }
Tcl_SetTimer(&tsdPtr->blockTime);
}
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -828,14 +1362,18 @@ Tcl_SetMaxBlockTime(
* Results:
* The return value is 1 if the function actually found an event to
* process. If no processing occurred, then 0 is returned (this can
- * happen if the TCL_DONT_WAIT flag is set or if there are no event
- * handlers to wait for in the set specified by flags).
+ * happen if the TCL_DONT_WAIT flag is set or block time was set using
+ * Tcl_SetMaxBlockTime before or if there are no event handlers to wait
+ * for in the set specified by flags).
*
* Side effects:
* May delay execution of process while waiting for an event, unless
* TCL_DONT_WAIT is set in the flags argument. Event sources are invoked
* to check for and queue events. Event handlers may produce arbitrary
* side effects.
+ * If block time was set (Tcl_SetMaxBlockTime) but another event occurs
+ * and interrupt wait, the function can return early, thereby it resets
+ * the block time (caller should use Tcl_SetMaxBlockTime again).
*
*----------------------------------------------------------------------
*/
@@ -849,18 +1387,9 @@ Tcl_DoOneEvent(
* others defined by event sources. */
{
int result = 0, oldMode;
- EventSource *sourcePtr;
Tcl_Time *timePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- /*
- * The first thing we do is to service any asynchronous event handlers.
- */
-
- if (Tcl_AsyncReady()) {
- (void) Tcl_AsyncInvoke(NULL, 0);
- return 1;
- }
+ int blockTimeWasSet;
/*
* No event flags is equivalent to TCL_ALL_EVENTS.
@@ -870,6 +1399,9 @@ Tcl_DoOneEvent(
flags |= TCL_ALL_EVENTS;
}
+ /* Block time was set outside an event source traversal, caller has specified a waittime */
+ blockTimeWasSet = tsdPtr->blockTimeSet;
+
/*
* Set the service mode to none so notifier event routines won't try to
* service events recursively.
@@ -877,14 +1409,33 @@ Tcl_DoOneEvent(
oldMode = tsdPtr->serviceMode;
tsdPtr->serviceMode = TCL_SERVICE_NONE;
+ tsdPtr->serviceLevel++;
/*
- * The core of this function is an infinite loop, even though we only
- * service one event. The reason for this is that we may be processing
- * events that don't do anything inside of Tcl.
+ * Asynchronous event handlers are considered to be the highest priority
+ * events, and so must be invoked before we process events on the event
+ * queue.
*/
- while (1) {
+ if (flags & TCL_ASYNC_EVENTS) {
+ if (Tcl_AsyncReady()) {
+ (void) Tcl_AsyncInvoke(NULL, 0);
+ result = 1;
+ goto done;
+ }
+
+ /* Async only and don't wait - return */
+ if ( (flags & (TCL_ALL_EVENTS|TCL_DONT_WAIT))
+ == (TCL_ASYNC_EVENTS|TCL_DONT_WAIT) ) {
+ goto done;
+ }
+ }
+
+ /*
+ * Main loop until servicing exact one event or block time resp.
+ * TCL_DONT_WAIT specified (infinite loop otherwise).
+ */
+ do {
/*
* If idle events are the only things to service, skip the main part
* of the loop and go directly to handle idle events (i.e. don't wait
@@ -892,12 +1443,12 @@ Tcl_DoOneEvent(
*/
if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) {
- flags = TCL_IDLE_EVENTS | TCL_DONT_WAIT;
goto idleEvents;
}
/*
- * Ask Tcl to service a queued event, if there are any.
+ * Ask Tcl to service any asynchronous event handlers or
+ * queued event, if there are any.
*/
if (Tcl_ServiceEvent(flags)) {
@@ -911,28 +1462,27 @@ Tcl_DoOneEvent(
*/
if (flags & TCL_DONT_WAIT) {
+
+ /* don't need to wait/check for events too often */
+ #if TCL_CHECK_EVENT_SOURCE_THRESHOLD
+ if (!CheckSourceThreshold(tsdPtr)) {
+ goto idleEvents;
+ }
+ #endif
tsdPtr->blockTime.sec = 0;
tsdPtr->blockTime.usec = 0;
tsdPtr->blockTimeSet = 1;
- } else {
- tsdPtr->blockTimeSet = 0;
+ timePtr = &tsdPtr->blockTime;
+ goto wait; /* for notifier resp. system events */
}
/*
* Set up all the event sources for new events. This will cause the
* block time to be updated if necessary.
*/
+ SetUpEventSources(tsdPtr, flags);
- tsdPtr->inTraversal = 1;
- for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
- sourcePtr = sourcePtr->nextPtr) {
- if (sourcePtr->setupProc) {
- sourcePtr->setupProc(sourcePtr->clientData, flags);
- }
- }
- tsdPtr->inTraversal = 0;
-
- if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
+ if (tsdPtr->blockTimeSet) {
timePtr = &tsdPtr->blockTime;
} else {
timePtr = NULL;
@@ -942,23 +1492,20 @@ Tcl_DoOneEvent(
* Wait for a new event or a timeout. If Tcl_WaitForEvent returns -1,
* we should abort Tcl_DoOneEvent.
*/
-
+ wait:
result = Tcl_WaitForEvent(timePtr);
+ tsdPtr->blockTimeServLev = 0; /* reset block-time level (processed). */
if (result < 0) {
- result = 0;
+ if (blockTimeWasSet) {
+ result = 0;
+ }
break;
}
/*
* Check all the event sources for new events.
*/
-
- for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
- sourcePtr = sourcePtr->nextPtr) {
- if (sourcePtr->checkProc) {
- sourcePtr->checkProc(sourcePtr->clientData, flags);
- }
- }
+ CheckEventSources(tsdPtr, flags);
/*
* Check for events queued by the notifier or event sources.
@@ -977,14 +1524,11 @@ Tcl_DoOneEvent(
idleEvents:
if (flags & TCL_IDLE_EVENTS) {
- if (TclServiceIdle()) {
+ if (TclServiceIdleEx(flags, INT_MAX)) {
result = 1;
break;
}
}
- if (flags & TCL_DONT_WAIT) {
- break;
- }
/*
* If Tcl_WaitForEvent has returned 1, indicating that one system
@@ -994,20 +1538,31 @@ Tcl_DoOneEvent(
* had the side effect of changing the variable (so the vwait can
* return and unwind properly).
*
- * NB: We will process idle events if any first, because otherwise we
- * might never do the idle events if the notifier always gets
- * system events.
+ * We can stop also if works in block to event mode (e. g. block time was
+ * set outside an event source, that means timeout was set so exit loop
+ * also without event/result).
*/
- if (result) {
+ result = 0;
+ if (blockTimeWasSet) {
break;
}
- }
+ } while ( !(flags & TCL_DONT_WAIT) );
+done:
+ /*
+ * Reset block time earliest at the end of event cycle and restore mode.
+ */
+ if (tsdPtr->blockTimeServLev < tsdPtr->serviceLevel) {
+ tsdPtr->blockTimeSet = 0;
+ tsdPtr->blockTimeServLev = 0;
+ }
tsdPtr->serviceMode = oldMode;
+ tsdPtr->serviceLevel--;
return result;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -1032,7 +1587,6 @@ int
Tcl_ServiceAll(void)
{
int result = 0;
- EventSource *sourcePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->serviceMode == TCL_SERVICE_NONE) {
@@ -1060,21 +1614,10 @@ Tcl_ServiceAll(void)
* so we can avoid multiple changes.
*/
- tsdPtr->inTraversal = 1;
tsdPtr->blockTimeSet = 0;
- for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
- sourcePtr = sourcePtr->nextPtr) {
- if (sourcePtr->setupProc) {
- sourcePtr->setupProc(sourcePtr->clientData, TCL_ALL_EVENTS);
- }
- }
- for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
- sourcePtr = sourcePtr->nextPtr) {
- if (sourcePtr->checkProc) {
- sourcePtr->checkProc(sourcePtr->clientData, TCL_ALL_EVENTS);
- }
- }
+ SetUpEventSources(tsdPtr, TCL_ALL_EVENTS);
+ CheckEventSources(tsdPtr, TCL_ALL_EVENTS);
while (Tcl_ServiceEvent(0)) {
result = 1;
@@ -1088,11 +1631,11 @@ Tcl_ServiceAll(void)
} else {
Tcl_SetTimer(&tsdPtr->blockTime);
}
- tsdPtr->inTraversal = 0;
tsdPtr->serviceMode = TCL_SERVICE_ALL;
return result;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -1131,7 +1674,32 @@ Tcl_ThreadAlert(
}
Tcl_MutexUnlock(&listLock);
}
-
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Sleep --
+ *
+ * Delay execution for the specified number of milliseconds.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Time passes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Sleep(
+ int ms) /* Number of milliseconds to sleep. */
+{
+ TclpUSleep((Tcl_WideInt)ms * 1000);
+}
+
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index c10986a..81e79aa 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -13,22 +13,6 @@
#include "tclInt.h"
/*
- * For each timer callback that's pending there is one record of the following
- * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
- * together in a list sorted by time (earliest event first).
- */
-
-typedef struct TimerHandler {
- Tcl_Time time; /* When timer is to fire. */
- Tcl_TimerProc *proc; /* Function to call. */
- ClientData clientData; /* Argument to pass to proc. */
- Tcl_TimerToken token; /* Identifies handler so it can be deleted. */
- struct TimerHandler *nextPtr;
- /* Next event in queue, or NULL for end of
- * queue. */
-} TimerHandler;
-
-/*
* The data structure below is used by the "after" command to remember the
* command to be executed later. All of the pending "after" commands for an
* interpreter are linked together in a list.
@@ -40,15 +24,12 @@ typedef struct AfterInfo {
* interp in which command will be
* executed. */
Tcl_Obj *commandPtr; /* Command to execute. */
- int id; /* Integer identifier for command; used to
- * cancel it. */
- Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
- * means that the command is run as an idle
- * handler rather than as a timer handler.
- * NULL means this is an "after idle" handler
- * rather than a timer handler. */
+ Tcl_Obj *selfPtr; /* Points to the handle object (self) */
+ unsigned int id; /* Integer identifier for command */
struct AfterInfo *nextPtr; /* Next in list of all "after" commands for
* this interpreter. */
+ struct AfterInfo *prevPtr; /* Prev in list of all "after" commands for
+ * this interpreter. */
} AfterInfo;
/*
@@ -63,23 +44,10 @@ typedef struct AfterAssocData {
AfterInfo *firstAfterPtr; /* First in list of all "after" commands still
* pending for this interpreter, or NULL if
* none. */
+ AfterInfo *lastAfterPtr; /* Last in list of all "after" commands. */
} AfterAssocData;
/*
- * There is one of the following structures for each of the handlers declared
- * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are
- * linked together into a list.
- */
-
-typedef struct IdleHandler {
- Tcl_IdleProc *proc; /* Function to call. */
- ClientData clientData; /* Value to pass to proc. */
- int generation; /* Used to distinguish older handlers from
- * recently-created ones. */
- struct IdleHandler *nextPtr;/* Next in list of active handlers. */
-} IdleHandler;
-
-/*
* The timer and idle queues are per-thread because they are associated with
* the notifier, which is also per-thread.
*
@@ -91,54 +59,48 @@ typedef struct IdleHandler {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
- TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
+typedef struct {
+ Tcl_WideInt relTimerBase; /* Time base of the first known relative */
+ /* timer, used to revert all events to the new
+ * base after possible time-jump (adjustment).*/
+ TclTimerEvent *promptList; /* First immediate event in queue. */
+ TclTimerEvent *promptTail; /* Last immediate event in queue. */
+ TclTimerEvent *relTimerList;/* First event in queue of relative timers. */
+ TclTimerEvent *relTimerTail;/* Last event in queue of relative timers. */
+ TclTimerEvent *absTimerList;/* First event in queue of absolute timers. */
+ TclTimerEvent *absTimerTail;/* Last event in queue of absolute timers. */
+ size_t timerListEpoch; /* Used for safe process of event queue (stop
+ * the cycle after modifying of event queue) */
int lastTimerId; /* Timer identifier of most recently created
- * timer. */
+ * timer event. */
int timerPending; /* 1 if a timer event is in the queue. */
- IdleHandler *idleList; /* First in list of all idle handlers. */
- IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */
- int idleGeneration; /* Used to fill in the "generation" fields of
- * IdleHandler structures. Increments each
- * time Tcl_DoOneEvent starts calling idle
- * handlers, so that all old handlers can be
+ TclTimerEvent *idleList; /* First in list of all idle handlers. */
+ TclTimerEvent *idleTail; /* Last in list (or NULL for empty list). */
+ size_t timerGeneration; /* Used to fill in the "generation" fields of */
+ size_t idleGeneration; /* timer or idle structures. Increments each
+ * time we place a new handler to queue inside,
+ * a new loop, so that all old handlers can be
* called without calling any of the new ones
* created by old ones. */
- int afterId; /* For unique identifiers of after events. */
+ unsigned int afterId; /* For unique identifiers of after events. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
- * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write
- * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes
- * the number of milliseconds difference between two times. Both macros use
- * both of their arguments multiple times, so make sure they are cheap and
- * side-effect free. The "prototypes" for these macros are:
- *
- * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2);
- * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2);
+ * Helper macros to wrap AfterInfo and handlers (and vice versa)
*/
-#define TCL_TIME_BEFORE(t1, t2) \
- (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec))
-
-#define TCL_TIME_DIFF_MS(t1, t2) \
- (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \
- ((long)(t1).usec - (long)(t2).usec)/1000)
+#define TclpTimerEvent2AfterInfo(ptr) \
+ ( (AfterInfo*)TclpTimerEvent2ExtraData(ptr) )
+#define TclpAfterInfo2TimerEvent(ptr) \
+ TclpExtraData2TimerEvent(ptr)
#define TCL_TIME_DIFF_MS_CEILING(t1, t2) \
(1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \
((long)(t1).usec - (long)(t2).usec + 999)/1000)
/*
- * Sleeps under that number of milliseconds don't get double-checked
- * and are done in exactly one Tcl_Sleep(). This to limit gettimeofday()s.
- */
-
-#define SLEEP_OFFLOAD_GETTIMEOFDAY 20
-
-/*
* The maximum number of milliseconds for each Tcl_Sleep call in AfterDelay.
* This is used to limit the maximum lag between interp limit and script
* cancellation checks.
@@ -152,16 +114,126 @@ static Tcl_ThreadDataKey dataKey;
static void AfterCleanupProc(ClientData clientData,
Tcl_Interp *interp);
-static int AfterDelay(Tcl_Interp *interp, Tcl_WideInt ms);
+static int AfterDelay(Tcl_Interp *interp, Tcl_WideInt usec,
+ int absolute);
static void AfterProc(ClientData clientData);
-static void FreeAfterPtr(AfterInfo *afterPtr);
-static AfterInfo * GetAfterEvent(AfterAssocData *assocPtr,
- Tcl_Obj *commandPtr);
+static void FreeAfterPtr(ClientData clientData);
+static AfterInfo * GetAfterEvent(AfterAssocData *assocPtr, Tcl_Obj *objPtr);
static ThreadSpecificData *InitTimer(void);
static void TimerExitProc(ClientData clientData);
-static int TimerHandlerEventProc(Tcl_Event *evPtr, int flags);
static void TimerCheckProc(ClientData clientData, int flags);
static void TimerSetupProc(ClientData clientData, int flags);
+
+static void AfterObj_DupInternalRep(Tcl_Obj *, Tcl_Obj *);
+static void AfterObj_FreeInternalRep(Tcl_Obj *);
+static void AfterObj_UpdateString(Tcl_Obj *);
+
+/*
+ * Type definition.
+ */
+
+Tcl_ObjType afterObjType = {
+ "after", /* name */
+ AfterObj_FreeInternalRep, /* freeIntRepProc */
+ AfterObj_DupInternalRep, /* dupIntRepProc */
+ AfterObj_UpdateString, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ */
+static void
+AfterObj_DupInternalRep(srcPtr, dupPtr)
+ Tcl_Obj *srcPtr;
+ Tcl_Obj *dupPtr;
+{
+ /*
+ * Because we should have only a single reference to the after event,
+ * we'll copy string representation only.
+ */
+ if (dupPtr->bytes == NULL) {
+ if (srcPtr->bytes == NULL) {
+ AfterObj_UpdateString(srcPtr);
+ }
+ if (srcPtr->bytes != tclEmptyStringRep) {
+ TclInitStringRep(dupPtr, srcPtr->bytes, srcPtr->length);
+ } else {
+ dupPtr->bytes = tclEmptyStringRep;
+ }
+ }
+}
+/*
+ *----------------------------------------------------------------------
+ */
+static void
+AfterObj_FreeInternalRep(objPtr)
+ Tcl_Obj *objPtr;
+{
+ /*
+ * Because we should always have a reference by active after event,
+ * so it is a triggered / canceled event - just reset type and pointers
+ */
+ objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = NULL;
+
+ /* prevent no string representation bug */
+ if (objPtr->bytes == NULL) {
+ objPtr->length = 0;
+ objPtr->bytes = tclEmptyStringRep;
+ }
+}
+/*
+ *----------------------------------------------------------------------
+ */
+static void
+AfterObj_UpdateString(objPtr)
+ Tcl_Obj *objPtr;
+{
+ char buf[16 + TCL_INTEGER_SPACE];
+ int len;
+
+ AfterInfo *afterPtr = (AfterInfo*)objPtr->internalRep.twoPtrValue.ptr1;
+
+ /* if already triggered / canceled - equivalent not found, we can use empty */
+ if (!afterPtr) {
+ objPtr->length = 0;
+ objPtr->bytes = tclEmptyStringRep;
+ return;
+ }
+
+ len = sprintf(buf, "after#%u", afterPtr->id);
+
+ objPtr->length = len;
+ objPtr->bytes = ckalloc((size_t)++len);
+ if (objPtr->bytes)
+ memcpy(objPtr->bytes, buf, len);
+
+}
+/*
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj*
+GetAfterObj(
+ AfterInfo *afterPtr)
+{
+ Tcl_Obj * objPtr = afterPtr->selfPtr;
+
+ if (objPtr != NULL) {
+ return objPtr;
+ }
+
+ TclNewObj(objPtr);
+ objPtr->typePtr = &afterObjType;
+ objPtr->bytes = NULL;
+ objPtr->internalRep.twoPtrValue.ptr1 = afterPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ Tcl_IncrRefCount(objPtr);
+ afterPtr->selfPtr = objPtr;
+
+ return objPtr;
+};
/*
*----------------------------------------------------------------------
@@ -186,12 +258,140 @@ InitTimer(void)
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
- Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
+ Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, tsdPtr);
Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
}
return tsdPtr;
}
+static void
+AttachTimerEvent(
+ ThreadSpecificData *tsdPtr,
+ TclTimerEvent *tmrEvent)
+{
+ TclTimerEvent **tmrList, **tmrTail;
+
+ tmrEvent->flags |= TCL_TMREV_LISTED;
+ if (tmrEvent->flags & TCL_TMREV_PROMPT) {
+ /* use timer generation, because usually no differences between
+ * call of "after 0" and "after 1" */
+ tmrEvent->generation = tsdPtr->timerGeneration;
+ /* attach to the prompt queue */
+ TclSpliceTailEx(tmrEvent, tsdPtr->promptList, tsdPtr->promptTail);
+ /* execute immediately: signal pending and set timer marker */
+ tsdPtr->timerPending = 1;
+ TclSetTimerEventMarker(0);
+ return;
+ }
+
+ if (tmrEvent->flags & TCL_TMREV_IDLE) {
+ /* idle generation */
+ tmrEvent->generation = tsdPtr->idleGeneration;
+ /* attach to the idle queue */
+ TclSpliceTailEx(tmrEvent, tsdPtr->idleList, tsdPtr->idleTail);
+ return;
+ }
+
+ /* current timer generation */
+ tmrEvent->generation = tsdPtr->timerGeneration;
+
+ /*
+ * Add the event to the queue in the correct position
+ * (ordered by event firing time).
+ */
+
+ tsdPtr->timerListEpoch++; /* signal - timer list was changed */
+
+ if (!(tmrEvent->flags & TCL_TMREV_AT)) {
+ tmrList = &tsdPtr->relTimerList;
+ tmrTail = &tsdPtr->relTimerTail;
+ } else {
+ tmrList = &tsdPtr->absTimerList;
+ tmrTail = &tsdPtr->absTimerTail;
+ }
+ /* if before current first (e. g. "after 1" before first "after 1000") */
+ if ( !(*tmrList) || tmrEvent->time < (*tmrList)->time) {
+ /* splice to the head */
+ TclSpliceInEx(tmrEvent, *tmrList, *tmrTail);
+ } else {
+ TclTimerEvent *tmrEventPos;
+ Tcl_WideInt usec = tmrEvent->time;
+ /* search from end as long as one with time before not found */
+ for (tmrEventPos = *tmrTail; tmrEventPos != NULL;
+ tmrEventPos = tmrEventPos->prevPtr) {
+ if (usec >= tmrEventPos->time) {
+ break;
+ }
+ }
+ /* normally it should be always true, because checked above, but ... */
+ if (tmrEventPos != NULL) {
+ /* insert after found element (with time before new) */
+ tmrEvent->prevPtr = tmrEventPos;
+ if ((tmrEvent->nextPtr = tmrEventPos->nextPtr)) {
+ tmrEventPos->nextPtr->prevPtr = tmrEvent;
+ } else {
+ *tmrTail = tmrEvent;
+ }
+ tmrEventPos->nextPtr = tmrEvent;
+ } else {
+ /* unexpected case, but ... splice to the head */
+ TclSpliceInEx(tmrEvent, *tmrList, *tmrTail);
+ }
+ }
+}
+
+static void
+DetachTimerEvent(
+ ThreadSpecificData *tsdPtr,
+ TclTimerEvent *tmrEvent)
+{
+ tmrEvent->flags &= ~TCL_TMREV_LISTED;
+ if (tmrEvent->flags & TCL_TMREV_PROMPT) {
+ /* prompt handler */
+ TclSpliceOutEx(tmrEvent, tsdPtr->promptList, tsdPtr->promptTail);
+ return;
+ }
+ if (tmrEvent->flags & TCL_TMREV_IDLE) {
+ /* idle handler */
+ TclSpliceOutEx(tmrEvent, tsdPtr->idleList, tsdPtr->idleTail);
+ return;
+ }
+ /* timer event-handler */
+ tsdPtr->timerListEpoch++; /* signal - timer list was changed */
+ if (!(tmrEvent->flags & TCL_TMREV_AT)) {
+ TclSpliceOutEx(tmrEvent, tsdPtr->relTimerList, tsdPtr->relTimerTail);
+ } else {
+ TclSpliceOutEx(tmrEvent, tsdPtr->absTimerList, tsdPtr->absTimerTail);
+ }
+}
+
+static Tcl_WideInt
+TimerMakeRelativeTime(
+ ThreadSpecificData *tsdPtr,
+ Tcl_WideInt usec)
+{
+ Tcl_WideInt now = TclpGetUTimeMonotonic();
+
+ /*
+ * We should have the ability to ajust end-time of relative events,
+ * for possible time-jumps.
+ */
+ if (tsdPtr->relTimerList) {
+ /*
+ * end-time = now + usec
+ * Adjust value of usec relative current base (to now), so
+ * end-time = base + relative event-time, which corresponds
+ * original end-time.
+ */
+ usec += now - tsdPtr->relTimerBase;
+ } else {
+ /* first event here - initial values (base/epoch) */
+ tsdPtr->relTimerBase = now;
+ }
+
+ return usec;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -215,15 +415,20 @@ TimerExitProc(
{
ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
- Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
- register TimerHandler *timerHandlerPtr;
+ Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, tsdPtr);
- timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
- while (timerHandlerPtr != NULL) {
- tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
- ckfree(timerHandlerPtr);
- timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
+ while ((tsdPtr->promptTail) != NULL) {
+ TclpDeleteTimerEvent(tsdPtr->promptTail);
+ }
+ while ((tsdPtr->relTimerTail) != NULL) {
+ TclpDeleteTimerEvent(tsdPtr->relTimerTail);
+ }
+ while ((tsdPtr->absTimerTail) != NULL) {
+ TclpDeleteTimerEvent(tsdPtr->absTimerTail);
+ }
+ while ((tsdPtr->idleTail) != NULL) {
+ TclpDeleteTimerEvent(tsdPtr->idleTail);
}
}
}
@@ -253,20 +458,151 @@ Tcl_CreateTimerHandler(
Tcl_TimerProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary data to pass to proc. */
{
- Tcl_Time time;
+ register TclTimerEvent *tmrEvent;
+ Tcl_WideInt usec;
/*
- * Compute when the event should fire.
+ * Compute when the event should fire (avoid overflow).
*/
- Tcl_GetTime(&time);
- time.sec += milliseconds/1000;
- time.usec += (milliseconds%1000)*1000;
- if (time.usec >= 1000000) {
- time.usec -= 1000000;
- time.sec += 1;
+ if (milliseconds < 0x7FFFFFFFFFFFFFFFL / 1000) {
+ usec = (Tcl_WideInt)milliseconds*1000;
+ } else {
+ usec = 0x7FFFFFFFFFFFFFFFL;
+ }
+
+ tmrEvent = TclpCreateTimerEvent(usec, proc, NULL, 0, 0);
+ if (tmrEvent == NULL) {
+ return NULL;
}
- return TclCreateAbsoluteTimerHandler(&time, proc, clientData);
+ tmrEvent->clientData = clientData;
+
+ return tmrEvent->token;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TclpCreateTimerEvent --
+ *
+ * Arrange for a given function to be invoked at or in a particular time
+ * in the future (microseconds).
+ *
+ * Results:
+ * The return value is a handler entry of the timer event, which may be
+ * used to access the event entry, e. g. delete the event before it fires.
+ *
+ * Side effects:
+ * When the time or offset in timePtr has been reached, proc will be invoked
+ * exactly once.
+ *
+ *--------------------------------------------------------------
+ */
+
+TclTimerEvent*
+TclpCreateTimerEvent(
+ Tcl_WideInt usec, /* Time to be invoked (absolute/relative) */
+ Tcl_TimerProc *proc, /* Function to invoke */
+ Tcl_TimerDeleteProc *deleteProc,/* Function to cleanup */
+ size_t extraDataSize, /* Size of extra data to allocate */
+ int flags) /* Flags corresponding type of event */
+{
+ register TclTimerEvent *tmrEvent;
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = InitTimer();
+ tmrEvent = (TclTimerEvent *)ckalloc(
+ sizeof(TclTimerEvent) + extraDataSize);
+ if (tmrEvent == NULL) {
+ return NULL;
+ }
+
+ if (usec <= 0 && !(flags & (TCL_TMREV_AT|TCL_TMREV_PROMPT|TCL_TMREV_IDLE))) {
+ usec = 0;
+ flags |= TCL_TMREV_PROMPT;
+ }
+
+ /*
+ * Fill in fields for the event.
+ */
+
+ tmrEvent->proc = proc;
+ tmrEvent->deleteProc = deleteProc;
+ tmrEvent->clientData = TclpTimerEvent2ExtraData(tmrEvent);
+ tmrEvent->flags = flags & (TCL_TMREV_AT|TCL_TMREV_PROMPT|TCL_TMREV_IDLE);
+ tsdPtr->lastTimerId++;
+ tmrEvent->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
+
+ /*
+ * If TCL_TMREV_AT (and TCL_TMREV_PROMPT) are not specified, event observes
+ * due-time considering possible time-jump.
+ */
+ if (!(flags & (TCL_TMREV_AT|TCL_TMREV_PROMPT|TCL_TMREV_IDLE))) {
+ /* relative event - realign time using current relative base */
+ usec = TimerMakeRelativeTime(tsdPtr, usec);
+ }
+
+ tmrEvent->time = usec;
+ tmrEvent->refCount = 0;
+
+ /*
+ * Attach the event to the corresponding queue in the correct position
+ * (ordered by event firing time, if time specified).
+ */
+
+ AttachTimerEvent(tsdPtr, tmrEvent);
+
+ return tmrEvent;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TclpCreatePromptTimerEvent --
+ *
+ * Arrange for proc to be invoked delayed (but prompt) as timer event,
+ * without time ("after 0").
+ * Or as idle event (the next time the system is idle i.e., just
+ * before the next time that Tcl_DoOneEvent would have to wait for
+ * something to happen).
+ *
+ * Providing the flag TCL_TMREV_PROMPT ensures that timer event-handler
+ * will be queued immediately to guarantee the execution of timer-event
+ * as soon as possible
+ *
+ * Results:
+ * Returns the created timer entry.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+TclTimerEvent *
+TclpCreatePromptTimerEvent(
+ Tcl_TimerProc *proc, /* Function to invoke. */
+ Tcl_TimerDeleteProc *deleteProc, /* Function to cleanup */
+ size_t extraDataSize,
+ int flags)
+{
+ register TclTimerEvent *tmrEvent;
+ ThreadSpecificData *tsdPtr = InitTimer();
+
+ tmrEvent = (TclTimerEvent *) ckalloc(sizeof(TclTimerEvent) + extraDataSize);
+ if (tmrEvent == NULL) {
+ return NULL;
+ }
+ tmrEvent->proc = proc;
+ tmrEvent->deleteProc = deleteProc;
+ tmrEvent->clientData = TclpTimerEvent2ExtraData(tmrEvent);
+ tmrEvent->flags = flags;
+ tmrEvent->time = 0;
+ tmrEvent->refCount = 0;
+
+ AttachTimerEvent(tsdPtr, tmrEvent);
+
+ return tmrEvent;
}
/*
@@ -275,11 +611,11 @@ Tcl_CreateTimerHandler(
* TclCreateAbsoluteTimerHandler --
*
* Arrange for a given function to be invoked at a particular time in the
- * future.
+ * future (absolute time).
*
* Results:
- * The return value is a token for the timer event, which may be used to
- * delete the event before it fires.
+ * The return value is a token of the timer event, which
+ * may be used to delete the event before it fires.
*
* Side effects:
* When the time in timePtr has been reached, proc will be invoked
@@ -294,42 +630,73 @@ TclCreateAbsoluteTimerHandler(
Tcl_TimerProc *proc,
ClientData clientData)
{
- register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
- ThreadSpecificData *tsdPtr = InitTimer();
-
- timerHandlerPtr = ckalloc(sizeof(TimerHandler));
+ register TclTimerEvent *tmrEvent;
+ Tcl_WideInt usec;
/*
- * Fill in fields for the event.
+ * Compute when the event should fire (avoid overflow).
*/
- memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
- timerHandlerPtr->proc = proc;
- timerHandlerPtr->clientData = clientData;
- tsdPtr->lastTimerId++;
- timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
+ if (timePtr->sec < 0x7FFFFFFFFFFFFFFFL / 1000000) {
+ usec = (((Tcl_WideInt)timePtr->sec) * 1000000) + timePtr->usec;
+ } else {
+ usec = 0x7FFFFFFFFFFFFFFFL;
+ }
+
+ tmrEvent = TclpCreateTimerEvent(usec, proc, NULL, 0, TCL_TMREV_AT);
+ if (tmrEvent == NULL) {
+ return NULL;
+ }
+ tmrEvent->clientData = clientData;
+
+ return tmrEvent->token;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TclCreateRelativeTimerHandler --
+ *
+ * Arrange for a given function to be invoked in a particular time offset
+ * in the future.
+ *
+ * Results:
+ * The return value is token of the timer event, which
+ * may be used to delete the event before it fires.
+ *
+ * Side effects:
+ * In contrary to absolute timer functions operate on relative time.
+ *
+ *--------------------------------------------------------------
+ */
+
+Tcl_TimerToken
+TclCreateTimerHandler(
+ Tcl_Time *timePtr,
+ Tcl_TimerProc *proc,
+ ClientData clientData,
+ int flags)
+{
+ register TclTimerEvent *tmrEvent;
+ Tcl_WideInt usec;
/*
- * Add the event to the queue in the correct position
- * (ordered by event firing time).
+ * Compute when the event should fire (avoid overflow).
*/
- for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
- prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
- if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
- break;
- }
- }
- timerHandlerPtr->nextPtr = tPtr2;
- if (prevPtr == NULL) {
- tsdPtr->firstTimerHandlerPtr = timerHandlerPtr;
+ if (timePtr->sec < 0x7FFFFFFFFFFFFFFFL / 1000000) {
+ usec = (((Tcl_WideInt)timePtr->sec) * 1000000) + timePtr->usec;
} else {
- prevPtr->nextPtr = timerHandlerPtr;
+ usec = 0x7FFFFFFFFFFFFFFFL;
}
- TimerSetupProc(NULL, TCL_ALL_EVENTS);
+ tmrEvent = TclpCreateTimerEvent(usec, proc, NULL, 0, flags);
+ if (tmrEvent == NULL) {
+ return NULL;
+ }
+ tmrEvent->clientData = clientData;
- return timerHandlerPtr->token;
+ return tmrEvent->token;
}
/*
@@ -353,30 +720,180 @@ TclCreateAbsoluteTimerHandler(
void
Tcl_DeleteTimerHandler(
Tcl_TimerToken token) /* Result previously returned by
- * Tcl_DeleteTimerHandler. */
+ * Tcl_CreateTimerHandler. */
{
- register TimerHandler *timerHandlerPtr, *prevPtr;
+ register TclTimerEvent *tmrEvent;
ThreadSpecificData *tsdPtr = InitTimer();
if (token == NULL) {
return;
}
- for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
- timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
- timerHandlerPtr = timerHandlerPtr->nextPtr) {
- if (timerHandlerPtr->token != token) {
+ for (tmrEvent = tsdPtr->relTimerTail;
+ tmrEvent != NULL;
+ tmrEvent = tmrEvent->prevPtr
+ ) {
+ if (tmrEvent->token != token) {
continue;
}
- if (prevPtr == NULL) {
- tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
- } else {
- prevPtr->nextPtr = timerHandlerPtr->nextPtr;
+
+ TclpDeleteTimerEvent(tmrEvent);
+ return;
+ }
+
+ for (tmrEvent = tsdPtr->absTimerTail;
+ tmrEvent != NULL;
+ tmrEvent = tmrEvent->prevPtr
+ ) {
+ if (tmrEvent->token != token) {
+ continue;
}
- ckfree(timerHandlerPtr);
+
+ TclpDeleteTimerEvent(tmrEvent);
return;
}
}
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TclpDeleteTimerEvent --
+ *
+ * Delete a previously-registered prompt, timer or idle handler.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroy the timer callback, so that its associated function will
+ * not be called. If the callback has already fired this will be executed
+ * internally.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+TclpDeleteTimerEvent(
+ TclTimerEvent *tmrEvent) /* Result previously returned by */
+ /* TclpCreateTimerEvent or derivatives. */
+{
+ ThreadSpecificData *tsdPtr;
+
+ if (tmrEvent == NULL) {
+ return;
+ }
+
+ tsdPtr = InitTimer();
+
+ /* detach from list */
+ if (tmrEvent->flags & TCL_TMREV_LISTED) {
+ DetachTimerEvent(tsdPtr, tmrEvent);
+ }
+
+ /* free it via deleteProc and ckfree */
+ if (tmrEvent->deleteProc && !(tmrEvent->flags & TCL_TMREV_DELETE)) {
+ /*
+ * Mark this entry will be deleted, so it can avoid double delete and
+ * caller can check in delete callback, the time entry handle is still
+ * the same (was not overriden in some recursive async-envent).
+ */
+ tmrEvent->flags |= TCL_TMREV_DELETE;
+ (*tmrEvent->deleteProc)(tmrEvent->clientData);
+ }
+
+ /* if frozen somewhere (nested service cycle) */
+ if (tmrEvent->refCount > 0) {
+ /* do nothing - event will be automatically deleted hereafter */
+ return;
+ }
+
+ ckfree(tmrEvent);
+}
+
+TclTimerEvent *
+TclpProlongTimerEvent(
+ TclTimerEvent *tmrEvent,
+ Tcl_WideInt usec,
+ int flags)
+{
+#if 0
+ return NULL;
+#else
+ ThreadSpecificData *tsdPtr = InitTimer();
+
+ if (tmrEvent->flags & TCL_TMREV_DELETE) {
+ return NULL;
+ }
+ /* if still belong to the queue, detach it from corresponding list */
+ if (tmrEvent->flags & TCL_TMREV_LISTED) {
+ DetachTimerEvent(tsdPtr, tmrEvent);
+ }
+ /* set wanted flags and prolong */
+ tmrEvent->flags |= (flags & (TCL_TMREV_AT|TCL_TMREV_PROMPT|TCL_TMREV_IDLE));
+ /* new firing time */
+ if (!(flags & (TCL_TMREV_PROMPT|TCL_TMREV_IDLE))) {
+ /* if relative event - realign time using current relative base */
+ if (!(flags & TCL_TMREV_AT)) {
+ usec = TimerMakeRelativeTime(tsdPtr, usec);
+ }
+ tmrEvent->time = usec;
+ }
+ /* attach to the queue again (new generation) */
+ AttachTimerEvent(tsdPtr, tmrEvent);
+ return tmrEvent;
+#endif
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TimerGetDueTime --
+ *
+ * Find the execution time offset of first relative or absolute timer
+ * starting from given heads.
+ *
+ * Results:
+ * A wide integer representing the due time (as microseconds) of first
+ * timer event to execute.
+ *
+ * Side effects:
+ * If time-jump recognized, may adjust the base for relative timers.
+ *
+ *--------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+TimerGetDueTime(
+ ThreadSpecificData *tsdPtr,
+ TclTimerEvent *relTimerList,
+ TclTimerEvent *absTimerList,
+ TclTimerEvent **dueEventPtr)
+{
+ TclTimerEvent *tmrEvent;
+ Tcl_WideInt timeOffs = 0x7FFFFFFFFFFFFFFFL;
+
+ /* find shortest due-time */
+ if ((tmrEvent = relTimerList) != NULL) {
+ /* offset to now (monotonic base) */
+ timeOffs = tsdPtr->relTimerBase + tmrEvent->time
+ - TclpGetUTimeMonotonic();
+ }
+ if (absTimerList) {
+ Tcl_WideInt absOffs;
+ /* offset to now (real-time base) */
+ absOffs = absTimerList->time - TclpGetMicroseconds();
+ if (!tmrEvent || absOffs < timeOffs) {
+ tmrEvent = absTimerList;
+ timeOffs = absOffs;
+ }
+ }
+
+ if (dueEventPtr) {
+ *dueEventPtr = tmrEvent;
+ }
+ return timeOffs;
+}
/*
*----------------------------------------------------------------------
@@ -398,37 +915,65 @@ Tcl_DeleteTimerHandler(
static void
TimerSetupProc(
- ClientData data, /* Not used. */
+ ClientData data, /* Specific data. */
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
- ThreadSpecificData *tsdPtr = InitTimer();
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
- if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
- || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
+ if (tsdPtr == NULL) { tsdPtr = InitTimer(); };
+
+ if ( ((flags & TCL_TIMER_EVENTS) && (tsdPtr->timerPending || tsdPtr->promptList))
+ || ((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList )
+ ) {
/*
- * There is an idle handler or a pending timer event, so just poll.
+ * There is a pending timer event or an idle handler, so just poll.
*/
blockTime.sec = 0;
blockTime.usec = 0;
- } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
+ } else if (
+ (flags & TCL_TIMER_EVENTS)
+ && (tsdPtr->relTimerList || tsdPtr->absTimerList)
+ ) {
/*
* Compute the timeout for the next timer on the list.
*/
+ Tcl_WideInt timeOffs;
- Tcl_GetTime(&blockTime);
- blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
- blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
- blockTime.usec;
- if (blockTime.usec < 0) {
- blockTime.sec -= 1;
- blockTime.usec += 1000000;
- }
- if (blockTime.sec < 0) {
+ timeOffs = TimerGetDueTime(tsdPtr,
+ tsdPtr->relTimerList, tsdPtr->absTimerList, NULL);
+
+ #ifdef TMR_RES_TOLERANCE
+ /* consider timer resolution tolerance (avoid busy wait) */
+ timeOffs -= ((timeOffs <= 1000000) ? timeOffs : 1000000) *
+ TMR_RES_TOLERANCE / 100;
+ #endif
+
+ if (timeOffs > 0) {
+ blockTime.sec = 0;
+ if (timeOffs >= 1000000) {
+ /*
+ * Note we use monotonic time by all wait functions, so to
+ * avoid too long wait by the absolute timers (to be able
+ * to trigger it) if time jumped to the expected time, just
+ * let block for maximal 1s if absolute timers available.
+ */
+ if (tsdPtr->absTimerList) {
+ /* we've some absolute timers - won't wait longer as 1s. */
+ timeOffs = 1000000;
+ }
+ blockTime.sec = (long) (timeOffs / 1000000);
+ blockTime.usec = (unsigned long)(timeOffs % 1000000);
+ } else {
+ blockTime.sec = 0;
+ blockTime.usec = (unsigned long)timeOffs;
+ }
+ } else {
blockTime.sec = 0;
blockTime.usec = 0;
}
+
} else {
return;
}
@@ -442,8 +987,7 @@ TimerSetupProc(
* TimerCheckProc --
*
* This function is called by Tcl_DoOneEvent to check the timer event
- * source for events. This routine checks both the idle and after timer
- * lists.
+ * source for events. This routine checks the first timer in the list.
*
* Results:
* None.
@@ -456,59 +1000,65 @@ TimerSetupProc(
static void
TimerCheckProc(
- ClientData data, /* Not used. */
+ ClientData data, /* Specific data. */
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
- Tcl_Event *timerEvPtr;
- Tcl_Time blockTime;
- ThreadSpecificData *tsdPtr = InitTimer();
+ Tcl_WideInt timeOffs = 0;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
- if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
- /*
- * Compute the timeout for the next timer on the list.
- */
+ if (!(flags & TCL_TIMER_EVENTS)) {
+ return;
+ }
- Tcl_GetTime(&blockTime);
- blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
- blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
- blockTime.usec;
- if (blockTime.usec < 0) {
- blockTime.sec -= 1;
- blockTime.usec += 1000000;
- }
- if (blockTime.sec < 0) {
- blockTime.sec = 0;
- blockTime.usec = 0;
- }
+ if (tsdPtr == NULL) { tsdPtr = InitTimer(); };
- /*
- * If the first timer has expired, stick an event on the queue.
- */
+ /* If already pending (or prompt-events) */
+ if (tsdPtr->timerPending || tsdPtr->promptList) {
+ goto mark;
+ }
- if (blockTime.sec == 0 && blockTime.usec == 0 &&
- !tsdPtr->timerPending) {
- tsdPtr->timerPending = 1;
- timerEvPtr = ckalloc(sizeof(Tcl_Event));
- timerEvPtr->proc = TimerHandlerEventProc;
- Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
- }
+ /*
+ * Verify the first timer on the queue.
+ */
+
+ if (!tsdPtr->relTimerList && !tsdPtr->absTimerList) {
+ return;
+ }
+
+ timeOffs = TimerGetDueTime(tsdPtr,
+ tsdPtr->relTimerList, tsdPtr->absTimerList, NULL);
+
+#ifdef TMR_RES_TOLERANCE
+ /* consider timer resolution tolerance (avoid busy wait) */
+ timeOffs -= ((timeOffs <= 1000000) ? timeOffs : 1000000) *
+ TMR_RES_TOLERANCE / 100;
+#endif
+
+ /*
+ * If the first timer has expired, stick an event on the queue.
+ */
+ if (timeOffs <= 0) {
+ mark:
+ TclSetTimerEventMarker(flags); /* force timer execution */
+ tsdPtr->timerPending = 1;
}
}
/*
*----------------------------------------------------------------------
*
- * TimerHandlerEventProc --
+ * TclServiceTimerEvents --
*
- * This function is called by Tcl_ServiceEvent when a timer event reaches
- * the front of the event queue. This function handles the event by
+ * This function is called by Tcl_ServiceEvent when a timer events should
+ * be processed. This function handles the event by
* invoking the callbacks for all timers that are ready.
*
* Results:
* Returns 1 if the event was handled, meaning it should be removed from
- * the queue. Returns 0 if the event was not handled, meaning it should
- * stay on the queue. The only time the event isn't handled is if the
- * TCL_TIMER_EVENTS flag bit isn't set.
+ * the queue.
+ * Returns 0 if the event was not handled (no timer events).
+ * Returns -1 if pending timer events available, meaning the marker should
+ * stay on the head of queue.
*
* Side effects:
* Whatever the timer handler callback functions do.
@@ -516,25 +1066,17 @@ TimerCheckProc(
*----------------------------------------------------------------------
*/
-static int
-TimerHandlerEventProc(
- Tcl_Event *evPtr, /* Event to service. */
- int flags) /* Flags that indicate what events to handle,
- * such as TCL_FILE_EVENTS. */
+int
+TclServiceTimerEvents(void)
{
- TimerHandler *timerHandlerPtr, **nextPtrPtr;
- Tcl_Time time;
- int currentTimerId;
+ TclTimerEvent *tmrEvent, *relTimerList, *absTimerList;
+ size_t currentGeneration, currentEpoch;
+ int result = 0;
+ int prevTmrPending;
ThreadSpecificData *tsdPtr = InitTimer();
- /*
- * Do nothing if timers aren't enabled. This leaves the event on the
- * queue, so we will get to it as soon as ServiceEvents() is called with
- * timers enabled.
- */
-
- if (!(flags & TCL_TIMER_EVENTS)) {
- return 0;
+ if (!tsdPtr->timerPending) {
+ return 0; /* no timer events */
}
/*
@@ -543,9 +1085,7 @@ TimerHandlerEventProc(
* 1. New handlers can get added to the list while the current one is
* being processed. If new ones get added, we don't want to process
* them during this pass through the list to avoid starving other event
- * sources. This is implemented using the token number in the handler:
- * new handlers will have a newer token than any of the ones currently
- * on the list.
+ * sources. This is implemented using check of the generation epoch.
* 2. The handler can call Tcl_DoOneEvent, so we have to remove the
* handler from the list before calling it. Otherwise an infinite loop
* could result.
@@ -562,39 +1102,140 @@ TimerHandlerEventProc(
* timers appearing before later ones.
*/
+ currentGeneration = tsdPtr->timerGeneration++;
tsdPtr->timerPending = 0;
- currentTimerId = tsdPtr->lastTimerId;
- Tcl_GetTime(&time);
- while (1) {
- nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
- timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
- if (timerHandlerPtr == NULL) {
- break;
+
+ /* First process all prompt (immediate) events */
+ while ((tmrEvent = tsdPtr->promptList) != NULL
+ && tmrEvent->generation <= currentGeneration
+ ) {
+ /* freeze / detach entry from the owner's list */
+ tmrEvent->refCount++;
+ tmrEvent->flags &= ~TCL_TMREV_LISTED;
+ TclSpliceOutEx(tmrEvent, tsdPtr->promptList, tsdPtr->promptTail);
+ /* reset current timer pending (correct process nested wait event) */
+ prevTmrPending = tsdPtr->timerPending;
+ tsdPtr->timerPending = 0;
+ /* execute event */
+ (*tmrEvent->proc)(tmrEvent->clientData);
+ result = 1;
+ /* restore current timer pending */
+ tsdPtr->timerPending += prevTmrPending;
+ /* unfreeze / if used somewhere else (nested) or prolongation (reattached) */
+ if (tmrEvent->refCount-- > 1 || (tmrEvent->flags & TCL_TMREV_LISTED)) {
+ continue;
+ };
+ /* free it via deleteProc and ckfree */
+ if (tmrEvent->deleteProc && !(tmrEvent->flags & TCL_TMREV_DELETE)) {
+ tmrEvent->flags |= TCL_TMREV_DELETE;
+ (*tmrEvent->deleteProc)(tmrEvent->clientData);
}
+ ckfree(tmrEvent);
+ }
+
+ /* if stil pending prompt events (new generation) - repeat event cycle as
+ * soon as possible */
+ if (tsdPtr->promptList) {
+ tsdPtr->timerPending = 1;
+ return -1;
+ }
- if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) {
+ /* Hereafter all relative and absolute timer events with time before now */
+ relTimerList = tsdPtr->relTimerList;
+ absTimerList = tsdPtr->absTimerList;
+ while (relTimerList || absTimerList) {
+ Tcl_WideInt timeOffs;
+
+ /* find timer (absolute/relative) with shortest due-time */
+ timeOffs = TimerGetDueTime(tsdPtr,
+ relTimerList, absTimerList, &tmrEvent);
+ /* the same tolerance logic as in TimerSetupProc/TimerCheckProc */
+ #ifdef TMR_RES_TOLERANCE
+ timeOffs -= ((timeOffs <= 1000000) ? timeOffs : 1000000) *
+ TMR_RES_TOLERANCE / 100;
+ #endif
+ /* still not reached */
+ if (timeOffs > 0) {
break;
}
+ /* for the next iteration */
+ if (tmrEvent == relTimerList) {
+ relTimerList = tmrEvent->nextPtr;
+ } else {
+ absTimerList = tmrEvent->nextPtr;
+ }
+
/*
- * Bail out if the next timer is of a newer generation.
+ * Bypass timers of newer generation.
*/
- if ((currentTimerId - PTR2INT(timerHandlerPtr->token)) < 0) {
- break;
+ if (tmrEvent->generation > currentGeneration) {
+ /* increase pending to signal repeat */
+ tsdPtr->timerPending++;
+ continue;
}
+ tsdPtr->timerListEpoch++; /* signal - timer list was changed */
+ currentEpoch = tsdPtr->timerListEpoch; /* save it to compare */
+
/*
* Remove the handler from the queue before invoking it, to avoid
* potential reentrancy problems.
*/
+ tmrEvent->refCount++; /* freeze */
+ tmrEvent->flags &= ~TCL_TMREV_LISTED;
+ if (!(tmrEvent->flags & TCL_TMREV_AT)) {
+ TclSpliceOutEx(tmrEvent,
+ tsdPtr->relTimerList, tsdPtr->relTimerTail);
+ } else {
+ TclSpliceOutEx(tmrEvent,
+ tsdPtr->absTimerList, tsdPtr->absTimerTail);
+ }
+
+ /* reset current timer pending (correct process nested wait event) */
+ prevTmrPending = tsdPtr->timerPending;
+ tsdPtr->timerPending = 0;
+ /* invoke timer proc */
+ (*tmrEvent->proc)(tmrEvent->clientData);
+ result = 1;
+ /* restore current timer pending */
+ tsdPtr->timerPending += prevTmrPending;
+ /* unfreeze / if used somewhere else (nested) or prolongation (reattached) */
+ if (tmrEvent->refCount-- > 1 || (tmrEvent->flags & TCL_TMREV_LISTED)) {
+ goto nextEvent;
+ };
+ /* free it via deleteProc and ckfree */
+ if (tmrEvent->deleteProc && !(tmrEvent->flags & TCL_TMREV_DELETE)) {
+ tmrEvent->flags |= TCL_TMREV_DELETE;
+ (*tmrEvent->deleteProc)(tmrEvent->clientData);
+ }
+ ckfree(tmrEvent);
+
+ nextEvent:
+ /* be sure that timer-list was not changed inside the proc call */
+ if (currentEpoch != tsdPtr->timerListEpoch) {
+ /* timer-list was changed - stop processing */
+ tsdPtr->timerPending++;
+ break;
+ }
+ }
- *nextPtrPtr = timerHandlerPtr->nextPtr;
- timerHandlerPtr->proc(timerHandlerPtr->clientData);
- ckfree(timerHandlerPtr);
+ /* pending timer events, so mark (queue) timer events */
+ if (tsdPtr->timerPending >= 1) {
+ tsdPtr->timerPending = 1;
+ return -1;
}
- TimerSetupProc(NULL, TCL_TIMER_EVENTS);
- return 1;
+
+ /* Reset generation if both timer queue are empty */
+ if (!tsdPtr->promptList && !tsdPtr->relTimerList && !tsdPtr->absTimerList) {
+ tsdPtr->timerGeneration = 0;
+ }
+
+ /* Compute the next timeout (later via TimerSetupProc using the first timer). */
+ tsdPtr->timerPending = 0;
+
+ return result; /* processing done, again later via TimerCheckProc */
}
/*
@@ -615,31 +1256,16 @@ TimerHandlerEventProc(
*
*--------------------------------------------------------------
*/
-
void
Tcl_DoWhenIdle(
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- register IdleHandler *idlePtr;
- Tcl_Time blockTime;
- ThreadSpecificData *tsdPtr = InitTimer();
+ TclTimerEvent *idlePtr = TclpCreatePromptTimerEvent(proc, NULL, 0, TCL_TMREV_IDLE);
- idlePtr = ckalloc(sizeof(IdleHandler));
- idlePtr->proc = proc;
- idlePtr->clientData = clientData;
- idlePtr->generation = tsdPtr->idleGeneration;
- idlePtr->nextPtr = NULL;
- if (tsdPtr->lastIdlePtr == NULL) {
- tsdPtr->idleList = idlePtr;
- } else {
- tsdPtr->lastIdlePtr->nextPtr = idlePtr;
+ if (idlePtr) {
+ idlePtr->clientData = clientData;
}
- tsdPtr->lastIdlePtr = idlePtr;
-
- blockTime.sec = 0;
- blockTime.usec = 0;
- Tcl_SetMaxBlockTime(&blockTime);
}
/*
@@ -665,26 +1291,26 @@ Tcl_CancelIdleCall(
Tcl_IdleProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- register IdleHandler *idlePtr, *prevPtr;
- IdleHandler *nextPtr;
+ register TclTimerEvent *idlePtr, *nextPtr;
ThreadSpecificData *tsdPtr = InitTimer();
- for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
- prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
- while ((idlePtr->proc == proc)
+ for (idlePtr = tsdPtr->idleList;
+ idlePtr != NULL;
+ idlePtr = nextPtr
+ ) {
+ nextPtr = idlePtr->nextPtr;
+ if ((idlePtr->proc == proc)
&& (idlePtr->clientData == clientData)) {
- nextPtr = idlePtr->nextPtr;
- ckfree(idlePtr);
- idlePtr = nextPtr;
- if (prevPtr == NULL) {
- tsdPtr->idleList = idlePtr;
- } else {
- prevPtr->nextPtr = idlePtr;
- }
- if (idlePtr == NULL) {
- tsdPtr->lastIdlePtr = prevPtr;
- return;
+ /* detach entry from the owner list */
+ idlePtr->flags &= ~TCL_TMREV_LISTED;
+ TclSpliceOutEx(idlePtr, tsdPtr->idleList, tsdPtr->idleTail);
+
+ /* free it via deleteProc and ckfree */
+ if (idlePtr->deleteProc && !(idlePtr->flags & TCL_TMREV_DELETE)) {
+ idlePtr->flags |= TCL_TMREV_DELETE;
+ (*idlePtr->deleteProc)(idlePtr->clientData);
}
+ ckfree(idlePtr);
}
}
}
@@ -692,7 +1318,7 @@ Tcl_CancelIdleCall(
/*
*----------------------------------------------------------------------
*
- * TclServiceIdle --
+ * TclServiceIdle -- , TclServiceIdleEx --
*
* This function is invoked by the notifier when it becomes idle. It will
* invoke all idle handlers that are present at the time the call is
@@ -709,19 +1335,19 @@ Tcl_CancelIdleCall(
*/
int
-TclServiceIdle(void)
+TclServiceIdleEx(
+ int flags,
+ int count)
{
- IdleHandler *idlePtr;
- int oldGeneration;
- Tcl_Time blockTime;
+ TclTimerEvent *idlePtr;
+ size_t currentGeneration;
ThreadSpecificData *tsdPtr = InitTimer();
- if (tsdPtr->idleList == NULL) {
+ if ((idlePtr = tsdPtr->idleList) == NULL) {
return 0;
}
- oldGeneration = tsdPtr->idleGeneration;
- tsdPtr->idleGeneration++;
+ currentGeneration = tsdPtr->idleGeneration++;
/*
* The code below is trickier than it may look, for the following reasons:
@@ -740,24 +1366,113 @@ TclServiceIdle(void)
* during the call.
*/
- for (idlePtr = tsdPtr->idleList;
- ((idlePtr != NULL)
- && ((oldGeneration - idlePtr->generation) >= 0));
- idlePtr = tsdPtr->idleList) {
- tsdPtr->idleList = idlePtr->nextPtr;
- if (tsdPtr->idleList == NULL) {
- tsdPtr->lastIdlePtr = NULL;
+ while (idlePtr->generation <= currentGeneration) {
+ /* freeze / detach entry from the owner's list */
+ idlePtr->refCount++;
+ idlePtr->flags &= ~TCL_TMREV_LISTED;
+ TclSpliceOutEx(idlePtr, tsdPtr->idleList, tsdPtr->idleTail);
+
+ /* execute event */
+ (*idlePtr->proc)(idlePtr->clientData);
+ /* unfreeze / if used somewhere else (nested) or prolongation (reattached) */
+ if (idlePtr->refCount-- > 1 || (idlePtr->flags & TCL_TMREV_LISTED)) {
+ goto nextEvent;
+ };
+ /* free it via deleteProc and ckfree */
+ if (idlePtr->deleteProc && !(idlePtr->flags & TCL_TMREV_DELETE)) {
+ idlePtr->flags |= TCL_TMREV_DELETE;
+ (*idlePtr->deleteProc)(idlePtr->clientData);
}
- idlePtr->proc(idlePtr->clientData);
ckfree(idlePtr);
+
+ nextEvent:
+ /*
+ * Stop processing idle if idle queue empty, count reached or other
+ * events queued (only if not idle events only to service).
+ */
+ if ( (idlePtr = tsdPtr->idleList) == NULL
+ || !--count
+ || ((flags & TCL_ALL_EVENTS) != TCL_IDLE_EVENTS
+ && TclPeekEventQueued(flags))
+ ) {
+ break;
+ }
}
- if (tsdPtr->idleList) {
- blockTime.sec = 0;
- blockTime.usec = 0;
- Tcl_SetMaxBlockTime(&blockTime);
+
+ /* Reset generation */
+ if (!tsdPtr->idleList) {
+ tsdPtr->idleGeneration = 0;
}
return 1;
}
+
+int
+TclServiceIdle(void)
+{
+ return TclServiceIdleEx(TCL_ALL_EVENTS, INT_MAX);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpGetUTimeFromObj --
+ *
+ * This function converts numeric tcl-object contains decimal milliseconds,
+ * (using milliseconds base) to time offset in microseconds,
+ *
+ * If input object contains double, the return time has microsecond
+ * precision.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * If possible leaves internal representation unchanged (e. g. integer).
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpGetUTimeFromObj(
+ Tcl_Interp *interp, /* Current interpreter or NULL. */
+ Tcl_Obj *objPtr, /* Object to read numeric time (in units
+ * corresponding given factor). */
+ Tcl_WideInt *timePtr, /* Resulting time if converted (in microseconds). */
+ int factor) /* Current factor of the time-object:
+ * 1 - microseconds,
+ * 1000 - milliseconds,
+ * 1000000 - seconds */
+{
+ if (objPtr->typePtr != &tclDoubleType) {
+ Tcl_WideInt tm;
+ if (Tcl_GetWideIntFromObj(NULL, objPtr, &tm) == TCL_OK) {
+ if (tm < 0x7FFFFFFFFFFFFFFFL / factor) { /* avoid overflow */
+ *timePtr = (tm * factor);
+ return TCL_OK;
+ }
+ *timePtr = 0x7FFFFFFFFFFFFFFFL;
+ return TCL_OK;
+ }
+ }
+ if (1) {
+ double tm;
+ if (Tcl_GetDoubleFromObj(interp, objPtr, &tm) == TCL_OK) {
+ if (tm < 0x7FFFFFFFFFFFFFFFL / factor) { /* avoid overflow */
+ /* use precise as possible calculation by double (microseconds) */
+ if (factor == 1) {
+ *timePtr = (Tcl_WideInt)tm;
+ } else {
+ *timePtr = ((Tcl_WideInt)tm * factor) +
+ (((Tcl_WideInt)(tm*factor)) % factor);
+ }
+ return TCL_OK;
+ }
+ *timePtr = 0x7FFFFFFFFFFFFFFFL;
+ return TCL_OK;
+ }
+ }
+ return TCL_ERROR;
+}
/*
*----------------------------------------------------------------------
@@ -784,16 +1499,20 @@ Tcl_AfterObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
- Tcl_Time wakeup;
+
+
+
+ Tcl_WideInt usec; /* Number of microseconds to wait (or time to wakeup) */
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index;
- static const char *const afterSubCmds[] = {
- "cancel", "idle", "info", NULL
+ static const char *afterSubCmds[] = {
+ "at", "cancel", "idle", "info", NULL
+ };
+ enum afterSubCmds {
+ AFTER_AT, AFTER_CANCEL, AFTER_IDLE, AFTER_INFO
};
- enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
@@ -811,6 +1530,7 @@ Tcl_AfterObjCmd(
assocPtr = ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
+ assocPtr->lastAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
@@ -818,45 +1538,84 @@ Tcl_AfterObjCmd(
* First lets see if the command was passed a number as the first argument.
*/
- if (objv[1]->typePtr == &tclIntType
-#ifndef TCL_WIDE_INT_IS_LONG
- || objv[1]->typePtr == &tclWideIntType
-#endif
- || objv[1]->typePtr == &tclBignumType
- || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
- &index) != TCL_OK)) {
- index = -1;
- if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
- const char *arg = Tcl_GetString(objv[1]);
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad argument \"%s\": must be"
- " cancel, idle, info, or an integer", arg));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
- arg, NULL);
- return TCL_ERROR;
- }
+ index = -1;
+ if ( ( TclObjIsIndexOfTable(objv[1], afterSubCmds)
+ || TclpGetUTimeFromObj(NULL, objv[1], &usec, 1000) != TCL_OK
+ )
+ && Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
+ &index) != TCL_OK
+ ) {
+ const char *arg = Tcl_GetString(objv[1]);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad argument \"%s\": must be "
+ "at, cancel, idle, info or a time", arg));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
+ arg, NULL);
+ return TCL_ERROR;
}
- /*
- * At this point, either index = -1 and ms contains the number of ms
+ /*
+ * At this point, either index = -1 and usec contains the time
* to wait, or else index is the index of a subcommand.
*/
switch (index) {
- case -1: {
- if (ms < 0) {
- ms = 0;
+ case -1:
+ /* usec already contains time-offset from objv[1] */
+ /* relative time offset should be positive */
+ if (usec < 0) {
+ usec = 0;
}
if (objc == 2) {
- return AfterDelay(interp, ms);
+ /* after <offset> */
+ return AfterDelay(interp, usec, 0);
}
- afterPtr = ckalloc(sizeof(AfterInfo));
+ case AFTER_AT: {
+ TclTimerEvent *tmrEvent;
+ int flags = 0;
+ if (index == AFTER_AT) {
+ flags = TCL_TMREV_AT;
+ objc--;
+ objv++;
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?option? time");
+ return TCL_ERROR;
+ }
+ /* get time from object, default factor for "at" - 1000000 (s) */
+ if (TclpGetUTimeFromObj(interp, objv[1], &usec, 1000000) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ /* after at <time> */
+ return AfterDelay(interp, usec, flags);
+ }
+ }
+
+ if (usec || (index == AFTER_AT)) {
+ /* after ?at? <time|offset> <command> ... */
+ tmrEvent = TclpCreateTimerEvent(usec, AfterProc,
+ FreeAfterPtr, sizeof(AfterInfo), flags);
+ } else {
+ /* after 0 <command> ... */
+ tmrEvent = TclpCreatePromptTimerEvent(AfterProc,
+ FreeAfterPtr, sizeof(AfterInfo), TCL_TMREV_PROMPT);
+ }
+
+ if (tmrEvent == NULL) { /* error handled in panic */
+ return TCL_ERROR;
+ }
+ afterPtr = TclpTimerEvent2AfterInfo(tmrEvent);
+
+ /* attach to the list */
afterPtr->assocPtr = assocPtr;
+ TclSpliceTailEx(afterPtr,
+ assocPtr->firstAfterPtr, assocPtr->lastAfterPtr);
+ afterPtr->selfPtr = NULL;
+
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
- afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
+ afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
@@ -870,20 +1629,9 @@ Tcl_AfterObjCmd(
* around when wrap-around occurs.
*/
- afterPtr->id = tsdPtr->afterId;
- tsdPtr->afterId += 1;
- Tcl_GetTime(&wakeup);
- wakeup.sec += (long)(ms / 1000);
- wakeup.usec += ((long)(ms % 1000)) * 1000;
- if (wakeup.usec > 1000000) {
- wakeup.sec++;
- wakeup.usec -= 1000000;
- }
- afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup,
- AfterProc, afterPtr);
- afterPtr->nextPtr = assocPtr->firstAfterPtr;
- assocPtr->firstAfterPtr = afterPtr;
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
+ afterPtr->id = tsdPtr->afterId++;
+
+ Tcl_SetObjResult(interp, GetAfterObj(afterPtr));
return TCL_OK;
}
case AFTER_CANCEL: {
@@ -895,94 +1643,116 @@ Tcl_AfterObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
+
+ afterPtr = NULL;
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
- command = Tcl_GetStringFromObj(commandPtr, &length);
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
- &tempLength);
- if ((length == tempLength)
+ if (commandPtr->typePtr == &afterObjType) {
+ afterPtr = (AfterInfo*)commandPtr->internalRep.twoPtrValue.ptr1;
+ } else {
+ command = Tcl_GetStringFromObj(commandPtr, &length);
+ for (afterPtr = assocPtr->lastAfterPtr;
+ afterPtr != NULL;
+ afterPtr = afterPtr->prevPtr
+ ) {
+ tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
+ &tempLength);
+ if ((length == tempLength)
&& !memcmp(command, tempCommand, (unsigned) length)) {
- break;
+ break;
+ }
}
- }
- if (afterPtr == NULL) {
- afterPtr = GetAfterEvent(assocPtr, commandPtr);
- }
- if (objc != 3) {
- Tcl_DecrRefCount(commandPtr);
- }
- if (afterPtr != NULL) {
- if (afterPtr->token != NULL) {
- Tcl_DeleteTimerHandler(afterPtr->token);
- } else {
- Tcl_CancelIdleCall(AfterProc, afterPtr);
+ if (afterPtr == NULL) {
+ afterPtr = GetAfterEvent(assocPtr, commandPtr);
+ }
+ if (objc != 3) {
+ Tcl_DecrRefCount(commandPtr);
}
- FreeAfterPtr(afterPtr);
+ }
+ if (afterPtr != NULL && afterPtr->assocPtr->interp == interp) {
+ TclpDeleteTimerEvent(TclpAfterInfo2TimerEvent(afterPtr));
}
break;
}
- case AFTER_IDLE:
+ case AFTER_IDLE: {
+ TclTimerEvent *idlePtr;
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
- afterPtr = ckalloc(sizeof(AfterInfo));
+
+ idlePtr = TclpCreatePromptTimerEvent(AfterProc,
+ FreeAfterPtr, sizeof(AfterInfo), TCL_TMREV_IDLE);
+ if (idlePtr == NULL) { /* error handled in panic */
+ return TCL_ERROR;
+ }
+ afterPtr = TclpTimerEvent2AfterInfo(idlePtr);
+
+ /* attach to the list */
afterPtr->assocPtr = assocPtr;
+ TclSpliceTailEx(afterPtr,
+ assocPtr->firstAfterPtr, assocPtr->lastAfterPtr);
+ afterPtr->selfPtr = NULL;
+
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
- afterPtr->id = tsdPtr->afterId;
- tsdPtr->afterId += 1;
- afterPtr->token = NULL;
- afterPtr->nextPtr = assocPtr->firstAfterPtr;
- assocPtr->firstAfterPtr = afterPtr;
- Tcl_DoWhenIdle(AfterProc, afterPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
- break;
- case AFTER_INFO:
+
+ afterPtr->id = tsdPtr->afterId++;
+
+ Tcl_SetObjResult(interp, GetAfterObj(afterPtr));
+
+ return TCL_OK;
+ };
+ case AFTER_INFO: {
+ Tcl_Obj *resultListPtr;
+
if (objc == 2) {
+ /* return list of all after-events */
Tcl_Obj *resultObj = Tcl_NewObj();
-
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (assocPtr->interp == interp) {
- Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
- "after#%d", afterPtr->id));
+ for (afterPtr = assocPtr->lastAfterPtr;
+ afterPtr != NULL;
+ afterPtr = afterPtr->prevPtr
+ ) {
+ if (assocPtr->interp != interp) {
+ continue;
}
+
+ Tcl_ListObjAppendElement(NULL, resultObj, GetAfterObj(afterPtr));
}
- Tcl_SetObjResult(interp, resultObj);
+
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
- afterPtr = GetAfterEvent(assocPtr, objv[2]);
- if (afterPtr == NULL) {
- const char *eventStr = TclGetString(objv[2]);
+ afterPtr = GetAfterEvent(assocPtr, objv[2]);
+ if (afterPtr == NULL || afterPtr->assocPtr->interp != interp) {
+ const char *eventStr = TclGetString(objv[2]);
+
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
- Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
+ Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
- } else {
- Tcl_Obj *resultListPtr = Tcl_NewObj();
-
- Tcl_ListObjAppendElement(interp, resultListPtr,
- afterPtr->commandPtr);
- Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (afterPtr->token == NULL) ? "idle" : "timer", -1));
- Tcl_SetObjResult(interp, resultListPtr);
- }
+ }
+ resultListPtr = Tcl_NewObj();
+ Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (TclpAfterInfo2TimerEvent(afterPtr)->flags & TCL_TMREV_IDLE) ?
+ "idle" : "timer", -1));
+ Tcl_SetObjResult(interp, resultListPtr);
break;
+ }
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
@@ -1010,22 +1780,33 @@ Tcl_AfterObjCmd(
static int
AfterDelay(
Tcl_Interp *interp,
- Tcl_WideInt ms)
+ Tcl_WideInt usec,
+ int absolute)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Time endTime, now;
- Tcl_WideInt diff;
+ Tcl_WideInt endTime, now, diff, limOffs = 0x7FFFFFFFFFFFFFFFL;
+ long tolerance = 0;
- Tcl_GetTime(&now);
- endTime = now;
- endTime.sec += (long)(ms/1000);
- endTime.usec += ((int)(ms%1000))*1000;
- if (endTime.usec >= 1000000) {
- endTime.sec++;
- endTime.usec -= 1000000;
+ if (usec > 0) {
+ /* calculate possible maximal tolerance (in usec) of original wait-time */
+ #ifdef TMR_RES_TOLERANCE
+ tolerance = ((usec < 1000000) ? usec : 1000000) * TMR_RES_TOLERANCE / 100;
+ #endif
}
+ if (!absolute) {
+ /*
+ * Note the time can be switched (time-jump), so use monotonic time here.
+ */
+ now = TclpGetUTimeMonotonic();
+ if ((endTime = (now + usec)) < now) { /* overflow */
+ endTime = 0x7FFFFFFFFFFFFFFFL;
+ }
+ } else {
+ now = TclpGetMicroseconds();
+ endTime = usec;
+ }
do {
if (Tcl_AsyncReady()) {
if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
@@ -1035,41 +1816,48 @@ AfterDelay(
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
return TCL_ERROR;
}
- if (iPtr->limit.timeEvent != NULL
- && TCL_TIME_BEFORE(iPtr->limit.time, now)) {
+ if ( iPtr->limit.timeEvent != NULL
+ && (limOffs = (TCL_TIME_TO_USEC(iPtr->limit.time)
+ - TclpGetMicroseconds())) <= 0
+ ) {
iPtr->limit.granularityTicker = 0;
if (Tcl_LimitCheck(interp) != TCL_OK) {
return TCL_ERROR;
}
}
- if (iPtr->limit.timeEvent == NULL
- || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
- diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
- if (diff > TCL_TIME_MAXIMUM_SLICE) {
- diff = TCL_TIME_MAXIMUM_SLICE;
- }
- if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1;
+ diff = endTime - now;
+ if (absolute && diff >= 1000000) {
+ /*
+ * Note by absolute sleep we should avoid too long waits, to be
+ * able to process further if time jumped to the expected time, so
+ * just let wait maximal 1 second.
+ */
+ diff = 1000000;
+ }
+ if (iPtr->limit.timeEvent == NULL || diff < limOffs) {
if (diff > 0) {
- Tcl_Sleep((long) diff);
- if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break;
- } else break;
- } else {
- diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
- if (diff > TCL_TIME_MAXIMUM_SLICE) {
- diff = TCL_TIME_MAXIMUM_SLICE;
+ if (diff > TCL_TIME_MAXIMUM_SLICE) {
+ diff = TCL_TIME_MAXIMUM_SLICE;
+ }
+ TclpUSleep(diff);
+ if (!absolute) {
+ now = TclpGetUTimeMonotonic();
+ } else {
+ now = TclpGetMicroseconds();
+ }
}
+ } else {
+ diff = limOffs;
if (diff > 0) {
- Tcl_Sleep((long) diff);
+ if (diff > TCL_TIME_MAXIMUM_SLICE) {
+ diff = TCL_TIME_MAXIMUM_SLICE;
+ }
+ TclpUSleep(diff);
+ if (!absolute) {
+ now = TclpGetUTimeMonotonic();
+ } else {
+ now = TclpGetMicroseconds();
+ }
}
if (Tcl_AsyncReady()) {
if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
@@ -1083,8 +1871,9 @@ AfterDelay(
return TCL_ERROR;
}
}
- Tcl_GetTime(&now);
- } while (TCL_TIME_BEFORE(now, endTime));
+
+ /* consider timer resolution tolerance (avoid busy wait) */
+ } while (now < endTime - tolerance);
return TCL_OK;
}
@@ -1111,7 +1900,7 @@ static AfterInfo *
GetAfterEvent(
AfterAssocData *assocPtr, /* Points to "after"-related information for
* this interpreter. */
- Tcl_Obj *commandPtr)
+ Tcl_Obj *objPtr)
{
const char *cmdString; /* Textual identifier for after event, such as
* "after#6". */
@@ -1119,7 +1908,11 @@ GetAfterEvent(
int id;
char *end;
- cmdString = TclGetString(commandPtr);
+ if (objPtr->typePtr == &afterObjType) {
+ return (AfterInfo*)objPtr->internalRep.twoPtrValue.ptr1;
+ }
+
+ cmdString = TclGetString(objPtr);
if (strncmp(cmdString, "after#", 6) != 0) {
return NULL;
}
@@ -1128,8 +1921,8 @@ GetAfterEvent(
if ((end == cmdString) || (*end != 0)) {
return NULL;
}
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
+ for (afterPtr = assocPtr->lastAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->prevPtr) {
if (afterPtr->id == id) {
return afterPtr;
}
@@ -1162,7 +1955,6 @@ AfterProc(
{
AfterInfo *afterPtr = clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
- AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
@@ -1172,16 +1964,21 @@ AfterProc(
* a core dump.
*/
- if (assocPtr->firstAfterPtr == afterPtr) {
- assocPtr->firstAfterPtr = afterPtr->nextPtr;
- } else {
- for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
- prevPtr = prevPtr->nextPtr) {
- /* Empty loop body. */
+ /* remove delete proc from handler (we'll do cleanup here) */
+ TclpAfterInfo2TimerEvent(afterPtr)->deleteProc = NULL;
+
+ /* release object (mark it was triggered) */
+ if (afterPtr->selfPtr) {
+ if (afterPtr->selfPtr->typePtr == &afterObjType) {
+ afterPtr->selfPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
- prevPtr->nextPtr = afterPtr->nextPtr;
+ Tcl_DecrRefCount(afterPtr->selfPtr);
+ afterPtr->selfPtr = NULL;
}
+ /* detach after-entry from the owner's list */
+ TclSpliceOutEx(afterPtr, assocPtr->firstAfterPtr, assocPtr->lastAfterPtr);
+
/*
* Execute the callback.
*/
@@ -1200,7 +1997,6 @@ AfterProc(
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
- ckfree(afterPtr);
}
/*
@@ -1216,29 +2012,32 @@ AfterProc(
* None.
*
* Side effects:
- * The memory associated with afterPtr is released.
+ * The memory associated with afterPtr is not released (owned by handler).
*
*----------------------------------------------------------------------
*/
static void
FreeAfterPtr(
- AfterInfo *afterPtr) /* Command to be deleted. */
+ ClientData clientData) /* Command to be deleted. */
{
- AfterInfo *prevPtr;
+ AfterInfo *afterPtr = (AfterInfo *) clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
- if (assocPtr->firstAfterPtr == afterPtr) {
- assocPtr->firstAfterPtr = afterPtr->nextPtr;
- } else {
- for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
- prevPtr = prevPtr->nextPtr) {
- /* Empty loop body. */
+ /* release object (mark it was removed) */
+ if (afterPtr->selfPtr) {
+ if (afterPtr->selfPtr->typePtr == &afterObjType) {
+ afterPtr->selfPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
- prevPtr->nextPtr = afterPtr->nextPtr;
+ Tcl_DecrRefCount(afterPtr->selfPtr);
+ afterPtr->selfPtr = NULL;
}
+
+ /* detach after-entry from the owner's list */
+ TclSpliceOutEx(afterPtr, assocPtr->firstAfterPtr, assocPtr->lastAfterPtr);
+
+ /* free command of entry */
Tcl_DecrRefCount(afterPtr->commandPtr);
- ckfree(afterPtr);
}
/*
@@ -1266,20 +2065,10 @@ AfterCleanupProc(
Tcl_Interp *interp) /* Interpreter that is being deleted. */
{
AfterAssocData *assocPtr = clientData;
- AfterInfo *afterPtr;
- while (assocPtr->firstAfterPtr != NULL) {
- afterPtr = assocPtr->firstAfterPtr;
- assocPtr->firstAfterPtr = afterPtr->nextPtr;
- if (afterPtr->token != NULL) {
- Tcl_DeleteTimerHandler(afterPtr->token);
- } else {
- Tcl_CancelIdleCall(AfterProc, afterPtr);
- }
- Tcl_DecrRefCount(afterPtr->commandPtr);
- ckfree(afterPtr);
+ while ( assocPtr->lastAfterPtr ) {
+ TclpDeleteTimerEvent(TclpAfterInfo2TimerEvent(assocPtr->lastAfterPtr));
}
- ckfree(assocPtr);
}
/*
generated by cgit v0.12 at 2024-07-15 11:33:55 (GMT)