home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / src / tclXprofile.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-12-10  |  25.1 KB  |  786 lines
  1. /*
  2.  * tclXprofile.c --
  3.  *
  4.  * Tcl performance profile monitor.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1993 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 3.1 1993/12/10 05:14:08 markd Exp $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * Stack entry used to keep track of an profiling information for active
  23.  * procedure.  Handling uplevels is tricky.  The eval level and procedure call
  24.  * level are kept track of.  These are used to distinguish between an uplevel
  25.  * and exiting a procedure.  During an uplevel, the invisible part of the
  26.  * profile stack is saved on another stack until the uplevel completes.
  27.  */
  28.  
  29. typedef struct profStackEntry_t {
  30.     long                     realTime;      /* Real time at procedure entry. */
  31.     long                     cpuTime;       /* CPU time at procedure entry.  */
  32.     int                      procLevel;     /* Call level of this procedure  */
  33.     int                      evalLevel;     /* Eval level of this prodecure  */
  34.     struct profStackEntry_t *prevEntryPtr;  /* Previous stack entry.         */
  35.     char                     procName [1];  /* Procedure name. MUST BE LAST! */
  36. } profStackEntry_t;
  37.  
  38.  
  39. /*
  40.  * Save stack entry used to hold profile stack entries during an uplevel.
  41.  */
  42.  
  43. typedef struct saveStackEntry_t {
  44.     long                      realTime;      /* Real and CPU time this when  */
  45.     long                      cpuTime;       /* stack section was saved.     */
  46.     profStackEntry_t         *topPtr;        /* Top of saved stack section   */
  47.     profStackEntry_t         *bottomPtr;     /* Bottom of saved stack        */
  48.     struct saveStackEntry_t  *prevEntryPtr;  /* Previous saved stack section */
  49. } saveStackEntry_t;
  50.  
  51. /*
  52.  * Data keeped on a stack snapshot.
  53.  */
  54.  
  55. typedef struct profDataEntry_t {
  56.     long count;
  57.     long realTime;
  58.     long cpuTime;
  59. } profDataEntry_t;
  60.  
  61. /*
  62.  * Client data structure for profile command.  A count of real and CPU time
  63.  * spent outside of the profiling routines is kept to factor out the variable
  64.  * overhead.
  65.  */
  66.  
  67. typedef struct profInfo_t { 
  68.     Tcl_Interp       *interp;            /* Interpreter this is for.         */
  69.     Tcl_Trace         traceHolder;       /* Handle to current trace.         */
  70.     int               allCommands;       /* Prof all commands, not just procs*/
  71.     long              realTime;          /* Real and CPU time counter.       */
  72.     long              cpuTime;
  73.     long              lastRealTime;      /* Real and CPU time of last exit   */
  74.     long              lastCpuTime;       /* from profiling routines.         */
  75.     profStackEntry_t *stackPtr;          /* Pointer to the top of prof stack */
  76.     saveStackEntry_t *saveStackPtr;      /* Frames saved during an uplevel   */
  77.     Tcl_HashTable     profDataTable;     /* Cumulative time table, Keyed by  */
  78.                                          /* call stack list.                 */
  79. } profInfo_t;
  80.  
  81. /*
  82.  * Prototypes of internal functions.
  83.  */
  84.  
  85. static long
  86. GetTimes _ANSI_ARGS_((long  *cpuTimesPtr));
  87.  
  88. static void
  89. ProcEntry _ANSI_ARGS_((profInfo_t *infoPtr,
  90.                        char       *procName,
  91.                        int         procLevel,
  92.                        int         evalLevel));
  93.  
  94. static void
  95. ProcPopEntry _ANSI_ARGS_((profInfo_t *infoPtr));
  96.  
  97. static void
  98. StackSync _ANSI_ARGS_((profInfo_t *infoPtr,
  99.                        int         procLevel,
  100.                        int         evalLevel));
  101.  
  102. static void
  103. DoUplevel _ANSI_ARGS_((profInfo_t *infoPtr,
  104.                        int         procLevel));
  105.  
  106. static void
  107. ProfTraceRoutine _ANSI_ARGS_((ClientData    clientData,
  108.                               Tcl_Interp   *interp,
  109.                               int           evalLevel,
  110.                               char         *command,
  111.                               int           (*cmdProc)(),
  112.                               ClientData    cmdClientData,
  113.                               int           argc,
  114.                               char        **argv));
  115.  
  116. static void
  117. CleanDataTable _ANSI_ARGS_((profInfo_t *infoPtr));
  118.  
  119. static void
  120. DeleteProfTrace _ANSI_ARGS_((profInfo_t *infoPtr));
  121.  
  122. static int
  123. DumpTableData  _ANSI_ARGS_((Tcl_Interp *interp,
  124.                             profInfo_t *infoPtr,
  125.                             char       *varName));
  126.  
  127. static int
  128. Tcl_ProfileCmd _ANSI_ARGS_((ClientData    clientData,
  129.                             Tcl_Interp   *interp,
  130.                             int           argc,
  131.                             char        **argv));
  132.  
  133. static void
  134. CleanUpProfMon _ANSI_ARGS_((ClientData  clientData,
  135.                             Tcl_Interp *interp));
  136.  
  137. #ifdef TIMES_RETS_REAL_TIME
  138.  
  139. /*
  140.  *-----------------------------------------------------------------------------
  141.  * GetTimes --
  142.  *
  143.  *   Get the current real and CPU time for the process.  This version of this
  144.  * function is used on systems where the times systems call returns the
  145.  * elasped real time.
  146.  *
  147.  * Parameters:
  148.  *   o cpuTimePtr (O) - The CPU time in milliseconds is returned here.
  149.  * Returns:
  150.  *   The current real time of the process, in milliseconds.
  151.  *-----------------------------------------------------------------------------
  152.  */
  153. static long
  154. GetTimes (cpuTimePtr)
  155.     long  *cpuTimePtr;
  156. {
  157.     struct tms cpuTimes;
  158.     long       realTime;
  159.  
  160.     realTime = TICKS_TO_MS (times (&cpuTimes));
  161.     *cpuTimePtr = TICKS_TO_MS (cpuTimes.tms_utime + cpuTimes.tms_stime);
  162.     return realTime;
  163. }
  164. #else
  165.  
  166. /*
  167.  *-----------------------------------------------------------------------------
  168.  * GetTimes --
  169.  *
  170.  *   Get the current real and CPU time for the process.  This version of this
  171.  * function is used on systems where the times systems call does not return the
  172.  * elasped real time.  It uses gettimeofday to figure out the real time.
  173.  *
  174.  * Parameters:
  175.  *   o cpuTimePtr (O) - The CPU time in milliseconds is returned here.
  176.  * Returns:
  177.  *   The current real time of the process, in milliseconds, relative to the
  178.  * first time this function was called.
  179.  *-----------------------------------------------------------------------------
  180.  */
  181. static long
  182. GetTimes (cpuTimePtr)
  183.     long  *cpuTimePtr;
  184. {
  185.     static struct timeval startTime = {0, 0};
  186.     struct timeval        currentTime;
  187.     struct tms            cpuTimes;
  188.     long                  realTime;
  189.  
  190.     /*
  191.      * If this is the first call, get base time.
  192.      */
  193.     if ((startTime.tv_sec == 0) && (startTime.tv_usec == 0))
  194.         gettimeofday (&startTime, NULL);
  195.     
  196.     gettimeofday (¤tTime, NULL);
  197.     currentTime.tv_sec  = currentTime.tv_sec  - startTime.tv_sec;
  198.     currentTime.tv_usec = currentTime.tv_usec - startTime.tv_usec;
  199.     realTime = (currentTime.tv_sec  * 1000) +
  200.                (currentTime.tv_usec / 1000);
  201.     times (&cpuTimes);
  202.     *cpuTimePtr = TICKS_TO_MS (cpuTimes.tms_utime + cpuTimes.tms_stime);
  203.     return realTime;
  204. }
  205. #endif /* TIMES_RETS_REAL_TIME */
  206.  
  207. /*
  208.  *-----------------------------------------------------------------------------
  209.  * ProcEntry --
  210.  *
  211.  *   Push a procedure entry onto the stack.
  212.  *
  213.  * Parameters:
  214.  *   o infoPtr (I/O) - The global profiling info.
  215.  *   o procName (I)  The procedure name.
  216.  *   o procLevel (I) - The procedure call level that the procedure will
  217.  *     execute at.
  218.  *   o evalLevel (I) - The eval level that the procedure will start
  219.  *     executing at.
  220.  *-----------------------------------------------------------------------------
  221.  */
  222. static void
  223. ProcEntry (infoPtr, procName, procLevel, evalLevel)
  224.     profInfo_t *infoPtr;
  225.     char       *procName;
  226.     int         procLevel;
  227.     int         evalLevel;
  228. {
  229.     profStackEntry_t *entryPtr;
  230.  
  231.     /*
  232.      * Calculate the size of an entry.  One byte for name is in the entry.
  233.      */
  234.     entryPtr = (profStackEntry_t *) ckalloc (sizeof (profStackEntry_t) +
  235.                                              strlen (procName));
  236.     
  237.     /*
  238.      * Fill it in and push onto the stack.  Note that the procedures frame has
  239.      * not yet been layed down or the procedure body eval execute, so the value
  240.      * they will be in the procedure is recorded.
  241.      */
  242.     entryPtr->realTime     = infoPtr->realTime;
  243.     entryPtr->cpuTime      = infoPtr->cpuTime;
  244.     entryPtr->procLevel    = procLevel;
  245.     entryPtr->evalLevel    = evalLevel;
  246.     strcpy (entryPtr->procName, procName);
  247.  
  248.     entryPtr->prevEntryPtr  = infoPtr->stackPtr;
  249.     infoPtr->stackPtr       = entryPtr;
  250. }
  251.  
  252. /*
  253.  *-----------------------------------------------------------------------------
  254.  * ProcPopEntry --
  255.  *
  256.  *   Pop the procedure entry from the top of the stack and record its
  257.  * times in the data table.
  258.  *
  259.  * Parameters:
  260.  *   o infoPtr (I/O) - The global profiling info.
  261.  *-----------------------------------------------------------------------------
  262.  */
  263. static void
  264. ProcPopEntry (infoPtr)
  265.     profInfo_t *infoPtr;
  266. {
  267.     profStackEntry_t *entryPtr = infoPtr->stackPtr;
  268.     profStackEntry_t *scanPtr;
  269.     int               idx, newEntry;
  270.     char             *stackListPtr;
  271.     Tcl_HashEntry    *hashEntryPtr;
  272.     profDataEntry_t  *dataEntryPtr;
  273.     char             *stackArgv [MAX_NESTING_DEPTH];
  274.  
  275.     /*
  276.      * Build up a stack list.  Entry [0] is the top of the stack.
  277.      */
  278.     idx= 0;
  279.     scanPtr = entryPtr;
  280.     while (scanPtr != NULL) {
  281.         stackArgv [idx] = scanPtr->procName;
  282.         idx++;
  283.         scanPtr = scanPtr->prevEntryPtr;
  284.     }
  285.     stackListPtr = Tcl_Merge (idx, stackArgv);
  286.  
  287.     /*
  288.      * Check the hash table for this entry, either finding an existing or
  289.      * creating a new hash entry.
  290.      */
  291.  
  292.     hashEntryPtr = Tcl_CreateHashEntry (&infoPtr->profDataTable,
  293.                                         stackListPtr,
  294.                                         &newEntry);
  295.     ckfree (stackListPtr);
  296.  
  297.     /*
  298.      * Fill in or increment the entry.
  299.      */
  300.     if (newEntry) {
  301.         dataEntryPtr = (profDataEntry_t *) ckalloc (sizeof (profDataEntry_t));
  302.         Tcl_SetHashValue (hashEntryPtr, dataEntryPtr);
  303.         dataEntryPtr->count    = 0;
  304.         dataEntryPtr->realTime = 0;
  305.         dataEntryPtr->cpuTime  = 0;;
  306.     } else
  307.         dataEntryPtr = (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr);
  308.  
  309.     dataEntryPtr->count++;
  310.     dataEntryPtr->realTime += (infoPtr->realTime - entryPtr->realTime);
  311.     dataEntryPtr->cpuTime  += (infoPtr->cpuTime  - entryPtr->cpuTime);
  312.  
  313.  
  314.     infoPtr->stackPtr = entryPtr->prevEntryPtr;
  315.     ckfree ((char *) entryPtr);
  316. }
  317.  
  318. /*
  319.  *-----------------------------------------------------------------------------
  320.  * StackSync --
  321.  *
  322.  *   Synchronize the profile stack with the interpreter procedure stack.
  323.  * This is done once return from uplevels, exits and error unwinds are
  324.  * detected (the command after).  Saved profile stack entries may be
  325.  * restored and procedure entries popped from the stack.  When entries
  326.  * are popped, their statistics is saved in stack.
  327.  *
  328.  * Parameters:
  329.  *   o infoPtr (I/O) - The global profiling info.
  330.  *   o procLevel (I) - Procedure call level to return to (zero to clear stack).
  331.  *   o evalLevel (I) - Eval call level to return to (zero to clear stack).
  332.  *-----------------------------------------------------------------------------
  333.  */
  334. static void
  335. StackSync (infoPtr, procLevel, evalLevel)
  336.     profInfo_t *infoPtr;
  337.     int         procLevel;
  338.     int         evalLevel;
  339. {
  340.     long              cpuDelta;
  341.     long              realDelta;
  342.     profStackEntry_t *endPtr;
  343.     profStackEntry_t *scanPtr;
  344.     saveStackEntry_t *saveEntryPtr;
  345.     
  346.     while (TRUE) {
  347.         /*
  348.          * Move top of saved stack to standard stack if stack is empty or
  349.          * saved eval level is greater than the top of the standard stack.
  350.          */
  351.         saveEntryPtr = infoPtr->saveStackPtr;
  352.  
  353.         if ((saveEntryPtr != NULL) && 
  354.             ((infoPtr->stackPtr == NULL) || 
  355.              (saveEntryPtr->topPtr->evalLevel >
  356.               infoPtr->stackPtr->evalLevel))) {
  357.  
  358.         /*
  359.          * To prevent the saved entries from getting `charged' with
  360.          * with the time they've been idling here in limbo, advance
  361.          * their 'start' times by the amount of time they'be been
  362.          * idling.  This prevents time spent executing uplevel-ed
  363.          * code from being counted twice.
  364.          */
  365.         cpuDelta  = infoPtr->cpuTime  - saveEntryPtr->cpuTime;
  366.         realDelta = infoPtr->realTime - saveEntryPtr->realTime;
  367.         endPtr    = saveEntryPtr->bottomPtr->prevEntryPtr;
  368.         scanPtr   = saveEntryPtr->topPtr;
  369.         while (scanPtr != endPtr) {
  370.         scanPtr->cpuTime  += cpuDelta;
  371.         scanPtr->realTime += realDelta;
  372.  
  373.         scanPtr = scanPtr->prevEntryPtr;
  374.         }
  375.  
  376.             infoPtr->stackPtr = saveEntryPtr->topPtr;
  377.             infoPtr->saveStackPtr = saveEntryPtr->prevEntryPtr;
  378.             ckfree ((char *) saveEntryPtr);
  379.  
  380.         } else {
  381.  
  382.             if ((infoPtr->stackPtr == NULL) ||
  383.                 ((procLevel >= infoPtr->stackPtr->procLevel) &&
  384.                  (evalLevel >= infoPtr->stackPtr->evalLevel)))
  385.                 break;  /* Done */
  386.             ProcPopEntry (infoPtr);
  387.  
  388.         }
  389.     }
  390. }
  391.  
  392. /*
  393.  *-----------------------------------------------------------------------------
  394.  * DoUplevel --
  395.  *
  396.  *   Do processing required when an uplevel is detected.  Builds and
  397.  * pushes a save stack containing all of the save entrys that have been
  398.  * hiden by the uplevel.  
  399.  *
  400.  * Parameters:
  401.  *   o infoPtr (I/O) - The global profiling info.
  402.  *   o procLevel (I) - The upleveled procedure call level.
  403.  *-----------------------------------------------------------------------------
  404.  */
  405. static void
  406. DoUplevel (infoPtr, procLevel)
  407.     profInfo_t *infoPtr;
  408.     int         procLevel;
  409. {
  410.     profStackEntry_t *scanPtr, *bottomPtr;
  411.     saveStackEntry_t *saveEntryPtr;
  412.  
  413.     /*
  414.      * Find the stack area to save.
  415.      */
  416.     bottomPtr = NULL;
  417.     scanPtr = infoPtr->stackPtr;
  418.     while ((scanPtr != NULL) && (scanPtr->procLevel > procLevel)) {
  419.         bottomPtr = scanPtr;
  420.         scanPtr = scanPtr->prevEntryPtr;
  421.     }
  422.     if (bottomPtr == NULL)
  423.         panic ("uplevel stack confusion");
  424.  
  425.     /*
  426.      * Save the stack entries in the save stack.
  427.      */
  428.     saveEntryPtr = (saveStackEntry_t *) ckalloc (sizeof (saveStackEntry_t));
  429.     saveEntryPtr->cpuTime      = infoPtr->cpuTime;
  430.     saveEntryPtr->realTime     = infoPtr->realTime;
  431.     saveEntryPtr->topPtr       = infoPtr->stackPtr;
  432.     saveEntryPtr->bottomPtr    = bottomPtr;
  433.     saveEntryPtr->prevEntryPtr = infoPtr->saveStackPtr;;
  434.  
  435.     infoPtr->saveStackPtr = saveEntryPtr;
  436.  
  437.     /*
  438.      * Hide the stack entries.
  439.      */
  440.     infoPtr->stackPtr = bottomPtr->prevEntryPtr;
  441.  
  442. }
  443.  
  444. /*
  445.  *-----------------------------------------------------------------------------
  446.  * ProfTraceRoutine --
  447.  *
  448.  *  Routine called by Tcl_Eval to do profiling.
  449.  *-----------------------------------------------------------------------------
  450.  */
  451. static void
  452. ProfTraceRoutine (clientData, interp, evalLevel, command, cmdProc,
  453.                   cmdClientData, argc, argv)
  454.     ClientData    clientData;
  455.     Tcl_Interp   *interp;
  456.     int           evalLevel;
  457.     char         *command;
  458.     int           (*cmdProc)();
  459.     ClientData    cmdClientData;
  460.     int           argc;
  461.     char        **argv;
  462. {
  463.     Interp      *iPtr      = (Interp *) interp;
  464.     profInfo_t  *infoPtr   = (profInfo_t *) clientData;
  465.     int          procLevel = (iPtr->varFramePtr == NULL) ? 0 : 
  466.                              iPtr->varFramePtr->level;
  467.     long         cpuTime;
  468.  
  469.     /*
  470.      * Calculate the time spent since the last trace.
  471.      */
  472.     infoPtr->realTime += GetTimes (&cpuTime) - infoPtr->lastRealTime;
  473.     infoPtr->cpuTime  += cpuTime - infoPtr->lastCpuTime;
  474.     
  475.     /*
  476.      * If the procedure level has changed, then something is up.  Its not a
  477.      * procedure call, as we head them off before they happen.  Its one of
  478.      * four events.
  479.      *
  480.      *   o A uplevel command was executed.
  481.      *   o Returned from an uplevel.
  482.      *   o A procedure exit has occured.
  483.      *   o An error unwind has occured.
  484.      *     
  485.      * Eval level must be tested as well as proc level to cover upleveled
  486.      * proc calls that don't execute any commands.
  487.      */
  488.      
  489.     if ((infoPtr->stackPtr != NULL) && 
  490.         ((procLevel != infoPtr->stackPtr->procLevel) ||
  491.          (evalLevel <  infoPtr->stackPtr->evalLevel))) {
  492.  
  493.         if ((procLevel < infoPtr->stackPtr->procLevel) &&
  494.             (evalLevel > infoPtr->stackPtr->evalLevel))
  495.             DoUplevel (infoPtr, procLevel);
  496.         else
  497.             StackSync (infoPtr, procLevel, evalLevel);
  498.     }
  499.  
  500.     /*
  501.      * If this is level zero and the stack is empty, add an entry for the
  502.      * global level.  This takes care of the first command at the global level
  503.      * after profiling has been enabled or the case where profiling was
  504.      * enabled in a proc and we have returned to the global level.
  505.      */
  506.      if ((infoPtr->stackPtr == NULL) && (procLevel == 0))
  507.          ProcEntry (infoPtr, "<global>", 0, evalLevel);
  508.  
  509.     /*
  510.      * If this command is a procedure or if all commands are being traced,
  511.      * handle the entry.
  512.      */
  513.  
  514.     if (infoPtr->allCommands || (TclFindProc (iPtr, argv [0]) != NULL))
  515.         ProcEntry (infoPtr, argv [0], procLevel + 1, evalLevel + 1);
  516.  
  517.     /*
  518.      * Save the exit time of the profiling trace handler.
  519.      */
  520.     infoPtr->lastRealTime = GetTimes (&infoPtr->lastCpuTime);
  521. }
  522.  
  523. /*
  524.  *-----------------------------------------------------------------------------
  525.  * CleanDataTable --
  526.  *
  527.  *  Clean up the hash data table, releasing all resources and setting it
  528.  *  to the empty state.
  529.  *
  530.  * Parameters:
  531.  *   o infoPtr (I/O) - The global profiling info.
  532.  *-----------------------------------------------------------------------------
  533.  */
  534. static void
  535. CleanDataTable (infoPtr)
  536.     profInfo_t *infoPtr;
  537. {
  538.     Tcl_HashEntry    *hashEntryPtr;
  539.     Tcl_HashSearch   searchCookie;
  540.  
  541.     hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable,
  542.                                        &searchCookie);
  543.     while (hashEntryPtr != NULL) {
  544.         ckfree ((char *) Tcl_GetHashValue (hashEntryPtr));
  545.         Tcl_DeleteHashEntry (hashEntryPtr);
  546.         hashEntryPtr = Tcl_NextHashEntry (&searchCookie);
  547.     }
  548. }
  549.  
  550. /*
  551.  *-----------------------------------------------------------------------------
  552.  * DeleteProfTrace --
  553.  *
  554.  *   Delete the profile trace and clean up the stack, logging all procs
  555.  * as if they had exited.  Data table must still be available.
  556.  *
  557.  * Parameters:
  558.  *   o infoPtr (I/O) - The global profiling info.
  559.  *-----------------------------------------------------------------------------
  560.  */
  561. static void
  562. DeleteProfTrace (infoPtr)
  563.     profInfo_t *infoPtr;
  564. {
  565.     Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHolder);
  566.     infoPtr->traceHolder = NULL;
  567.  
  568.     StackSync (infoPtr, 0, 0);
  569.  
  570. }
  571.  
  572. /*
  573.  *-----------------------------------------------------------------------------
  574.  * DumpTableData --
  575.  *
  576.  *   Dump the table data to an array variable.  Entries will be deleted
  577.  * as they are dumped to limit memory utilization.
  578.  *
  579.  * Parameters:
  580.  *   o interp (I) - Pointer to the interprer.
  581.  *   o infoPtr (I/O) - The global profiling info.
  582.  *   o varName (I) - The name of the variable to save the data in.
  583.  * Returns:
  584.  *   Standard Tcl command results
  585.  *-----------------------------------------------------------------------------
  586.  */
  587. static int
  588. DumpTableData (interp, infoPtr, varName)
  589.     Tcl_Interp *interp;
  590.     profInfo_t *infoPtr;
  591.     char       *varName;
  592. {
  593.     Tcl_HashEntry    *hashEntryPtr;
  594.     Tcl_HashSearch    searchCookie;
  595.     profDataEntry_t  *dataEntryPtr;
  596.     char             *dataArgv [3], *dataListPtr;
  597.     char              countBuf [32], realTimeBuf [32], cpuTimeBuf [32];
  598.  
  599.     dataArgv [0] = countBuf;
  600.     dataArgv [1] = realTimeBuf;
  601.     dataArgv [2] = cpuTimeBuf;
  602.  
  603.     Tcl_UnsetVar (interp, varName, 0);
  604.     hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable,
  605.                                        &searchCookie);
  606.     while (hashEntryPtr != NULL) {
  607.         dataEntryPtr = 
  608.             (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr);
  609.  
  610.         sprintf (countBuf,    "%ld", dataEntryPtr->count);
  611.         sprintf (realTimeBuf, "%ld", dataEntryPtr->realTime);
  612.         sprintf (cpuTimeBuf,  "%ld", dataEntryPtr->cpuTime);
  613.  
  614.         dataListPtr = Tcl_Merge (3, dataArgv);
  615.  
  616.         if (Tcl_SetVar2 (interp, varName,
  617.                          Tcl_GetHashKey (&infoPtr->profDataTable,
  618.                                          hashEntryPtr),
  619.                          dataListPtr, TCL_LEAVE_ERR_MSG) == NULL) {
  620.             ckfree (dataListPtr);
  621.             return TCL_ERROR;
  622.         }
  623.         ckfree (dataListPtr);
  624.         ckfree ((char *) dataEntryPtr);
  625.         Tcl_DeleteHashEntry (hashEntryPtr);
  626.  
  627.         hashEntryPtr = Tcl_NextHashEntry (&searchCookie);
  628.     }
  629.  
  630.     return TCL_OK;
  631. }
  632.  
  633. /*
  634.  *-----------------------------------------------------------------------------
  635.  * Tcl_ProfileCmd --
  636.  *
  637.  *   Implements the TCL profile command:
  638.  *     profile ?-commands? on
  639.  *     profile off arrayvar
  640.  *-----------------------------------------------------------------------------
  641.  */
  642. static int
  643. Tcl_ProfileCmd (clientData, interp, argc, argv)
  644.     ClientData    clientData;
  645.     Tcl_Interp   *interp;
  646.     int           argc;
  647.     char        **argv;
  648. {
  649.     Interp      *iPtr = (Interp *) interp;
  650.     profInfo_t  *infoPtr = (profInfo_t *) clientData;
  651.     int          idx;
  652.     int          cmdArgc,   optionsArgc = 0;
  653.     char       **cmdArgv, **optionsArgv = &(argv [1]);
  654.  
  655.     /*
  656.      * Scan for options (currently only one is supported).  Set cmdArgv to
  657.      * contain the rest of the command following the options.
  658.      */
  659.     for (idx = 1; (idx < argc) && (argv [idx][0] == '-'); idx++)
  660.         optionsArgc++;
  661.     cmdArgc = argc - idx;
  662.     cmdArgv = &(argv [idx]);
  663.  
  664.     if (cmdArgc < 1)
  665.         goto wrongArgs;
  666.  
  667.     /*
  668.      * Handle the on command.
  669.      */
  670.     if (STREQU (cmdArgv [0], "on")) {
  671.         int  allCommands = FALSE;
  672.  
  673.         if ((cmdArgc != 1) || (optionsArgc > 1))
  674.             goto wrongArgs;
  675.  
  676.         if (optionsArgc == 1) {
  677.             if (!STREQU (optionsArgv [0], "-commands")) {
  678.                 Tcl_AppendResult (interp, "expected option of \"-commands\", ",
  679.                                   "got \"", optionsArgv [0], "\"",
  680.                                   (char *) NULL);
  681.                 return TCL_ERROR;
  682.             }
  683.             allCommands = TRUE;
  684.         }
  685.  
  686.         if (infoPtr->traceHolder != NULL) {
  687.             Tcl_AppendResult (interp, "profiling is already enabled",
  688.                               (char *) NULL);
  689.             return TCL_ERROR;
  690.         }
  691.             
  692.         CleanDataTable (infoPtr);
  693.         infoPtr->traceHolder =
  694.             Tcl_CreateTrace (interp, MAXINT,
  695.                              (Tcl_CmdTraceProc *) ProfTraceRoutine,
  696.                              (ClientData) infoPtr);
  697.         infoPtr->realTime = 0;
  698.         infoPtr->cpuTime  = 0;
  699.         infoPtr->lastRealTime = GetTimes (&infoPtr->lastCpuTime);
  700.         infoPtr->allCommands = allCommands;
  701.         return TCL_OK;
  702.     }
  703.  
  704.     /*
  705.      * Handle the off command.  Dump the hash table to a variable.
  706.      */
  707.     if (STREQU (cmdArgv [0], "off")) {
  708.  
  709.         if ((cmdArgc != 2) || (optionsArgc > 0))
  710.             goto wrongArgs;
  711.  
  712.         if (infoPtr->traceHolder == NULL) {
  713.             Tcl_AppendResult (interp, "profiling is not currently enabled",
  714.                               (char *) NULL);
  715.             return TCL_ERROR;
  716.         }
  717.             
  718.         DeleteProfTrace (infoPtr);
  719.  
  720.         if (DumpTableData (interp, infoPtr, argv [2]) != TCL_OK)
  721.             return TCL_ERROR;
  722.         return TCL_OK;
  723.     }
  724.  
  725.     /*
  726.      * Not a valid subcommand.
  727.      */
  728.     Tcl_AppendResult (interp, "expected one of \"on\" or \"off\", got \"",
  729.                       argv [1], "\"", (char *) NULL);
  730.     return TCL_ERROR;
  731.  
  732.   wrongArgs:
  733.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  734.                       " ?-commands? on|off arrayVar", (char *) NULL);
  735.     return TCL_ERROR;
  736. }
  737.  
  738. /*
  739.  *-----------------------------------------------------------------------------
  740.  * ProfMonCleanUp --
  741.  *
  742.  *   Release the client data area when the interpreter is deleted.
  743.  *-----------------------------------------------------------------------------
  744.  */
  745. static void
  746. ProfMonCleanUp (clientData, interp)
  747.     ClientData  clientData;
  748.     Tcl_Interp *interp;
  749. {
  750.     profInfo_t *infoPtr = (profInfo_t *) clientData;
  751.  
  752.     if (infoPtr->traceHolder != NULL)
  753.         DeleteProfTrace (infoPtr);
  754.     CleanDataTable (infoPtr);
  755.     Tcl_DeleteHashTable (&infoPtr->profDataTable);
  756.     ckfree ((char *) infoPtr);
  757. }
  758.  
  759. /*
  760.  *-----------------------------------------------------------------------------
  761.  * Tcl_InitProfile --
  762.  *
  763.  *   Initialize the Tcl profiling command.
  764.  *-----------------------------------------------------------------------------
  765.  */
  766. void
  767. Tcl_InitProfile (interp)
  768.     Tcl_Interp *interp;
  769. {
  770.     profInfo_t *infoPtr;
  771.  
  772.     infoPtr = (profInfo_t *) ckalloc (sizeof (profInfo_t));
  773.  
  774.     infoPtr->interp       = interp;
  775.     infoPtr->traceHolder  = NULL;
  776.     infoPtr->stackPtr     = NULL;
  777.     infoPtr->saveStackPtr = NULL;
  778.     Tcl_InitHashTable (&infoPtr->profDataTable, TCL_STRING_KEYS);
  779.  
  780.     Tcl_CallWhenDeleted (interp, ProfMonCleanUp, (ClientData) infoPtr);
  781.  
  782.     Tcl_CreateCommand (interp, "profile", Tcl_ProfileCmd, 
  783.                        (ClientData) infoPtr, (void (*)()) NULL);
  784. }
  785.  
  786.