/*
 * tclXprofile.c --
 *
 * Tcl performance profile monitor.
 *-----------------------------------------------------------------------------
 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
 * Mark Diekhans make no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without express or
 * implied warranty.
 *-----------------------------------------------------------------------------
 * $Id: tclXprofile.c,v 1.4 2009/10/13 19:28:23 kot Exp $
 *-----------------------------------------------------------------------------
 */

#include "tclExtdInt.h"

/*
 * For when the level is not known.
 */
#define UNKNOWN_LEVEL -1

/*
 * Stack entry used to keep track of an profiling information for procedures
 * (and commands in command mode).  This stack mirrors the Tcl procedure stack.
 * A chain of variable scope entries is also kept.  This tracks the uplevel
 * chain kept in the Tcl stack.  Unlike the Tcl stack, an entry is also make
 * for the global context and for the commands when in command mode.  We count
 * the amount of time actually in the procedure, not what it has called.  This
 * is the time it spent on the top of the stack.  This is do for both eval
 * level and variable scope.
 */

typedef struct profEntry_t {
    int                 isProc;           /* Procedure, not command.       */
    int                 procLevel;        /* Procedure level.              */ 
    int                 scopeLevel;       /* Varaible scope level.         */ 
    int                 evalLevel;        /* Tcl_Eval level.               */ 
    clock_t             evalRealTime;     /* Cumulative real and CPU time  */
    clock_t             evalCpuTime;      /* entry was on top of stack.    */
    clock_t             scopeRealTime;    /* Cumulative Real and CPU time  */
    clock_t             scopeCpuTime;     /* entry's scope was active.     */
    struct profEntry_t *prevEntryPtr;     /* Procedure call stack.         */
    struct profEntry_t *prevScopePtr;     /* Procedure var scope chain.    */
    char                cmdName [1];      /* Command name. MUST BE LAST!   */
} profEntry_t;

/*
 * Data keeped on a stack snapshot.
 */
typedef struct profDataEntry_t {
    clock_t count;
    clock_t realTime;
    clock_t cpuTime;
} profDataEntry_t;

/*
 * Client data structure for profile command.  This contains all global
 * profiling information for the interpreter.
 */

typedef struct profInfo_t { 
    Tcl_Interp     *interp;                /* Interpreter this is for.       */
    Tcl_Trace       traceHandle;           /* Handle to current trace.       */
    int             commandMode;           /* Prof all commands?             */
    int             evalMode;              /* Use eval stack.                */
    Tcl_Command     currentCmd;            /* Current command table entry.   */
    Tcl_CmdInfo     savedCmdInfo;          /* Details about the current cmd. */
    int             evalLevel;             /* Eval level when invoked.       */
    clock_t         realTime;              /* Current real and CPU time.     */
    clock_t         cpuTime;
    clock_t         prevRealTime;          /* Real and CPU time of previous  */
    clock_t         prevCpuTime;           /* trace.                         */
    int             updatedTimes;          /* Has current times been updated?*/
    profEntry_t    *stackPtr;              /* Proc/command nesting stack.    */
    int             stackSize;             /* Size of the stack.             */
    profEntry_t    *scopeChainPtr;         /* Variable scope chain.          */
    Tcl_HashTable   profDataTable;         /* Cumulative time table, Keyed   */
                                           /* by call stack list.            */
} profInfo_t;

/*
 * Argument to Tcl_Panic on logic errors.  Takes an id number.
 */
static const char *PROF_PANIC = "TclX profile bug id = %d\n";

/*
 * Prototypes of internal functions.
 */
static void
PushEntry (profInfo_t *infoPtr,
           const char *cmdName,
           int         isProc,
           int         procLevel,
           int         scopeLevel,
           int         evalLevel);

static void
RecordData (profInfo_t  *infoPtr,
            profEntry_t *entryPtr);

static void
PopEntry (profInfo_t *infoPtr);

static void
UpdateTOSTimes (profInfo_t *infoPtr);

static void
ProfCommandEvalSetup (profInfo_t *infoPtr,
                      int        *isProcPtr);
    
static void
ProfCommandEvalFinishup (profInfo_t *infoPtr,
                         int         isProc);

