git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxprof.c

   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