]>
Commit | Line | Data |
---|---|---|
6a5fa4e0 MG |
1 | /* |
2 | * tclXprofile.c -- | |
3 | * | |
4 | * Tcl performance profile monitor. | |
5 | *----------------------------------------------------------------------------- | |
6 | * Copyright 1992 Karl Lehenbauer and Mark Diekhans. | |
7 | * | |
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 | |
13 | * implied warranty. | |
14 | *----------------------------------------------------------------------------- | |
15 | * $Id: tclXprofile.c,v 2.0 1992/10/16 04:51:05 markd Rel $ | |
16 | *----------------------------------------------------------------------------- | |
17 | */ | |
18 | ||
19 | #include "tclhash.h" | |
20 | #include "tclxint.h" | |
21 | ||
22 | /* | |
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. | |
28 | */ | |
29 | ||
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! */ | |
37 | } profStackEntry_t; | |
38 | ||
39 | ||
40 | /* | |
41 | * Save stack entry used to hold profile stack entries during an uplevel. | |
42 | */ | |
43 | ||
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 */ | |
48 | } saveStackEntry_t; | |
49 | ||
50 | /* | |
51 | * Data keeped on a stack snapshot. | |
52 | */ | |
53 | ||
54 | typedef struct profDataEntry_t { | |
55 | long count; | |
56 | long realTime; | |
57 | long cpuTime; | |
58 | } profDataEntry_t; | |
59 | ||
60 | /* | |
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 | |
63 | * overhead. | |
64 | */ | |
65 | ||
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. */ | |
71 | long cpuTime; | |
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. */ | |
78 | } profInfo_t; | |
79 | ||
80 | /* | |
81 | * Prototypes of internal functions. | |
82 | */ | |
83 | ||
84 | static void | |
85 | ProcEntry _ANSI_ARGS_((profInfo_t *infoPtr, | |
86 | char *procName, | |
87 | int procLevel, | |
88 | int evalLevel)); | |
89 | ||
90 | static void | |
91 | ProcPopEntry _ANSI_ARGS_((profInfo_t *infoPtr)); | |
92 | ||
93 | static void | |
94 | StackSync _ANSI_ARGS_((profInfo_t *infoPtr, | |
95 | int procLevel, | |
96 | int evalLevel)); | |
97 | ||
98 | static void | |
99 | DoUplevel _ANSI_ARGS_((profInfo_t *infoPtr, | |
100 | int procLevel)); | |
101 | ||
102 | static void | |
103 | ProfTraceRoutine _ANSI_ARGS_((ClientData clientData, | |
104 | Tcl_Interp *interp, | |
105 | int evalLevel, | |
106 | char *command, | |
107 | int (*cmdProc)(), | |
108 | ClientData cmdClientData, | |
109 | int argc, | |
110 | char **argv)); | |
111 | ||
112 | static void | |
113 | CleanDataTable _ANSI_ARGS_((profInfo_t *infoPtr)); | |
114 | ||
115 | static void | |
116 | DeleteProfTrace _ANSI_ARGS_((profInfo_t *infoPtr)); | |
117 | ||
118 | static int | |
119 | DumpTableData _ANSI_ARGS_((Tcl_Interp *interp, | |
120 | profInfo_t *infoPtr, | |
121 | char *varName)); | |
122 | ||
123 | static int | |
124 | Tcl_ProfileCmd _ANSI_ARGS_((ClientData clientData, | |
125 | Tcl_Interp *interp, | |
126 | int argc, | |
127 | char **argv)); | |
128 | ||
129 | static void | |
130 | CleanUpProfMon _ANSI_ARGS_((ClientData clientData)); | |
131 | ||
132 | \f | |
133 | /* | |
134 | *----------------------------------------------------------------------------- | |
135 | * | |
136 | * ProcEntry -- | |
137 | * Push a procedure entry onto the stack. | |
138 | * | |
139 | * Parameters: | |
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 | |
143 | * execute at. | |
144 | * o evalLevel (I) - The eval level that the procedure will start | |
145 | * executing at. | |
146 | *----------------------------------------------------------------------------- | |
147 | */ | |
148 | static void | |
149 | ProcEntry (infoPtr, procName, procLevel, evalLevel) | |
150 | profInfo_t *infoPtr; | |
151 | char *procName; | |
152 | int procLevel; | |
153 | int evalLevel; | |
154 | { | |
155 | profStackEntry_t *entryPtr; | |
156 | ||
157 | /* | |
158 | * Calculate the size of an entry. One byte for name is in the entry. | |
159 | */ | |
160 | entryPtr = (profStackEntry_t *) ckalloc (sizeof (profStackEntry_t) + | |
161 | strlen (procName)); | |
162 | ||
163 | /* | |
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. | |
167 | */ | |
168 | entryPtr->realTime = infoPtr->realTime; | |
169 | entryPtr->cpuTime = infoPtr->cpuTime; | |
170 | entryPtr->procLevel = procLevel; | |
171 | entryPtr->evalLevel = evalLevel; | |
172 | strcpy (entryPtr->procName, procName); | |
173 | ||
174 | entryPtr->prevEntryPtr = infoPtr->stackPtr; | |
175 | infoPtr->stackPtr = entryPtr; | |
176 | } | |
177 | \f | |
178 | /* | |
179 | *----------------------------------------------------------------------------- | |
180 | * | |
181 | * ProcPopEntry -- | |
182 | * Pop the procedure entry from the top of the stack and record its | |
183 | * times in the data table. | |
184 | * | |
185 | * Parameters: | |
186 | * o infoPtr (I/O) - The global profiling info. | |
187 | *----------------------------------------------------------------------------- | |
188 | */ | |
189 | static void | |
190 | ProcPopEntry (infoPtr) | |
191 | profInfo_t *infoPtr; | |
192 | { | |
193 | profStackEntry_t *entryPtr = infoPtr->stackPtr; | |
194 | profStackEntry_t *scanPtr; | |
195 | int idx, newEntry; | |
196 | char *stackListPtr; | |
197 | Tcl_HashEntry *hashEntryPtr; | |
198 | profDataEntry_t *dataEntryPtr; | |
199 | char *stackArgv [MAX_NESTING_DEPTH]; | |
200 | ||
201 | /* | |
202 | * Build up a stack list. Entry [0] is the top of the stack. | |
203 | */ | |
204 | idx= 0; | |
205 | scanPtr = entryPtr; | |
206 | while (scanPtr != NULL) { | |
207 | stackArgv [idx] = scanPtr->procName; | |
208 | idx++; | |
209 | scanPtr = scanPtr->prevEntryPtr; | |
210 | } | |
211 | stackListPtr = Tcl_Merge (idx, stackArgv); | |
212 | ||
213 | /* | |
214 | * Check the hash table for this entry, either finding an existing or | |
215 | * creating a new hash entry. | |
216 | */ | |
217 | ||
218 | hashEntryPtr = Tcl_CreateHashEntry (&infoPtr->profDataTable, | |
219 | stackListPtr, | |
220 | &newEntry); | |
221 | ckfree (stackListPtr); | |
222 | ||
223 | /* | |
224 | * Fill in or increment the entry. | |
225 | */ | |
226 | if (newEntry) { | |
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;; | |
232 | } else | |
233 | dataEntryPtr = (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr); | |
234 | ||
235 | dataEntryPtr->count++; | |
236 | dataEntryPtr->realTime += (infoPtr->realTime - entryPtr->realTime); | |
237 | dataEntryPtr->cpuTime += (infoPtr->cpuTime - entryPtr->cpuTime); | |
238 | ||
239 | ||
240 | infoPtr->stackPtr = entryPtr->prevEntryPtr; | |
241 | ckfree ((char *) entryPtr); | |
242 | } | |
243 | \f | |
244 | /* | |
245 | *----------------------------------------------------------------------------- | |
246 | * | |
247 | * StackSync -- | |
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. | |
253 | * | |
254 | * Parameters: | |
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 | *----------------------------------------------------------------------------- | |
259 | */ | |
260 | static void | |
261 | StackSync (infoPtr, procLevel, evalLevel) | |
262 | profInfo_t *infoPtr; | |
263 | int procLevel; | |
264 | int evalLevel; | |
265 | { | |
266 | saveStackEntry_t *saveEntryPtr; | |
267 | ||
268 | while (TRUE) { | |
269 | /* | |
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. | |
272 | */ | |
273 | saveEntryPtr = infoPtr->saveStackPtr; | |
274 | ||
275 | if ((saveEntryPtr != NULL) && | |
276 | ((infoPtr->stackPtr == NULL) || | |
277 | (saveEntryPtr->topPtr->evalLevel > | |
278 | infoPtr->stackPtr->evalLevel))) { | |
279 | ||
280 | infoPtr->stackPtr = saveEntryPtr->topPtr; | |
281 | infoPtr->saveStackPtr = saveEntryPtr->prevEntryPtr; | |
282 | ckfree ((char *) saveEntryPtr); | |
283 | ||
284 | } else { | |
285 | ||
286 | if ((infoPtr->stackPtr == NULL) || | |
287 | ((procLevel >= infoPtr->stackPtr->procLevel) && | |
288 | (evalLevel >= infoPtr->stackPtr->evalLevel))) | |
289 | break; /* Done */ | |
290 | ProcPopEntry (infoPtr); | |
291 | ||
292 | } | |
293 | } | |
294 | } | |
295 | \f | |
296 | /* | |
297 | *----------------------------------------------------------------------------- | |
298 | * | |
299 | * DoUplevel -- | |
300 | * | |
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. | |
304 | * | |
305 | * Parameters: | |
306 | * o infoPtr (I/O) - The global profiling info. | |
307 | * o procLevel (I) - The upleveled procedure call level. | |
308 | *----------------------------------------------------------------------------- | |
309 | */ | |
310 | static void | |
311 | DoUplevel (infoPtr, procLevel) | |
312 | profInfo_t *infoPtr; | |
313 | int procLevel; | |
314 | { | |
315 | profStackEntry_t *scanPtr, *bottomPtr; | |
316 | saveStackEntry_t *saveEntryPtr; | |
317 | ||
318 | /* | |
319 | * Find the stack area to save. | |
320 | */ | |
321 | bottomPtr = NULL; | |
322 | scanPtr = infoPtr->stackPtr; | |
323 | while ((scanPtr != NULL) && (scanPtr->procLevel > procLevel)) { | |
324 | bottomPtr = scanPtr; | |
325 | scanPtr = scanPtr->prevEntryPtr; | |
326 | } | |
327 | if (bottomPtr == NULL) | |
328 | panic ("uplevel stack confusion"); | |
329 | ||
330 | /* | |
331 | * Save the stack entries in the save stack. | |
332 | */ | |
333 | saveEntryPtr = (saveStackEntry_t *) ckalloc (sizeof (saveStackEntry_t)); | |
334 | saveEntryPtr->topPtr = infoPtr->stackPtr; | |
335 | saveEntryPtr->bottomPtr = bottomPtr; | |
336 | saveEntryPtr->prevEntryPtr = infoPtr->saveStackPtr;; | |
337 | ||
338 | infoPtr->saveStackPtr = saveEntryPtr; | |
339 | ||
340 | /* | |
341 | * Hide the stack entries. | |
342 | */ | |
343 | infoPtr->stackPtr = bottomPtr->prevEntryPtr; | |
344 | ||
345 | } | |
346 | \f | |
347 | /* | |
348 | *----------------------------------------------------------------------------- | |
349 | * | |
350 | * ProfTraceRoutine -- | |
351 | * Routine called by Tcl_Eval to do profiling. | |
352 | * | |
353 | *----------------------------------------------------------------------------- | |
354 | */ | |
355 | static void | |
356 | ProfTraceRoutine (clientData, interp, evalLevel, command, cmdProc, | |
357 | cmdClientData, argc, argv) | |
358 | ClientData clientData; | |
359 | Tcl_Interp *interp; | |
360 | int evalLevel; | |
361 | char *command; | |
362 | int (*cmdProc)(); | |
363 | ClientData cmdClientData; | |
364 | int argc; | |
365 | char **argv; | |
366 | { | |
367 | Interp *iPtr = (Interp *) interp; | |
368 | struct tms cpuTimes; | |
369 | profInfo_t *infoPtr = (profInfo_t *) clientData; | |
370 | int procLevel = (iPtr->varFramePtr == NULL) ? 0 : | |
371 | iPtr->varFramePtr->level; | |
372 | ||
373 | /* | |
374 | * Calculate the time spent since the last trace. | |
375 | */ | |
376 | infoPtr->realTime += times (&cpuTimes) - infoPtr->lastRealTime; | |
377 | infoPtr->cpuTime += (cpuTimes.tms_utime + cpuTimes.tms_stime) - | |
378 | infoPtr->lastCpuTime; | |
379 | ||
380 | ||
381 | /* | |
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 | |
384 | * four events. | |
385 | * | |
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. | |
390 | * | |
391 | * Eval level must be tested as well as proc level to cover upleveled | |
392 | * proc calls that don't execute any commands. | |
393 | */ | |
394 | ||
395 | if ((infoPtr->stackPtr != NULL) && | |
396 | ((procLevel != infoPtr->stackPtr->procLevel) || | |
397 | (evalLevel < infoPtr->stackPtr->evalLevel))) { | |
398 | ||
399 | if ((procLevel < infoPtr->stackPtr->procLevel) && | |
400 | (evalLevel > infoPtr->stackPtr->evalLevel)) | |
401 | DoUplevel (infoPtr, procLevel); | |
402 | else | |
403 | StackSync (infoPtr, procLevel, evalLevel); | |
404 | } | |
405 | ||
406 | /* | |
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. | |
411 | */ | |
412 | if ((infoPtr->stackPtr == NULL) && (procLevel == 0)) | |
413 | ProcEntry (infoPtr, "<global>", 0, evalLevel); | |
414 | ||
415 | /* | |
416 | * If this command is a procedure or if all commands are being traced, | |
417 | * handle the entry. | |
418 | */ | |
419 | ||
420 | if (infoPtr->allCommands || (TclFindProc (iPtr, argv [0]) != NULL)) | |
421 | ProcEntry (infoPtr, argv [0], procLevel + 1, evalLevel + 1); | |
422 | ||
423 | /* | |
424 | * Save the exit time of the profiling trace handler. | |
425 | */ | |
426 | infoPtr->lastRealTime = times (&cpuTimes); | |
427 | infoPtr->lastCpuTime = cpuTimes.tms_utime + cpuTimes.tms_stime; | |
428 | ||
429 | } | |
430 | \f | |
431 | /* | |
432 | *----------------------------------------------------------------------------- | |
433 | * | |
434 | * CleanDataTable -- | |
435 | * | |
436 | * Clean up the hash data table, releasing all resources and setting it | |
437 | * to the empty state. | |
438 | * | |
439 | * Parameters: | |
440 | * o infoPtr (I/O) - The global profiling info. | |
441 | *----------------------------------------------------------------------------- | |
442 | */ | |
443 | static void | |
444 | CleanDataTable (infoPtr) | |
445 | profInfo_t *infoPtr; | |
446 | { | |
447 | Tcl_HashEntry *hashEntryPtr; | |
448 | Tcl_HashSearch searchCookie; | |
449 | ||
450 | hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable, | |
451 | &searchCookie); | |
452 | while (hashEntryPtr != NULL) { | |
453 | ckfree ((char *) Tcl_GetHashValue (hashEntryPtr)); | |
454 | Tcl_DeleteHashEntry (hashEntryPtr); | |
455 | hashEntryPtr = Tcl_NextHashEntry (&searchCookie); | |
456 | } | |
457 | } | |
458 | \f | |
459 | /* | |
460 | *----------------------------------------------------------------------------- | |
461 | * | |
462 | * DeleteProfTrace -- | |
463 | * | |
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. | |
466 | * | |
467 | * Parameters: | |
468 | * o infoPtr (I/O) - The global profiling info. | |
469 | *----------------------------------------------------------------------------- | |
470 | */ | |
471 | static void | |
472 | DeleteProfTrace (infoPtr) | |
473 | profInfo_t *infoPtr; | |
474 | { | |
475 | Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHolder); | |
476 | infoPtr->traceHolder = NULL; | |
477 | ||
478 | StackSync (infoPtr, 0, 0); | |
479 | ||
480 | } | |
481 | \f | |
482 | /* | |
483 | *----------------------------------------------------------------------------- | |
484 | * | |
485 | * DumpTableData -- | |
486 | * | |
487 | * Dump the table data to an array variable. Entries will be deleted | |
488 | * as they are dumped to limit memory utilization. | |
489 | * | |
490 | * Parameters: | |
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. | |
494 | * Returns: | |
495 | * Standard Tcl command results | |
496 | *----------------------------------------------------------------------------- | |
497 | */ | |
498 | static int | |
499 | DumpTableData (interp, infoPtr, varName) | |
500 | Tcl_Interp *interp; | |
501 | profInfo_t *infoPtr; | |
502 | char *varName; | |
503 | { | |
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]; | |
509 | ||
510 | dataArgv [0] = countBuf; | |
511 | dataArgv [1] = realTimeBuf; | |
512 | dataArgv [2] = cpuTimeBuf; | |
513 | ||
514 | Tcl_UnsetVar (interp, varName, 0); | |
515 | hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable, | |
516 | &searchCookie); | |
517 | while (hashEntryPtr != NULL) { | |
518 | dataEntryPtr = | |
519 | (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr); | |
520 | ||
521 | sprintf (countBuf, "%ld", dataEntryPtr->count); | |
522 | sprintf (realTimeBuf, "%ld", dataEntryPtr->realTime * MS_PER_TICK); | |
523 | sprintf (cpuTimeBuf, "%ld", dataEntryPtr->cpuTime * MS_PER_TICK); | |
524 | ||
525 | dataListPtr = Tcl_Merge (3, dataArgv); | |
526 | ||
527 | if (Tcl_SetVar2 (interp, varName, | |
528 | Tcl_GetHashKey (&infoPtr->profDataTable, | |
529 | hashEntryPtr), | |
530 | dataListPtr, TCL_LEAVE_ERR_MSG) == NULL) { | |
531 | ckfree (dataListPtr); | |
532 | return TCL_ERROR; | |
533 | } | |
534 | ckfree (dataListPtr); | |
535 | ckfree ((char *) dataEntryPtr); | |
536 | Tcl_DeleteHashEntry (hashEntryPtr); | |
537 | ||
538 | hashEntryPtr = Tcl_NextHashEntry (&searchCookie); | |
539 | } | |
540 | ||
541 | return TCL_OK; | |
542 | } | |
543 | \f | |
544 | /* | |
545 | *----------------------------------------------------------------------------- | |
546 | * | |
547 | * Tcl_ProfileCmd -- | |
548 | * Implements the TCL profile command: | |
549 | * profile on | |
550 | * profile off arrayvar | |
551 | * | |
552 | * Results: | |
553 | * Standard TCL results. | |
554 | * | |
555 | *----------------------------------------------------------------------------- | |
556 | */ | |
557 | static int | |
558 | Tcl_ProfileCmd (clientData, interp, argc, argv) | |
559 | ClientData clientData; | |
560 | Tcl_Interp *interp; | |
561 | int argc; | |
562 | char **argv; | |
563 | { | |
564 | Interp *iPtr = (Interp *) interp; | |
565 | profInfo_t *infoPtr = (profInfo_t *) clientData; | |
566 | int idx; | |
567 | int cmdArgc, optionsArgc = 0; | |
568 | char **cmdArgv, **optionsArgv = &(argv [1]); | |
569 | ||
570 | /* | |
571 | * Scan for options (currently only one is supported). Set cmdArgv to | |
572 | * contain the rest of the command following the options. | |
573 | */ | |
574 | for (idx = 1; (idx < argc) && (argv [idx][0] == '-'); idx++) | |
575 | optionsArgc++; | |
576 | cmdArgc = argc - idx; | |
577 | cmdArgv = &(argv [idx]); | |
578 | ||
579 | if (cmdArgc < 1) | |
580 | goto wrongArgs; | |
581 | ||
582 | /* | |
583 | * Handle the on command. | |
584 | */ | |
585 | if (STREQU (cmdArgv [0], "on")) { | |
586 | int allCommands = FALSE; | |
587 | struct tms cpuTimes; | |
588 | ||
589 | if ((cmdArgc != 1) || (optionsArgc > 1)) | |
590 | goto wrongArgs; | |
591 | ||
592 | if (optionsArgc == 1) { | |
593 | if (!STREQU (optionsArgv [0], "-commands")) { | |
594 | Tcl_AppendResult (interp, "expected option of \"-commands\", ", | |
595 | "got \"", optionsArgv [0], "\"", | |
596 | (char *) NULL); | |
597 | return TCL_ERROR; | |
598 | } | |
599 | allCommands = TRUE; | |
600 | } | |
601 | ||
602 | if (infoPtr->traceHolder != NULL) { | |
603 | Tcl_AppendResult (interp, "profiling is already enabled", | |
604 | (char *) NULL); | |
605 | return TCL_ERROR; | |
606 | } | |
607 | ||
608 | CleanDataTable (infoPtr); | |
609 | infoPtr->traceHolder = Tcl_CreateTrace (interp, MAXINT, | |
610 | ProfTraceRoutine, | |
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; | |
617 | return TCL_OK; | |
618 | } | |
619 | ||
620 | /* | |
621 | * Handle the off command. Dump the hash table to a variable. | |
622 | */ | |
623 | if (STREQU (cmdArgv [0], "off")) { | |
624 | ||
625 | if ((cmdArgc != 2) || (optionsArgc > 0)) | |
626 | goto wrongArgs; | |
627 | ||
628 | if (infoPtr->traceHolder == NULL) { | |
629 | Tcl_AppendResult (interp, "profiling is not currently enabled", | |
630 | (char *) NULL); | |
631 | return TCL_ERROR; | |
632 | } | |
633 | ||
634 | DeleteProfTrace (infoPtr); | |
635 | ||
636 | if (DumpTableData (interp, infoPtr, argv [2]) != TCL_OK) | |
637 | return TCL_ERROR; | |
638 | return TCL_OK; | |
639 | } | |
640 | ||
641 | /* | |
642 | * Not a valid subcommand. | |
643 | */ | |
644 | Tcl_AppendResult (interp, "expected one of \"on\" or \"off\", got \"", | |
645 | argv [1], "\"", (char *) NULL); | |
646 | return TCL_ERROR; | |
647 | ||
648 | wrongArgs: | |
649 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
650 | " [-commands] on|off arrayVar", (char *) NULL); | |
651 | return TCL_ERROR; | |
652 | } | |
653 | \f | |
654 | /* | |
655 | *----------------------------------------------------------------------------- | |
656 | * | |
657 | * CleanUpProfMon -- | |
658 | * | |
659 | * Release the client data area when the profile command is deleted. | |
660 | * | |
661 | *----------------------------------------------------------------------------- | |
662 | */ | |
663 | static void | |
664 | CleanUpProfMon (clientData) | |
665 | ClientData clientData; | |
666 | { | |
667 | profInfo_t *infoPtr = (profInfo_t *) clientData; | |
668 | ||
669 | if (infoPtr->traceHolder != NULL) | |
670 | DeleteProfTrace (infoPtr); | |
671 | CleanDataTable (infoPtr); | |
672 | Tcl_DeleteHashTable (&infoPtr->profDataTable); | |
673 | ckfree ((char *) infoPtr); | |
674 | } | |
675 | \f | |
676 | /* | |
677 | *----------------------------------------------------------------------------- | |
678 | * | |
679 | * Tcl_InitProfile -- | |
680 | * | |
681 | * Initialize the Tcl profiling command. | |
682 | * | |
683 | *----------------------------------------------------------------------------- | |
684 | */ | |
685 | void | |
686 | Tcl_InitProfile (interp) | |
687 | Tcl_Interp *interp; | |
688 | { | |
689 | profInfo_t *infoPtr; | |
690 | ||
691 | infoPtr = (profInfo_t *) ckalloc (sizeof (profInfo_t)); | |
692 | ||
693 | infoPtr->interp = interp; | |
694 | infoPtr->traceHolder = NULL; | |
695 | infoPtr->stackPtr = NULL; | |
696 | infoPtr->saveStackPtr = NULL; | |
697 | Tcl_InitHashTable (&infoPtr->profDataTable, TCL_STRING_KEYS); | |
698 | ||
699 | Tcl_CreateCommand (interp, "profile", Tcl_ProfileCmd, | |
700 | (ClientData)infoPtr, CleanUpProfMon); | |
701 | } | |
702 |