static int
ProfStrCommandEval (ClientData    clientData,
                    Tcl_Interp   *interp,
                    int           argc,
                    const char **argv);

static int
ProfObjCommandEval (ClientData    clientData,
                    Tcl_Interp   *interp,
                    int           objc,
                    Tcl_Obj      *const objv[]);

static Tcl_CmdObjTraceProc ProfTraceRoutine;

static void
CleanDataTable (profInfo_t *infoPtr);

static void
InitializeProcStack (profInfo_t *infoPtr,
                     CallFrame  *framePtr);

static void
TurnOnProfiling (profInfo_t *infoPtr,
                 int         commandMode,
                 int         evalMode);

static void
DeleteProfTrace (profInfo_t *infoPtr);

static int
TurnOffProfiling (Tcl_Interp *interp,
                  profInfo_t *infoPtr,
                  char       *varName);

static int
TclX_ProfileObjCmd (ClientData   clientData,
                    Tcl_Interp  *interp,
                    int          objc,
                    Tcl_Obj    *const objv[]);

static void
ProfMonCleanUp (ClientData  clientData,
                Tcl_Interp *interp);


/*-----------------------------------------------------------------------------
 * PushEntry --
 *   Push a procedure or command entry onto the stack.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *   o cmdName  The procedure or command name.
 *   o isProc - TRUE if its a proc, FALSE if other command.
 *   o procLevel - The procedure call level that the procedure or command will
 *     execute at.
 *   o scopeLevel - The procedure variable scope level that the commands local
 *     variables are at.
 *   o evalLevel - The eval level the command was executed at.  For procedures
 *     this is the level it was called at, since if the procedure's commands
 *     are logged, they will be an the next eval level.  Maybe be
 *     UNKNOWN_LEVEL.
 *-----------------------------------------------------------------------------
 */
static void
PushEntry (profInfo_t *infoPtr,
           const char *cmdName,
           int         isProc,
           int         procLevel,
           int         scopeLevel,
           int         evalLevel)
{
    profEntry_t *entryPtr, *scanPtr;

    /*
     * Calculate the size of an entry.  One byte for name is in the entry.
     */
    entryPtr = (profEntry_t *) ckalloc (sizeof (profEntry_t) +
                                        strlen (cmdName));
    
    /*
     * Fill it in and push onto the stack.  Note that the procedures frame has
     * not yet been layed down or the procedure body eval execute, so the value
     * they will be in the procedure is recorded.
     */
    entryPtr->isProc = isProc;
    entryPtr->procLevel = procLevel;
    entryPtr->scopeLevel = scopeLevel;
    entryPtr->evalLevel = evalLevel;
    entryPtr->evalRealTime = 0;
    entryPtr->evalCpuTime = 0;
    entryPtr->scopeRealTime = 0;
    entryPtr->scopeCpuTime = 0;
    strcpy (entryPtr->cmdName, cmdName);

    /*
     * Push onto the stack and set the variable scope chain.  The variable
     * scope entry is chained to the first entry who's scope is less than ours
     * if this is a proc or less than or equal to ours if this is a command.
     */
    entryPtr->prevEntryPtr = infoPtr->stackPtr;
    infoPtr->stackPtr = entryPtr;
    infoPtr->stackSize++;

    scanPtr = infoPtr->scopeChainPtr;
    while ((scanPtr != NULL) && (scanPtr->procLevel > 0) &&
           ((isProc && (scanPtr->scopeLevel >= scopeLevel)) ||
            ((!isProc) && (scanPtr->scopeLevel > scopeLevel)))) {
        scanPtr = scanPtr->prevScopePtr;
        /*
         * Only global level can be NULL.
         */
        if (scanPtr == NULL)
            Tcl_Panic (PROF_PANIC, 1);
    }
    entryPtr->prevScopePtr = scanPtr;
    infoPtr->scopeChainPtr = entryPtr;
}

/*-----------------------------------------------------------------------------
 * RecordData --
 *   Record an entries times in the data table.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *   o entryPtr - The entry to record.
 *-----------------------------------------------------------------------------
 */
