diff options
author | sebres <sebres@users.sourceforge.net> | 2019-03-05 17:34:31 (GMT) |
---|---|---|
committer | sebres <sebres@users.sourceforge.net> | 2019-03-05 17:34:31 (GMT) |
commit | df27b4e4e05a39d0241a2d4bc5aa87aee5851750 (patch) | |
tree | 619cd0773039ed7e42e7ecb6093f7bb5cc64096b | |
parent | 10591b96c8e649549d81f6672d42003de5450043 (diff) | |
parent | 78000f7f87aa86ac0fb04fbb8402c4fc2054d0fa (diff) | |
download | tcl-df27b4e4e05a39d0241a2d4bc5aa87aee5851750.zip tcl-df27b4e4e05a39d0241a2d4bc5aa87aee5851750.tar.gz tcl-df27b4e4e05a39d0241a2d4bc5aa87aee5851750.tar.bz2 |
merge 8.6 (TIP#527, New measurement facilities in TCL: New command timerate, performance test suite)
-rw-r--r-- | doc/timerate.n | 129 | ||||
-rw-r--r-- | generic/tclBasic.c | 28 | ||||
-rw-r--r-- | generic/tclClock.c | 9 | ||||
-rw-r--r-- | generic/tclCmdMZ.c | 387 | ||||
-rw-r--r-- | generic/tclInt.h | 15 | ||||
-rw-r--r-- | generic/tclPort.h | 3 | ||||
-rw-r--r-- | library/tclIndex | 3 | ||||
-rw-r--r-- | tests-perf/clock.perf.tcl | 411 | ||||
-rw-r--r-- | tests-perf/test-performance.tcl | 144 | ||||
-rw-r--r-- | tests-perf/timer-event.perf.tcl | 182 | ||||
-rw-r--r-- | tests/cmdMZ.test | 64 | ||||
-rw-r--r-- | tools/tcltk-man2html-utils.tcl | 1 | ||||
-rw-r--r-- | unix/tclUnixTime.c | 71 | ||||
-rw-r--r-- | win/tclWinTime.c | 428 |
14 files changed, 1777 insertions, 98 deletions
diff --git a/doc/timerate.n b/doc/timerate.n new file mode 100644 index 0000000..3c764c8 --- /dev/null +++ b/doc/timerate.n @@ -0,0 +1,129 @@ +'\" +'\" Copyright (c) 2005 Sergey Brester aka sebres. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH timerate n "" Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +timerate \- Time-related execution resp. performance measurement of a script +.SH SYNOPSIS +\fBtimerate \fIscript\fR \fI?time ?max-count??\fR +.sp +\fBtimerate \fI?-direct?\fR \fI?-overhead double?\fR \fIscript\fR \fI?time ?max-count??\fR +.sp +\fBtimerate \fI?-calibrate?\fR \fI?-direct?\fR \fIscript\fR \fI?time ?max-count??\fR +.BE +.SH DESCRIPTION +.PP +The first and second form will evaluate \fIscript\fR until the interval +\fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second) +if \fItime\fR is not specified. +.sp +The parameter \fImax-count\fR could additionally impose a further restriction +by the maximal number of iterations to evaluate the script. +If \fImax-count\fR is specified, the evalution will stop either this count of +iterations is reached or the time is exceeded. +.sp +It will then return a canonical tcl-list of the form +.PP +.CS +\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR +.CE +.PP +which indicates: +.IP \(bu +the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0]) +.IP \(bu +the count how many times it was executed ([\fBlindex\fR $result 2]) +.IP \(bu +the estimated rate per second ([\fBlindex\fR $result 4]) +.IP \(bu +the estimated real execution time without measurement overhead ([\fBlindex\fR $result 6]) +.PP +Time is measured in elapsed time using the finest timer resolution as possible, +not CPU time. +This command may be used to provide information as to how well the script or a +tcl-command is performing and can help determine bottlenecks and fine-tune +application performance. +.TP +\fI-calibrate\fR +. +To measure very fast scripts as exact as posible the calibration process +may be required. + +The \fI-calibrate\fR option is used to calibrate timerate, calculating the +estimated overhead of the given script as the default overhead for future +invocations of the \fBtimerate\fR command. If the \fItime\fR parameter is not +specified, the calibrate procedure runs for up to 10 seconds. +.TP +\fI-overhead double\fR +. +The \fI-overhead\fR parameter supplies an estimate (in microseconds) of the +measurement overhead of each iteration of the tested script. This quantity +will be subtracted from the measured time prior to reporting results. +.TP +\fI-direct\fR +. +The \fI-direct\fR option causes direct execution of the supplied script, +without compilation, in a manner similar to the \fBtime\fR command. It can be +used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical +lists, and of the uncompiled versions of bytecoded commands. +.PP +As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed +number of iterations, the timerate command runs it for a fixed time. +Additionally, the compiled variant of the script will be used during the entire +measurement, as if the script were part of a compiled procedure, if the \fI-direct\fR +option is not specified. The fixed time period and possibility of compilation allow +for more precise results and prevent very long execution times by slow scripts, making +it practical for measuring scripts with highly uncertain execution times. + +.SH EXAMPLE +Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including +operations on variable \fIi\fR) to count to a ten: +.PP +.CS +# calibrate: +timerate -calibrate {} +# measure: +timerate { for {set i 0} {$i<10} {incr i} {} } 5000 +.CE +.PP +Estimate how fast it takes for a simple Tcl \fBfor\fR loop, ignoring the +overhead for to perform ten iterations, ignoring the overhead of the management +of the variable that controls the loop: +.PP +.CS +# calibrate for overhead of variable operations: +set i 0; timerate -calibrate {expr {$i<10}; incr i} 1000 +# measure: +timerate { for {set i 0} {$i<10} {incr i} {} } 5000 +.CE +.PP +Estimate the speed of calculating the hour of the day using \fBclock format\fR only, +ignoring overhead of the portion of the script that prepares the time for it to +calculate: +.PP +.CS +# calibrate: +timerate -calibrate {} +# estimate overhead: +set tm 0 +set ovh [lindex [timerate { incr tm [expr {24*60*60}] }] 0] +# measure using esimated overhead: +set tm 0 +timerate -overhead $ovh { + clock format $tm -format %H + incr tm [expr {24*60*60}]; # overhead for this is ignored +} 5000 +.CE +.SH "SEE ALSO" +time(n) +.SH KEYWORDS +script, timerate, time +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 25b6f78..47579a4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -319,6 +319,9 @@ static const CmdInfo builtInCmds[] = { {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, +#ifdef TCL_TIMERATE + {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE}, +#endif {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -559,7 +562,7 @@ Tcl_CreateInterp(void) const BuiltinFuncDef *builtinFuncPtr; const OpCmdInfo *opcmdInfoPtr; const CmdInfo *cmdInfoPtr; - Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; + Tcl_Namespace *nsPtr; Tcl_HashEntry *hPtr; int isNew; CancelInfo *cancelInfo; @@ -974,6 +977,17 @@ Tcl_CreateInterp(void) Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); + /* Create an unsupported command for timerate */ + Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate", + Tcl_TimeRateObjCmd, NULL, NULL); + + /* Export unsupported commands */ + nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); + if (nsPtr) { + Tcl_Export(interp, nsPtr, "*", 1); + } + + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -986,8 +1000,8 @@ Tcl_CreateInterp(void) * Register the builtin math functions. */ - mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); - if (mathfuncNSPtr == NULL) { + nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); + if (nsPtr == NULL) { Tcl_Panic("Can't create math function namespace"); } #define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */ @@ -997,18 +1011,18 @@ Tcl_CreateInterp(void) strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); Tcl_CreateObjCommand(interp, mathFuncName, builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL); - Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0); + Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0); } /* * Register the mathematical "operator" commands. [TIP #174] */ - mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); - if (mathopNSPtr == NULL) { + nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); + if (nsPtr == NULL) { Tcl_Panic("can't create math operator namespace"); } - Tcl_Export(interp, mathopNSPtr, "*", 1); + Tcl_Export(interp, nsPtr, "*", 1); #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ diff --git a/generic/tclClock.c b/generic/tclClock.c index 233ddd2..aeff164 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1772,8 +1772,7 @@ ClockClicksObjCmd( #endif break; case CLICKS_MICROS: - Tcl_GetTime(&now); - clicks = ((Tcl_WideInt) now.sec * 1000000) + now.usec; + clicks = TclpGetMicroseconds(); break; } @@ -1843,15 +1842,11 @@ 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_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - ((Tcl_WideInt) now.sec * 1000000) + now.usec)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds())); return TCL_OK; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index bd93205..7349515 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -17,6 +17,7 @@ */ #include "tclInt.h" +#include "tclCompile.h" #include "tclRegexp.h" #include "tclStringTrim.h" @@ -4030,7 +4031,7 @@ Tcl_TimeObjCmd( start = TclpGetWideClicks(); #endif while (i-- > 0) { - result = Tcl_EvalObjEx(interp, objPtr, 0); + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); if (result != TCL_OK) { return result; } @@ -4070,6 +4071,390 @@ Tcl_TimeObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_TimeRateObjCmd -- + * + * This object-based procedure is invoked to process the "timerate" Tcl + * command. + * This is similar to command "time", except the execution limited by + * given time (in milliseconds) instead of repetition count. + * + * Example: + * timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]` + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TimeRateObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static + double measureOverhead = 0; /* global measure-overhead */ + double overhead = -1; /* given measure-overhead */ + register Tcl_Obj *objPtr; + register int result, i; + Tcl_Obj *calibrate = NULL, *direct = NULL; + Tcl_WideUInt count = 0; /* Holds repetition count */ + Tcl_WideInt maxms = WIDE_MIN; + /* Maximal running time (in milliseconds) */ + Tcl_WideUInt maxcnt = WIDE_MAX; + /* Maximal count of iterations. */ + Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster + * repeat count without time check) */ + Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max threshold + * additionally avoid divide to zero (never < 1) */ + unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid + * growth of execution time. */ + register Tcl_WideInt start, middle, stop; +#ifndef TCL_WIDE_CLICKS + Tcl_Time now; +#endif + + static const char *const options[] = { + "-direct", "-overhead", "-calibrate", "--", NULL + }; + enum options { + TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST + }; + + NRE_callback *rootPtr; + ByteCode *codePtr = NULL; + + for (i = 1; i < objc - 1; i++) { + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, + &index) != TCL_OK) { + break; + } + if (index == TMRT_LAST) { + i++; + break; + } + switch (index) { + case TMRT_EV_DIRECT: + direct = objv[i]; + break; + case TMRT_OVERHEAD: + if (++i >= objc - 1) { + goto usage; + } + if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) { + return TCL_ERROR; + } + break; + case TMRT_CALIBRATE: + calibrate = objv[i]; + break; + } + } + + if (i >= objc || i < objc-3) { +usage: + Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"); + return TCL_ERROR; + } + objPtr = objv[i++]; + if (i < objc) { /* max-time */ + result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms); + if (result != TCL_OK) { + return result; + } + if (i < objc) { /* max-count*/ + Tcl_WideInt v; + result = Tcl_GetWideIntFromObj(interp, objv[i], &v); + if (result != TCL_OK) { + return result; + } + maxcnt = (v > 0) ? v : 0; + } + } + + /* if calibrate */ + if (calibrate) { + + /* if no time specified for the calibration */ + if (maxms == WIDE_MIN) { + 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 */ + TclNewIntObj(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)UWIDE_MAX; + + /* calibration cycle until it'll be preciser */ + maxms = -1000; + do { + lastMeasureOverhead = measureOverhead; + TclNewIntObj(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)UWIDE_MAX; + } else { + maxms = -maxms; + } + + } + + if (maxms == WIDE_MIN) { + 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 */ + if (maxcnt > 0) + while (1) { + /* eval single iteration */ + count++; + + if (!direct) { + /* precompiled */ + rootPtr = TOP_CB(interp); + result = TclNRExecuteByteCode(interp, codePtr); + result = TclNRRunCallbacks(interp, result, rootPtr); + } else { + /* eval */ + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); + } + if (result != TCL_OK) { + /* allow break from measurement cycle (used for conditional stop) */ + if (result != TCL_BREAK) { + goto done; + } + /* force stop immediately */ + threshold = 1; + maxcnt = 0; + result = TCL_OK; + } + + /* 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 || count >= maxcnt) { + break; + } + + /* don't calculate threshold by few iterations, because sometimes first + * iteration(s) can be too fast or slow (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; + /* interations seems to be longer */ + if (threshold > (maxIterTm * 2)) { + if ((factor *= 2) > 50) factor = 50; + } else { + if (factor < 50) factor++; + } + } else if (factor > 4) { + /* interations seems to be shorter */ + if (threshold < (maxIterTm / 2)) { + if ((factor /= 2) < 4) factor = 4; + } else { + factor--; + } + } + /* as relation between remaining time and time since last check, + * maximal some % of time (by factor), so avoid growing of the execution time + * if iterations are not consistent, e. g. wax continuously on time) */ + threshold = ((stop - middle) / maxIterTm) / factor + 1; + if (threshold > 100000) { /* fix for too large threshold */ + threshold = 100000; + } + /* consider max-count */ + if (threshold > maxcnt - count) { + threshold = maxcnt - count; + } + } + + { + 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_WideUInt curOverhead = overhead * count; + if (middle > (Tcl_WideInt)curOverhead) { + middle -= curOverhead; + } else { + middle = 0; + } + } + } 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 < (WIDE_MAX / 1000000)) { + val = (count * 1000000) / middle; + if (val < 100000) { + if (val < 100) { fmt = "%.3f"; } else + if (val < 1000) { fmt = "%.2f"; } else + { fmt = "%.1f"; }; + objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle); + } else { + objs[4] = Tcl_NewWideIntObj(val); + } + } else { + objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000); + } + + /* estimated net execution time (in millisecs) */ + if (!calibrate) { + objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000); + TclNewLiteralStringObj(objs[7], "nett-ms"); + } + + /* + * Construct the result as a list because many programs have always parsed + * as such (extracting the first element, typically). + */ + + TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */ + TclNewLiteralStringObj(objs[3], "#"); + TclNewLiteralStringObj(objs[5], "#/sec"); + Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr)); + } + +done: + + if (codePtr != NULL) { + TclReleaseByteCode(codePtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_TryObjCmd, TclNRTryObjCmd -- * * This procedure is invoked to process the "try" Tcl command. See the diff --git a/generic/tclInt.h b/generic/tclInt.h index 3525bf5..3a77196 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3259,10 +3259,22 @@ MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); + #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); +MODULE_SCOPE double TclpWideClickInMicrosec(void); +#else +# ifdef _WIN32 +# define TCL_WIDE_CLICKS 1 +MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); +MODULE_SCOPE double TclpWideClickInMicrosec(void); +# define TclpWideClicksToNanoseconds(clicks) \ + ((double)(clicks) * TclpWideClickInMicrosec() * 1000) +# endif #endif +MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); + MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); @@ -3538,6 +3550,9 @@ MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclPort.h b/generic/tclPort.h index d3f6233..58e1f5e 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -27,5 +27,8 @@ #define UWIDE_MAX ((Tcl_WideUInt)-1) #define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) #define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) +#define UWIDE_MAX ((Tcl_WideUInt)-1) +#define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) +#define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) #endif /* _TCLPORT */ diff --git a/library/tclIndex b/library/tclIndex index 87a2814..5a702ad 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -73,3 +73,6 @@ set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm. set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]] set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +if {[namespace exists ::tcl::unsupported]} { + set auto_index(timerate) {namespace import ::tcl::unsupported::timerate} +} diff --git a/tests-perf/clock.perf.tcl b/tests-perf/clock.perf.tcl new file mode 100644 index 0000000..d574c2c --- /dev/null +++ b/tests-perf/clock.perf.tcl @@ -0,0 +1,411 @@ +#!/usr/bin/tclsh +# ------------------------------------------------------------------------ +# +# test-performance.tcl -- +# +# This file provides common performance tests for comparison of tcl-speed +# degradation by switching between branches. +# (currently for clock ensemble only) +# +# ------------------------------------------------------------------------ +# +# Copyright (c) 2014 Serg G. Brester (aka sebres) +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# + +array set in {-time 500} +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + array set in $argv +} + +## common test performance framework: +if {![namespace exists ::tclTestPerf]} { + source [file join [file dirname [info script]] test-performance.tcl] +} + +namespace eval ::tclTestPerf-TclClock { + +namespace path {::tclTestPerf} + +## set testing defaults: +set ::env(TCL_TZ) :CET + +# warm-up interpeter compiler env, clock platform-related features: + +## warm-up test-related features (load clock.tcl, system zones, locales, etc.): +clock scan "" -gmt 1 +clock scan "" +clock scan "" -timezone :CET +clock scan "" -format "" -locale en +clock scan "" -format "" -locale de + +## ------------------------------------------ + +proc test-format {{reptime 1000}} { + _test_run $reptime { + # Format : short, week only (in gmt) + {clock format 1482525936 -format "%u" -gmt 1} + # Format : short, week only (system zone) + {clock format 1482525936 -format "%u"} + # Format : short, week only (CEST) + {clock format 1482525936 -format "%u" -timezone :CET} + # Format : date only (in gmt) + {clock format 1482525936 -format "%Y-%m-%d" -gmt 1} + # Format : date only (system zone) + {clock format 1482525936 -format "%Y-%m-%d"} + # Format : date only (CEST) + {clock format 1482525936 -format "%Y-%m-%d" -timezone :CET} + # Format : time only (in gmt) + {clock format 1482525936 -format "%H:%M" -gmt 1} + # Format : time only (system zone) + {clock format 1482525936 -format "%H:%M"} + # Format : time only (CEST) + {clock format 1482525936 -format "%H:%M" -timezone :CET} + # Format : time only (in gmt) + {clock format 1482525936 -format "%H:%M:%S" -gmt 1} + # Format : time only (system zone) + {clock format 1482525936 -format "%H:%M:%S"} + # Format : time only (CEST) + {clock format 1482525936 -format "%H:%M:%S" -timezone :CET} + # Format : default (in gmt) + {clock format 1482525936 -gmt 1 -locale en} + # Format : default (system zone) + {clock format 1482525936 -locale en} + # Format : default (CEST) + {clock format 1482525936 -timezone :CET -locale en} + # Format : ISO date-time (in gmt, numeric zone) + {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -gmt 1} + # Format : ISO date-time (system zone, CEST, numeric zone) + {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z"} + # Format : ISO date-time (CEST, numeric zone) + {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -timezone :CET} + # Format : ISO date-time (system zone, CEST) + {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %Z"} + # Format : julian day with time (in gmt): + {clock format 1246379415 -format "%J %H:%M:%S" -gmt 1} + # Format : julian day with time (system zone): + {clock format 1246379415 -format "%J %H:%M:%S"} + + # Format : locale date-time (en): + {clock format 1246379415 -format "%x %X" -locale en} + # Format : locale date-time (de): + {clock format 1246379415 -format "%x %X" -locale de} + + # Format : locale lookup table month: + {clock format 1246379400 -format "%b" -locale en -gmt 1} + # Format : locale lookup 2 tables - month and day: + {clock format 1246379400 -format "%b %Od" -locale en -gmt 1} + # Format : locale lookup 3 tables - week, month and day: + {clock format 1246379400 -format "%a %b %Od" -locale en -gmt 1} + # Format : locale lookup 4 tables - week, month, day and year: + {clock format 1246379400 -format "%a %b %Od %Oy" -locale en -gmt 1} + + # Format : dynamic clock value (without converter caches): + setup {set i 0} + {clock format [incr i] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET} + cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]} + # Format : dynamic clock value (without any converter caches, zone range overflow): + setup {set i 0} + {clock format [incr i 86400] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET} + cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]} + + # Format : dynamic format (cacheable) + {clock format 1246379415 -format [string trim "%d.%m.%Y %H:%M:%S "] -gmt 1} + + # Format : all (in gmt, locale en) + {clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -gmt 1 -locale en} + # Format : all (in CET, locale de) + {clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de} + } +} + +proc test-scan {{reptime 1000}} { + _test_run $reptime { + # Scan : date (in gmt) + {clock scan "25.11.2015" -format "%d.%m.%Y" -base 0 -gmt 1} + # Scan : date (system time zone, with base) + {clock scan "25.11.2015" -format "%d.%m.%Y" -base 0} + # Scan : date (system time zone, without base) + {clock scan "25.11.2015" -format "%d.%m.%Y"} + # Scan : greedy match + {clock scan "111" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "1111" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "11111" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "111111" -format "%d%m%y" -base 0 -gmt 1} + # Scan : greedy match (space separated) + {clock scan "1 1 1" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "111 1" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "1 111" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "1 11 1" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "1 11 11" -format "%d%m%y" -base 0 -gmt 1} + {clock scan "11 11 11" -format "%d%m%y" -base 0 -gmt 1} + + # Scan : time (in gmt) + {clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000 -gmt 1} + # Scan : time (system time zone, with base) + {clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000} + # Scan : time (gmt, without base) + {clock scan "10:35:55" -format "%H:%M:%S" -gmt 1} + # Scan : time (system time zone, without base) + {clock scan "10:35:55" -format "%H:%M:%S"} + + # Scan : date-time (in gmt) + {clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0 -gmt 1} + # Scan : date-time (system time zone with base) + {clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0} + # Scan : date-time (system time zone without base) + {clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S"} + + # Scan : julian day in gmt + {clock scan 2451545 -format %J -gmt 1} + # Scan : julian day in system TZ + {clock scan 2451545 -format %J} + # Scan : julian day in other TZ + {clock scan 2451545 -format %J -timezone +0200} + # Scan : julian day with time: + {clock scan "2451545 10:20:30" -format "%J %H:%M:%S"} + # Scan : julian day with time (greedy match): + {clock scan "2451545 102030" -format "%J%H%M%S"} + + # Scan : century, lookup table month + {clock scan {1970 Jan 2} -format {%C%y %b %d} -locale en -gmt 1} + # Scan : century, lookup table month and day (both entries are first) + {clock scan {1970 Jan 01} -format {%C%y %b %Od} -locale en -gmt 1} + # Scan : century, lookup table month and day (list scan: entries with position 12 / 31) + {clock scan {2016 Dec 31} -format {%C%y %b %Od} -locale en -gmt 1} + + # Scan : ISO date-time (CEST) + {clock scan "2009-06-30T18:30:00+02:00" -format "%Y-%m-%dT%H:%M:%S%z"} + {clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"} + # Scan : ISO date-time (UTC) + {clock scan "2009-06-30T18:30:00Z" -format "%Y-%m-%dT%H:%M:%S%z"} + {clock scan "2009-06-30T18:30:00 UTC" -format "%Y-%m-%dT%H:%M:%S %z"} + + # Scan : locale date-time (en): + {clock scan "06/30/2009 18:30:15" -format "%x %X" -gmt 1 -locale en} + # Scan : locale date-time (de): + {clock scan "30.06.2009 18:30:15" -format "%x %X" -gmt 1 -locale de} + + # Scan : dynamic format (cacheable) + {clock scan "25.11.2015 10:35:55" -format [string trim "%d.%m.%Y %H:%M:%S "] -base 0 -gmt 1} + + break + # # Scan : long format test (allock chain) + # {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1} + # # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc): + # {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1} + # # Scan : again: + # {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1} + } {puts [clock format $_(r) -locale en]} +} + +proc test-freescan {{reptime 1000}} { + _test_run $reptime { + # FreeScan : relative date + {clock scan "5 years 18 months 385 days" -base 0 -gmt 1} + # FreeScan : relative date with relative weekday + {clock scan "5 years 18 months 385 days Fri" -base 0 -gmt 1} + # FreeScan : relative date with ordinal month + {clock scan "5 years 18 months 385 days next 1 January" -base 0 -gmt 1} + # FreeScan : relative date with ordinal month and relative weekday + {clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1} + # FreeScan : ordinal month + {clock scan "next January" -base 0 -gmt 1} + # FreeScan : relative week + {clock scan "next Fri" -base 0 -gmt 1} + # FreeScan : relative weekday and week offset + {clock scan "next January + 2 week" -base 0 -gmt 1} + # FreeScan : time only with base + {clock scan "19:18:30" -base 148863600 -gmt 1} + # FreeScan : time only without base, gmt + {clock scan "19:18:30" -gmt 1} + # FreeScan : time only without base, system + {clock scan "19:18:30"} + # FreeScan : date, system time zone + {clock scan "05/08/2016 20:18:30"} + # FreeScan : date, supplied time zone + {clock scan "05/08/2016 20:18:30" -timezone :CET} + # FreeScan : date, supplied gmt (equivalent -timezone :GMT) + {clock scan "05/08/2016 20:18:30" -gmt 1} + # FreeScan : date, supplied time zone gmt + {clock scan "05/08/2016 20:18:30" -timezone :GMT} + # FreeScan : time only, numeric zone in string, base time gmt (exchange zones between gmt / -0500) + {clock scan "20:18:30 -0500" -base 148863600 -gmt 1} + # FreeScan : time only, zone in string (exchange zones between system / gmt) + {clock scan "19:18:30 GMT" -base 148863600} + # FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST + {clock scan "19:18:30 MST" -base 148863600 -gmt 1 + clock scan "19:18:30 EST" -base 148863600 + } + } {puts [clock format $_(r) -locale en]} +} + +proc test-add {{reptime 1000}} { + set tests { + # Add : years + {clock add 1246379415 5 years -gmt 1} + # Add : months + {clock add 1246379415 18 months -gmt 1} + # Add : weeks + {clock add 1246379415 20 weeks -gmt 1} + # Add : days + {clock add 1246379415 385 days -gmt 1} + # Add : weekdays + {clock add 1246379415 3 weekdays -gmt 1} + + # Add : hours + {clock add 1246379415 5 hours -gmt 1} + # Add : minutes + {clock add 1246379415 55 minutes -gmt 1} + # Add : seconds + {clock add 1246379415 100 seconds -gmt 1} + + # Add : +/- in gmt + {clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -gmt 1} + # Add : +/- in system timezone + {clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -timezone :CET} + + # Add : gmt + {clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -gmt 1} + # Add : system timezone + {clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -timezone :CET} + + # Add : all in gmt + {clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -gmt 1} + # Add : all in system timezone + {clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -timezone :CET} + + } + # if does not support add of weekdays: + if {[catch {clock add 0 3 weekdays -gmt 1}]} { + regsub -all {\mweekdays\M} $tests "days" tests + } + _test_run $reptime $tests {puts [clock format $_(r) -locale en]} +} + +proc test-convert {{reptime 1000}} { + _test_run $reptime { + # Convert locale (en -> de): + {clock format [clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en] -format "%a %b %d %Y" -gmt 1 -locale de} + # Convert locale (de -> en): + {clock format [clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de] -format "%a %b %d %Y" -gmt 1 -locale en} + + # Convert TZ: direct + {clock format [clock scan "19:18:30" -base 148863600 -timezone EST] -timezone MST} + {clock format [clock scan "19:18:30" -base 148863600 -timezone MST] -timezone EST} + # Convert TZ: included in scan string & format + {clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone MST} + {clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone EST} + + # Format locale 1x: comparison values + {clock format 0 -gmt 1 -locale en} + {clock format 0 -gmt 1 -locale de} + {clock format 0 -gmt 1 -locale fr} + # Format locale 2x: without switching locale (en, en) + {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en} + # Format locale 2x: with switching locale (en, de) + {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de} + # Format locale 3x: without switching locale (en, en, en) + {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en} + # Format locale 3x: with switching locale (en, de, fr) + {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de; clock format 0 -gmt 1 -locale fr} + + # Scan locale 2x: without switching locale (en, en) + (de, de) + {clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en} + {clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de} + # Scan locale 2x: with switching locale (en, de) + {clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de} + # Scan locale 3x: with switching locale (en, de, fr) + {clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "mar. mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale fr} + + # Format TZ 2x: comparison values + {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"} + {clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"} + # Format TZ 2x: without switching + {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"} + {clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"} + # Format TZ 2x: with switching + {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"} + # Format TZ 3x: with switching (CET, EST, MST) + {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"} + # Format TZ 3x: with switching (GMT, EST, MST) + {clock format 0 -gmt 1 -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"} + + # FreeScan TZ 2x (+1 system-default): without switching TZ + {clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 MST" -base 148863600} + {clock scan "19:18:30 EST" -base 148863600; clock scan "19:18:30 EST" -base 148863600} + # FreeScan TZ 2x (+1 system-default): with switching TZ + {clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 EST" -base 148863600} + # FreeScan TZ 2x (+1 gmt, +1 system-default) + {clock scan "19:18:30 MST" -base 148863600 -gmt 1; clock scan "19:18:30 EST" -base 148863600} + + # Scan TZ: comparison included in scan string vs. given + {clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"} + {clock scan "2009-06-30T18:30:00 CET" -format "%Y-%m-%dT%H:%M:%S %z"} + {clock scan "2009-06-30T18:30:00" -timezone CET -format "%Y-%m-%dT%H:%M:%S"} + } +} + +proc test-other {{reptime 1000}} { + _test_run $reptime { + # Bad zone + {catch {clock scan "1 day" -timezone BAD_ZONE -locale en}} + + # Scan : julian day (overflow) + {catch {clock scan 5373485 -format %J}} + + # Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference) + {set i 0; time { clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50} + # Scan : test reusability of GC objects (format is dynamic, so tcl-obj removed with last reference) + {set i 50; time { clock scan "[incr i -1] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50} + } +} + +proc test-ensemble-perf {{reptime 1000}} { + _test_run $reptime { + # Clock clicks (ensemble) + {clock clicks} + # Clock clicks (direct) + {::tcl::clock::clicks} + # Clock seconds (ensemble) + {clock seconds} + # Clock seconds (direct) + {::tcl::clock::seconds} + # Clock microseconds (ensemble) + {clock microseconds} + # Clock microseconds (direct) + {::tcl::clock::microseconds} + # Clock scan (ensemble) + {clock scan ""} + # Clock scan (direct) + {::tcl::clock::scan ""} + # Clock format (ensemble) + {clock format 0 -f %s} + # Clock format (direct) + {::tcl::clock::format 0 -f %s} + } +} + +proc test {{reptime 1000}} { + puts "" + test-ensemble-perf [expr {$reptime / 2}]; #fast enough + test-format $reptime + test-scan $reptime + test-freescan $reptime + test-add $reptime + test-convert [expr {$reptime / 2}]; #fast enough + test-other $reptime + + puts \n**OK** +} + +}; # end of ::tclTestPerf-TclClock + +# ------------------------------------------------------------------------ + +# if calling direct: +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + ::tclTestPerf-TclClock::test $in(-time) +} diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl new file mode 100644 index 0000000..4629cd4 --- /dev/null +++ b/tests-perf/test-performance.tcl @@ -0,0 +1,144 @@ +# ------------------------------------------------------------------------ +# +# test-performance.tcl -- +# +# This file provides common performance tests for comparison of tcl-speed +# degradation or regression by switching between branches. +# +# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl". +# +# ------------------------------------------------------------------------ +# +# Copyright (c) 2014 Serg G. Brester (aka sebres) +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# + +namespace eval ::tclTestPerf { +# warm-up interpeter compiler env, calibrate timerate measurement functionality: + +# if no timerate here - import from unsupported: +if {[namespace which -command timerate] eq {}} { + namespace inscope ::tcl::unsupported {namespace export timerate} + namespace import ::tcl::unsupported::timerate +} + +# if not yet calibrated: +if {[lindex [timerate {} 10] 6] >= (10-1)} { + puts -nonewline "Calibration ... "; flush stdout + puts "done: [lrange \ + [timerate -calibrate {}] \ + 0 1]" +} + +proc {**STOP**} {args} { + return -code error -level 4 "**STOP** in [info level [expr {[info level]-2}]] [join $args { }]" +} + +proc _test_get_commands {lst} { + regsub -all {(?:^|\n)[ \t]*(\#[^\n]*|\msetup\M[^\n]*|\mcleanup\M[^\n]*)(?=\n\s*(?:[\{\#]|setup|cleanup|$))} $lst "\n{\\1}" +} + +proc _test_out_total {} { + upvar _ _ + + set tcnt [llength $_(itm)] + if {!$tcnt} { + puts "" + return + } + + set mintm 0x7fffffff + set maxtm 0 + set nett 0 + set wtm 0 + set wcnt 0 + set i 0 + foreach tm $_(itm) { + if {[llength $tm] > 6} { + set nett [expr {$nett + [lindex $tm 6]}] + } + set wtm [expr {$wtm + [lindex $tm 0]}] + set wcnt [expr {$wcnt + [lindex $tm 2]}] + set tm [lindex $tm 0] + if {$tm > $maxtm} {set maxtm $tm; set maxi $i} + if {$tm < $mintm} {set mintm $tm; set mini $i} + incr i + } + + puts [string repeat ** 40] + set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]] + if {$nett > 0} { + append s [format " (%.2f nett-sec.)" [expr {$nett / 1000.0}]] + } + puts "Total $s:" + lset _(m) 0 [format %.6f $wtm] + lset _(m) 2 $wcnt + lset _(m) 4 [format %.3f [expr {$wcnt / (($nett ? $nett : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]] + if {[llength $_(m)] > 6} { + lset _(m) 6 [format %.3f $nett] + } + puts $_(m) + puts "Average:" + lset _(m) 0 [format %.6f [expr {[lindex $_(m) 0] / $tcnt}]] + lset _(m) 2 [expr {[lindex $_(m) 2] / $tcnt}] + if {[llength $_(m)] > 6} { + lset _(m) 6 [format %.3f [expr {[lindex $_(m) 6] / $tcnt}]] + lset _(m) 4 [format %.0f [expr {[lindex $_(m) 2] / [lindex $_(m) 6] * 1000}]] + } + puts $_(m) + puts "Min:" + puts [lindex $_(itm) $mini] + puts "Max:" + puts [lindex $_(itm) $maxi] + puts [string repeat ** 40] + puts "" +} + +proc _test_run {args} { + upvar _ _ + # parse args: + set _(out-result) 1 + if {[lindex $args 0] eq "-no-result"} { + set _(out-result) 0 + set args [lrange $args 1 end] + } + if {[llength $args] < 2 || [llength $args] > 3} { + return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\"" + } + set outcmd {puts $_(r)} + set args [lassign $args reptime lst] + if {[llength $args]} { + set outcmd [lindex $args 0] + } + # avoid output if only once: + if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} { + set _(out-result) 0 + } + array set _ [list itm {} reptime $reptime starttime [clock milliseconds]] + + # process measurement: + foreach _(c) [_test_get_commands $lst] { + puts "% [regsub -all {\n[ \t]*} $_(c) {; }]" + if {[regexp {^\s*\#} $_(c)]} continue + if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} { + puts [if 1 [lindex $_(c) 1]] + continue + } + # if output result (and not once): + if {$_(out-result)} { + set _(r) [if 1 $_(c)] + if {$outcmd ne {}} $outcmd + if {[llength $_(reptime)] > 1} { # decrement max-count + lset _(reptime) 1 [expr {[lindex $_(reptime) 1] - 1}] + } + } + puts [set _(m) [timerate $_(c) {*}$_(reptime)]] + lappend _(itm) $_(m) + puts "" + } + _test_out_total +} + +}; # end of namespace ::tclTestPerf diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl new file mode 100644 index 0000000..805f0f8 --- /dev/null +++ b/tests-perf/timer-event.perf.tcl @@ -0,0 +1,182 @@ +#!/usr/bin/tclsh + +# ------------------------------------------------------------------------ +# +# timer-event.perf.tcl -- +# +# This file provides performance tests for comparison of tcl-speed +# of timer events (event-driven tcl-handling). +# +# ------------------------------------------------------------------------ +# +# Copyright (c) 2014 Serg G. Brester (aka sebres) +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# + + +if {![namespace exists ::tclTestPerf]} { + source [file join [file dirname [info script]] test-performance.tcl] +} + + +namespace eval ::tclTestPerf-Timer-Event { + +namespace path {::tclTestPerf} + +proc test-queue {{reptime {1000 10000}}} { + + set howmuch [lindex $reptime 1] + + # because of extremely short measurement times by tests below, wait a little bit (warming-up), + # to minimize influence of the time-gradation (just for better dispersion resp. result-comparison) + timerate {after 0} 156 + + puts "*** up to $howmuch events ***" + # single iteration by update, so using -no-result (measure only): + _test_run -no-result $reptime [string map [list \{*\}\$reptime $reptime \$howmuch $howmuch \\# \#] { + # generate up to $howmuch idle-events: + {after idle {set foo bar}} + # update / after idle: + {update; if {![llength [after info]]} break} + + # generate up to $howmuch idle-events: + {after idle {set foo bar}} + # update idletasks / after idle: + {update idletasks; if {![llength [after info]]} break} + + # generate up to $howmuch immediate events: + {after 0 {set foo bar}} + # update / after 0: + {update; if {![llength [after info]]} break} + + # generate up to $howmuch 1-ms events: + {after 1 {set foo bar}} + setup {after 1} + # update / after 1: + {update; if {![llength [after info]]} break} + + # generate up to $howmuch immediate events (+ 1 event of the second generation): + {after 0 {after 0 {}}} + # update / after 0 (double generation): + {update; if {![llength [after info]]} break} + + # cancel forwards "after idle" / $howmuch idle-events in queue: + setup {set i 0; timerate {set ev([incr i]) [after idle {set foo bar}]} {*}$reptime} + setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events} + {after cancel $ev([incr i]); if {$i >= $le} break} + cleanup {update; unset -nocomplain ev} + # cancel backwards "after idle" / $howmuch idle-events in queue: + setup {set i 0; timerate {set ev([incr i]) [after idle {set foo bar}]} {*}$reptime} + setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events} + {after cancel $ev([incr i -1]); if {$i <= 1} break} + cleanup {update; unset -nocomplain ev} + + # cancel forwards "after 0" / $howmuch timer-events in queue: + setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime} + setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events} + {after cancel $ev([incr i]); if {$i >= $howmuch} break} + cleanup {update; unset -nocomplain ev} + # cancel backwards "after 0" / $howmuch timer-events in queue: + setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime} + setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events} + {after cancel $ev([incr i -1]); if {$i <= 1} break} + cleanup {update; unset -nocomplain ev} + + # end $howmuch events. + cleanup {if [llength [after info]] {error "unexpected: [llength [after info]] events are still there."}} + }] +} + +proc test-access {{reptime {1000 5000}}} { + set howmuch [lindex $reptime 1] + + _test_run $reptime [string map [list \{*\}\$reptime $reptime \$howmuch $howmuch] { + # event random access: after idle + after info (by $howmuch events) + setup {set i -1; timerate {set ev([incr i]) [after idle {}]} {*}$reptime} + {after info $ev([expr {int(rand()*$i)}])} + cleanup {update; unset -nocomplain ev} + # event random access: after 0 + after info (by $howmuch events) + setup {set i -1; timerate {set ev([incr i]) [after 0 {}]} {*}$reptime} + {after info $ev([expr {int(rand()*$i)}])} + cleanup {update; unset -nocomplain ev} + + # end $howmuch events. + cleanup {if [llength [after info]] {error "unexpected: [llength [after info]] events are still there."}} + }] +} + +proc test-exec {{reptime 1000}} { + _test_run $reptime { + # after idle + after cancel + {after cancel [after idle {set foo bar}]} + # after 0 + after cancel + {after cancel [after 0 {set foo bar}]} + # after idle + update idletasks + {after idle {set foo bar}; update idletasks} + # after idle + update + {after idle {set foo bar}; update} + # immediate: after 0 + update + {after 0 {set foo bar}; update} + # delayed: after 1 + update + {after 1 {set foo bar}; update} + # empty update: + {update} + # empty update idle tasks: + {update idletasks} + + # simple shortest sleep: + {after 0} + } +} + +proc test-nrt-capability {{reptime 1000}} { + _test_run $reptime { + # comparison values: + {after 0 {set a 5}; update} + {after 0 {set a 5}; vwait a} + + # conditional vwait with very brief wait-time: + {after 1 {set a timeout}; vwait a; expr {$::a ne "timeout" ? 1 : "0[unset ::a]"}} + {after 0 {set a timeout}; vwait a; expr {$::a ne "timeout" ? 1 : "0[unset ::a]"}} + } +} + +proc test-long {{reptime 1000}} { + _test_run $reptime { + # in-between important event by amount of idle events: + {time {after idle {after 30}} 10; after 1 {set important 1}; vwait important;} + cleanup {foreach i [after info] {after cancel $i}} + # in-between important event (of new generation) by amount of idle events: + {time {after idle {after 30}} 10; after 1 {after 0 {set important 1}}; vwait important;} + cleanup {foreach i [after info] {after cancel $i}} + } +} + +proc test {{reptime 1000}} { + test-exec $reptime + foreach howmuch {5000 50000} { + test-access [list $reptime $howmuch] + } + test-nrt-capability $reptime + test-long $reptime + + puts "" + foreach howmuch { 10000 20000 40000 60000 } { + test-queue [list $reptime $howmuch] + } + + puts \n**OK** +} + +}; # end of ::tclTestPerf-Timer-Event + +# ------------------------------------------------------------------------ + +# if calling direct: +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + array set in {-time 500} + array set in $argv + ::tclTestPerf-Timer-Event::test $in(-time) +} diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index a5f3009..45231c8 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -342,6 +342,70 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { invoked from within "time {error foo}"}} +test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate} msg] $msg +} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} +test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate a b c d} msg] $msg +} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} +test cmdMZ-6.2.2 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate a b c} msg] $msg +} {1 {expected integer but got "b"}} +test cmdMZ-6.2.3 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate a b} msg] $msg +} {1 {expected integer but got "b"}} +test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate -overhead b {} a b} msg] $msg +} {1 {expected floating-point number but got "b"}} +test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} { + list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg +} {1 {missing close-brace}} +test cmdMZ-6.5 {Tcl_TimeRateObjCmd: result format and one iteration} { + regexp {^\d+.\d+ \ws/# 1 # \d+ #/sec \d+.\d+ nett-ms$} [timerate {} 0] +} 1 +test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} { + set m1 [timerate {after 0} 20] + set m2 [timerate {after 1} 20] + list \ + [expr {[lindex $m1 0] < [lindex $m2 0]}] \ + [expr {[lindex $m1 0] < 100}] \ + [expr {[lindex $m2 0] >= 500}] \ + [expr {[lindex $m1 2] > 1000}] \ + [expr {[lindex $m2 2] <= 50}] \ + [expr {[lindex $m1 4] > 10000}] \ + [expr {[lindex $m2 4] < 10000}] \ + [expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 50}] \ + [expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 50}] +} [lrepeat 9 1] +test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { + list [catch {timerate {error foo} 1} msg] $msg $::errorInfo +} {1 foo {foo + while executing +"error foo" + invoked from within +"timerate {error foo} 1"}} +test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { + set m1 [timerate {break}] + list \ + [expr {[lindex $m1 0] < 1000}] \ + [expr {[lindex $m1 2] == 1}] \ + [expr {[lindex $m1 4] > 1000}] \ + [expr {[lindex $m1 6] < 10}] +} {1 1 1 1} +test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { + set m1 [timerate {} 1000 5]; # max-count wins + set m2 [timerate {after 20} 1 5]; # max-time wins + list [lindex $m1 2] [lindex $m2 2] +} {5 1} +test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} { + set m1 [timerate -overhead 1e6 {after 10} 100 1] + list \ + [expr {[lindex $m1 0] == 0.0}] \ + [expr {[lindex $m1 2] == 1}] \ + [expr {[lindex $m1 4] == 1000000}] \ + [expr {[lindex $m1 6] <= 0.001}] +} {1 1 1 1} + # The tests for Tcl_WhileObjCmd are in while.test # cleanup diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index b69e601..5a4550b 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -149,6 +149,7 @@ proc process-text {text} { {\(em} "—" \ {\(en} "–" \ {\(fm} "′" \ + {\(mc} "µ" \ {\(mu} "×" \ {\(mi} "−" \ {\(->} "<font size=\"+1\">→</font>" \ diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 6a73ac2..d95d39b 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -87,6 +87,32 @@ TclpGetSeconds(void) /* *---------------------------------------------------------------------- * + * TclpGetMicroseconds -- + * + * This procedure returns the number of microseconds from the epoch. + * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of microseconds from the epoch. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetMicroseconds(void) +{ + Tcl_Time time; + + tclGetTimeProcPtr(&time, tclTimeClientData); + return ((Tcl_WideInt)time.sec)*1000000 + time.usec; +} + +/* + *---------------------------------------------------------------------- + * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution @@ -219,6 +245,51 @@ TclpWideClicksToNanoseconds( return nsec; } + +/* + *---------------------------------------------------------------------- + * + * TclpWideClickInMicrosec -- + * + * This procedure return scale to convert click values from the + * TclpGetWideClicks native resolution to microsecond resolution + * and back. + * + * Results: + * 1 click in microseconds as double. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +double +TclpWideClickInMicrosec(void) +{ + if (tclGetTimeProcPtr != NativeGetTime) { + return 1.0; + } else { +#ifdef MAC_OSX_TCL + static int initialized = 0; + static double scale = 0.0; + + if (initialized) { + return scale; + } else { + mach_timebase_info_data_t tb; + + mach_timebase_info(&tb); + /* value of tb.numer / tb.denom = 1 click in nanoseconds */ + scale = ((double)tb.numer) / tb.denom / 1000; + initialized = 1; + return scale; + } +#else +#error Wide high-resolution clicks not implemented on this platform +#endif + } +} #endif /* TCL_WIDE_CLICKS */ /* diff --git a/win/tclWinTime.c b/win/tclWinTime.c index dd603d1..19c53c8 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -53,6 +53,7 @@ typedef struct { * initialized. */ int perfCounterAvailable; /* Flag == 1 if the hardware has a performance * counter. */ + DWORD calibrationInterv; /* Calibration interval in seconds (start 1 sec) */ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual * clock calibrated. */ HANDLE readyEvent; /* System event used to trigger the requesting @@ -63,7 +64,6 @@ typedef struct { LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance * counter, that is, the value returned from * QueryPerformanceFrequency. */ - /* * The following values are used for calculating virtual time. Virtual * time is always equal to: @@ -76,6 +76,8 @@ typedef struct { ULARGE_INTEGER fileTimeLastCall; LARGE_INTEGER perfCounterLastCall; LARGE_INTEGER curCounterFreq; + LARGE_INTEGER posixEpoch; /* Posix epoch expressed as 100-ns ticks since + * the windows epoch. */ /* * Data used in developing the estimate of performance counter frequency @@ -92,6 +94,7 @@ static TimeInfo timeInfo = { { NULL, 0, 0, NULL, NULL, 0 }, 0, 0, + 1, (HANDLE) NULL, (HANDLE) NULL, (HANDLE) NULL, @@ -100,11 +103,13 @@ static TimeInfo timeInfo = { (ULARGE_INTEGER) (DWORDLONG) 0, (LARGE_INTEGER) (Tcl_WideInt) 0, (LARGE_INTEGER) (Tcl_WideInt) 0, + (LARGE_INTEGER) (Tcl_WideInt) 0, #else - 0, - 0, - 0, - 0, + {0, 0}, + {0, 0}, + {0, 0}, + {0, 0}, + {0, 0}, #endif { 0 }, { 0 }, @@ -112,6 +117,17 @@ static TimeInfo timeInfo = { }; /* + * Scale to convert wide click values from the TclpGetWideClicks native + * resolution to microsecond resolution and back. + */ +static struct { + int initialized; /* 1 if initialized, 0 otherwise */ + int perfCounter; /* 1 if performance counter usable for wide clicks */ + double microsecsScale; /* Denominator scale between clock / microsecs */ +} wideClick = {0, 0.0}; + + +/* * Declarations for functions defined later in this file. */ @@ -127,6 +143,7 @@ static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime); static void NativeScaleTime(Tcl_Time* timebuf, ClientData clientData); +static Tcl_WideInt NativeGetMicroseconds(void); static void NativeGetTime(Tcl_Time* timebuf, ClientData clientData); @@ -158,10 +175,19 @@ ClientData tclTimeClientData = NULL; unsigned long TclpGetSeconds(void) { - Tcl_Time t; + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return usecSincePosixEpoch / 1000000; + } else { + Tcl_Time t; - tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ - return t.sec; + tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ + return t.sec; + } } /* @@ -186,19 +212,147 @@ TclpGetSeconds(void) unsigned long TclpGetClicks(void) { - /* - * Use the Tcl_GetTime abstraction to get the time in microseconds, as - * nearly as we can, and return it. - */ + Tcl_WideInt usecSincePosixEpoch; - Tcl_Time now; /* Current Tcl time */ - unsigned long retval; /* Value to return */ + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return (unsigned long)usecSincePosixEpoch; + } else { + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ - tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + Tcl_Time now; /* Current Tcl time */ - retval = (now.sec * 1000000) + now.usec; - return retval; + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (unsigned long)(now.sec * 1000000) + now.usec; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetWideClicks -- + * + * This procedure returns a WideInt value that represents the highest + * resolution clock in microseconds available on the system. + * + * Results: + * Number of microseconds (from some start time). + * + * Side effects: + * This should be used for time-delta resp. for measurement purposes + * only, because on some platforms can return microseconds from some + * start time (not from the epoch). + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetWideClicks(void) +{ + LARGE_INTEGER curCounter; + + if (!wideClick.initialized) { + LARGE_INTEGER perfCounterFreq; + + /* + * The frequency of the performance counter is fixed at system boot and + * is consistent across all processors. Therefore, the frequency need + * only be queried upon application initialization. + */ + if (QueryPerformanceFrequency(&perfCounterFreq)) { + wideClick.perfCounter = 1; + wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart; + } else { + /* fallback using microseconds */ + wideClick.perfCounter = 0; + wideClick.microsecsScale = 1; + } + + wideClick.initialized = 1; + } + if (wideClick.perfCounter) { + if (QueryPerformanceCounter(&curCounter)) { + return (Tcl_WideInt)curCounter.QuadPart; + } + /* fallback using microseconds */ + wideClick.perfCounter = 0; + wideClick.microsecsScale = 1; + return TclpGetMicroseconds(); + } else { + return TclpGetMicroseconds(); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpWideClickInMicrosec -- + * + * This procedure return scale to convert wide click values from the + * TclpGetWideClicks native resolution to microsecond resolution + * and back. + * + * Results: + * 1 click in microseconds as double. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +double +TclpWideClickInMicrosec(void) +{ + if (!wideClick.initialized) { + (void)TclpGetWideClicks(); /* initialize */ + } + return wideClick.microsecsScale; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetMicroseconds -- + * + * This procedure returns a WideInt value that represents the highest + * resolution clock in microseconds available on the system. + * + * Results: + * Number of microseconds (from the epoch). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetMicroseconds(void) +{ + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return usecSincePosixEpoch; + } else { + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ + + Tcl_Time now; + + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (((Tcl_WideInt)now.sec) * 1000000) + now.usec; + } } /* @@ -227,7 +381,17 @@ void Tcl_GetTime( Tcl_Time *timePtr) /* Location to store time information. */ { - tclGetTimeProcPtr(timePtr, tclTimeClientData); + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + } else { + tclGetTimeProcPtr(timePtr, tclTimeClientData); + } } /* @@ -260,13 +424,14 @@ NativeScaleTime( /* *---------------------------------------------------------------------- * - * NativeGetTime -- + * NativeGetMicroseconds -- * - * TIP #233: Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in microseconds since the beginning + * of the epoch: 00:00 UCT, January 1, 1970. * * Results: - * Returns the current time in timePtr. + * Returns the wide integer with number of microseconds from the epoch, or + * 0 if high resolution timer is not available. * * Side effects: * On the first call, initializes a set of static variables to keep track @@ -279,13 +444,20 @@ NativeScaleTime( *---------------------------------------------------------------------- */ -static void -NativeGetTime( - Tcl_Time *timePtr, - ClientData clientData) -{ - struct _timeb t; +static inline Tcl_WideInt +NativeCalc100NsTicks( + ULONGLONG fileTimeLastCall, + LONGLONG perfCounterLastCall, + LONGLONG curCounterFreq, + LONGLONG curCounter +) { + return fileTimeLastCall + + ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq); +} +static Tcl_WideInt +NativeGetMicroseconds(void) +{ /* * Initialize static storage on the first trip through. * @@ -296,6 +468,10 @@ NativeGetTime( if (!timeInfo.initialized) { TclpInitLock(); if (!timeInfo.initialized) { + + timeInfo.posixEpoch.LowPart = 0xD53E8000; + timeInfo.posixEpoch.HighPart = 0x019DB1DE; + timeInfo.perfCounterAvailable = QueryPerformanceFrequency(&timeInfo.nominalFreq); @@ -400,22 +576,12 @@ NativeGetTime( * time. */ - ULARGE_INTEGER fileTimeLastCall; - LARGE_INTEGER perfCounterLastCall, curCounterFreq; + ULONGLONG fileTimeLastCall; + LONGLONG perfCounterLastCall, curCounterFreq; /* Copy with current data of calibration cycle */ LARGE_INTEGER curCounter; /* Current performance counter. */ - Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns - * ticks since the Windows epoch. */ - static LARGE_INTEGER posixEpoch; - /* Posix epoch expressed as 100-ns ticks since - * the windows epoch. */ - Tcl_WideInt usecSincePosixEpoch; - /* Current microseconds since Posix epoch. */ - - posixEpoch.LowPart = 0xD53E8000; - posixEpoch.HighPart = 0x019DB1DE; QueryPerformanceCounter(&curCounter); @@ -424,21 +590,18 @@ NativeGetTime( */ EnterCriticalSection(&timeInfo.cs); - fileTimeLastCall.QuadPart = timeInfo.fileTimeLastCall.QuadPart; - perfCounterLastCall.QuadPart = timeInfo.perfCounterLastCall.QuadPart; - curCounterFreq.QuadPart = timeInfo.curCounterFreq.QuadPart; + fileTimeLastCall = timeInfo.fileTimeLastCall.QuadPart; + perfCounterLastCall = timeInfo.perfCounterLastCall.QuadPart; + curCounterFreq = timeInfo.curCounterFreq.QuadPart; LeaveCriticalSection(&timeInfo.cs); /* * If calibration cycle occurred after we get curCounter */ - if (curCounter.QuadPart <= perfCounterLastCall.QuadPart) { - usecSincePosixEpoch = - (fileTimeLastCall.QuadPart - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + if (curCounter.QuadPart <= perfCounterLastCall) { + /* Calibrated file-time is saved from posix in 100-ns ticks */ + return fileTimeLastCall / 10; } /* @@ -451,27 +614,62 @@ NativeGetTime( * loop should recover. */ - if (curCounter.QuadPart - perfCounterLastCall.QuadPart < - 11 * curCounterFreq.QuadPart / 10 + if (curCounter.QuadPart - perfCounterLastCall < + 11 * curCounterFreq * timeInfo.calibrationInterv / 10 ) { - curFileTime = fileTimeLastCall.QuadPart + - ((curCounter.QuadPart - perfCounterLastCall.QuadPart) - * 10000000 / curCounterFreq.QuadPart); - - usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + /* Calibrated file-time is saved from posix in 100-ns ticks */ + return NativeCalc100NsTicks(fileTimeLastCall, + perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10; } } /* - * High resolution timer is not available. Just use ftime. + * High resolution timer is not available. */ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233: Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * See NativeGetMicroseconds for more information. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime( + Tcl_Time *timePtr, + ClientData clientData) +{ + Tcl_WideInt usecSincePosixEpoch; + + /* + * Try to use high resolution timer. + */ + if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) { + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + } else { + /* + * High resolution timer is not available. Just use ftime. + */ + + struct _timeb t; - _ftime(&t); - timePtr->sec = (long)t.time; - timePtr->usec = t.millitm * 1000; + _ftime(&t); + timePtr->sec = (long)t.time; + timePtr->usec = t.millitm * 1000; + } } /* @@ -492,6 +690,8 @@ NativeGetTime( *---------------------------------------------------------------------- */ +void TclWinResetTimerResolution(void); + static void StopCalibration( ClientData unused) /* Client data is unused */ @@ -782,6 +982,8 @@ CalibrationThread( QueryPerformanceFrequency(&timeInfo.curCounterFreq); timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime; timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime; + /* Calibrated file-time will be saved from posix in 100-ns ticks */ + timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart; ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart, timeInfo.perfCounterLastCall.QuadPart, @@ -841,6 +1043,7 @@ UpdateTimeEachSecond(void) /* Current value returned from * QueryPerformanceCounter. */ FILETIME curSysTime; /* Current system time. */ + static LARGE_INTEGER lastFileTime; /* File time of the previous calibration */ LARGE_INTEGER curFileTime; /* File time at the time this callback was * scheduled. */ Tcl_WideInt estFreq; /* Estimated perf counter frequency. */ @@ -852,15 +1055,24 @@ UpdateTimeEachSecond(void) * step over 1 second. */ /* - * Sample performance counter and system time. + * Sample performance counter and system time (from posix epoch). */ - QueryPerformanceCounter(&curPerfCounter); GetSystemTimeAsFileTime(&curSysTime); curFileTime.LowPart = curSysTime.dwLowDateTime; curFileTime.HighPart = curSysTime.dwHighDateTime; - - EnterCriticalSection(&timeInfo.cs); + curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart; + /* If calibration still not needed (check for possible time switch) */ + if ( curFileTime.QuadPart > lastFileTime.QuadPart + && curFileTime.QuadPart < lastFileTime.QuadPart + + (timeInfo.calibrationInterv * 10000000) + ) { + /* again in next one second */ + return; + } + QueryPerformanceCounter(&curPerfCounter); + + lastFileTime.QuadPart = curFileTime.QuadPart; /* * We devide by timeInfo.curCounterFreq.QuadPart in several places. That @@ -872,7 +1084,6 @@ UpdateTimeEachSecond(void) */ if (timeInfo.curCounterFreq.QuadPart == 0){ - LeaveCriticalSection(&timeInfo.cs); timeInfo.perfCounterAvailable = 0; return; } @@ -911,12 +1122,9 @@ UpdateTimeEachSecond(void) * is estFreq * 20000000 / (vt1 - vt0) */ - vt0 = 10000000 * (curPerfCounter.QuadPart - - timeInfo.perfCounterLastCall.QuadPart) - / timeInfo.curCounterFreq.QuadPart - + timeInfo.fileTimeLastCall.QuadPart; - vt1 = 20000000 + curFileTime.QuadPart; - + vt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart, + timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart, + curPerfCounter.QuadPart); /* * If we've gotten more than a second away from system time, then drifting * the clock is going to be pretty hopeless. Just let it jump. Otherwise, @@ -925,21 +1133,75 @@ UpdateTimeEachSecond(void) tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { - timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart; - timeInfo.curCounterFreq.QuadPart = estFreq; + /* jump to current system time, use curent estimated frequency */ + vt0 = curFileTime.QuadPart; } else { - driftFreq = estFreq * 20000000 / (vt1 - vt0); + /* calculate new frequency and estimate drift to the next second */ + vt1 = 20000000 + curFileTime.QuadPart; + driftFreq = (estFreq * 20000000 / (vt1 - vt0)); + /* + * Avoid too large drifts (only half of the current difference), + * that allows also be more accurate (aspire to the smallest tdiff), + * so then we can prolong calibration interval by tdiff < 100000 + */ + driftFreq = timeInfo.curCounterFreq.QuadPart + + (driftFreq - timeInfo.curCounterFreq.QuadPart) / 2; - if (driftFreq > 1003*estFreq/1000) { - driftFreq = 1003*estFreq/1000; - } else if (driftFreq < 997*estFreq/1000) { - driftFreq = 997*estFreq/1000; + /* + * Average between estimated, 2 current and 5 drifted frequencies, + * (do the soft drifting as possible) + */ + estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + 5 * driftFreq) / 8; + } + + /* Avoid too large discrepancy from nominal frequency */ + if (estFreq > 1003*timeInfo.nominalFreq.QuadPart/1000) { + estFreq = 1003*timeInfo.nominalFreq.QuadPart/1000; + vt0 = curFileTime.QuadPart; + } else if (estFreq < 997*timeInfo.nominalFreq.QuadPart/1000) { + estFreq = 997*timeInfo.nominalFreq.QuadPart/1000; + vt0 = curFileTime.QuadPart; + } else if (vt0 != curFileTime.QuadPart) { + /* + * Be sure the clock ticks never backwards (avoid it by negative drifting) + * just compare native time (in 100-ns) before and hereafter using + * new calibrated values) and do a small adjustment (short time freeze) + */ + LARGE_INTEGER newPerfCounter; + Tcl_WideInt nt0, nt1; + + QueryPerformanceCounter(&newPerfCounter); + nt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart, + timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart, + newPerfCounter.QuadPart); + nt1 = NativeCalc100NsTicks(vt0, + curPerfCounter.QuadPart, estFreq, + newPerfCounter.QuadPart); + if (nt0 > nt1) { /* drifted backwards, try to compensate with new base */ + /* first adjust with a micro jump (short frozen time is acceptable) */ + vt0 += nt0 - nt1; + /* if drift unavoidable (e. g. we had a time switch), then reset it */ + vt1 = vt0 - curFileTime.QuadPart; + if (vt1 > 10000000 || vt1 < -10000000) { + /* larger jump resp. shift relative new file-time */ + vt0 = curFileTime.QuadPart; + } } + } + + /* In lock commit new values to timeInfo (hold lock as short as possible) */ + EnterCriticalSection(&timeInfo.cs); - timeInfo.fileTimeLastCall.QuadPart = vt0; - timeInfo.curCounterFreq.QuadPart = driftFreq; + /* grow calibration interval up to 10 seconds (if still precise enough) */ + if (tdiff < -100000 || tdiff > 100000) { + /* too long drift - reset calibration interval to 1000 second */ + timeInfo.calibrationInterv = 1; + } else if (timeInfo.calibrationInterv < 10) { + timeInfo.calibrationInterv++; } + timeInfo.fileTimeLastCall.QuadPart = vt0; + timeInfo.curCounterFreq.QuadPart = estFreq; timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart; LeaveCriticalSection(&timeInfo.cs); |