diff options
-rw-r--r-- | doc/timerate.n | 114 | ||||
-rw-r--r-- | generic/tclBasic.c | 1 | ||||
-rw-r--r-- | generic/tclClock.c | 10 | ||||
-rw-r--r-- | generic/tclCmdMZ.c | 343 | ||||
-rw-r--r-- | generic/tclCompile.h | 22 | ||||
-rw-r--r-- | generic/tclExecute.c | 228 | ||||
-rw-r--r-- | generic/tclInt.h | 15 | ||||
-rwxr-xr-x | library/reg/pkgIndex.tcl | 10 | ||||
-rw-r--r-- | unix/tclUnixTime.c | 71 | ||||
-rw-r--r-- | win/tclWinTime.c | 271 |
10 files changed, 944 insertions, 141 deletions
diff --git a/doc/timerate.n b/doc/timerate.n new file mode 100644 index 0000000..df9a8f7 --- /dev/null +++ b/doc/timerate.n @@ -0,0 +1,114 @@ +'\" +'\" 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?\fR +.sp +\fBtimerate \fI?-direct?\fR \fI?-overhead double?\fR \fIscript\fR \fI?time?\fR +.sp +\fBtimerate \fI?-calibrate?\fR \fI?-direct?\fR \fIscript\fR \fI?time?\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 +It will then return a canonical tcl-list of the form +.PP +.CS +\f0.095977 µs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR +.CE +.PP +which indicates: +.IP \(bu +the average amount of time required per iteration, in microseconds (lindex $result 0) +.IP \(bu +the count how many times it was executed (lindex $result 2) +.IP \(bu +the estimated rate per second (lindex $result 4) +.IP \(bu +the estimated real execution time without measurement overhead (lindex $result 6) +.PP +Time is measured in elapsed time using heighest 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. +.PP +\fI-calibrate\fR +. +To measure very fast scripts as exact as posible the calibration process +may be required. + +This parameter used to calibrate \fBtimerate\fR calculating the estimated overhead +of given \fIscript\fR as default overhead for further execution of \fBtimerate\fR. +It can take up to 10 seconds if parameter \fItime\fR is not specified. +.PP +\fI-overhead double\fR +. +This parameter used to supply the measurement overhead of single iteration +(in microseconds) that should be ignored during whole evaluation process. +.PP +\fI-direct\fR +. +Causes direct execution per iteration (not compiled variant of evaluation used). +.PP +In opposition to \fBtime\fR the execution limited here by fixed time instead of +repetition count. +Additionally the compiled variant of the script will be used during whole evaluation +(as if it were part of a compiled \fBproc\fR), if parameter \fI-direct\fR is not specified. +Therefore it provides more precise results and prevents very long execution time +by slow scripts resp. scripts with unknown speed. + +.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 only (ignoring the +overhead for operations on variable \fIi\fR) to count to a ten: +.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 rate of calculating the hour using \fBclock format\fR only, ignoring +overhead of the rest, without measurement how fast it takes for a whole script: +.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 44cf543..83e1a75 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 782c681..b019ef9 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1739,9 +1739,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 +1808,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 30586b1..2b96c5a 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); @@ -3941,6 +3942,348 @@ Tcl_TimeObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_TimeRateObjCmd -- + * + * This object-based procedure is invoked to process the "timerate" Tcl + * command. + * This is similar to command "time", except the execution limited by + * given time (in milliseconds) instead of repetition count. + * + * Example: + * timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]` + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TimeRateObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static + double measureOverhead = 0; /* global measure-overhead */ + double overhead = -1; /* given measure-overhead */ + register Tcl_Obj *objPtr; + register int result, i; + Tcl_Obj *calibrate = NULL, *direct = NULL; + Tcl_WideInt count = 0; /* Holds repetition count */ + Tcl_WideInt maxms = -0x7FFFFFFFFFFFFFFFL; + /* Maximal running time (in milliseconds) */ + Tcl_WideInt threshold = 1; /* Current threshold for check time (faster + * repeat count without time check) */ + Tcl_WideInt maxIterTm = 1; /* Max time of some iteration as max threshold + * additionally avoid divide to zero (never < 1) */ + register Tcl_WideInt start, middle, stop; +#ifndef TCL_WIDE_CLICKS + Tcl_Time now; +#endif + + static const char *const options[] = { + "-direct", "-overhead", "-calibrate", "--", NULL + }; + enum options { + TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST + }; + + 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; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. See the diff --git a/generic/tclCompile.h b/generic/tclCompile.h index bc298ae..ee994d7 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/tclExecute.c b/generic/tclExecute.c index e85863d..61d0ddc 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/tclInt.h b/generic/tclInt.h index 6113f23..a184950 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2768,10 +2768,22 @@ 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) +# endif #endif +MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); + MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); MODULE_SCOPE int TclUtfCasecmp(CONST char *cs, CONST char *ct); @@ -3014,6 +3026,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[]); diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 1241f2a..3cd2c4c 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,19 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { + if {[info exists [file join $dir tclreg12g.dll]]} { package ifneeded registry 1.2.2 \ [list load [file join $dir tclreg12g.dll] registry] + } else { + package ifneeded registry 1.2.2 \ + [list load tclreg12g registry] + } } else { + if {[info exists [file join $dir tclreg12.dll]]} { package ifneeded registry 1.2.2 \ [list load [file join $dir tclreg12.dll] registry] + } else { + package ifneeded registry 1.2.2 \ + [list load tclreg12 registry] + } } diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 11b0ecf..1b4ea15 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 46e2cd2..374c41c 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -110,6 +110,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. */ @@ -123,6 +134,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); @@ -154,10 +166,19 @@ ClientData tclTimeClientData = NULL; unsigned long TclpGetSeconds(void) { - Tcl_Time t; + Tcl_WideInt usecSincePosixEpoch; - (*tclGetTimeProcPtr) (&t, tclTimeClientData); /* Tcl_GetTime inlined. */ - return t.sec; + /* 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; + } } /* @@ -182,19 +203,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; + + /* 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. + */ + + Tcl_Time now; /* Current Tcl time */ + + 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_Time now; /* Current Tcl time */ - unsigned long retval; /* Value to return */ +Tcl_WideInt +TclpGetMicroseconds(void) +{ + Tcl_WideInt usecSincePosixEpoch; - (*tclGetTimeProcPtr) (&now, tclTimeClientData); /* Tcl_GetTime inlined */ + /* 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. + */ - retval = (now.sec * 1000000) + now.usec; - return retval; + Tcl_Time now; + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (((Tcl_WideInt)now.sec) * 1000000) + now.usec; + } } /* @@ -252,7 +401,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); + } } /* @@ -285,13 +444,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 @@ -304,13 +464,12 @@ NativeScaleTime( *---------------------------------------------------------------------- */ -static void -NativeGetTime( - Tcl_Time *timePtr, - ClientData clientData) +static Tcl_WideInt +NativeGetMicroseconds(void) { - struct _timeb t; - + static LARGE_INTEGER posixEpoch; + /* Posix epoch expressed as 100-ns ticks since + * the windows epoch. */ /* * Initialize static storage on the first trip through. * @@ -321,6 +480,10 @@ NativeGetTime( if (!timeInfo.initialized) { TclpInitLock(); if (!timeInfo.initialized) { + + posixEpoch.LowPart = 0xD53E8000; + posixEpoch.HighPart = 0x019DB1DE; + timeInfo.perfCounterAvailable = QueryPerformanceFrequency(&timeInfo.nominalFreq); @@ -433,15 +596,9 @@ NativeGetTime( /* 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); /* @@ -461,9 +618,7 @@ NativeGetTime( if (curCounter.QuadPart <= perfCounterLastCall.QuadPart) { usecSincePosixEpoch = (fileTimeLastCall.QuadPart - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + return usecSincePosixEpoch; } /* @@ -484,19 +639,57 @@ NativeGetTime( * 10000000 / curCounterFreq.QuadPart); usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + return usecSincePosixEpoch; } } /* - * 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; - _ftime(&t); - timePtr->sec = (long)t.time; - timePtr->usec = t.millitm * 1000; + /* + * 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; + } } /* |