static void
RecordData (profInfo_t  *infoPtr,
            profEntry_t *entryPtr)
{
    int idx, newEntry;
    profEntry_t *scanPtr;
    char **stackArgv, *stackListPtr;
    Tcl_HashEntry *hashEntryPtr;
    profDataEntry_t *dataEntryPtr;

    /*
     * Build up a stack list.  Entry [0] is the top of the stack, either the
     * scope or eval stack is followed, based on the -eval option.  If both
     * scope and command mode are enabled, commands other than the top command
     * are skipped.
     */
    stackArgv = (char **) ckalloc (sizeof (char *) * infoPtr->stackSize);
    if (infoPtr->evalMode) {
        for (idx= 0, scanPtr = entryPtr; scanPtr != NULL;
             scanPtr = scanPtr->prevEntryPtr) {
            stackArgv [idx++] = scanPtr->cmdName;
        }
    } else {
        for (idx= 0, scanPtr = entryPtr; scanPtr != NULL;
             scanPtr = scanPtr->prevScopePtr) {
            stackArgv [idx++] = scanPtr->cmdName;
        }
    }
    stackListPtr = Tcl_Merge (idx, (const char **) stackArgv);
    ckfree ((char *) stackArgv);

    /*
     * Check the hash table for this entry, either finding an existing or
     * creating a new hash entry.
     */

    hashEntryPtr = Tcl_CreateHashEntry (&infoPtr->profDataTable,
                                        stackListPtr,
                                        &newEntry);
    ckfree (stackListPtr);

    /*
     * Either get the existing entry or create a new one.
     */
    if (newEntry) {
        dataEntryPtr = (profDataEntry_t *) ckalloc (sizeof (profDataEntry_t));
        Tcl_SetHashValue (hashEntryPtr, dataEntryPtr);
        dataEntryPtr->count = 0;
        dataEntryPtr->realTime = 0;
        dataEntryPtr->cpuTime  = 0;
    } else {
        dataEntryPtr = (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr);
    }

    /*
     * Increment the cumulative data.
     */
    dataEntryPtr->count++;
    if (infoPtr->evalMode) {
        dataEntryPtr->realTime += entryPtr->evalRealTime;
        dataEntryPtr->cpuTime += entryPtr->evalCpuTime;
    } else {
        dataEntryPtr->realTime += entryPtr->scopeRealTime;
        dataEntryPtr->cpuTime += entryPtr->scopeCpuTime;
    }
}

/*-----------------------------------------------------------------------------
 * PopEntry --
 *   Pop the procedure entry from the top of the stack and record its
 * times in the data table.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *-----------------------------------------------------------------------------
 */
static void
PopEntry (profInfo_t *infoPtr)
{
    profEntry_t *entryPtr = infoPtr->stackPtr;

    RecordData (infoPtr, entryPtr);

    /*
     * Remove from the stack, reset the scope chain and free.
     */
    infoPtr->stackPtr = entryPtr->prevEntryPtr;
    infoPtr->stackSize--;
    infoPtr->scopeChainPtr = infoPtr->stackPtr;

    ckfree ((char *) entryPtr);
}

/*-----------------------------------------------------------------------------
 * UpdateTOSTimes --
 *   Update the time spent in the entry on the top of the stack before another
 * is pushed on top or its poped off.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *-----------------------------------------------------------------------------
 */
static void
UpdateTOSTimes (profInfo_t *infoPtr)
{
    /*
     * Get the current time if we haven't already.
     */
    if (!infoPtr->updatedTimes) {
        infoPtr->prevRealTime = infoPtr->realTime;
        infoPtr->prevCpuTime = infoPtr->cpuTime;
        TclXOSElapsedTime (&infoPtr->realTime, &infoPtr->cpuTime);
        infoPtr->updatedTimes = TRUE;
    }
    if (infoPtr->stackPtr != NULL) {
        infoPtr->stackPtr->evalRealTime +=
            infoPtr->realTime - infoPtr->prevRealTime;
        infoPtr->stackPtr->evalCpuTime +=
            infoPtr->cpuTime - infoPtr->prevCpuTime;
    }
    if (infoPtr->scopeChainPtr != NULL) {
        infoPtr->scopeChainPtr->scopeRealTime +=
            infoPtr->realTime - infoPtr->prevRealTime;
        infoPtr->scopeChainPtr->scopeCpuTime +=
            infoPtr->cpuTime - infoPtr->prevCpuTime;
    }
}

