summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCkalloc.c54
-rw-r--r--generic/tclExecute.c204
-rw-r--r--generic/tclInt.decls4
-rw-r--r--generic/tclIntDecls.h6
4 files changed, 149 insertions, 119 deletions
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;
generated by cgit v0.12 at 2024-08-20 12:22:19 (GMT)