Tcl Source Code

Check-in [2d254280f0]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge 8.6 (TIP#527, New measurement facilities in TCL: New command timerate, performance test suite)
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-branch
Files: files | file ages | folders
SHA3-256: 2d254280f0e745454aefd895ee5d2adc027c4d60b864bb96851d9983d66abe23
User & Date: sebres 2019-03-05 17:34:31
Context
2019-03-05
17:39
timerate is supported in 8.7 check-in: db95e7a61e user: sebres tags: core-8-branch
17:34
merge 8.6 (TIP#527, New measurement facilities in TCL: New command timerate, performance test suite) check-in: 2d254280f0 user: sebres tags: core-8-branch
16:59
integrate sebres-8-6-timerate, merge 8.5 (TIP#527, New measurement facilities in TCL: New command ti... check-in: 49f82cfd7f user: sebres tags: core-8-6-branch
2019-03-02
18:15
Various tommath/numeric related optimizations: - Remove the DD_STEEL formatter: it isn't used anywhe... check-in: 5293802fe6 user: jan.nijtmans tags: core-8-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added doc/timerate.n.


































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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:

Changes to generic/tclBasic.c.

315
316
317
318
319
320
321



322
323
324
325
326
327
328
...
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
...
969
970
971
972
973
974
975











976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
    {"pwd",		Tcl_PwdObjCmd,		NULL,			NULL,	0},
    {"read",		Tcl_ReadObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"seek",		Tcl_SeekObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"socket",		Tcl_SocketObjCmd,	NULL,			NULL,	0},
    {"source",		Tcl_SourceObjCmd,	NULL,			TclNRSourceObjCmd,	0},
    {"tell",		Tcl_TellObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"time",		Tcl_TimeObjCmd,		NULL,			NULL,	CMD_IS_SAFE},



    {"unload",		Tcl_UnloadObjCmd,	NULL,			NULL,	0},
    {"update",		Tcl_UpdateObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"vwait",		Tcl_VwaitObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {NULL,		NULL,			NULL,			NULL,	0}
};

/*
................................................................................
{
    Interp *iPtr;
    Tcl_Interp *interp;
    Command *cmdPtr;
    const BuiltinFuncDef *builtinFuncPtr;
    const OpCmdInfo *opcmdInfoPtr;
    const CmdInfo *cmdInfoPtr;
    Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
    Tcl_HashEntry *hPtr;
    int isNew;
    CancelInfo *cancelInfo;
    union {
	char c[sizeof(short)];
	short s;
    } order;
................................................................................
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);












#ifdef USE_DTRACE
    /*
     * Register the tcl::dtrace command.
     */

    Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */

    /*
     * Register the builtin math functions.
     */

    mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL);
    if (mathfuncNSPtr == NULL) {
	Tcl_Panic("Can't create math function namespace");
    }
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
    memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
    for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
	    builtinFuncPtr++) {
	strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
	Tcl_CreateObjCommand(interp, mathFuncName,
		builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
	Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0);
    }

    /*
     * Register the mathematical "operator" commands. [TIP #174]
     */

    mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
    if (mathopNSPtr == NULL) {
	Tcl_Panic("can't create math operator namespace");
    }
    Tcl_Export(interp, mathopNSPtr, "*", 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++){
	TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData));

	occdPtr->op = opcmdInfoPtr->name;
	occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;






>
>
>







 







|







 







>
>
>
>
>
>
>
>
>
>
>













|
|









|






|
|


|







315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
...
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
...
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
    {"pwd",		Tcl_PwdObjCmd,		NULL,			NULL,	0},
    {"read",		Tcl_ReadObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"seek",		Tcl_SeekObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"socket",		Tcl_SocketObjCmd,	NULL,			NULL,	0},
    {"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},
    {NULL,		NULL,			NULL,			NULL,	0}
};