/*-----------------------------------------------------------------------------
 * ProfCommandEvalSetup --
 *   Do initial work that is common to both the string and object command
 * evaluators.
 *
 * Returns:
 *   A pointer to the current command table entry.
 *-----------------------------------------------------------------------------
 */
static void
ProfCommandEvalSetup (profInfo_t *infoPtr, int *isProcPtr)
{
    Interp *iPtr = (Interp *) infoPtr->interp;
    Tcl_CmdInfo cmdInfo;
    int procLevel, scopeLevel, isProc;
    Tcl_Obj *fullCmdNamePtr;
    const char *fullCmdName;

    Tcl_GetCommandInfoFromToken(infoPtr->currentCmd, &cmdInfo);
    /*
     * Restore the command table entry.  If the command has modified it, don't
     * mess with it.
     */
    if (cmdInfo.proc == ProfStrCommandEval)
        cmdInfo.proc = infoPtr->savedCmdInfo.proc;
    if (cmdInfo.clientData == (ClientData) infoPtr)
        cmdInfo.clientData = infoPtr->savedCmdInfo.clientData;
    if (cmdInfo.objProc == ProfObjCommandEval)
        cmdInfo.objProc = infoPtr->savedCmdInfo.objProc;
    if (cmdInfo.objClientData == (ClientData) infoPtr)
        cmdInfo.objClientData = infoPtr->savedCmdInfo.objClientData;
    if (cmdInfo.deleteProc == NULL)
        cmdInfo.deleteProc = infoPtr->savedCmdInfo.deleteProc;
    if (cmdInfo.deleteData == NULL)
        cmdInfo.deleteData = infoPtr->savedCmdInfo.deleteData;
    cmdInfo.isNativeObjectProc = infoPtr->savedCmdInfo.isNativeObjectProc;

    Tcl_SetCommandInfoFromToken(infoPtr->currentCmd, &cmdInfo);

    fullCmdNamePtr = Tcl_NewObj ();
    Tcl_GetCommandFullName (infoPtr->interp, infoPtr->currentCmd, 
                            fullCmdNamePtr);
    fullCmdName = Tcl_GetStringFromObj (fullCmdNamePtr, NULL);

    /*
     * Use the level value passed in by Tcl_Interp through ProfTraceRoutine.
     *   Ref: Tcl_CmdObjTraceProc(ClientData, Tcl_Interp*, int level, ...)
     * The value calcuated from iPtr->framePtr chain may be smaller.
     * And will cause issue when checking (infoPtr->stackPtr->procLevel > procLevel).
     */
    procLevel = infoPtr->evalLevel;
    scopeLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;

    /* 
     * If there are entries on the stack that are at a higher proc call level
     * than we are, we have exited into the initial entries that where pushed
     * on the stack before we started.  Pop those entries.
     */
    if (infoPtr->stackPtr->procLevel > procLevel) {
        UpdateTOSTimes (infoPtr);
        do {
            if (infoPtr->stackPtr->evalLevel != UNKNOWN_LEVEL) 
                Tcl_Panic (PROF_PANIC, 2);  /* Not an initial entry */
            PopEntry (infoPtr);
        } while (infoPtr->stackPtr->procLevel > procLevel);
    }

    /*
     * If this command is a procedure or if all commands are being traced,
     * handle the entry.
     */
    isProc = (TclFindProc (iPtr, fullCmdName) != NULL);
    if (infoPtr->commandMode || isProc) {
        UpdateTOSTimes (infoPtr);
        if (isProc) {
            PushEntry (infoPtr, fullCmdName, TRUE,
                       procLevel + 1, scopeLevel + 1, infoPtr->evalLevel);
        } else {
            PushEntry (infoPtr, fullCmdName, FALSE,
                       procLevel, scopeLevel, infoPtr->evalLevel);
        }
    }

    /*
     * Leaving profiler, must get time again when we reenter.
     */
    infoPtr->updatedTimes = FALSE;

    *isProcPtr = isProc;

    Tcl_DecrRefCount (fullCmdNamePtr);
}

