diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclCkalloc.c | 54 | ||||
| -rw-r--r-- | generic/tclExecute.c | 204 | ||||
| -rw-r--r-- | generic/tclInt.decls | 4 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 6 |
5 files changed, 159 insertions, 119 deletions
@@ -1,3 +1,13 @@ +2010-10-01 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclExecute.c (EvalStatsCmd): change 'evalstats' to + return data to interp by default, or if given an arg, use that as + filename to output to (accepts 'stdout' and 'stderr'). + Fix output to print used inst count data. + * generic/tclCkalloc.c: change TclDumpMemoryInfo sig to allow + * generic/tclInt.decls: objPtr as well as FILE* as output. + * generic/tclIntDecls.h: + 2010-09-24 Andreas Kupries <andreask@activestate.com> * tclWinsock.c: [Bug 3056775]: Fixed race condition between thread diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 81b8851..27aad95 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -14,7 +14,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.32.4.2 2009/10/18 11:21:38 mistachkin Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.32.4.3 2010/10/02 00:29:42 hobbs Exp $ */ #include "tclInt.h" @@ -165,22 +165,32 @@ TclInitDbCkalloc(void) *---------------------------------------------------------------------- */ -void -TclDumpMemoryInfo( - FILE *outFile) +int +TclDumpMemoryInfo(ClientData clientData, int flags) { - fprintf(outFile,"total mallocs %10d\n", - total_mallocs); - fprintf(outFile,"total frees %10d\n", - total_frees); - fprintf(outFile,"current packets allocated %10d\n", - current_malloc_packets); - fprintf(outFile,"current bytes allocated %10lu\n", - current_bytes_malloced); - fprintf(outFile,"maximum packets allocated %10d\n", - maximum_malloc_packets); - fprintf(outFile,"maximum bytes allocated %10lu\n", + char buf[1024]; + + if (clientData == NULL) { return 0; } + sprintf(buf, + "total mallocs %10d\n" + "total frees %10d\n" + "current packets allocated %10d\n" + "current bytes allocated %10lu\n" + "maximum packets allocated %10d\n" + "maximum bytes allocated %10lu\n", + total_mallocs, + total_frees, + current_malloc_packets, + current_bytes_malloced, + maximum_malloc_packets, maximum_bytes_malloced); + if (flags == 0) { + fprintf((FILE *)clientData, buf); + } else { + /* Assume objPtr to append to */ + Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1); + } + return 1; } /* @@ -228,7 +238,7 @@ ValidateMemory( } } if (guard_failed) { - TclDumpMemoryInfo (stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "low guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ @@ -250,7 +260,7 @@ ValidateMemory( } if (guard_failed) { - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "high guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ @@ -389,7 +399,7 @@ Tcl_DbCkalloc( } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } @@ -483,7 +493,7 @@ Tcl_AttemptDbCkalloc( } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo((ClientData) stderr, 0); return NULL; } @@ -1250,10 +1260,10 @@ Tcl_ValidateAllMemory( { } -void -TclDumpMemoryInfo( - FILE *outFile) +int +TclDumpMemoryInfo(ClientData clientData, int flags) { + return 1; } #endif /* TCL_MEM_DEBUG */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4f9ee5f..3048663 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.369.2.15 2010/09/01 19:42:39 andreas_kupries Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.369.2.16 2010/10/02 00:29:42 hobbs Exp $ */ #include "tclInt.h" @@ -1825,7 +1825,7 @@ TclExecuteByteCode( #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", CURR_DEPTH); + fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif @@ -2413,15 +2413,13 @@ TclExecuteByteCode( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc, - codePtr, bcFramePtr, - pc - codePtr->codeStart); + codePtr, bcFramePtr, pc - codePtr->codeStart); DECACHE_STACK_INFO(); result = TclEvalObjvInternal(interp, objc, objv, /* call from TEBC */(char *) -1, -1, 0); CACHE_STACK_INFO(); TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc, - codePtr, - pc - codePtr->codeStart); + codePtr, pc - codePtr->codeStart); iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (result == TCL_OK) { @@ -6703,7 +6701,7 @@ TclExecuteByteCode( *(++catchTop) = CURR_DEPTH; TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), + TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); @@ -6711,7 +6709,7 @@ TclExecuteByteCode( catchTop--; Tcl_ResetResult(interp); result = TCL_OK; - TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1))); + TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); case INST_PUSH_RESULT: @@ -7452,7 +7450,7 @@ TclExecuteByteCode( if (traceInstructions) { fprintf(stdout, " ... found catch at %d, catchTop=%d, " "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, catchTop - initCatchTop - 1, + rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), (long) *catchTop, (unsigned) rangePtr->catchOffset); } #endif @@ -8117,9 +8115,13 @@ EvalStatsCmd( int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; + Tcl_Obj *objPtr; #define Percent(a,b) ((a) * 100.0 / (b)) + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + numInstructions = 0.0; for (i = 0; i < 256; i++) { if (statsPtr->instructionCount[i] != 0) { @@ -8150,65 +8152,65 @@ EvalStatsCmd( * Summary statistics, total and current source and ByteCode sizes. */ - fprintf(stdout, "\n----------------------------------------------------------------\n"); - fprintf(stdout, + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, "Compilation and execution statistics for interpreter 0x%p\n", iPtr); - fprintf(stdout, "\nNumber ByteCodes executed %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed %ld\n", statsPtr->numExecutions); - fprintf(stdout, "Number ByteCodes compiled %ld\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled %ld\n", statsPtr->numCompilations); - fprintf(stdout, " Mean executions/compile %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile %.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); - fprintf(stdout, "\nInstructions executed %.0f\n", + Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed %.0f\n", numInstructions); - fprintf(stdout, " Mean inst/compile %.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile %.0f\n", numInstructions / statsPtr->numCompilations); - fprintf(stdout, " Mean inst/execution %.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution %.0f\n", numInstructions / statsPtr->numExecutions); - fprintf(stdout, "\nTotal ByteCodes %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes %ld\n", statsPtr->numCompilations); - fprintf(stdout, " Source bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n", statsPtr->totalSrcBytes); - fprintf(stdout, " Code bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n", totalCodeBytes); - fprintf(stdout, " ByteCode bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n", statsPtr->totalByteCodeBytes); - fprintf(stdout, " Literal bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n", totalLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), statsPtr->totalLitStringBytes); - fprintf(stdout, " Mean code/compile %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/compile %.1f\n", totalCodeBytes / statsPtr->numCompilations); - fprintf(stdout, " Mean code/source %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n", numCurrentByteCodes); - fprintf(stdout, " Source bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n", statsPtr->currentSrcBytes); - fprintf(stdout, " Code bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n", currentCodeBytes); - fprintf(stdout, " ByteCode bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n", statsPtr->currentByteCodeBytes); - fprintf(stdout, " Literal bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n", currentLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), statsPtr->currentLitStringBytes); - fprintf(stdout, " Mean code/source %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", + Tcl_AppendPrintfToObj(objPtr, " Code + source bytes %.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); @@ -8220,18 +8222,18 @@ EvalStatsCmd( */ numSharedMultX = 0; - fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); - fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared) %ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - fprintf(stdout, " refcount ==%d %ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d %ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - fprintf(stdout, " refcount >=%d %ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d %ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - fprintf(stdout, " Total shared objects %d\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects %d\n", numSharedMultX); /* @@ -8268,48 +8270,48 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - fprintf(stdout, "\nTotal objects (all interps) %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps) %ld\n", tclObjsAlloced); - fprintf(stdout, "Current objects %ld\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects %ld\n", (tclObjsAlloced - tclObjsFreed)); - fprintf(stdout, "Total literal objects %ld\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects %ld\n", statsPtr->numLiteralsCreated); - fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals %ld (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - fprintf(stdout, " Literals reused > 1x %d\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x %d\n", numSharedMultX); - fprintf(stdout, " Mean reference count %.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean reference count %.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - fprintf(stdout, " Mean len, str reused >1x %.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x %.2f\n", (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - fprintf(stdout, " Mean len, str used 1x %.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x %.2f\n", (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", sharingBytesSaved, Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - fprintf(stdout, " Bytes with sharing %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing %.6g\n", currentLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), statsPtr->currentLitStringBytes); - fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); - fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); - fprintf(stdout, " table %lu + buckets %lu + entries %lu\n", + Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))); @@ -8318,33 +8320,33 @@ EvalStatsCmd( * Breakdown of current ByteCode space requirements. */ - fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); - fprintf(stdout, " Bytes Pct of Avg per\n"); - fprintf(stdout, " total ByteCode\n"); - fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n"); + Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n"); + Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n"); + Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n", statsPtr->currentByteCodeBytes, statsPtr->currentByteCodeBytes / numCurrentByteCodes); - fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", currentHeaderBytes, Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), currentHeaderBytes / numCurrentByteCodes); - fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", statsPtr->currentInstBytes, Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), statsPtr->currentInstBytes / numCurrentByteCodes); - fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", statsPtr->currentLitBytes, Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), statsPtr->currentLitBytes / numCurrentByteCodes); - fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", statsPtr->currentExceptBytes, Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), statsPtr->currentExceptBytes / numCurrentByteCodes); - fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", statsPtr->currentAuxBytes, Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), statsPtr->currentAuxBytes / numCurrentByteCodes); - fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", statsPtr->currentCmdMapBytes, Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); @@ -8353,8 +8355,8 @@ EvalStatsCmd( * Detailed literal statistics. */ - fprintf(stdout, "\nLiteral string sizes:\n"); - fprintf(stdout, " Up to length Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to length Percentage\n"); maxSizeDecade = 0; for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { @@ -8366,12 +8368,12 @@ EvalStatsCmd( for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); - fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); ckfree((char *) litTableStats); @@ -8379,8 +8381,8 @@ EvalStatsCmd( * Source and ByteCode size distributions. */ - fprintf(stdout, "\nSource sizes:\n"); - fprintf(stdout, " Up to size Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->srcCount[i] > 0) { @@ -8398,12 +8400,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode sizes:\n"); - fprintf(stdout, " Up to size Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->byteCodeCount[i] > 0) { @@ -8421,12 +8423,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); - fprintf(stdout, " Up to ms Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->lifetimeCount[i] > 0) { @@ -8444,7 +8446,7 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - fprintf(stdout, " %12.3f %8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %12.3f %8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } @@ -8452,28 +8454,46 @@ EvalStatsCmd( * Instruction counts. */ - fprintf(stdout, "\nInstruction counts:\n"); + Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s %8ld %6.1f%%\n", - tclInstructionTable[i].name, - statsPtr->instructionCount[i], + Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", + tclInstructionTable[i].name, statsPtr->instructionCount[i]); + if (statsPtr->instructionCount[i]) { + Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", Percent(statsPtr->instructionCount[i], numInstructions)); - } - } - - fprintf(stdout, "\nInstructions NEVER executed:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s\n", tclInstructionTable[i].name); + } else { + Tcl_AppendPrintfToObj(objPtr, "0\n"); } } #ifdef TCL_MEM_DEBUG - fprintf(stdout, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(stdout); + Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif - fprintf(stdout, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + + if (objc == 1) { + Tcl_SetObjResult(interp, objPtr); + } else { + Tcl_Channel outChan; + char *str = Tcl_GetStringFromObj(objv[1], &length); + + if (length) { + if (strcmp(str, "stdout") == 0) { + outChan = Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(str, "stderr") == 0) { + outChan = Tcl_GetStdChannel(TCL_STDERR); + } else { + outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664); + } + } else { + outChan = Tcl_GetStdChannel(TCL_STDOUT); + } + if (outChan != NULL) { + Tcl_WriteObj(outChan, objPtr); + } + } + Tcl_DecrRefCount(objPtr); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 1ca3a1b..ad35bf8 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.121.2.4 2010/02/07 22:16:54 nijtmans Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.121.2.5 2010/10/02 00:29:42 hobbs Exp $ library tcl @@ -82,7 +82,7 @@ declare 12 generic { # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 generic { - void TclDumpMemoryInfo(FILE *outFile) + int TclDumpMemoryInfo(ClientData clientData, int flags) } # Removed in 8.1: # declare 15 generic { diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8028b41..5596952 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.112.2.3 2010/07/02 20:49:47 nijtmans Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.112.2.4 2010/10/02 00:29:42 hobbs Exp $ */ #ifndef _TCLINTDECLS @@ -121,7 +121,7 @@ EXTERN void TclDeleteVars(Interp *iPtr, #ifndef TclDumpMemoryInfo_TCL_DECLARED #define TclDumpMemoryInfo_TCL_DECLARED /* 14 */ -EXTERN void TclDumpMemoryInfo(FILE *outFile); +EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags); #endif /* Slot 15 is reserved */ #ifndef TclExprFloatError_TCL_DECLARED @@ -1055,7 +1055,7 @@ typedef struct TclIntStubs { void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void *reserved13; - void (*tclDumpMemoryInfo) (FILE *outFile); /* 14 */ + int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ void *reserved15; void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */ void *reserved17; |