4 * Tcl performance profile monitor.
5 *-----------------------------------------------------------------------------
6 * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
8 * Permission to use, copy, modify, and distribute this software and its
9 * documentation for any purpose and without fee is hereby granted, provided
10 * that the above copyright notice appear in all copies. Karl Lehenbauer and
11 * Mark Diekhans make no representations about the suitability of this
12 * software for any purpose. It is provided "as is" without express or
14 *-----------------------------------------------------------------------------
15 * $Id: tclXprofile.c,v 2.0 1992/10/16 04:51:05 markd Rel $
16 *-----------------------------------------------------------------------------
23 * Stack entry used to keep track of an profiling information for active
24 * procedure. Handling uplevels is tricky. The eval level and procedure call
25 * level are kept track of. These are used to distinguish between an uplevel
26 * and exiting a procedure. During an uplevel, the invisible part of the
27 * profile stack is saved on another stack until the uplevel completes.
30 typedef struct profStackEntry_t
{
31 long realTime
; /* Real time at procedure entry. */
32 long cpuTime
; /* CPU time at procedure entry. */
33 int procLevel
; /* Call level of this procedure */
34 int evalLevel
; /* Eval level of this prodecure */
35 struct profStackEntry_t
*prevEntryPtr
; /* Previous stack entry. */
36 char procName
[1]; /* Procedure name. MUST BE LAST! */
41 * Save stack entry used to hold profile stack entries during an uplevel.
44 typedef struct saveStackEntry_t
{
45 profStackEntry_t
*topPtr
; /* Top of saved stack section */
46 profStackEntry_t
*bottomPtr
; /* Bottom of saved stack */
47 struct saveStackEntry_t
*prevEntryPtr
; /* Previous saved stack section */
51 * Data keeped on a stack snapshot.
54 typedef struct profDataEntry_t
{
61 * Client data structure for profile command. A count of real and CPU time
62 * spent outside of the profiling routines is kept to factor out the variable
66 typedef struct profInfo_t
{
67 Tcl_Interp
*interp
; /* Interpreter this is for. */
68 Tcl_Trace traceHolder
; /* Handle to current trace. */
69 int allCommands
; /* Prof all commands, not just procs*/
70 long realTime
; /* Real and CPU time counter. */
72 long lastRealTime
; /* Real and CPU time of last exit */
73 long lastCpuTime
; /* from profiling routines. */
74 profStackEntry_t
*stackPtr
; /* Pointer to the top of prof stack */
75 saveStackEntry_t
*saveStackPtr
; /* Frames saved during an uplevel */
76 Tcl_HashTable profDataTable
; /* Cumulative time table, Keyed by */
77 /* call stack list. */
81 * Prototypes of internal functions.
85 ProcEntry
_ANSI_ARGS_((profInfo_t
*infoPtr
,
91 ProcPopEntry
_ANSI_ARGS_((profInfo_t
*infoPtr
));
94 StackSync
_ANSI_ARGS_((profInfo_t
*infoPtr
,
99 DoUplevel
_ANSI_ARGS_((profInfo_t
*infoPtr
,
103 ProfTraceRoutine
_ANSI_ARGS_((ClientData clientData
,
108 ClientData cmdClientData
,
113 CleanDataTable
_ANSI_ARGS_((profInfo_t
*infoPtr
));
116 DeleteProfTrace
_ANSI_ARGS_((profInfo_t
*infoPtr
));
119 DumpTableData
_ANSI_ARGS_((Tcl_Interp
*interp
,
124 Tcl_ProfileCmd
_ANSI_ARGS_((ClientData clientData
,
130 CleanUpProfMon
_ANSI_ARGS_((ClientData clientData
));
134 *-----------------------------------------------------------------------------
137 * Push a procedure entry onto the stack.
140 * o infoPtr (I/O) - The global profiling info.
141 * o procName (I) The procedure name.
142 * o procLevel (I) - The procedure call level that the procedure will
144 * o evalLevel (I) - The eval level that the procedure will start
146 *-----------------------------------------------------------------------------
149 ProcEntry (infoPtr
, procName
, procLevel
, evalLevel
)
155 profStackEntry_t
*entryPtr
;
158 * Calculate the size of an entry. One byte for name is in the entry.
160 entryPtr
= (profStackEntry_t
*) ckalloc (sizeof (profStackEntry_t
) +
164 * Fill it in and push onto the stack. Note that the procedures frame has
165 * not yet been layed down or the procedure body eval execute, so the value
166 * they will be in the procedure is recorded.
168 entryPtr
->realTime
= infoPtr
->realTime
;
169 entryPtr
->cpuTime
= infoPtr
->cpuTime
;
170 entryPtr
->procLevel
= procLevel
;
171 entryPtr
->evalLevel
= evalLevel
;
172 strcpy (entryPtr
->procName
, procName
);
174 entryPtr
->prevEntryPtr
= infoPtr
->stackPtr
;
175 infoPtr
->stackPtr
= entryPtr
;
179 *-----------------------------------------------------------------------------
182 * Pop the procedure entry from the top of the stack and record its
183 * times in the data table.
186 * o infoPtr (I/O) - The global profiling info.
187 *-----------------------------------------------------------------------------
190 ProcPopEntry (infoPtr
)
193 profStackEntry_t
*entryPtr
= infoPtr
->stackPtr
;
194 profStackEntry_t
*scanPtr
;
197 Tcl_HashEntry
*hashEntryPtr
;
198 profDataEntry_t
*dataEntryPtr
;
199 char *stackArgv
[MAX_NESTING_DEPTH
];
202 * Build up a stack list. Entry [0] is the top of the stack.
206 while (scanPtr
!= NULL
) {
207 stackArgv
[idx
] = scanPtr
->procName
;
209 scanPtr
= scanPtr
->prevEntryPtr
;
211 stackListPtr
= Tcl_Merge (idx
, stackArgv
);
214 * Check the hash table for this entry, either finding an existing or
215 * creating a new hash entry.
218 hashEntryPtr
= Tcl_CreateHashEntry (&infoPtr
->profDataTable
,
221 ckfree (stackListPtr
);
224 * Fill in or increment the entry.
227 dataEntryPtr
= (profDataEntry_t
*) ckalloc (sizeof (profDataEntry_t
));
228 Tcl_SetHashValue (hashEntryPtr
, dataEntryPtr
);
229 dataEntryPtr
->count
= 0;
230 dataEntryPtr
->realTime
= 0;
231 dataEntryPtr
->cpuTime
= 0;;
233 dataEntryPtr
= (profDataEntry_t
*) Tcl_GetHashValue (hashEntryPtr
);
235 dataEntryPtr
->count
++;
236 dataEntryPtr
->realTime
+= (infoPtr
->realTime
- entryPtr
->realTime
);
237 dataEntryPtr
->cpuTime
+= (infoPtr
->cpuTime
- entryPtr
->cpuTime
);
240 infoPtr
->stackPtr
= entryPtr
->prevEntryPtr
;
241 ckfree ((char *) entryPtr
);
245 *-----------------------------------------------------------------------------
248 * Synchronize the profile stack with the interpreter procedure stack.
249 * This is done once return from uplevels, exits and error unwinds are
250 * detected (the command after). Saved profile stack entries may be
251 * restored and procedure entries popped from the stack. When entries
252 * are popped, their statistics is saved in stack.
255 * o infoPtr (I/O) - The global profiling info.
256 * o procLevel (I) - Procedure call level to return to (zero to clear stack).
257 * o evalLevel (I) - Eval call level to return to (zero to clear stack).
258 *-----------------------------------------------------------------------------
261 StackSync (infoPtr
, procLevel
, evalLevel
)
266 saveStackEntry_t
*saveEntryPtr
;
270 * Move top of saved stack to standard stack if stack is empty or
271 * saved eval level is greater than the top of the standard stack.
273 saveEntryPtr
= infoPtr
->saveStackPtr
;
275 if ((saveEntryPtr
!= NULL
) &&
276 ((infoPtr
->stackPtr
== NULL
) ||
277 (saveEntryPtr
->topPtr
->evalLevel
>
278 infoPtr
->stackPtr
->evalLevel
))) {
280 infoPtr
->stackPtr
= saveEntryPtr
->topPtr
;
281 infoPtr
->saveStackPtr
= saveEntryPtr
->prevEntryPtr
;
282 ckfree ((char *) saveEntryPtr
);
286 if ((infoPtr
->stackPtr
== NULL
) ||
287 ((procLevel
>= infoPtr
->stackPtr
->procLevel
) &&
288 (evalLevel
>= infoPtr
->stackPtr
->evalLevel
)))
290 ProcPopEntry (infoPtr
);
297 *-----------------------------------------------------------------------------
301 * Do processing required when an uplevel is detected. Builds and
302 * pushes a save stack containing all of the save entrys that have been
303 * hiden by the uplevel.
306 * o infoPtr (I/O) - The global profiling info.
307 * o procLevel (I) - The upleveled procedure call level.
308 *-----------------------------------------------------------------------------
311 DoUplevel (infoPtr
, procLevel
)
315 profStackEntry_t
*scanPtr
, *bottomPtr
;
316 saveStackEntry_t
*saveEntryPtr
;
319 * Find the stack area to save.
322 scanPtr
= infoPtr
->stackPtr
;
323 while ((scanPtr
!= NULL
) && (scanPtr
->procLevel
> procLevel
)) {
325 scanPtr
= scanPtr
->prevEntryPtr
;
327 if (bottomPtr
== NULL
)
328 panic ("uplevel stack confusion");
331 * Save the stack entries in the save stack.
333 saveEntryPtr
= (saveStackEntry_t
*) ckalloc (sizeof (saveStackEntry_t
));
334 saveEntryPtr
->topPtr
= infoPtr
->stackPtr
;
335 saveEntryPtr
->bottomPtr
= bottomPtr
;
336 saveEntryPtr
->prevEntryPtr
= infoPtr
->saveStackPtr
;;
338 infoPtr
->saveStackPtr
= saveEntryPtr
;
341 * Hide the stack entries.
343 infoPtr
->stackPtr
= bottomPtr
->prevEntryPtr
;
348 *-----------------------------------------------------------------------------
350 * ProfTraceRoutine --
351 * Routine called by Tcl_Eval to do profiling.
353 *-----------------------------------------------------------------------------
356 ProfTraceRoutine (clientData
, interp
, evalLevel
, command
, cmdProc
,
357 cmdClientData
, argc
, argv
)
358 ClientData clientData
;
363 ClientData cmdClientData
;
367 Interp
*iPtr
= (Interp
*) interp
;
369 profInfo_t
*infoPtr
= (profInfo_t
*) clientData
;
370 int procLevel
= (iPtr
->varFramePtr
== NULL
) ? 0 :
371 iPtr
->varFramePtr
->level
;
374 * Calculate the time spent since the last trace.
376 infoPtr
->realTime
+= times (&cpuTimes
) - infoPtr
->lastRealTime
;
377 infoPtr
->cpuTime
+= (cpuTimes
.tms_utime
+ cpuTimes
.tms_stime
) -
378 infoPtr
->lastCpuTime
;
382 * If the procedure level has changed, then something is up. Its not a
383 * procedure call, as we head them off before they happen. Its one of
386 * o A uplevel command was executed.
387 * o Returned from an uplevel.
388 * o A procedure exit has occured.
389 * o An error unwind has occured.
391 * Eval level must be tested as well as proc level to cover upleveled
392 * proc calls that don't execute any commands.
395 if ((infoPtr
->stackPtr
!= NULL
) &&
396 ((procLevel
!= infoPtr
->stackPtr
->procLevel
) ||
397 (evalLevel
< infoPtr
->stackPtr
->evalLevel
))) {
399 if ((procLevel
< infoPtr
->stackPtr
->procLevel
) &&
400 (evalLevel
> infoPtr
->stackPtr
->evalLevel
))
401 DoUplevel (infoPtr
, procLevel
);
403 StackSync (infoPtr
, procLevel
, evalLevel
);
407 * If this is level zero and the stack is empty, add an entry for the
408 * global level. This takes care of the first command at the global level
409 * after profiling has been enabled or the case where profiling was
410 * enabled in a proc and we have returned to the global level.
412 if ((infoPtr
->stackPtr
== NULL
) && (procLevel
== 0))
413 ProcEntry (infoPtr
, "<global>", 0, evalLevel
);
416 * If this command is a procedure or if all commands are being traced,
420 if (infoPtr
->allCommands
|| (TclFindProc (iPtr
, argv
[0]) != NULL
))
421 ProcEntry (infoPtr
, argv
[0], procLevel
+ 1, evalLevel
+ 1);
424 * Save the exit time of the profiling trace handler.
426 infoPtr
->lastRealTime
= times (&cpuTimes
);
427 infoPtr
->lastCpuTime
= cpuTimes
.tms_utime
+ cpuTimes
.tms_stime
;
432 *-----------------------------------------------------------------------------
436 * Clean up the hash data table, releasing all resources and setting it
437 * to the empty state.
440 * o infoPtr (I/O) - The global profiling info.
441 *-----------------------------------------------------------------------------
444 CleanDataTable (infoPtr
)
447 Tcl_HashEntry
*hashEntryPtr
;
448 Tcl_HashSearch searchCookie
;
450 hashEntryPtr
= Tcl_FirstHashEntry (&infoPtr
->profDataTable
,
452 while (hashEntryPtr
!= NULL
) {
453 ckfree ((char *) Tcl_GetHashValue (hashEntryPtr
));
454 Tcl_DeleteHashEntry (hashEntryPtr
);
455 hashEntryPtr
= Tcl_NextHashEntry (&searchCookie
);
460 *-----------------------------------------------------------------------------
464 * Delete the profile trace and clean up the stack, logging all procs
465 * as if they had exited. Data table must still be available.
468 * o infoPtr (I/O) - The global profiling info.
469 *-----------------------------------------------------------------------------
472 DeleteProfTrace (infoPtr
)
475 Tcl_DeleteTrace (infoPtr
->interp
, infoPtr
->traceHolder
);
476 infoPtr
->traceHolder
= NULL
;
478 StackSync (infoPtr
, 0, 0);
483 *-----------------------------------------------------------------------------
487 * Dump the table data to an array variable. Entries will be deleted
488 * as they are dumped to limit memory utilization.
491 * o interp (I) - Pointer to the interprer.
492 * o infoPtr (I/O) - The global profiling info.
493 * o varName (I) - The name of the variable to save the data in.
495 * Standard Tcl command results
496 *-----------------------------------------------------------------------------
499 DumpTableData (interp
, infoPtr
, varName
)
504 Tcl_HashEntry
*hashEntryPtr
;
505 Tcl_HashSearch searchCookie
;
506 profDataEntry_t
*dataEntryPtr
;
507 char *dataArgv
[3], *dataListPtr
;
508 char countBuf
[32], realTimeBuf
[32], cpuTimeBuf
[32];
510 dataArgv
[0] = countBuf
;
511 dataArgv
[1] = realTimeBuf
;
512 dataArgv
[2] = cpuTimeBuf
;
514 Tcl_UnsetVar (interp
, varName
, 0);
515 hashEntryPtr
= Tcl_FirstHashEntry (&infoPtr
->profDataTable
,
517 while (hashEntryPtr
!= NULL
) {
519 (profDataEntry_t
*) Tcl_GetHashValue (hashEntryPtr
);
521 sprintf (countBuf
, "%ld", dataEntryPtr
->count
);
522 sprintf (realTimeBuf
, "%ld", dataEntryPtr
->realTime
* MS_PER_TICK
);
523 sprintf (cpuTimeBuf
, "%ld", dataEntryPtr
->cpuTime
* MS_PER_TICK
);
525 dataListPtr
= Tcl_Merge (3, dataArgv
);
527 if (Tcl_SetVar2 (interp
, varName
,
528 Tcl_GetHashKey (&infoPtr
->profDataTable
,
530 dataListPtr
, TCL_LEAVE_ERR_MSG
) == NULL
) {
531 ckfree (dataListPtr
);
534 ckfree (dataListPtr
);
535 ckfree ((char *) dataEntryPtr
);
536 Tcl_DeleteHashEntry (hashEntryPtr
);
538 hashEntryPtr
= Tcl_NextHashEntry (&searchCookie
);
545 *-----------------------------------------------------------------------------
548 * Implements the TCL profile command:
550 * profile off arrayvar
553 * Standard TCL results.
555 *-----------------------------------------------------------------------------
558 Tcl_ProfileCmd (clientData
, interp
, argc
, argv
)
559 ClientData clientData
;
564 Interp
*iPtr
= (Interp
*) interp
;
565 profInfo_t
*infoPtr
= (profInfo_t
*) clientData
;
567 int cmdArgc
, optionsArgc
= 0;
568 char **cmdArgv
, **optionsArgv
= &(argv
[1]);
571 * Scan for options (currently only one is supported). Set cmdArgv to
572 * contain the rest of the command following the options.
574 for (idx
= 1; (idx
< argc
) && (argv
[idx
][0] == '-'); idx
++)
576 cmdArgc
= argc
- idx
;
577 cmdArgv
= &(argv
[idx
]);
583 * Handle the on command.
585 if (STREQU (cmdArgv
[0], "on")) {
586 int allCommands
= FALSE
;
589 if ((cmdArgc
!= 1) || (optionsArgc
> 1))
592 if (optionsArgc
== 1) {
593 if (!STREQU (optionsArgv
[0], "-commands")) {
594 Tcl_AppendResult (interp
, "expected option of \"-commands\", ",
595 "got \"", optionsArgv
[0], "\"",
602 if (infoPtr
->traceHolder
!= NULL
) {
603 Tcl_AppendResult (interp
, "profiling is already enabled",
608 CleanDataTable (infoPtr
);
609 infoPtr
->traceHolder
= Tcl_CreateTrace (interp
, MAXINT
,
611 (ClientData
) infoPtr
);
612 infoPtr
->realTime
= 0;
613 infoPtr
->cpuTime
= 0;
614 infoPtr
->lastRealTime
= times (&cpuTimes
);
615 infoPtr
->lastCpuTime
= cpuTimes
.tms_utime
+ cpuTimes
.tms_stime
;
616 infoPtr
->allCommands
= allCommands
;
621 * Handle the off command. Dump the hash table to a variable.
623 if (STREQU (cmdArgv
[0], "off")) {
625 if ((cmdArgc
!= 2) || (optionsArgc
> 0))
628 if (infoPtr
->traceHolder
== NULL
) {
629 Tcl_AppendResult (interp
, "profiling is not currently enabled",
634 DeleteProfTrace (infoPtr
);
636 if (DumpTableData (interp
, infoPtr
, argv
[2]) != TCL_OK
)
642 * Not a valid subcommand.
644 Tcl_AppendResult (interp
, "expected one of \"on\" or \"off\", got \"",
645 argv
[1], "\"", (char *) NULL
);
649 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
650 " [-commands] on|off arrayVar", (char *) NULL
);
655 *-----------------------------------------------------------------------------
659 * Release the client data area when the profile command is deleted.
661 *-----------------------------------------------------------------------------
664 CleanUpProfMon (clientData
)
665 ClientData clientData
;
667 profInfo_t
*infoPtr
= (profInfo_t
*) clientData
;
669 if (infoPtr
->traceHolder
!= NULL
)
670 DeleteProfTrace (infoPtr
);
671 CleanDataTable (infoPtr
);
672 Tcl_DeleteHashTable (&infoPtr
->profDataTable
);
673 ckfree ((char *) infoPtr
);
677 *-----------------------------------------------------------------------------
681 * Initialize the Tcl profiling command.
683 *-----------------------------------------------------------------------------
686 Tcl_InitProfile (interp
)
691 infoPtr
= (profInfo_t
*) ckalloc (sizeof (profInfo_t
));
693 infoPtr
->interp
= interp
;
694 infoPtr
->traceHolder
= NULL
;
695 infoPtr
->stackPtr
= NULL
;
696 infoPtr
->saveStackPtr
= NULL
;
697 Tcl_InitHashTable (&infoPtr
->profDataTable
, TCL_STRING_KEYS
);
699 Tcl_CreateCommand (interp
, "profile", Tcl_ProfileCmd
,
700 (ClientData
)infoPtr
, CleanUpProfMon
);