/*-----------------------------------------------------------------------------
 * ProfCommandEvalFinishup --
 *   Do final work that is common to both the string and object command
 * evaluators.
 *-----------------------------------------------------------------------------
 */
static void
ProfCommandEvalFinishup (profInfo_t *infoPtr, int isProc)
{
    /*
     * If tracing is still running, pop the entry, recording the information.
     */
    if (infoPtr->traceHandle != NULL) {
        if (infoPtr->commandMode || isProc) {
            UpdateTOSTimes (infoPtr);
            PopEntry (infoPtr);
        }
    }
    /*
     * Leaving profiler, must get time again when we reenter.
     */
    infoPtr->updatedTimes = FALSE;
}

/*-----------------------------------------------------------------------------
 * ProfStrCommandEval --
 *   Function to evaluate a string command.  The procedure trace routine
 * substitutes this function for the command executor function in the Tcl
 * command table.  We restore the command table, record data about the start
 * of the command and then actually execute the command.  When the command
 * returns, we record data about the time it took.
 *
 * FIX:  This all falls apart if another trace is executed between the
 * doctoring of the command entry and this function being called.
 *-----------------------------------------------------------------------------
 */
static int
ProfStrCommandEval (ClientData    clientData,
                    Tcl_Interp   *interp,
                    int           argc,
                    const char **argv)
{
    profInfo_t *infoPtr = (profInfo_t *) clientData;
    int isProc, result;

    ProfCommandEvalSetup (infoPtr, &isProc);

    result = (*infoPtr->savedCmdInfo.proc)(infoPtr->savedCmdInfo.clientData, interp,
                                     argc, argv);

    ProfCommandEvalFinishup (infoPtr, isProc);
    return result;
}

/*-----------------------------------------------------------------------------
 * ProfObjCommandEval --
 *   Function to evaluate a object command.  The procedure trace routine
 * substitutes this function for the command executor function in the Tcl
 * command table.  We restore the command table, record data about the start
 * of the command and then actually execute the command.  When the command
 * returns, we record data about the time it took.
 *
 * FIX:  This all falls apart if another trace is executed between the
 * doctoring of the command entry and this function being called.
 *-----------------------------------------------------------------------------
 */
static int
ProfObjCommandEval (ClientData    clientData,
                    Tcl_Interp   *interp,
                    int           objc,
                    Tcl_Obj      *const objv[])
{
    profInfo_t *infoPtr = (profInfo_t *) clientData;
    int isProc, result;

    ProfCommandEvalSetup (infoPtr, &isProc);

    result = (*infoPtr->savedCmdInfo.objProc)(infoPtr->savedCmdInfo.objClientData, interp,
                                        objc, objv);

    ProfCommandEvalFinishup (infoPtr, isProc);
    return result;
}

/*-----------------------------------------------------------------------------
  * ProfTraceRoutine --
 *   Routine called by Tcl_Eval to do profiling.  It intercepts the current
 * command being executed by temporarily editing the command table.
 *-----------------------------------------------------------------------------
 */
static int
ProfTraceRoutine (ClientData  clientData,
                  Tcl_Interp *interp,
                  int         evalLevel,
                  const char *command,
                  Tcl_Command cmd,
                  int         objc,
                  Tcl_Obj    *const objv[])
{
    /* struct Tcl_Obj * const *objv; */
    profInfo_t *infoPtr = (profInfo_t *) clientData;
    Tcl_CmdInfo cmdInfo;

    if (cmd == NULL)
        Tcl_Panic (PROF_PANIC, 4);

    //TIP #571: We don' want to profile the tailcall itself. As it can only be called in a procedure/lambda context
    if ( ! strcmp((*objv)->bytes, "tailcall") ) {
        return TCL_OK;
    }
    /*
     * Save current state information.
     */
    Tcl_GetCommandInfoFromToken(cmd, &(infoPtr->savedCmdInfo));
    infoPtr->evalLevel = evalLevel;
    infoPtr->currentCmd = cmd;

    /*
     * Force our routines to be called.
     */
    cmdInfo.proc = ProfStrCommandEval;
    cmdInfo.clientData = (ClientData) infoPtr;
    cmdInfo.objProc = ProfObjCommandEval;
    cmdInfo.objClientData = (ClientData) infoPtr;
    cmdInfo.isNativeObjectProc = infoPtr->savedCmdInfo.isNativeObjectProc;
    cmdInfo.deleteProc = NULL;
    cmdInfo.deleteData = NULL;
    Tcl_SetCommandInfoFromToken(cmd, &cmdInfo);

    return TCL_OK;
}