/*
................................................................................
{
    Interp *iPtr;
    Tcl_Interp *interp;
    Command *cmdPtr;
    const BuiltinFuncDef *builtinFuncPtr;
    const OpCmdInfo *opcmdInfoPtr;
    const CmdInfo *cmdInfoPtr;
    Tcl_Namespace *nsPtr;
    Tcl_HashEntry *hPtr;
    int isNew;
    CancelInfo *cancelInfo;
    union {
	char c[sizeof(short)];
	short s;
    } order;
................................................................................
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    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.
     */

    Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */

    /*
     * Register the builtin math functions.
     */

    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::") */
    memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
    for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
	    builtinFuncPtr++) {
	strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
	Tcl_CreateObjCommand(interp, mathFuncName,
		builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
	Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
    }

    /*
     * Register the mathematical "operator" commands. [TIP #174]
     */

    nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
    if (nsPtr == NULL) {
	Tcl_Panic("can't create math operator namespace");
    }
    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++){
	TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData));

	occdPtr->op = opcmdInfoPtr->name;
	occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;

Changes to generic/tclClock.c.

1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
....
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
#ifdef TCL_WIDE_CLICKS
	clicks = TclpGetWideClicks();
#else
	clicks = (Tcl_WideInt) TclpGetClicks();
#endif
	break;
    case CLICKS_MICROS:
	Tcl_GetTime(&now);
	clicks = ((Tcl_WideInt) now.sec * 1000000) + now.usec;
	break;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks));
    return TCL_OK;
}
 
................................................................................
int
ClockMicrosecondsObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp *interp,		/* Tcl interpreter */
    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));
    return TCL_OK;
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * ClockParseformatargsObjCmd --






|
<







 







<
<




<
|
<







1768
1769
1770
1771
1772
1773
1774
1775

1776
1777
1778
1779
1780
1781
1782
....
1838
1839
1840
1841
1842
1843
1844


1845
1846
1847
1848

1849

1850
1851
1852
1853
1854
1855
1856
#ifdef TCL_WIDE_CLICKS
	clicks = TclpGetWideClicks();
#else
	clicks = (Tcl_WideInt) TclpGetClicks();
#endif
	break;
    case CLICKS_MICROS:
	clicks = TclpGetMicroseconds();

	break;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks));
    return TCL_OK;
}
 
................................................................................
int
ClockMicrosecondsObjCmd(
    ClientData clientData,	/* Client data is unused */
    Tcl_Interp *interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj *const *objv)	/* Parameter values */
{


    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));

    return TCL_OK;
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * ClockParseformatargsObjCmd --

Changes to generic/tclCmdMZ.c.

13
14
15
16
17
18
19

20
21
22
23
24
25
26
....
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
....
4062
4063
4064
4065
4066
4067
4068
































































































































































































































































































































































































4069
4070
4071
4072
4073
4074
4075
 * Copyright (c) 2003-2009 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

#include "tclRegexp.h"
#include "tclStringTrim.h"

static inline Tcl_Obj *	During(Tcl_Interp *interp, int resultCode,
			    Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
static Tcl_NRPostProc	SwitchPostProc;
static Tcl_NRPostProc	TryPostBody;
................................................................................
    i = count;
#ifndef TCL_WIDE_CLICKS
    Tcl_GetTime(&start);
#else
    start = TclpGetWideClicks();
#endif
    while (i-- > 0) {
	result = Tcl_EvalObjEx(interp, objPtr, 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
#ifndef TCL_WIDE_CLICKS
    Tcl_GetTime(&stop);
    totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6
................................................................................
    TclNewLiteralStringObj(objs[1], "microseconds");
    TclNewLiteralStringObj(objs[2], "per");
    TclNewLiteralStringObj(objs[3], "iteration");
    Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));

    return TCL_OK;
}
































































































































































































































































































































































































 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TryObjCmd, TclNRTryObjCmd --
 *
 *	This procedure is invoked to process the "try" Tcl command. See the






>







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
....
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
....
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
 * Copyright (c) 2003-2009 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tclRegexp.h"
#include "tclStringTrim.h"

