summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCkalloc.c54
-rw-r--r--generic/tclExecute.c193
-rw-r--r--generic/tclInt.decls4
-rw-r--r--generic/tclIntDecls.h6
4 files changed, 144 insertions, 113 deletions
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 70aead9..8ffdda1 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.38 2010/02/25 22:20:10 nijtmans Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.39 2010/10/02 00:23:44 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) 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) 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;
}
@@ -1247,10 +1257,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 ade67b6..606cca2 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,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.502 2010/09/28 15:22:54 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.503 2010/10/02 00:23:44 hobbs Exp $
*/
#include "tclInt.h"
@@ -2077,7 +2077,6 @@ TEBCresume(
NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn);
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
-
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
iPtr->flags |= ERR_ALREADY_LOGGED;
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
@@ -8338,9 +8337,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) {
@@ -8371,65 +8374,65 @@ EvalStatsCmd(
* Summary statistics, total and current source and ByteCode sizes.
*/
- fprintf(stdout, "\n----------------------------------------------------------------\n");
- fprintf(stdout,
- "Compilation and execution statistics for interpreter 0x%p\n",
+ Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
+ Tcl_AppendPrintfToObj(objPtr,
+ "Compilation and execution statistics for interpreter %#lx\n",
iPtr);
- fprintf(stdout, "\nNumber ByteCodes executed\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
statsPtr->numExecutions);
- fprintf(stdout, "Number ByteCodes compiled\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n",
statsPtr->numCompilations);
- fprintf(stdout, " Mean executions/compile\t%.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
- fprintf(stdout, "\nInstructions executed\t\t%.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
numInstructions);
- fprintf(stdout, " Mean inst/compile\t\t%.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n",
numInstructions / statsPtr->numCompilations);
- fprintf(stdout, " Mean inst/execution\t\t%.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
numInstructions / statsPtr->numExecutions);
- fprintf(stdout, "\nTotal ByteCodes\t\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n",
statsPtr->numCompilations);
- fprintf(stdout, " Source bytes\t\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->totalSrcBytes);
- fprintf(stdout, " Code bytes\t\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
totalCodeBytes);
- fprintf(stdout, " ByteCode bytes\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->totalByteCodeBytes);
- fprintf(stdout, " Literal bytes\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.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\t\t%.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
totalCodeBytes / statsPtr->numCompilations);
- fprintf(stdout, " Mean code/source\t\t%.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
- fprintf(stdout, "\nCurrent (active) ByteCodes\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
numCurrentByteCodes);
- fprintf(stdout, " Source bytes\t\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->currentSrcBytes);
- fprintf(stdout, " Code bytes\t\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
currentCodeBytes);
- fprintf(stdout, " ByteCode bytes\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->currentByteCodeBytes);
- fprintf(stdout, " Literal bytes\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.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\t\t%.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
- fprintf(stdout, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
@@ -8441,18 +8444,18 @@ EvalStatsCmd(
*/
numSharedMultX = 0;
- fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
- fprintf(stdout, " Object had refcount <=1 (not shared)\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
+ Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
- fprintf(stdout, " refcount ==%d\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
- fprintf(stdout, " refcount >=%d\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
- fprintf(stdout, " Total shared objects\t\t\t%d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n",
numSharedMultX);
/*
@@ -8489,48 +8492,48 @@ EvalStatsCmd(
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
- fprintf(stdout, "\nTotal objects (all interps)\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
tclObjsAlloced);
- fprintf(stdout, "Current objects\t\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
(tclObjsAlloced - tclObjsFreed));
- fprintf(stdout, "Total literal objects\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n",
statsPtr->numLiteralsCreated);
- fprintf(stdout, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
- fprintf(stdout, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, globalTablePtr->numEntries));
- fprintf(stdout, " Literals reused > 1x\t\t%d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n",
numSharedMultX);
- fprintf(stdout, " Mean reference count\t\t%.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
- fprintf(stdout, " Mean len, str reused >1x \t%.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n",
(numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
- fprintf(stdout, " Mean len, str used 1x\t\t%.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n",
(numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
- fprintf(stdout, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n",
sharingBytesSaved,
Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));
- fprintf(stdout, " Bytes with sharing\t\t%.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.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\t\t%.6g = objects %.6g + strings %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
- fprintf(stdout, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
- fprintf(stdout, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%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)));
@@ -8539,33 +8542,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);
@@ -8574,8 +8577,8 @@ EvalStatsCmd(
* Detailed literal statistics.
*/
- fprintf(stdout, "\nLiteral string sizes:\n");
- fprintf(stdout, "\t Up to length\t\tPercentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
for (i = 31; i >= 0; i--) {
if (statsPtr->literalCount[i] > 0) {
@@ -8587,12 +8590,12 @@ EvalStatsCmd(
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
- fprintf(stdout, "\t%10d\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%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);
@@ -8600,8 +8603,8 @@ EvalStatsCmd(
* Source and ByteCode size distributions.
*/
- fprintf(stdout, "\nSource sizes:\n");
- fprintf(stdout, "\t Up to size\t\tPercentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
@@ -8619,12 +8622,12 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
- fprintf(stdout, "\t%10d\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
- fprintf(stdout, "\nByteCode sizes:\n");
- fprintf(stdout, "\t Up to size\t\tPercentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
@@ -8642,12 +8645,12 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
- fprintf(stdout, "\t%10d\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
- fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
- fprintf(stdout, "\t Up to ms\t\tPercentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
@@ -8665,7 +8668,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->lifetimeCount[i];
- fprintf(stdout, "\t%12.3f\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n",
decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
}
@@ -8673,28 +8676,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 fe08bd5..1a114f1 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.149 2010/09/27 19:42:38 msofer Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.150 2010/10/02 00:23:44 hobbs Exp $
library tcl
@@ -83,7 +83,7 @@ declare 12 {
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
- void TclDumpMemoryInfo(FILE *outFile)
+ int TclDumpMemoryInfo(ClientData clientData, int flags)
}
# Removed in 8.1:
# declare 15 {
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index bd4cdda..259229b 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.143 2010/09/27 19:42:38 msofer Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.144 2010/10/02 00:23:45 hobbs Exp $
*/
#ifndef _TCLINTDECLS
@@ -92,7 +92,7 @@ EXTERN void TclDeleteVars(Interp *iPtr,
TclVarHashTable *tablePtr);
/* Slot 13 is reserved */
/* 14 */
-EXTERN void TclDumpMemoryInfo(FILE *outFile);
+EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags);
/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError(Tcl_Interp *interp, double value);
@@ -615,7 +615,7 @@ typedef struct TclIntStubs {
void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */
void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */
void (*reserved13)(void);
- void (*tclDumpMemoryInfo) (FILE *outFile); /* 14 */
+ int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */
void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
void (*reserved17)(void);