/*-----------------------------------------------------------------------------
 * CleanDataTable --
 *    Clean up the hash data table, releasing all resources and setting it
 * to the empty state.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *-----------------------------------------------------------------------------
 */
static void
CleanDataTable (profInfo_t *infoPtr)
{
    Tcl_HashEntry    *hashEntryPtr;
    Tcl_HashSearch   searchCookie;

    hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable,
                                       &searchCookie);
    while (hashEntryPtr != NULL) {
        ckfree ((char *) Tcl_GetHashValue (hashEntryPtr));
        Tcl_DeleteHashEntry (hashEntryPtr);
        hashEntryPtr = Tcl_NextHashEntry (&searchCookie);
    }
}

/*-----------------------------------------------------------------------------
 * InitializeProcStack --
 *    Recursive procedure to initialize the procedure call stack so its in the
 * same state as the actual procedure  call stack.  If commandMode is enable,
 * command records are still are not initialized on the stack, as we have no
 * way of knowing what command did a Tcl_Eval.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *   o framePtr - Pointer to the frame to push.  We recurse down to the bottom,
 *     then push on the way out.
 *-----------------------------------------------------------------------------
 */
static void
InitializeProcStack (profInfo_t *infoPtr, CallFrame *framePtr)
{
    if (framePtr == NULL || framePtr->objv == NULL)
        return;
    InitializeProcStack (infoPtr, framePtr->callerPtr);
    
       
    PushEntry (infoPtr,
               Tcl_GetStringFromObj (framePtr->objv [0], NULL),
               TRUE,
               infoPtr->stackPtr->procLevel + 1,
               framePtr->level,
               UNKNOWN_LEVEL);
}

/*-----------------------------------------------------------------------------
 * TurnOnProfiling --
 *    Turn on profiling.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *   o commandMode - TRUE if all commands are going to be logged, FALSE if just
 *     procs.
 *   o evalMode - TRUE if eval stack is to be used to log entries.  FALSE if
 *     the scope stack is to be used.
 *-----------------------------------------------------------------------------
 */
static void
TurnOnProfiling (profInfo_t *infoPtr, int commandMode, int evalMode)
{
    Interp *iPtr = (Interp *) infoPtr->interp;
    int scopeLevel;
    profEntry_t *scanPtr;

    CleanDataTable (infoPtr);

    infoPtr->traceHandle =
        Tcl_CreateObjTrace (infoPtr->interp, 0,
                         TCL_ALLOW_INLINE_COMPILATION, ProfTraceRoutine,
                         (ClientData) infoPtr, NULL);
    infoPtr->commandMode = commandMode;
    infoPtr->evalMode = evalMode;
    infoPtr->realTime = 0;
    infoPtr->cpuTime = 0;
    infoPtr->prevRealTime = 0;
    infoPtr->prevCpuTime = 0;
    infoPtr->updatedTimes = FALSE;
    
    /*
     * Add entry for global context, then add in current procedures.
     */
    PushEntry (infoPtr, "<global>", TRUE, 0, 0, 0);
    InitializeProcStack (infoPtr, ((Interp *) infoPtr->interp)->framePtr);

    /*
     * Find the current top of the scope stack.
     */
    scopeLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
    scanPtr = infoPtr->scopeChainPtr;
    while ((scanPtr != NULL) && (scanPtr->scopeLevel >= scopeLevel) &&
           (scanPtr->procLevel > 0)) {
        scanPtr = scanPtr->prevScopePtr;
        /*
         * Only global level can be NULL.
         */
        if (scanPtr == NULL)
            Tcl_Panic (PROF_PANIC, 6);
    }
    infoPtr->scopeChainPtr = scanPtr;

    /*
     * Get the time we started.
     */
    TclXOSElapsedTime (&infoPtr->realTime, &infoPtr->cpuTime);
}