static inline Tcl_Obj *	During(Tcl_Interp *interp, int resultCode,
			    Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
static Tcl_NRPostProc	SwitchPostProc;
static Tcl_NRPostProc	TryPostBody;
................................................................................
    i = count;
#ifndef TCL_WIDE_CLICKS
    Tcl_GetTime(&start);
#else
    start = TclpGetWideClicks();
#endif
    while (i-- > 0) {
	result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
#ifndef TCL_WIDE_CLICKS
    Tcl_GetTime(&stop);
    totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6
................................................................................
    TclNewLiteralStringObj(objs[1], "microseconds");
    TclNewLiteralStringObj(objs[2], "per");
    TclNewLiteralStringObj(objs[3], "iteration");
    Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TimeRateObjCmd --
 *
 *	This object-based procedure is invoked to process the "timerate" Tcl
 *	command. 
 *	This is similar to command "time", except the execution limited by 
 *	given time (in milliseconds) instead of repetition count.
 *
 * Example:
 *	timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]`
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TimeRateObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static 
    double measureOverhead = 0; /* global measure-overhead */
    double overhead = -1;	/* given measure-overhead */
    register Tcl_Obj *objPtr;
    register int result, i;
    Tcl_Obj *calibrate = NULL, *direct = NULL;
    Tcl_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

Changes to generic/tclInt.h.

3255
3256
3257
3258
3259
3260
3261

3262
3263
3264









3265


3266
3267
3268
3269
3270
3271
3272
....
3533
3534
3535
3536
3537
3538
3539



3540
3541
3542
3543
3544
3545
3546
MODULE_SCOPE int	TclpLoadMemory(Tcl_Interp *interp, void *buffer,
			    int size, int codeSize, Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
#endif
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);









#endif


MODULE_SCOPE int	TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void *	TclpThreadCreateKey(void);
MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void	TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void *	TclpThreadGetMasterTSD(void *tsdKeyPtr);
MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp,
			    const char *msg, int length);
................................................................................
MODULE_SCOPE int	Tcl_TellObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_TimeObjCmd(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[]);
MODULE_SCOPE int	Tcl_TryObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);






>



>
>
>
>
>
>
>
>
>

>
>







 







>
>
>







3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
....
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
MODULE_SCOPE int	TclpLoadMemory(Tcl_Interp *interp, void *buffer,
			    int size, int codeSize, Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
#endif
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);
MODULE_SCOPE void	TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void *	TclpThreadGetMasterTSD(void *tsdKeyPtr);
MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp,
			    const char *msg, int length);
................................................................................
MODULE_SCOPE int	Tcl_TellObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
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[]);
MODULE_SCOPE int	Tcl_TryObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

Changes to generic/tclPort.h.

21
22
23
24
25
26
27



28
29
30
31
#   include "tclWinPort.h"
#else
#   include "tclUnixPort.h"
#endif
#include "tcl.h"

#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 */






>
>
>




21
22
23
24
25
26
27
28
29
30
31
32
33
34
#   include "tclWinPort.h"
#else
#   include "tclUnixPort.h"
#endif
#include "tcl.h"

#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 */

Changes to library/tclIndex.

69
70
71
72
73
74
75



set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
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]]









>
>
>
69
70
71
72
73
74
75
76
77
78
set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
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}
}

Added tests-perf/clock.perf.tcl.






















































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
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)
}

Added tests-perf/test-performance.tcl.
































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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

Added tests-perf/timer-event.perf.tcl.












































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
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)
}

Changes to tests/cmdMZ.test.

337
338
339
340
341
342
343
































































344
345
346
347
348
349
350
351
352
353
354
355
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
"time {error foo}"}}

































































# The tests for Tcl_WhileObjCmd are in while.test
 
# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return

# Local Variables:
# mode: tcl
# End:






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    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
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return

# Local Variables:
# mode: tcl
# End:

Changes to tools/tcltk-man2html-utils.tcl.

145
146
147
148
149
150
151

152
153
154
155
156
157
158
	    {\%}	{} \
	    "\\\n"	"\n" \
	    {\(+-}	"&#177;" \
	    {\(co}	"&copy;" \
	    {\(em}	"&#8212;" \
	    {\(en}	"&#8211;" \
	    {\(fm}	"&#8242;" \

	    {\(mu}	"&#215;" \
	    {\(mi}	"&#8722;" \
	    {\(->}	"<font size=\"+1\">&#8594;</font>" \
	    {\fP}	{\fR} \
	    {\.}	. \
	    {\(bu}	"&#8226;" \
	    ]






>







145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
	    {\%}	{} \
	    "\\\n"	"\n" \
	    {\(+-}	"&#177;" \
	    {\(co}	"&copy;" \
	    {\(em}	"&#8212;" \
	    {\(en}	"&#8211;" \
	    {\(fm}	"&#8242;" \
	    {\(mc}	"&#181;" \
	    {\(mu}	"&#215;" \
	    {\(mi}	"&#8722;" \
	    {\(->}	"<font size=\"+1\">&#8594;</font>" \
	    {\fP}	{\fR} \
	    {\.}	. \
	    {\(bu}	"&#8226;" \
	    ]

Changes to unix/tclUnixTime.c.

83
84
85
86
87
88
89


























90
91
92
93
94
95
96
...
215
216
217
218
219
220
221













































222
223
224
225
226
227
228
{
    return time(NULL);
}
 
/*
 *----------------------------------------------------------------------
 *


























 * TclpGetClicks --
 *
 *	This procedure returns a value that represents the highest resolution
 *	clock available on the system. There are no garantees on what the
 *	resolution will be. In Tcl we will call this value a "click". The
 *	start time is also system dependant.
 *
................................................................................
#else
#error Wide high-resolution clicks not implemented on this platform
#endif
    }

    return nsec;
}













































#endif /* TCL_WIDE_CLICKS */
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
{
    return time(NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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
 *	clock available on the system. There are no garantees on what the
 *	resolution will be. In Tcl we will call this value a "click". The
 *	start time is also system dependant.
 *
................................................................................
#else
#error Wide high-resolution clicks not implemented on this platform
#endif
    }

    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 */
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *

Changes to win/tclWinTime.c.

49
50
51
52
53
54
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78


79
80
81
82
83
84
85
..
88
89
90
91
92
93
94

95
96
97
98
99
100
101
102

103
104
105
106
107

108
109
110
111
112











113
114
115
116
117
118
119
...
123
124
125
126
127
128
129

130
131
132
133
134
135
136
...
154
155
156
157
158
159
160








161
162
163
164

165
166
167
168
169
170
171
...
182
183
184
185
186
187
188








189
190
191
192
193
194
195
196
197

198

























































































































199
200
201
202
203
204
205
206
207
208
...
223
224
225
226
227
228
229









230

231
232
233
234
235
236
237
...
256
257
258
259
260
261
262
263
264
265
266
267
268
269

270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285






286
287


288
289
290
291
292
293
294
295
296
297
298




299
300
301
302
303
304
305
...
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456

457
458
459
460
461
462
463
464
465
466
467
468





































469
470
471


472
473
474

475
476
477
478
479
480
481
...
487
488
489
490
491
492
493


494
495
496
497
498
499
500
...
778
779
780
781
782
783
784


785
786
787
788
789
790
791
...
837
838
839
840
841
842
843

844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861








862
863



864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
...
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927

928
929
930


931







932
933
934
935
936





937
938

















939
940












941
942















943
944
945
946
947
948
949
typedef struct {
    CRITICAL_SECTION cs;	/* Mutex guarding this structure. */
    int initialized;		/* Flag == 1 if this structure is
				 * initialized. */
    int perfCounterAvailable;	/* Flag == 1 if the hardware has a performance
				 * counter. */

    HANDLE calibrationThread;	/* Handle to the thread that keeps the virtual
				 * clock calibrated. */
    HANDLE readyEvent;		/* System event used to trigger the requesting
				 * thread when the clock calibration procedure
				 * is initialized for the first time. */
    HANDLE exitEvent; 		/* Event to signal out of an exit handler to
				 * tell the calibration loop to terminate. */
    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:
     *    lastFileTime + (current perf counter - lastCounter)
     *				* 10000000 / curCounterFreq
     * and lastFileTime and lastCounter are updated any time that virtual time
     * is returned to a caller.
     */

    ULARGE_INTEGER fileTimeLastCall;
    LARGE_INTEGER perfCounterLastCall;
    LARGE_INTEGER curCounterFreq;



    /*
     * Data used in developing the estimate of performance counter frequency
     */

    Tcl_WideUInt fileTimeSample[SAMPLES];
				/* Last 64 samples of system time. */
................................................................................
    int sampleNo;		/* Current sample number. */
} TimeInfo;

static TimeInfo timeInfo = {
    { NULL, 0, 0, NULL, NULL, 0 },
    0,
    0,

    (HANDLE) NULL,
    (HANDLE) NULL,
    (HANDLE) NULL,
#ifdef HAVE_CAST_TO_UNION
    (LARGE_INTEGER) (Tcl_WideInt) 0,
    (ULARGE_INTEGER) (DWORDLONG) 0,
    (LARGE_INTEGER) (Tcl_WideInt) 0,
    (LARGE_INTEGER) (Tcl_WideInt) 0,

#else
    0,
    0,
    0,
    0,

#endif
    { 0 },
    { 0 },
    0
};












/*
 * Declarations for functions defined later in this file.
 */

#ifndef TCL_NO_DEPRECATED
static struct tm *	ComputeGMT(const time_t *tp);
................................................................................
static void 		UpdateTimeEachSecond(void);
static void		ResetCounterSamples(Tcl_WideUInt fileTime,
			    Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);
static Tcl_WideInt	AccumulateSample(Tcl_WideInt perfCounter,
			    Tcl_WideUInt fileTime);
static void		NativeScaleTime(Tcl_Time* timebuf,
			    ClientData clientData);

static void		NativeGetTime(Tcl_Time* timebuf,
			    ClientData clientData);

/*
 * TIP #233 (Virtualized Time): Data for the time hooks, if any.
 */

................................................................................
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetSeconds(void)
{








    Tcl_Time t;

    tclGetTimeProcPtr(&t, tclTimeClientData);	/* Tcl_GetTime inlined. */
    return t.sec;

}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGetClicks --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetClicks(void)
{








    /*
     * 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 */
    unsigned long retval;	/* Value to return */

    tclGetTimeProcPtr(&now, tclTimeClientData);	/* Tcl_GetTime inlined */



























































































































    retval = (now.sec * 1000000) + now.usec;
    return retval;

}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *
................................................................................
 *----------------------------------------------------------------------
 */

void
Tcl_GetTime(
    Tcl_Time *timePtr)		/* Location to store time information. */
{









    tclGetTimeProcPtr(timePtr, tclTimeClientData);

}
 
/*
 *----------------------------------------------------------------------
 *
 * NativeScaleTime --
 *
................................................................................
     * Native scale is 1:1. Nothing is done.
     */
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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:
 *	On the first call, initializes a set of static variables to keep track
 *	of the base value of the performance counter, the corresponding wall
 *	clock (obtained through ftime) and the frequency of the performance
 *	counter. Also spins a thread whose function is to wake up periodically
 *	and monitor these values, adjusting them as necessary to correct for
 *	drift in the performance counter's oscillator.
 *
 *----------------------------------------------------------------------
 */

static void
NativeGetTime(
    Tcl_Time *timePtr,
    ClientData clientData)






{
    struct _timeb t;



    /*
     * Initialize static storage on the first trip through.
     *
     * Note: Outer check for 'initialized' is a performance win since it
     * avoids an extra mutex lock in the common case.
     */

    if (!timeInfo.initialized) {
	TclpInitLock();
	if (!timeInfo.initialized) {




	    timeInfo.perfCounterAvailable =
		    QueryPerformanceFrequency(&timeInfo.nominalFreq);

	    /*
	     * Some hardware abstraction layers use the CPU clock in place of
	     * the real-time clock as a performance counter reference. This
	     * results in:
................................................................................

    if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) {
	/*
	 * Query the performance counter and use it to calculate the current
	 * time.
	 */

	ULARGE_INTEGER fileTimeLastCall;
	LARGE_INTEGER 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);

	/*
	 * Hold time section locked as short as possible
	 */
	EnterCriticalSection(&timeInfo.cs);

	fileTimeLastCall.QuadPart = timeInfo.fileTimeLastCall.QuadPart;
	perfCounterLastCall.QuadPart = timeInfo.perfCounterLastCall.QuadPart;
	curCounterFreq.QuadPart = 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 it appears to be more than 1.1 seconds since the last trip
	 * through the calibration loop, the performance counter may have
	 * jumped forward. (See MSDN Knowledge Base article Q274323 for a
	 * description of the hardware problem that makes this test
	 * necessary.) If the counter jumps, we don't want to use it directly.
	 * Instead, we must return system time. Eventually, the calibration
	 * loop should recover.
	 */

	if (curCounter.QuadPart - perfCounterLastCall.QuadPart <
		11 * curCounterFreq.QuadPart / 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;
	}
    }

    /*





































     * High resolution timer is not available. Just use ftime.
     */



    _ftime(&t);
    timePtr->sec = (long)t.time;
    timePtr->usec = t.millitm * 1000;

}
 
/*
 *----------------------------------------------------------------------
 *
 * StopCalibration --
 *
................................................................................
 *
 * Side effects:
 *	Sets the 'exitEvent' event in the 'timeInfo' structure to ask the
 *	thread in question to exit, and waits for it to do so.
 *
 *----------------------------------------------------------------------
 */



static void
StopCalibration(
    ClientData unused)		/* Client data is unused */
{
    SetEvent(timeInfo.exitEvent);

................................................................................
     */

    GetSystemTimeAsFileTime(&curFileTime);
    QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
    QueryPerformanceFrequency(&timeInfo.curCounterFreq);
    timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
    timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;



    ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
	    timeInfo.perfCounterLastCall.QuadPart,
	    timeInfo.curCounterFreq.QuadPart);

    /*
     * Wake up the calling thread. When it wakes up, it will release the
................................................................................
static void
UpdateTimeEachSecond(void)
{
    LARGE_INTEGER curPerfCounter;
				/* Current value returned from
				 * QueryPerformanceCounter. */
    FILETIME curSysTime;	/* Current system time. */

    LARGE_INTEGER curFileTime;	/* File time at the time this callback was
				 * scheduled. */
    Tcl_WideInt estFreq;	/* Estimated perf counter frequency. */
    Tcl_WideInt vt0;		/* Tcl time right now. */
    Tcl_WideInt vt1;		/* Tcl time one second from now. */
    Tcl_WideInt tdiff;		/* Difference between system clock and Tcl
				 * time. */
    Tcl_WideInt driftFreq;	/* Frequency needed to drift virtual time into
				 * step over 1 second. */

    /*
     * Sample performance counter and system time.
     */

    QueryPerformanceCounter(&curPerfCounter);
    GetSystemTimeAsFileTime(&curSysTime);
    curFileTime.LowPart = curSysTime.dwLowDateTime;
    curFileTime.HighPart = curSysTime.dwHighDateTime;









    EnterCriticalSection(&timeInfo.cs);




    /*
     * We devide by timeInfo.curCounterFreq.QuadPart in several places. That
     * value should always be positive on a correctly functioning system. But
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.
     */

    if (timeInfo.curCounterFreq.QuadPart == 0){
	LeaveCriticalSection(&timeInfo.cs);
	timeInfo.perfCounterAvailable = 0;
	return;
    }

    /*
     * Several things may have gone wrong here that have to be checked for.
     *  (1) The performance counter may have jumped.
................................................................................
     *
     * vt1 = 20000000 + curFileTime
     *
     * The frequency that we need to use to drift the counter back into place
     * is estFreq * 20000000 / (vt1 - vt0)
     */

    vt0 = 10000000 * (curPerfCounter.QuadPart
		- timeInfo.perfCounterLastCall.QuadPart)
	    / timeInfo.curCounterFreq.QuadPart
	    + timeInfo.fileTimeLastCall.QuadPart;
    vt1 = 20000000 + curFileTime.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,
     * compute the drift frequency and fill in everything.
     */

    tdiff = vt0 - curFileTime.QuadPart;
    if (tdiff > 10000000 || tdiff < -10000000) {

	timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart;
	timeInfo.curCounterFreq.QuadPart = estFreq;
    } else {


	driftFreq = estFreq * 20000000 / (vt1 - vt0);








	if (driftFreq > 1003*estFreq/1000) {
	    driftFreq = 1003*estFreq/1000;
	} else if (driftFreq < 997*estFreq/1000) {
	    driftFreq = 997*estFreq/1000;





	}


















	timeInfo.fileTimeLastCall.QuadPart = vt0;
	timeInfo.curCounterFreq.QuadPart = driftFreq;












    }
















    timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart;

    LeaveCriticalSection(&timeInfo.cs);
}
 
/*
 *----------------------------------------------------------------------






>










<












>
>







 







>








>

|
|
|
|
>





>
>
>
>
>
>
>
>
>
>
>







 







>







 







>
>
>
>
>
>
>
>
|

|
|
>







 







>
>
>
>
>
>
>
>
|
|
|
|

|
<

|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|







 







>
>
>
>
>
>
>
>
>
|
>







 







|

|
|


|
>












|
|
|
|
>
>
>
>
>
>
|
<
>
>
|










>
>
>
>







 







|
|




<
<
<
<
<
<
<
<
<
<








|
|
|






|
|
|
<
<
<












|
|

>
|
<
|
<
<
<
<
<




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|

>
>
|
|
|
>







 







>
>







 







>
>







 







>











|


<



>
>
>
>
>
>
>
>
|
<
>
>
>











<







 







|
|
|
<
<
<








>
|
<

>
>
|
>
>
>
>
>
>
>

<
<
<
<
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
...
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
...
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228

229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354

355
356
357
358
359
360
361
362
...
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
...
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457

458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
572
573
574
575
576
577
578
579
580
581
582
583
584










585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604



605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621

622





623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
...
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
...
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
....
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060

1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072

1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086

1087
1088
1089
1090
1091
1092
1093
....
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127



1128
1129
1130
1131
1132
1133
1134
1135
1136
1137

1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149




1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
typedef struct {
    CRITICAL_SECTION cs;	/* Mutex guarding this structure. */
    int initialized;		/* Flag == 1 if this structure is
				 * 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
				 * thread when the clock calibration procedure
				 * is initialized for the first time. */
    HANDLE exitEvent; 		/* Event to signal out of an exit handler to
				 * tell the calibration loop to terminate. */
    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:
     *    lastFileTime + (current perf counter - lastCounter)
     *				* 10000000 / curCounterFreq
     * and lastFileTime and lastCounter are updated any time that virtual time
     * is returned to a caller.
     */

    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
     */

    Tcl_WideUInt fileTimeSample[SAMPLES];
				/* Last 64 samples of system time. */
................................................................................
    int sampleNo;		/* Current sample number. */
} TimeInfo;

static TimeInfo timeInfo = {
    { NULL, 0, 0, NULL, NULL, 0 },
    0,
    0,
    1,
    (HANDLE) NULL,
    (HANDLE) NULL,
    (HANDLE) NULL,
#ifdef HAVE_CAST_TO_UNION
    (LARGE_INTEGER) (Tcl_WideInt) 0,
    (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},
#endif
    { 0 },
    { 0 },
    0
};

/*
 * 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.
 */

#ifndef TCL_NO_DEPRECATED
static struct tm *	ComputeGMT(const time_t *tp);
................................................................................
static void 		UpdateTimeEachSecond(void);
static void		ResetCounterSamples(Tcl_WideUInt fileTime,
			    Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);
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);

/*
 * TIP #233 (Virtualized Time): Data for the time hooks, if any.
 */

................................................................................
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetSeconds(void)
{
    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;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGetClicks --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

unsigned long
TclpGetClicks(void)
{
    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_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;

    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetTime --
 *
................................................................................
 *----------------------------------------------------------------------
 */

void
Tcl_GetTime(
    Tcl_Time *timePtr)		/* Location to store time information. */
{
    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);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * NativeScaleTime --
 *
................................................................................
     * Native scale is 1:1. Nothing is done.
     */
}
 
/*
 *----------------------------------------------------------------------
 *
 * NativeGetMicroseconds --
 *
 *	Gets the current system time in microseconds since the beginning
 *	of the epoch: 00:00 UCT, January 1, 1970.
 *
 * Results:
 *	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
 *	of the base value of the performance counter, the corresponding wall
 *	clock (obtained through ftime) and the frequency of the performance
 *	counter. Also spins a thread whose function is to wake up periodically
 *	and monitor these values, adjusting them as necessary to correct for
 *	drift in the performance counter's oscillator.
 *
 *----------------------------------------------------------------------
 */

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.
     *
     * Note: Outer check for 'initialized' is a performance win since it
     * avoids an extra mutex lock in the common case.
     */

    if (!timeInfo.initialized) {
	TclpInitLock();
	if (!timeInfo.initialized) {

	    timeInfo.posixEpoch.LowPart = 0xD53E8000;
	    timeInfo.posixEpoch.HighPart = 0x019DB1DE;

	    timeInfo.perfCounterAvailable =
		    QueryPerformanceFrequency(&timeInfo.nominalFreq);

	    /*
	     * Some hardware abstraction layers use the CPU clock in place of
	     * the real-time clock as a performance counter reference. This
	     * results in:
................................................................................

    if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) {
	/*
	 * Query the performance counter and use it to calculate the current
	 * time.
	 */

	ULONGLONG fileTimeLastCall;
	LONGLONG perfCounterLastCall, curCounterFreq;
				/* Copy with current data of calibration cycle */

	LARGE_INTEGER curCounter;
				/* Current performance counter. */











	QueryPerformanceCounter(&curCounter);

	/*
	 * Hold time section locked as short as possible
	 */
	EnterCriticalSection(&timeInfo.cs);

	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) {
	    /* Calibrated file-time is saved from posix in 100-ns ticks */
	    return fileTimeLastCall / 10;



	}

	/*
	 * If it appears to be more than 1.1 seconds since the last trip
	 * through the calibration loop, the performance counter may have
	 * jumped forward. (See MSDN Knowledge Base article Q274323 for a
	 * description of the hardware problem that makes this test
	 * necessary.) If the counter jumps, we don't want to use it directly.
	 * Instead, we must return system time. Eventually, the calibration
	 * loop should recover.
	 */

	if (curCounter.QuadPart - perfCounterLastCall <
		11 * curCounterFreq * timeInfo.calibrationInterv / 10
	) {
	    /* 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.
     */
    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;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * StopCalibration --
 *
................................................................................
 *
 * Side effects:
 *	Sets the 'exitEvent' event in the 'timeInfo' structure to ask the
 *	thread in question to exit, and waits for it to do so.
 *
 *----------------------------------------------------------------------
 */

void TclWinResetTimerResolution(void);

static void
StopCalibration(
    ClientData unused)		/* Client data is unused */
{
    SetEvent(timeInfo.exitEvent);

................................................................................
     */

    GetSystemTimeAsFileTime(&curFileTime);
    QueryPerformanceCounter(&timeInfo.perfCounterLastCall);
    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,
	    timeInfo.curCounterFreq.QuadPart);

    /*
     * Wake up the calling thread. When it wakes up, it will release the
................................................................................
static void
UpdateTimeEachSecond(void)
{
    LARGE_INTEGER curPerfCounter;
				/* 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. */
    Tcl_WideInt vt0;		/* Tcl time right now. */
    Tcl_WideInt vt1;		/* Tcl time one second from now. */
    Tcl_WideInt tdiff;		/* Difference between system clock and Tcl
				 * time. */
    Tcl_WideInt driftFreq;	/* Frequency needed to drift virtual time into
				 * step over 1 second. */

    /*
     * Sample performance counter and system time (from posix epoch).
     */


    GetSystemTimeAsFileTime(&curSysTime);
    curFileTime.LowPart = curSysTime.dwLowDateTime;
    curFileTime.HighPart = curSysTime.dwHighDateTime;
    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
     * value should always be positive on a correctly functioning system. But
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.
     */

    if (timeInfo.curCounterFreq.QuadPart == 0){

	timeInfo.perfCounterAvailable = 0;
	return;
    }

    /*
     * Several things may have gone wrong here that have to be checked for.
     *  (1) The performance counter may have jumped.
................................................................................
     *
     * vt1 = 20000000 + curFileTime
     *
     * The frequency that we need to use to drift the counter back into place
     * is estFreq * 20000000 / (vt1 - vt0)
     */

    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,
     * compute the drift frequency and fill in everything.
     */

    tdiff = vt0 - curFileTime.QuadPart;
    if (tdiff > 10000000 || tdiff < -10000000) {
    	/* jump to current system time, use curent estimated frequency */
    	vt0 = curFileTime.QuadPart;

    } else {
    	/* 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;





	/* 
	 * 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);

    /* 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);
}
 
/*
 *----------------------------------------------------------------------