From 71888ada420fa0b95470d4b89fe60dc65f3cce97 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 29 Jun 2017 21:07:24 +0200 Subject: [PATCH] Squashed rebase from tclSE back porting branch (8.5/8.6), interim state. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Current commit-history: * partially back ported event-performance * after at: added simple workaround for absolute timers/sleep ("after at real-time"): because we use monotonic time in 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 absolute time, just let block for maximal 1 second if absolute timers available. test-cases: time-jumps (TIP #302) test covered now. Note: on some platforms it is only possible if the user has corresponding privileges to change system date and time. Ex.: sudo LD_LIBRARY_PATH=. ./tclsh ../tests/timer.test -match timer-20.* * code review and small optimizations * fix check event source threshold (corresponds 100-ns ranges, if the wide-clicks supported); because of variable width of 1 wide-click: windows - frequency dependent, unix - nanoseconds, darwin/osx - tb.numer / tb.denom nanoseconds. * unix: implements wide-clicks on unix (1 wide-click == 0.001 microseconds (1 nanosecond)), so more precise now (e. g. by time measurement etc.); unix/configure: regenerated (autoconf) * [unix] fixes conditional-wait: timeout is monotonic based; * Introduced monotonic time as ultimate fix for time-jump issue (fixed for windows and unix now, TIP #302 fully implemented now); Usage of monotonic time instead of adjustment via timeJump/timeJumpEpoch is more precise and effective. New sub-command "clock monotonic" to provide monotonic time facility for tcl-level. * don't cancel scheduled event as long as the event list is not bidirectional (too slow by large queue) - rewritten to cancel delayed (by execute it). * fixed timer-marker handling: timer should be always executed after queued event (of the same generation), it was marked (be sure it marked to immediate execution in corresponding checkProc only). tclIO: scheduled event rewritten using Tcl_Event instead of timer event (IO is not timer, e. g. executed also by usage of `vwait -notimer ...`, etc). * Merge branch 'fix-busy-prompt-timers' into event-8.5-perf-branch * Amend to timer-marker: dualize special state of timer-marker (to differentiate between timer generations), so: INT2PTR(-1) - exec immediate (marker reached); INT2PTR(-2) - check in the next-cycle (marker reached only if no other events available); Avoids permanent busy execution of prompt-events (always busy in timer), if they regenerate itself continuously for waiting for other events (like writable/readable), see e. g. socket-2.12. * "after at" set factor to 1000000 (seconds), test cases fixed * revert dual lists (relative/absolute) back to single list (because of better handling, a bit faster, etc.) * don't use tolerance in vwait, because of dual usage, it causes canceling of wait before end-time, on small timeout values (like 0.5, etc.) * call TclWinResetTimerResolution at end of sleep resp. wait for event (no calibration thread anymore) * calibration cycle completely rewritten (no calibration thread needed, soft drifts within 250ms intervals, fewer discrepancy and fewer virtual time gradation, etc). todo: implement resetting timer-resolution to original value (without calibration thread now). * extended performance test-cases (test-nrt-capability): RTS-near sleeps with very brief sleep-time. * chanio.test: optimize several tests cases running too long (shorten unwanted large sleeps) * bug fix: prevent setting of negative block-time by too few initial wait-time, that may expire immediately (for example `vwait 0.0001 test`). * extended performance test-cases (test-nrt-capability): covering of brief wait-times and other RTS-near constructs. * [unix] optimized Tcl_WaitForEvent similar to windows changes (makes Tcl for *nix more "RTS" resp. NRT-capable): - more precise waiting now (e.g. still microseconds by time up to 0.005 ms), important since after/vwait accepting microseconds (double); - avoids too long waiting on *nix wait/sleep primitives, e. g. by `timerate {vwait 0 a}` - 1.5µs now vs. 31.9µs before; - extended with new internal function TclpSleep (in contrast to Tcl_Sleep accept Tcl_Time, so microseconds); * added performance test-cases to cover timer-events speed resp. event-driven tcl-handling (cherry-picked and back-ported from tclSE-9) * fix sporadic errors on some fast cpu/platforms (because bgerror executed in background and it is an idle-event, give enough time to process it (resp. wait until last idle event is done); * make timer test-case more precise and time-independent, ignores short tolerance (deviation by waiting); several time-independent test-cases optimized (wait shorter now) + some new cases to cover more situations. * after info, after cancel: compare interpreter of the timer-events by direct retrieving via internal representation (ignore foreign events), test cases extended. * resolved some warnings / fixed unix resp. x64 compilation * code review + better usage of the waiting tolerance (fewer CPU-greedy now, avoid busy-wait if the rest of wait-time too small and can be neglected); TMR_RES_TOLERANCE can be defined to use wait-tolerance on *nix platforms (currently windows only as relation resp. deviation between default timer resolution 15.600 in exact milliseconds, means 15600/15000 + small overhead); Decreasing of TMR_RES_TOLERANCE (up to 0) makes tcl more "RTS" resp. NRT-capable (very precise wait-intervals, but more CPU-hungry). * [win] 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' * [win32] use timer resolution handling in Tcl_Sleep also; * Use auto-reset event object (system automatically resets the event state to nonsignaled after wake-up), avoids unwanted reset if wake-up for some other reasons (timeout/aio/message). * optimization of Tcl_LimitExceeded by internal usage (tclInt header) * dynamic increase of timer resolution corresponding wait-time; non-blocking wait for event - if block-time set outside an event source traversal, use it as timeout, so can return with result 0 (no events); * [enhancement] extend "vwait" with same options as "update", new syntax "vwait ?options? ?timeout? varname". some small improvements and fixing: - Tcl_DoOneEvent can wait for block time that was set with Tcl_SetMaxBlockTime outside an event source traversal, and stop waiting if Tcl_SetMaxBlockTime was called outside an event source (another event occurs and interrupt waiting loop), etc; - safer more precise pre-lookup by options (use TclObjIsIndexOfTable instead of simply comparison of type with tclIndexType); test cases extended to cover conditional "vwait" usage; * interim commit: try to extend "vwait" with same options as "update" * [performance] do one event (update / event servicing) cycle optimized (introduced threshold to prevent sourcing resp. waiting for new events by no-wait). [enhancement] new event type introduced: TCL_ASYNC_EVENTS, command "update" becomes options to process only specified types, resp. to bypass some event types (including -idle/-noidle that in opposite to "idletasks" does not included window events); test cases extended. * command "vwait" extended with timeout argument (in ms), 0 could be used to process pending events only (without wait), negative value equivalent execution of "vwait" without timeout (infinite); test cases fixed and extended; * [performance] large performance increase by event servicing cycles (3x - 5x faster now); [win] prevent listen using PeekMessage twice, and no wait anymore for too short timeouts (because windows can wait too long), compare 0µs with up-to 100µs overhead within MsgWaitForMultipleObjectsEx; [bad behavior] process idle events only as long as no other events available (now TclPeekEventQueued will be used to check new events are available in service idle cycle); [enhancement] new option "noidletasks" for command "update", so "update noidle" means "process all events but not idle"; * [performance] much better handling for timer events within Tcl_ServiceEvent using timer marker in the queue and direct call of TclServiceTimerEvents if marker reached (instead of continuous adding handler event, polling it in the queue and removing hereafter); this provides double performance increase in the service cycle; * [performance] introduced additional queue for prompt timer events (after 0) that should be executed immediately (no time); normalizes timer, prompt and idle events structures using common TimerEntry structure for all types; * bug fix: wrong release of after-id tcl-object if it switch type (object leak) * [bug/stable fix] don't execute TimerSetupProc directly (may be unwanted, because changes the blocking time, also if TCL_TIMER_EVENTS|TCL_IDLE_EVENTS not set), so let do that within Tcl_DoOneEvent cycle only (we have registered an event source). [performance] optimization for "after 0" as immediately execution without time (invoke as soon as possible) - generation and invocation of such timers twice faster now. [performance] leave handler-event in the queue as long as pending timers still available (with expired time or immediate timers) by generation lock, resp. changed/not invalidated timer-queue) - so fewer event/allocations and guarantee to be executed within the next event cycle; * after-id: introduced object of type "afterObjType" as self-referenced weak pointer to timer/idle event, used for fast access to the "after" event (cancel, info etc.); test cases extended to cover it additionally * rewrite interpreter limit handling using new timer event handling (with delete callback) * timer resp. idle events optimized: better handling using doubly linked lists, prevents allocating memory twice for the "after" events (use memory inside timer/idle event for the "after" structure), etc. * [performance] after-event list optimized (interp-assoc switched to doubly linked list, because requires handling from both ends of the list) closes ticket [0520d17284500573d7c46aa88e0c6b4ebc9b6a02] --- generic/tcl.h | 2 + generic/tclBasic.c | 1 + generic/tclClock.c | 46 +- generic/tclCmdMZ.c | 343 + generic/tclCompile.h | 22 + generic/tclEvent.c | 206 +- generic/tclExecute.c | 228 +- generic/tclIO.c | 101 +- generic/tclIO.h | 574 +- generic/tclIndexObj.c | 53 +- generic/tclInt.h | 207 +- generic/tclInterp.c | 65 +- generic/tclNotify.c | 521 +- generic/tclTimer.c | 1619 ++- library/init.tcl | 2 +- library/reg/pkgIndex.tcl | 10 + tests-perf/test-performance.tcl | 121 + tests-perf/timer-event.perf.tcl | 190 + tests/chanio.test | 12 +- tests/event.test | 241 +- tests/interp.test | 7125 +++++----- tests/io.test | 18 +- tests/timer.test | 461 +- unix/configure | 20988 +++++++++--------------------- unix/configure.in | 7 +- unix/tclUnixEvent.c | 72 - unix/tclUnixNotfy.c | 267 +- unix/tclUnixTime.c | 207 +- win/tclWinNotify.c | 467 +- win/tclWinTime.c | 1099 +- 30 files changed, 15201 insertions(+), 20074 deletions(-) create mode 100644 tests-perf/test-performance.tcl create mode 100644 tests-perf/timer-event.perf.tcl diff --git a/generic/tcl.h b/generic/tcl.h index 64c4683d1d53..b65a5cb029c6 100644 --- a/generic/tcl.h +++ b/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) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 44cf54316765..83e1a7522914 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -203,6 +203,7 @@ static const CmdInfo builtInCmds[] = { {"source", Tcl_SourceObjCmd, NULL, 0}, {"tell", Tcl_TellObjCmd, NULL, 1}, {"time", Tcl_TimeObjCmd, NULL, 1}, + {"timerate", Tcl_TimeRateObjCmd, NULL, 1}, {"unload", Tcl_UnloadObjCmd, NULL, 0}, {"update", Tcl_UpdateObjCmd, NULL, 1}, {"vwait", Tcl_VwaitObjCmd, NULL, 1}, diff --git a/generic/tclClock.c b/generic/tclClock.c index 782c68191d92..090eac000e6f 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[]); @@ -212,6 +215,7 @@ static const struct ClockCommand clockCommands[] = { { "getenv", ClockGetenvObjCmd }, { "microseconds", ClockMicrosecondsObjCmd }, { "milliseconds", ClockMillisecondsObjCmd }, + { "monotonic", ClockMonotonicObjCmd }, { "seconds", ClockSecondsObjCmd }, { "Oldscan", TclClockOldscanObjCmd }, { "ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd }, @@ -1739,9 +1743,7 @@ ClockClicksObjCmd( break; } case CLICKS_MICROS: - Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - ((Tcl_WideInt) now.sec * 1000000) + now.usec)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds())); break; } @@ -1810,15 +1812,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 30586b1fdc70..2b96c5a8dff1 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -17,6 +17,7 @@ */ #include "tclInt.h" +#include "tclCompile.h" #include "tclRegexp.h" static int UniCharIsAscii(int character); @@ -3938,6 +3939,348 @@ Tcl_TimeObjCmd( return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * 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 + }; + + 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 = Tcl_GetWideIntFromObj(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 */ + result = TclExecuteByteCode(interp, codePtr); + } 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; +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompile.h b/generic/tclCompile.h index bc298aea8b35..ee994d72ee65 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -859,6 +859,9 @@ MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp, *---------------------------------------------------------------- */ +MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + const CmdFrame *invoker, int word); + MODULE_SCOPE int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, int word); @@ -937,6 +940,25 @@ MODULE_SCOPE void TclPrintSource(FILE *outFile, CONST char *string, int maxChars); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); + +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 int TclSingleOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 4db524c198c5..4bc9219deb28 100644 --- a/generic/tclEvent.c +++ b/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,44 +1380,138 @@ Tcl_VwaitObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - int done, foundEvent; + int done = 0, foundEvent = 1, limit = 0, checktime = 0; + int flags = TCL_ALL_EVENTS; /* default flags */ 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; + } + } + + done = 0; + + /* + * 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_TraceVar(interp, nameString, 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 (flags & TCL_DONT_WAIT) { + foundEvent = 1; + done = -2; + } else if (usec > 0 && foundEvent == 0) { + foundEvent = 1; + } + /* 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)) { + limit = 1; + foundEvent = 0; break; } - } + } while (!done); + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); + /* if timeout specified (and no errors) */ + if (usec != -1 && foundEvent > 0) { + 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); + if (limit) { + Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } - if (!done) { - Tcl_AppendResult(interp, "limit exceeded", NULL); + if (foundEvent <= 0) { + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, + "\": would wait forever", NULL); return TCL_ERROR; } return TCL_OK; @@ -1409,28 +1559,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 +1574,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; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e85863dc3abc..61d0ddc8d36e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1346,48 +1346,29 @@ FreeExprCodeInternalRep( /* *---------------------------------------------------------------------- * - * TclCompEvalObj -- + * TclCompileObj -- * - * This procedure evaluates the script contained in a Tcl_Obj by first - * compiling it and then passing it to TclExecuteByteCode. + * This procedure compiles the script contained in a Tcl_Obj. * * Results: - * The return value is one of the return codes defined in tcl.h (such as - * TCL_OK), and interp->objResultPtr refers to a Tcl object that either - * contains the result of executing the code or an error message. + * A pointer to the corresponding ByteCode, never NULL. * * Side effects: - * Almost certainly, depending on the ByteCode's instructions. + * The object is shimmered to bytecode type. * *---------------------------------------------------------------------- */ -int -TclCompEvalObj( - Tcl_Interp *interp, +ByteCode * +TclCompileObj( + Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, int word) { register Interp *iPtr = (Interp *) interp; register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ - int result; - Namespace *namespacePtr; - - /* - * Check that the interpreter is ready to execute scripts. Note that we - * manage the interp's runlevel here: it is a small white lie (maybe), but - * saves a ++/-- pair at each invocation. Amazingly enough, the impact on - * performance is noticeable. - */ - - iPtr->numLevels++; - if (TclInterpReady(interp) == TCL_ERROR) { - result = TCL_ERROR; - goto done; - } - - namespacePtr = iPtr->varFramePtr->nsPtr; + Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; /* * If the object is not already of tclByteCodeType, compile it (and reset @@ -1418,19 +1399,24 @@ TclCompEvalObj( || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - /* - * This byteCode is invalid: free it and recompile. - */ - - objPtr->typePtr->freeIntRepProc(objPtr); + if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto recompileObj; } + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } + + /* + * Check that any compiled locals do refer to the current proc + * environment! If not, recompile. + */ + + if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && + (codePtr->procPtr == NULL) && + (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ + goto recompileObj; } /* @@ -1468,77 +1454,68 @@ TclCompEvalObj( * information. */ - if (invoker) { + if (invoker == NULL) { + return codePtr; + } else { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - int redo = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - - *ctxPtr = *invoker; + ExtCmdLoc *eclPtr; + CmdFrame *ctxCopyPtr; + int redo; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ + if (!hePtr) { + return codePtr; + } - TclGetSrcInfoForPc(ctxPtr); - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is - * dead. - */ + eclPtr = Tcl_GetHashValue(hePtr); + redo = 0; + ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxCopyPtr = *invoker; - Tcl_DecrRefCount(ctxPtr->data.eval.path); - ctxPtr->data.eval.path = NULL; - } - } + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ - if (word < ctxPtr->nline) { + TclGetSrcInfoForPc(ctxCopyPtr); + if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) { /* - * Note: We do not care if the line[word] is -1. This - * is a difference and requires a recompile (location - * changed from absolute to relative, literal is used - * fixed and through variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). + * The reference made by 'TclGetSrcInfoForPc' is dead. */ - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxPtr->type == TCL_LOCATION_SOURCE)); + Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); + ctxCopyPtr->data.eval.path = NULL; } + } - TclStackFree(interp, ctxPtr); + if (word < ctxCopyPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This is a + * difference and requires a recompile (location changed from + * absolute to relative, literal is used fixed and through + * variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ - if (redo) { - goto recompileObj; - } + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxCopyPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); } - } - - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ - runCompiledObj: - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); + TclStackFree(interp, ctxCopyPtr); + if (!redo) { + return codePtr; + } } - goto done; } - recompileObj: + recompileObj: iPtr->errorLine = 1; /* @@ -1550,12 +1527,75 @@ TclCompEvalObj( iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; - tclByteCodeType.setFromAnyProc(interp, objPtr); + TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; - goto runCompiledObj; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } + return codePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompEvalObj -- + * + * This procedure evaluates the script contained in a Tcl_Obj by first + * compiling it and then passing it to TclExecuteByteCode. + * + * Results: + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp->objResultPtr refers to a Tcl object that either + * contains the result of executing the code or an error message. + * + * Side effects: + * Almost certainly, depending on the ByteCode's instructions. + * + *---------------------------------------------------------------------- + */ + +int +TclCompEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + const CmdFrame *invoker, + int word) +{ + register Interp *iPtr = (Interp *) interp; + register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ + int result; + + /* + * Check that the interpreter is ready to execute scripts. Note that we + * manage the interp's runlevel here: it is a small white lie (maybe), but + * saves a ++/-- pair at each invocation. Amazingly enough, the impact on + * performance is noticeable. + */ + + iPtr->numLevels++; + if (TclInterpReady(interp) == TCL_ERROR) { + result = TCL_ERROR; + goto done; + } + + /* Compile objPtr to the byte code */ + codePtr = TclCompileObj(interp, objPtr, invoker, word); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } - done: + done: iPtr->numLevels--; return result; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 2e1569fa5a6c..9f2a35e586d0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -167,7 +167,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); @@ -1586,7 +1586,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; @@ -2965,10 +2965,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. @@ -3447,10 +3454,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 @@ -4384,7 +4398,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. @@ -4665,7 +4679,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. @@ -7982,7 +7996,7 @@ Tcl_NotifyChannel( * None. * * Side effects: - * May schedule a timer or driver handler. + * May schedule a event or driver handler. * *---------------------------------------------------------------------- */ @@ -8011,7 +8025,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. */ @@ -8040,7 +8054,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. @@ -8062,9 +8076,13 @@ UpdateInterest( mask &= ~TCL_EXCEPTION; - if (!statePtr->timer) { - statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, - chanPtr); + if (!statePtr->schedEvent) { + Tcl_Event *evPtr = (Tcl_Event *)ckalloc( + sizeof(Tcl_Event) + sizeof(Channel*)); + *(Channel**)(evPtr+1) = chanPtr; + evPtr->proc = ChannelScheduledProc; + statePtr->schedEvent = evPtr; + Tcl_QueueEvent(evPtr, TCL_QUEUE_TAIL); } } } @@ -8074,9 +8092,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: @@ -8088,31 +8106,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(0, ChannelTimerProc,chanPtr); + statePtr->schedEvent->proc = ChannelScheduledProc; /* reattach to tail */ + Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); Tcl_Release(statePtr); - } else { - statePtr->timer = NULL; - UpdateInterest(chanPtr); + + return 1; } + + statePtr->schedEvent = NULL; /* event done. */ + UpdateInterest(chanPtr); + return 1; } /* @@ -8565,9 +8593,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: @@ -8579,14 +8607,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; } /* @@ -8703,7 +8734,11 @@ TclCopyChannel( */ if ((nonBlocking == CHANNEL_NONBLOCKING) && (toRead == 0)) { - Tcl_CreateTimerHandler(0, ZeroTransferTimerProc, csPtr); + Tcl_Event *evPtr = (Tcl_Event *)ckalloc( + sizeof(Tcl_Event) + sizeof(ClientData*)); + *(ClientData*)(evPtr+1) = csPtr; + evPtr->proc = ZeroTransferEventProc; + Tcl_QueueEvent(evPtr, TCL_QUEUE_TAIL); return 0; } diff --git a/generic/tclIO.h b/generic/tclIO.h index d0967981b1a8..d11d5bef9f0a 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -1,287 +1,287 @@ -/* - * tclIO.h -- - * - * This file provides the generic portions (those that are the same on - * all platforms and for all channel types) of Tcl's IO facilities. - * - * Copyright (c) 1998-2000 Ajuba Solutions - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/* - * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not - * compile on systems where neither is defined. We want both defined so that - * we can test safely for both. In the code we still have to test for both - * because there may be systems on which both are defined and have different - * values. - */ - -#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) -# define EWOULDBLOCK EAGAIN -#endif -#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) -# define EAGAIN EWOULDBLOCK -#endif -#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) -#error one of EWOULDBLOCK or EAGAIN must be defined -#endif - -/* - * struct ChannelBuffer: - * - * Buffers data being sent to or from a channel. - */ - -typedef struct ChannelBuffer { - int refCount; /* Current uses count */ - int nextAdded; /* The next position into which a character - * will be put in the buffer. */ - int nextRemoved; /* Position of next byte to be removed from - * the buffer. */ - int bufLength; /* How big is the buffer? */ - struct ChannelBuffer *nextPtr; - /* Next buffer in chain. */ - char buf[4]; /* Placeholder for real buffer. The real - * buffer occuppies this space + bufSize-4 - * bytes. This must be the last field in the - * structure. */ -} ChannelBuffer; - -#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) - -/* - * How much extra space to allocate in buffer to hold bytes from previous - * buffer (when converting to UTF-8) or to hold bytes that will go to next - * buffer (when converting from UTF-8). - */ - -#define BUFFER_PADDING 16 - -/* - * The following defines the *default* buffer size for channels. - */ - -#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) - -/* - * The following structure describes the information saved from a call to - * "fileevent". This is used later when the event being waited for to invoke - * the saved script in the interpreter designed in this record. - */ - -typedef struct EventScriptRecord { - struct Channel *chanPtr; /* The channel for which this script is - * registered. This is used only when an error - * occurs during evaluation of the script, to - * delete the handler. */ - Tcl_Obj *scriptPtr; /* Script to invoke. */ - Tcl_Interp *interp; /* In what interpreter to invoke script? */ - int mask; /* Events must overlap current mask for the - * stored script to be invoked. */ - struct EventScriptRecord *nextPtr; - /* Next in chain of records. */ -} EventScriptRecord; - -/* - * struct Channel: - * - * One of these structures is allocated for each open channel. It contains - * data specific to the channel but which belongs to the generic part of the - * Tcl channel mechanism, and it points at an instance specific (and type - * specific) instance data, and at a channel type structure. - */ - -typedef struct Channel { - struct ChannelState *state; /* Split out state information */ - ClientData instanceData; /* Instance-specific data provided by creator - * of channel. */ - Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ - struct Channel *downChanPtr;/* Refers to channel this one was stacked - * upon. This reference is NULL for normal - * channels. See Tcl_StackChannel. */ - struct Channel *upChanPtr; /* Refers to the channel above stacked this - * one. NULL for the top most channel. */ - - /* - * Intermediate buffers to hold pre-read data for consumption by a newly - * stacked transformation. See 'Tcl_StackChannel'. - */ - - ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ - ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ - - int refCount; -} Channel; - -/* - * struct ChannelState: - * - * One of these structures is allocated for each open channel. It contains - * data specific to the channel but which belongs to the generic part of the - * Tcl channel mechanism, and it points at an instance specific (and type - * specific) instance data, and at a channel type structure. - */ - -typedef struct ChannelState { - char *channelName; /* The name of the channel instance in Tcl - * commands. Storage is owned by the generic - * IO code, is dynamically allocated. */ - int flags; /* ORed combination of the flags defined - * below. */ - Tcl_Encoding encoding; /* Encoding to apply when reading or writing - * data on this channel. NULL means no - * encoding is applied to data. */ - Tcl_EncodingState inputEncodingState; - /* Current encoding state, used when - * converting input data bytes to UTF-8. */ - int inputEncodingFlags; /* Encoding flags to pass to conversion - * routine when converting input data bytes to - * UTF-8. May be TCL_ENCODING_START before - * converting first byte and TCL_ENCODING_END - * when EOF is seen. */ - Tcl_EncodingState outputEncodingState; - /* Current encoding state, used when - * converting UTF-8 to output data bytes. */ - int outputEncodingFlags; /* Encoding flags to pass to conversion - * routine when converting UTF-8 to output - * data bytes. May be TCL_ENCODING_START - * before converting first byte and - * TCL_ENCODING_END when EOF is seen. */ - TclEolTranslation inputTranslation; - /* What translation to apply for end of line - * sequences on input? */ - TclEolTranslation outputTranslation; - /* What translation to use for generating end - * of line sequences in output? */ - int inEofChar; /* If nonzero, use this as a signal of EOF on - * input. */ - int outEofChar; /* If nonzero, append this to the channel when - * it is closed if it is open for writing. */ - int unreportedError; /* Non-zero if an error report was deferred - * because it happened in the background. The - * value is the POSIX error code. */ - int refCount; /* How many interpreters hold references to - * this IO channel? */ - struct CloseCallback *closeCbPtr; - /* Callbacks registered to be called when the - * channel is closed. */ - char *outputStage; /* Temporary staging buffer used when - * translating EOL before converting from - * UTF-8 to external form. */ - ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ - ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ - ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ - ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates - * need to allocate a new buffer for "gets" - * that crosses buffer boundaries. */ - ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ - ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ - struct ChannelHandler *chPtr;/* List of channel handlers registered for - * this channel. */ - int interestMask; /* Mask of all events this channel has - * handlers for. */ - EventScriptRecord *scriptRecordPtr; - /* 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. */ - struct CopyState *csPtrR; /* State of background copy for which channel - * is input, or NULL. */ - struct CopyState *csPtrW; /* State of background copy for which channel - * is output, or NULL. */ - Channel *topChanPtr; /* Refers to topmost channel in a stack. Never - * NULL. */ - Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. - * This channel can be relied on to live as - * long as the channel state. Never NULL. */ - struct ChannelState *nextCSPtr; - /* Next in list of channels currently open. */ - Tcl_ThreadId managingThread;/* TIP #10: Id of the thread managing this - * stack of channels. */ - - /* - * TIP #219 ... Info for the I/O system ... - * Error message set by channel drivers, for the propagation of arbitrary - * Tcl errors. This information, if present (chanMsg not NULL), takes - * precedence over a posix error code returned by a channel operation. - */ - - Tcl_Obj* chanMsg; - Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was deferred - * because it happened in the background. The - * value is the chanMg, if any. #219's - * companion to 'unreportedError'. */ - int epoch; /* Used to test validity of stored channelname - * lookup results. */ -} ChannelState; - -/* - * Values for the flags field in Channel. Any ORed combination of the - * following flags can be stored in the field. These flags record various - * options and state bits about the channel. In addition to the flags below, - * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. - */ - -#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in nonblocking - * mode. */ -#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be - * flushed after every newline. */ -#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always - * be flushed immediately. */ -#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the queued - * output buffers has been - * scheduled. */ -#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No further - * Tcl-level IO on the channel is - * allowed. */ -#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. This - * bit is cleared before every input - * operation. */ -#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel - * because we saw the input - * eofChar. This bit prevents clearing - * of the EOF bit before every input - * operation. */ -#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred on - * this channel. This bit is cleared - * before every input or output - * operation. */ -#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input - * translation mode and the last byte - * seen was a "\r". */ -#define CHANNEL_DEAD (1<<13) /* The channel has been closed by the - * exit handler (on exit) but not - * deallocated. When any IO operation - * sees this flag on a channel, it - * does not call driver level - * functions to avoid referring to - * deallocated data. */ -#define CHANNEL_NEED_MORE_DATA (1<<14) /* The last input operation failed - * because there was not enough data - * to complete the operation. This - * flag is set when gets fails to get - * a complete line or when read fails - * to get a complete character. When - * set, file events will not be - * delivered for buffered data until - * the state of the channel - * changes. */ -#define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is - * being used. */ - -#define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. - * Its structures are still live and - * usable, but it may not be closed - * again from within the close - * handler. */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ +/* + * tclIO.h -- + * + * This file provides the generic portions (those that are the same on + * all platforms and for all channel types) of Tcl's IO facilities. + * + * Copyright (c) 1998-2000 Ajuba Solutions + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +/* + * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not + * compile on systems where neither is defined. We want both defined so that + * we can test safely for both. In the code we still have to test for both + * because there may be systems on which both are defined and have different + * values. + */ + +#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) +# define EWOULDBLOCK EAGAIN +#endif +#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) +# define EAGAIN EWOULDBLOCK +#endif +#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) +#error one of EWOULDBLOCK or EAGAIN must be defined +#endif + +/* + * struct ChannelBuffer: + * + * Buffers data being sent to or from a channel. + */ + +typedef struct ChannelBuffer { + int refCount; /* Current uses count */ + int nextAdded; /* The next position into which a character + * will be put in the buffer. */ + int nextRemoved; /* Position of next byte to be removed from + * the buffer. */ + int bufLength; /* How big is the buffer? */ + struct ChannelBuffer *nextPtr; + /* Next buffer in chain. */ + char buf[4]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-4 + * bytes. This must be the last field in the + * structure. */ +} ChannelBuffer; + +#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) + +/* + * How much extra space to allocate in buffer to hold bytes from previous + * buffer (when converting to UTF-8) or to hold bytes that will go to next + * buffer (when converting from UTF-8). + */ + +#define BUFFER_PADDING 16 + +/* + * The following defines the *default* buffer size for channels. + */ + +#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) + +/* + * The following structure describes the information saved from a call to + * "fileevent". This is used later when the event being waited for to invoke + * the saved script in the interpreter designed in this record. + */ + +typedef struct EventScriptRecord { + struct Channel *chanPtr; /* The channel for which this script is + * registered. This is used only when an error + * occurs during evaluation of the script, to + * delete the handler. */ + Tcl_Obj *scriptPtr; /* Script to invoke. */ + Tcl_Interp *interp; /* In what interpreter to invoke script? */ + int mask; /* Events must overlap current mask for the + * stored script to be invoked. */ + struct EventScriptRecord *nextPtr; + /* Next in chain of records. */ +} EventScriptRecord; + +/* + * struct Channel: + * + * One of these structures is allocated for each open channel. It contains + * data specific to the channel but which belongs to the generic part of the + * Tcl channel mechanism, and it points at an instance specific (and type + * specific) instance data, and at a channel type structure. + */ + +typedef struct Channel { + struct ChannelState *state; /* Split out state information */ + ClientData instanceData; /* Instance-specific data provided by creator + * of channel. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ + struct Channel *downChanPtr;/* Refers to channel this one was stacked + * upon. This reference is NULL for normal + * channels. See Tcl_StackChannel. */ + struct Channel *upChanPtr; /* Refers to the channel above stacked this + * one. NULL for the top most channel. */ + + /* + * Intermediate buffers to hold pre-read data for consumption by a newly + * stacked transformation. See 'Tcl_StackChannel'. + */ + + ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ + ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + + int refCount; +} Channel; + +/* + * struct ChannelState: + * + * One of these structures is allocated for each open channel. It contains + * data specific to the channel but which belongs to the generic part of the + * Tcl channel mechanism, and it points at an instance specific (and type + * specific) instance data, and at a channel type structure. + */ + +typedef struct ChannelState { + char *channelName; /* The name of the channel instance in Tcl + * commands. Storage is owned by the generic + * IO code, is dynamically allocated. */ + int flags; /* ORed combination of the flags defined + * below. */ + Tcl_Encoding encoding; /* Encoding to apply when reading or writing + * data on this channel. NULL means no + * encoding is applied to data. */ + Tcl_EncodingState inputEncodingState; + /* Current encoding state, used when + * converting input data bytes to UTF-8. */ + int inputEncodingFlags; /* Encoding flags to pass to conversion + * routine when converting input data bytes to + * UTF-8. May be TCL_ENCODING_START before + * converting first byte and TCL_ENCODING_END + * when EOF is seen. */ + Tcl_EncodingState outputEncodingState; + /* Current encoding state, used when + * converting UTF-8 to output data bytes. */ + int outputEncodingFlags; /* Encoding flags to pass to conversion + * routine when converting UTF-8 to output + * data bytes. May be TCL_ENCODING_START + * before converting first byte and + * TCL_ENCODING_END when EOF is seen. */ + TclEolTranslation inputTranslation; + /* What translation to apply for end of line + * sequences on input? */ + TclEolTranslation outputTranslation; + /* What translation to use for generating end + * of line sequences in output? */ + int inEofChar; /* If nonzero, use this as a signal of EOF on + * input. */ + int outEofChar; /* If nonzero, append this to the channel when + * it is closed if it is open for writing. */ + int unreportedError; /* Non-zero if an error report was deferred + * because it happened in the background. The + * value is the POSIX error code. */ + int refCount; /* How many interpreters hold references to + * this IO channel? */ + struct CloseCallback *closeCbPtr; + /* Callbacks registered to be called when the + * channel is closed. */ + char *outputStage; /* Temporary staging buffer used when + * translating EOL before converting from + * UTF-8 to external form. */ + ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ + ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ + ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ + ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates + * need to allocate a new buffer for "gets" + * that crosses buffer boundaries. */ + ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ + ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + struct ChannelHandler *chPtr;/* List of channel handlers registered for + * this channel. */ + int interestMask; /* Mask of all events this channel has + * handlers for. */ + EventScriptRecord *scriptRecordPtr; + /* Chain of all scripts registered for event + * handlers ("fileevent") on this channel. */ + int bufSize; /* What size buffers to allocate? */ + 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 + * is output, or NULL. */ + Channel *topChanPtr; /* Refers to topmost channel in a stack. Never + * NULL. */ + Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. + * This channel can be relied on to live as + * long as the channel state. Never NULL. */ + struct ChannelState *nextCSPtr; + /* Next in list of channels currently open. */ + Tcl_ThreadId managingThread;/* TIP #10: Id of the thread managing this + * stack of channels. */ + + /* + * TIP #219 ... Info for the I/O system ... + * Error message set by channel drivers, for the propagation of arbitrary + * Tcl errors. This information, if present (chanMsg not NULL), takes + * precedence over a posix error code returned by a channel operation. + */ + + Tcl_Obj* chanMsg; + Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was deferred + * because it happened in the background. The + * value is the chanMg, if any. #219's + * companion to 'unreportedError'. */ + int epoch; /* Used to test validity of stored channelname + * lookup results. */ +} ChannelState; + +/* + * Values for the flags field in Channel. Any ORed combination of the + * following flags can be stored in the field. These flags record various + * options and state bits about the channel. In addition to the flags below, + * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. + */ + +#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in nonblocking + * mode. */ +#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be + * flushed after every newline. */ +#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always + * be flushed immediately. */ +#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the queued + * output buffers has been + * scheduled. */ +#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No further + * Tcl-level IO on the channel is + * allowed. */ +#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. This + * bit is cleared before every input + * operation. */ +#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel + * because we saw the input + * eofChar. This bit prevents clearing + * of the EOF bit before every input + * operation. */ +#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred on + * this channel. This bit is cleared + * before every input or output + * operation. */ +#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input + * translation mode and the last byte + * seen was a "\r". */ +#define CHANNEL_DEAD (1<<13) /* The channel has been closed by the + * exit handler (on exit) but not + * deallocated. When any IO operation + * sees this flag on a channel, it + * does not call driver level + * functions to avoid referring to + * deallocated data. */ +#define CHANNEL_NEED_MORE_DATA (1<<14) /* The last input operation failed + * because there was not enough data + * to complete the operation. This + * flag is set when gets fails to get + * a complete line or when read fails + * to get a complete character. When + * set, file events will not be + * delivered for buffered data until + * the state of the channel + * changes. */ +#define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is + * being used. */ + +#define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. + * Its structures are still live and + * usable, but it may not be closed + * again from within the close + * handler. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 73ba515670e9..4caba7a6069a 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -27,7 +27,7 @@ static void FreeIndex(Tcl_Obj *objPtr); * that can be invoked by generic object code. */ -static Tcl_ObjType indexType = { +Tcl_ObjType tclIndexType = { "index", /* name */ FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ @@ -60,6 +60,43 @@ typedef struct { #define EXPAND_OF(indexRep) \ STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) +/* + *---------------------------------------------------------------------- + * + * 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; +} + /* *---------------------------------------------------------------------- * @@ -105,7 +142,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; /* @@ -179,7 +216,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; @@ -240,13 +277,13 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr->typePtr == &indexType) { + if (objPtr->typePtr == &tclIndexType) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { TclFreeIntRep(objPtr); indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; + objPtr->typePtr = &tclIndexType; } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; @@ -382,7 +419,7 @@ DupIndex( memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; - dupPtr->typePtr = &indexType; + dupPtr->typePtr = &tclIndexType; } /* @@ -532,7 +569,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; @@ -588,7 +625,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); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6113f23414cd..ecfa96a60f59 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 @@ -127,6 +137,58 @@ typedef int ptrdiff_t; # endif #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. @@ -1797,8 +1859,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 @@ -1946,18 +2007,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; \ @@ -1968,6 +2048,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: * @@ -2406,6 +2491,7 @@ MODULE_SCOPE Tcl_ObjType tclByteCodeType; MODULE_SCOPE Tcl_ObjType tclDoubleType; MODULE_SCOPE Tcl_ObjType tclEndOffsetType; MODULE_SCOPE Tcl_ObjType tclIntType; +MODULE_SCOPE Tcl_ObjType tclIndexType; MODULE_SCOPE Tcl_ObjType tclListType; MODULE_SCOPE Tcl_ObjType tclDictType; MODULE_SCOPE Tcl_ObjType tclProcBodyType; @@ -2475,12 +2561,19 @@ MODULE_SCOPE char tclEmptyString; #define TCL_DD_SHORTEST0 0x0 /* 'Shortest possible' after masking */ + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ +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 void TclAdvanceContinuations(int* line, int** next, int loc); @@ -2768,10 +2861,83 @@ MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclpFinalizeThreadDataThread(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 Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); MODULE_SCOPE int TclUtfCasecmp(CONST char *cs, CONST char *ct); @@ -2828,9 +2994,26 @@ 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); +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[]); @@ -3014,6 +3197,9 @@ MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, 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[]); @@ -3944,6 +4130,17 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, #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 dbbf10ab174c..0c98844a1913 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3042,6 +3042,8 @@ Tcl_MakeSafe( *---------------------------------------------------------------------- */ +#undef Tcl_LimitExceeded + int Tcl_LimitExceeded( Tcl_Interp *interp) @@ -3511,7 +3513,7 @@ TclLimitRemoveAllHandlers( */ if (iPtr->limit.timeEvent != NULL) { - Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); + TclpDeleteTimerEvent(iPtr->limit.timeEvent); iPtr->limit.timeEvent = NULL; } } @@ -3681,15 +3683,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. * @@ -3707,22 +3720,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 b45539aff383..0dd55c4c3fc5 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -31,6 +31,15 @@ typedef struct EventSource { struct EventSource *nextPtr; } 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. @@ -49,6 +58,8 @@ 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_Mutex queueMutex; /* Mutex to protect access to the previous * three fields. */ int serviceMode; /* One of TCL_SERVICE_NONE or @@ -70,6 +81,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; @@ -477,6 +497,12 @@ QueueEvent( tsdPtr->lastEventPtr = evPtr; } tsdPtr->firstEventPtr = evPtr; + + /* move timer event hereafter */ + if (tsdPtr->timerMarkerPtr == INT2PTR(-1)) { + tsdPtr->timerMarkerPtr = evPtr; + } + } else if (position == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance the @@ -494,10 +520,45 @@ QueueEvent( if (evPtr->nextPtr == NULL) { tsdPtr->lastEventPtr = evPtr; } + + /* move timer event hereafter */ + if (tsdPtr->timerMarkerPtr == INT2PTR(-1)) { + tsdPtr->timerMarkerPtr = evPtr; + } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } +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; + } + + /* + * Update 'last' and 'marker' events if either has been deleted. + */ + + if (evPtr->nextPtr == NULL) { + tsdPtr->lastEventPtr = prevPtr; + } + if (tsdPtr->markerEventPtr == evPtr) { + tsdPtr->markerEventPtr = prevPtr; + } + if (tsdPtr->timerMarkerPtr == evPtr) { + tsdPtr->timerMarkerPtr = prevPtr ? prevPtr : INT2PTR(-1); + } +} + /* *---------------------------------------------------------------------- * @@ -526,7 +587,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); @@ -540,47 +600,73 @@ Tcl_DeleteEvents( 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. - */ - - if (prevPtr == NULL) { - tsdPtr->firstEventPtr = evPtr->nextPtr; - } else { - prevPtr->nextPtr = evPtr->nextPtr; - } /* - * Update 'last' and 'marker' events if either has been deleted. + * This event should be deleted. Unlink it. */ - if (evPtr->nextPtr == NULL) { - tsdPtr->lastEventPtr = prevPtr; - } - if (tsdPtr->markerEventPtr == evPtr) { - tsdPtr->markerEventPtr = prevPtr; - } + UnlinkEvent(tsdPtr, evPtr, prevPtr); /* * Delete the event data structure. */ - hold = evPtr; - evPtr = evPtr->nextPtr; - ckfree((char *) hold); + ckfree((char *) evPtr); } else { /* * Event is to be retained. */ prevPtr = evPtr; - evPtr = evPtr->nextPtr; } + evPtr = nextPtr; } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } +void +TclpCancelEvent( + Tcl_Event *evPtr) /* Event to remove from queue. */ +{ + Tcl_Event *prevPtr = NULL; + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + Tcl_MutexLock(&(tsdPtr->queueMutex)); + + /* + * Search event to unlink from queue. + */ + + if (evPtr != tsdPtr->firstEventPtr) { + for (prevPtr = tsdPtr->firstEventPtr; + prevPtr && prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + if (!prevPtr) { + evPtr = NULL; /* not in queue (already removed) */ + } + } + + if (evPtr) { + /* + * Unlink it. + */ + + UnlinkEvent(tsdPtr, evPtr, prevPtr); + + /* + * Delete the event data structure. + */ + ckfree((char *) evPtr); + } + + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); +} + /* *---------------------------------------------------------------------- * @@ -610,28 +696,48 @@ Tcl_ServiceEvent( * matching this will be skipped for * processing later. */ { - Tcl_Event *evPtr, *prevPtr; + Tcl_Event *evPtr, *prevPtr = NULL; Tcl_EventProc *proc; int result; 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; } /* @@ -640,8 +746,15 @@ Tcl_ServiceEvent( */ Tcl_MutexLock(&(tsdPtr->queueMutex)); - for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; - evPtr = evPtr->nextPtr) { + for (evPtr = tsdPtr->firstEventPtr; + evPtr != NULL && tsdPtr->timerMarkerPtr != INT2PTR(-1); + evPtr = evPtr->nextPtr + ) { + + 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 @@ -660,6 +773,7 @@ Tcl_ServiceEvent( proc = evPtr->proc; if (proc == NULL) { + prevPtr = evPtr; continue; } evPtr->proc = NULL; @@ -676,38 +790,48 @@ Tcl_ServiceEvent( Tcl_MutexLock(&(tsdPtr->queueMutex)); if (result) { + /* * The event was processed, so remove it from the queue. */ - if (tsdPtr->firstEventPtr == evPtr) { - tsdPtr->firstEventPtr = evPtr->nextPtr; - if (evPtr->nextPtr == NULL) { - tsdPtr->lastEventPtr = NULL; - } - if (tsdPtr->markerEventPtr == evPtr) { - tsdPtr->markerEventPtr = NULL; - } - } else { + prevPtr = NULL; + if (evPtr != tsdPtr->firstEventPtr) { 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; - } - } else { + if (!prevPtr) { evPtr = NULL; } } if (evPtr) { - ckfree((char *) evPtr); + /* Detach event from queue */ + UnlinkEvent(tsdPtr, evPtr, prevPtr); + + /* If wanted to prolong (repeat) */ + if (evPtr->proc) { + /* + * Event was restored (prolonged) - sign to reattach to tail + */ + if (evPtr != tsdPtr->lastEventPtr) { + /* detach event from queue */ + UnlinkEvent(tsdPtr, evPtr, prevPtr); + /* attach to tail */ + evPtr->nextPtr = NULL; + if (tsdPtr->firstEventPtr == NULL) { + tsdPtr->firstEventPtr = evPtr; + } else { + tsdPtr->lastEventPtr->nextPtr = evPtr; + } + tsdPtr->lastEventPtr = evPtr; + } + } else { + /* Free event */ + UnlinkEvent(tsdPtr, evPtr, prevPtr); + ckfree((char *) evPtr); + } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; @@ -721,9 +845,197 @@ Tcl_ServiceEvent( } } 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 + +/* + *---------------------------------------------------------------------- + * + * 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) +{ + EventSource *sourcePtr; + 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. + */ + for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + if (sourcePtr->checkProc) { + (sourcePtr->checkProc)(sourcePtr->clientData, flags); + } + } + + } 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); + }; + } +} + /* *---------------------------------------------------------------------- * @@ -835,14 +1147,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). * *---------------------------------------------------------------------- */ @@ -859,22 +1175,36 @@ Tcl_DoOneEvent( EventSource *sourcePtr; Tcl_Time *timePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int blockTimeWasSet; /* - * The first thing we do is to service any asynchronous event handlers. + * No event flags is equivalent to TCL_ALL_EVENTS. */ - if (Tcl_AsyncReady()) { - (void) Tcl_AsyncInvoke(NULL, 0); - return 1; + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; } + /* Block time was set outside an event source traversal, caller has specified a waittime */ + blockTimeWasSet = tsdPtr->blockTimeSet; + /* - * No event flags is equivalent to 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 ((flags & TCL_ALL_EVENTS) == 0) { - flags |= TCL_ALL_EVENTS; + if (flags & TCL_ASYNC_EVENTS) { + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke(NULL, 0); + return 1; + } + + /* Async only and don't wait - return */ + if ( (flags & (TCL_ALL_EVENTS|TCL_DONT_WAIT)) + == (TCL_ASYNC_EVENTS|TCL_DONT_WAIT) ) { + return 0; + } } /* @@ -886,12 +1216,10 @@ Tcl_DoOneEvent( tsdPtr->serviceMode = TCL_SERVICE_NONE; /* - * 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. + * Main loop until servicing exact one event or block time resp. + * TCL_DONT_WAIT specified (infinite loop otherwise). */ - - while (1) { + 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 @@ -899,12 +1227,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)) { @@ -918,11 +1246,18 @@ 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 */ } /* @@ -939,7 +1274,7 @@ Tcl_DoOneEvent( } tsdPtr->inTraversal = 0; - if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) { + if (tsdPtr->blockTimeSet) { timePtr = &tsdPtr->blockTime; } else { timePtr = NULL; @@ -949,10 +1284,12 @@ 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); if (result < 0) { - result = 0; + if (blockTimeWasSet) { + result = 0; + } break; } @@ -984,14 +1321,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 @@ -1001,15 +1335,19 @@ 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) ); + + /* Reset block time earliest at the end of event cycle */ + tsdPtr->blockTimeSet = 0; tsdPtr->serviceMode = oldMode; return result; @@ -1141,6 +1479,29 @@ 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 33838ec42384..d22d32672424 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -12,22 +12,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 @@ -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,22 +44,9 @@ 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,41 +59,42 @@ 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) /* * Prototypes for functions referenced only in this file: @@ -133,16 +102,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; +}; /* *---------------------------------------------------------------------- @@ -168,12 +247,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; +} + /* *---------------------------------------------------------------------- * @@ -198,15 +405,20 @@ TimerExitProc( ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 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((char *) 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); } } } @@ -236,20 +448,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; } /* @@ -258,11 +601,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 @@ -277,43 +620,73 @@ TclCreateAbsoluteTimerHandler( Tcl_TimerProc *proc, ClientData clientData) { - register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; - ThreadSpecificData *tsdPtr; - - tsdPtr = InitTimer(); - timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + register TclTimerEvent *tmrEvent; + Tcl_WideInt usec; /* - * Fill in fields for the event. + * Compute when the event should fire (avoid overflow). */ - memcpy((void *)&timerHandlerPtr->time, (void *)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; } /* @@ -337,31 +710,182 @@ 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((char *) 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((char *)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; +} + + /* *---------------------------------------------------------------------- * @@ -382,38 +906,66 @@ 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 (tsdPtr == NULL) { tsdPtr = InitTimer(); }; - if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList) - || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) { + 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; } @@ -427,8 +979,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. @@ -441,59 +992,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 = (Tcl_Event *) 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. @@ -501,25 +1058,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 */ } /* @@ -528,9 +1077,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. @@ -547,39 +1094,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((char *) 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); + } - (*nextPtrPtr) = timerHandlerPtr->nextPtr; - (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); - ckfree((char *) timerHandlerPtr); + /* 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((char *) 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; + } } - TimerSetupProc(NULL, TCL_TIMER_EVENTS); - return 1; + + /* pending timer events, so mark (queue) timer events */ + if (tsdPtr->timerPending >= 1) { + tsdPtr->timerPending = 1; + 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 */ } /* @@ -600,31 +1248,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 = (IdleHandler *) 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); } /* @@ -650,26 +1283,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((char *) 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((char *) idlePtr); } } } @@ -677,7 +1310,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 @@ -694,19 +1327,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: @@ -725,24 +1358,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); + } ckfree((char *) 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); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetTimeFromObj -- + * + * 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; +} /* *---------------------------------------------------------------------- @@ -769,17 +1491,17 @@ Tcl_AfterObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_WideInt ms; /* 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; - char buf[16 + TCL_INTEGER_SPACE]; static CONST char *afterSubCmds[] = { - "cancel", "idle", "info", NULL + "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) { @@ -797,6 +1519,7 @@ Tcl_AfterObjCmd( assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; + assocPtr->lastAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, (ClientData) assocPtr); } @@ -805,38 +1528,77 @@ Tcl_AfterObjCmd( * First lets see if the command was passed a number as the first argument. */ - if (objv[1]->typePtr == &tclIntType -#ifndef NO_WIDE_TYPE - || 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) { - Tcl_AppendResult(interp, "bad argument \"", - Tcl_GetString(objv[1]), - "\": must be cancel, idle, info, or an integer", - 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 + ) { + Tcl_AppendResult(interp, "bad argument \"", + Tcl_GetString(objv[1]), + "\": must be at, cancel, idle, info or a time", 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 */ + return AfterDelay(interp, usec, 0); + } + 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