/*-----------------------------------------------------------------------------
 * DeleteProfTrace --
 *   Delete the profile trace and clean up the stack, logging all procs
 * as if they had exited.  Data table must still be available.
 *
 * Parameters:
 *   o infoPtr - The global profiling info.
 *-----------------------------------------------------------------------------
 */
static void
DeleteProfTrace (profInfo_t *infoPtr)
{
    Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHandle);
    infoPtr->traceHandle = NULL;

    UpdateTOSTimes (infoPtr);
    while (infoPtr->stackPtr != NULL) {
        PopEntry (infoPtr);
    }
}

/*-----------------------------------------------------------------------------
 * TurnOffProfiling --
 *   Turn off profiling.  Dump the table data to an array variable.  Entries
 * will be deleted as they are dumped to limit memory utilization.
 *
 * Parameters:
 *   o interp - Pointer to the interprer.
 *   o infoPtr - The global profiling info.
 *   o varName - The name of the variable to save the data in.
 * Returns:
 *   TCL_OK or TCL_ERROR.
 * FIX: Should take Tcl_Obj for varName.
 *-----------------------------------------------------------------------------
 */
static int
TurnOffProfiling (Tcl_Interp *interp, profInfo_t *infoPtr, char *varName)
{
    Tcl_HashEntry *hashEntryPtr;
    Tcl_HashSearch searchCookie;
    profDataEntry_t *dataEntryPtr;
    const char *dataArgv [3];
    char countBuf [32], realTimeBuf [32], cpuTimeBuf [32], *dataListPtr;

    DeleteProfTrace (infoPtr);

    dataArgv [0] = countBuf;
    dataArgv [1] = realTimeBuf;
    dataArgv [2] = cpuTimeBuf;

    Tcl_UnsetVar (interp, varName, 0);
    hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable,
                                       &searchCookie);
    while (hashEntryPtr != NULL) {
        dataEntryPtr = 
            (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr);

        sprintf (countBuf,    "%ld", (long) dataEntryPtr->count);
        sprintf (realTimeBuf, "%ld", (long) dataEntryPtr->realTime);
        sprintf (cpuTimeBuf,  "%ld", (long) dataEntryPtr->cpuTime);

        dataListPtr = Tcl_Merge (3, dataArgv);

        if (Tcl_SetVar2 (interp, varName,
                         Tcl_GetHashKey (&infoPtr->profDataTable,
                                         hashEntryPtr),
                         dataListPtr, TCL_LEAVE_ERR_MSG) == NULL) {
            ckfree (dataListPtr);
            return TCL_ERROR;
        }
        ckfree (dataListPtr);
        ckfree ((char *) dataEntryPtr);
        Tcl_DeleteHashEntry (hashEntryPtr);

        hashEntryPtr = Tcl_NextHashEntry (&searchCookie);
    }

    return TCL_OK;
}

/*-----------------------------------------------------------------------------
 * TclX_ProfileObjCmd --
 *   Implements the TCL profile command:
 *     profile ?-commands? ?-eval? on
 *     profile off arrayvar
 *-----------------------------------------------------------------------------
 */
