Event performance branch

generic/tcl.h

@@ -710,6 +710,7 @@ typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...));
 typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
 	Tcl_Channel chan, char *address, int port));
 typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_TimerDeleteProc) _ANSI_ARGS_((ClientData clientData));
 typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
 	struct Tcl_Obj *objPtr));
 typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
@@ -1296,6 +1297,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)
@@ -1322,7 +1324,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;
 
 /*

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[]);
@@ -212,6 +215,7 @@ static const struct ClockCommand clockCommands[] = {
     { "getenv",			ClockGetenvObjCmd },
     { "microseconds",		ClockMicrosecondsObjCmd },
     { "milliseconds",		ClockMillisecondsObjCmd },
+    { "monotonic",		ClockMonotonicObjCmd },
     { "seconds",		ClockSecondsObjCmd },
     { "Oldscan",		TclClockOldscanObjCmd },
     { "ConvertLocalToUTC",	ClockConvertlocaltoutcObjCmd },
@@ -1816,6 +1820,40 @@ ClockMicrosecondsObjCmd(
     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_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetUTimeMonotonic()));
+    return TCL_OK;
+}
+
 /*
  *-----------------------------------------------------------------------------
  *

generic/tclEvent.c

@@ -1298,6 +1298,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;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -1324,46 +1380,149 @@ Tcl_VwaitObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *CONST objv[])	/* Argument objects. */
 {
-    int done, foundEvent;
-    char *nameString;
-
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "name");
+    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, "?options? ?timeout? name");
 	return TCL_ERROR;
     }
-    nameString = Tcl_GetString(objv[1]);
-    if (Tcl_TraceVar(interp, nameString,
+
+    /* 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, (ClientData) &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 interpreter limit exceeded */
 	if (Tcl_LimitExceeded(interp)) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+	    done = -4;
 	    break;
 	}
-    }
-    Tcl_UntraceVar(interp, nameString,
+    } while (!done);
+
+    Tcl_UntraceVar2(interp, nameString, NULL,
 	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 	    VwaitVarProc, (ClientData) &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.
+	 */
+
+	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.
      */
 
     Tcl_ResetResult(interp);
-    if (!foundEvent) {
-	Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
-		"\": would wait forever", NULL);
-	return TCL_ERROR;
-    }
-    if (!done) {
-	Tcl_AppendResult(interp, "limit exceeded", NULL);
-	return TCL_ERROR;
-    }
     return TCL_OK;
 }
 
@@ -1409,28 +1568,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 *updateOptions[] = {"idletasks", NULL};
-    enum updateOptions {REGEXP_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 REGEXP_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) {
@@ -1439,6 +1583,9 @@ Tcl_UpdateObjCmd(
 	    Tcl_AppendResult(interp, "limit exceeded", NULL);
 	    return TCL_ERROR;
 	}
+
+	/* be sure not to produce infinite wait (wait only once) */
+	flags |= TCL_DONT_WAIT;
     }
 
     /*