static int
TclX_ProfileObjCmd (ClientData   clientData,
                    Tcl_Interp  *interp,
                    int          objc,
                    Tcl_Obj    *const objv[])
{
    profInfo_t *infoPtr = (profInfo_t *) clientData;
    int argIdx;
    int commandMode = FALSE, evalMode = FALSE;
    char *argStr;
        
    /*
     * Parse option arguments.
     */
    for (argIdx = 1; argIdx < objc; argIdx++) {
        argStr = Tcl_GetStringFromObj (objv [argIdx], NULL);
        if (argStr[0] != '-')
            break;
        if (STREQU (argStr, "-commands")) {
            commandMode = TRUE;
        } else if (STREQU (argStr, "-eval")) {
            evalMode = TRUE;
        } else {
            TclX_AppendObjResult (interp, "expected one of \"-commands\", or ",
                                  "\"-eval\", got \"", argStr, "\"",
                                  (char *) NULL);
            return TCL_ERROR;
        }
    }
    if (argIdx >= objc)
        goto wrongArgs;

    /*
     * Get argument string for remainder of strings.
     */
    argStr = Tcl_GetStringFromObj (objv [argIdx], NULL);
    
    /*
     * Handle the on command.
     */
    if (STREQU (argStr, "on")) {
        if (argIdx != objc - 1)
            goto wrongArgs;

        if (infoPtr->traceHandle != NULL) {
            TclX_AppendObjResult (interp, "profiling is already enabled",
                                  (char *) NULL);
            return TCL_ERROR; 
        }

        TurnOnProfiling (infoPtr, commandMode, evalMode);
        return TCL_OK;
    }

    /*
     * Handle the off command.  Dump the hash table to a variable.
     */
    if (STREQU (argStr, "off")) {

        if (argIdx != objc - 2)
            goto wrongArgs;

        if (commandMode || evalMode) {
            TclX_AppendObjResult (interp, "option \"",
                                  commandMode ? "-command" : "-eval",
                                  "\" not valid when turning off ",
                                  "profiling", (char *) NULL);
            return TCL_ERROR;
        }

        if (infoPtr->traceHandle == NULL) {
            TclX_AppendObjResult (interp, "profiling is not currently enabled",
                                  (char *) NULL);
            return TCL_ERROR;
        }
            
        if (TurnOffProfiling (interp, infoPtr, 
                              Tcl_GetStringFromObj (objv [argIdx + 1],
                                                    NULL)) != TCL_OK)
            return TCL_ERROR;
        return TCL_OK;
    }

    /*
     * Not a valid subcommand.
     */
    TclX_AppendObjResult (interp, "expected one of \"on\" or \"off\", got \"",
                          argStr, "\"", (char *) NULL);
    return TCL_ERROR;

  wrongArgs:
    return TclX_WrongArgs (interp, objv [0],
                           "?-commands? ?-eval? on|off arrayVar");
}

/*-----------------------------------------------------------------------------
 * ProfMonCleanUp --
 *   Release the client data area when the interpreter is deleted.
 *-----------------------------------------------------------------------------
 */
static void
ProfMonCleanUp (ClientData clientData, Tcl_Interp *interp)
{
    profInfo_t *infoPtr = (profInfo_t *) clientData;

    if (infoPtr->traceHandle != NULL)
        DeleteProfTrace (infoPtr);
    CleanDataTable (infoPtr);
    Tcl_DeleteHashTable (&infoPtr->profDataTable);
    ckfree ((char *) infoPtr);
}

/*-----------------------------------------------------------------------------
 * Tcl_InitProfile --
 *   Initialize the Tcl profiling command.
 *-----------------------------------------------------------------------------
 */
void
TclX_ProfileInit (Tcl_Interp *interp)
{
    profInfo_t *infoPtr;

    infoPtr = (profInfo_t *) ckalloc (sizeof (profInfo_t));

    infoPtr->interp = interp;
    infoPtr->traceHandle = NULL;
    infoPtr->commandMode = FALSE;
    infoPtr->evalMode = FALSE;
    infoPtr->currentCmd = NULL;
    infoPtr->evalLevel = UNKNOWN_LEVEL;
    infoPtr->realTime = 0;
    infoPtr->cpuTime = 0;
    infoPtr->prevRealTime = 0;
    infoPtr->prevCpuTime = 0;
    infoPtr->updatedTimes = FALSE;
    infoPtr->stackPtr = NULL;
    infoPtr->stackSize = 0;
    infoPtr->scopeChainPtr = NULL;
    Tcl_InitHashTable (&infoPtr->profDataTable, TCL_STRING_KEYS);

    Tcl_CallWhenDeleted (interp, ProfMonCleanUp, (ClientData) infoPtr);

    Tcl_CreateObjCommand (interp, 
			  "profile",
			  TclX_ProfileObjCmd,
                          (ClientData) infoPtr,
			  (Tcl_CmdDeleteProc*) NULL);
}

/* vim: set ts=4 sw=4 sts=4 et : */
