← Back to branch summary

~ubuntu-branches/ubuntu/raring/tcl8.5/raring

« back to all changes in this revision

Viewing changes to generic/tclExecute.c

  • Committer: Bazaar Package Importer
  • Author(s): Sergei Golovan
  • Date: 2011-06-26 11:47:14 UTC
  • mfrom: (11.2.2 sid)
  • Revision ID: james.westby@ubuntu.com-20110626114714-mdw95b180f00mm08
Tags: 8.5.10-1
http://bugs.debian.org/617628
* New upstream release (closes: #617628).
* Changed tclsh8.5 alternative priority to 850 to make it higher than
  tclsh8.4 one.
* Bumped standards version to 3.9.2.

Show diffs side-by-side

added added

removed removed

Lines of Context:
generic/tclExecute.c
12
12
 *
13
13
 * See the file "license.terms" for information on usage and redistribution of
14
14
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
15
 
 *
16
 
 * RCS: @(#) $Id: tclExecute.c,v 1.369.2.15 2010/09/01 19:42:39 andreas_kupries Exp $
17
15
 */
18
16
 
19
17
#include "tclInt.h"
921
919
 
922
920
    /*
923
921
     * Reset move to hold the number of words to be moved to new stack (if
924
 
     * any) and growth to hold the complete stack requirements: add the marker
925
 
     * and maximal possible offset. 
 
922
     * any) and growth to hold the complete stack requirements: add one for
 
923
     * the marker, (WALLOCALIGN-1) for the maximal possible offset.
926
924
     */
927
925
 
928
926
    if (move) {
929
927
        moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
930
928
    }
931
 
    needed = growth + moveWords + WALLOCALIGN - 1;
 
929
    needed = growth + moveWords + WALLOCALIGN;
932
930
 
933
931
    /*
934
932
     * Check if there is enough room in the next stack (if there is one, it
1475
1473
         *     information.
1476
1474
         */
1477
1475
 
1478
 
        {
 
1476
        if (invoker) {
1479
1477
            Tcl_HashEntry *hePtr =
1480
1478
                    Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
1481
1479
 
1482
1480
            if (hePtr) {
1483
1481
                ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
1484
1482
                int redo = 0;
1485
 
 
1486
 
                if (invoker) {
1487
 
                    CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
1488
 
                    *ctxPtr = *invoker;
1489
 
 
1490
 
                    if (invoker->type == TCL_LOCATION_BC) {
1491
 
                        /*
1492
 
                         * Note: Type BC => ctx.data.eval.path    is not used.
1493
 
                         *                  ctx.data.tebc.codePtr used instead
1494
 
                         */
1495
 
 
1496
 
                        TclGetSrcInfoForPc(ctxPtr);
1497
 
                        if (ctxPtr->type == TCL_LOCATION_SOURCE) {
1498
 
                            /*
1499
 
                             * The reference made by 'TclGetSrcInfoForPc' is
1500
 
                             * dead.
1501
 
                             */
1502
 
 
1503
 
                            Tcl_DecrRefCount(ctxPtr->data.eval.path);
1504
 
                            ctxPtr->data.eval.path = NULL;
1505
 
                        }
1506
 
                    }
1507
 
 
1508
 
                    if (word < ctxPtr->nline) {
1509
 
                        /*
1510
 
                         * Note: We do not care if the line[word] is -1. This
1511
 
                         * is a difference and requires a recompile (location
1512
 
                         * changed from absolute to relative, literal is used
1513
 
                         * fixed and through variable)
1514
 
                         *
1515
 
                         * Example:
1516
 
                         * test info-32.0 using literal of info-24.8
1517
 
                         *     (dict with ... vs           set body ...).
1518
 
                         */
1519
 
 
1520
 
                        redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
1521
 
                                    && (eclPtr->start != ctxPtr->line[word]))
1522
 
                                || ((eclPtr->type == TCL_LOCATION_BC)
1523
 
                                    && (ctxPtr->type == TCL_LOCATION_SOURCE));
1524
 
                    }
1525
 
 
1526
 
                    TclStackFree(interp, ctxPtr);
1527
 
                }
1528
 
 
 
1483
                CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
 
1484
 
 
1485
                *ctxPtr = *invoker;
 
1486
 
 
1487
                if (invoker->type == TCL_LOCATION_BC) {
 
1488
                    /*
 
1489
                     * Note: Type BC => ctx.data.eval.path    is not used.
 
1490
                     *              ctx.data.tebc.codePtr used instead
 
1491
                     */
 
1492
                    
 
1493
                    TclGetSrcInfoForPc(ctxPtr);
 
1494
                    if (ctxPtr->type == TCL_LOCATION_SOURCE) {
 
1495
                        /*
 
1496
                         * The reference made by 'TclGetSrcInfoForPc' is
 
1497
                         * dead.
 
1498
                         */
 
1499
                        
 
1500
                        Tcl_DecrRefCount(ctxPtr->data.eval.path);
 
1501
                        ctxPtr->data.eval.path = NULL;
 
1502
                    }
 
1503
                }
 
1504
                
 
1505
                if (word < ctxPtr->nline) {
 
1506
                    /*
 
1507
                     * Note: We do not care if the line[word] is -1. This
 
1508
                     * is a difference and requires a recompile (location
 
1509
                     * changed from absolute to relative, literal is used
 
1510
                     * fixed and through variable)
 
1511
                     *
 
1512
                     * Example:
 
1513
                     * test info-32.0 using literal of info-24.8
 
1514
                     *     (dict with ... vs           set body ...).
 
1515
                     */
 
1516
                    
 
1517
                    redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
 
1518
                            && (eclPtr->start != ctxPtr->line[word]))
 
1519
                        || ((eclPtr->type == TCL_LOCATION_BC)
 
1520
                                && (ctxPtr->type == TCL_LOCATION_SOURCE));
 
1521
                }
 
1522
                
 
1523
                TclStackFree(interp, ctxPtr);
 
1524
            
1529
1525
                if (redo) {
1530
1526
                    goto recompileObj;
1531
1527
                }
1799
1795
 
1800
1796
    catchTop = initCatchTop = (ptrdiff_t *) (
1801
1797
        GrowEvaluationStack(iPtr->execEnvPtr,
1802
 
                codePtr->maxExceptDepth + sizeof(CmdFrame) +
1803
 
                    codePtr->maxStackDepth, 0) - 1);
 
1798
                (sizeof(CmdFrame) + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *) +
 
1799
                codePtr->maxExceptDepth + codePtr->maxStackDepth, 0) - 1);
1804
1800
    bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
1805
1801
    tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1;
1806
1802
    esPtr = iPtr->execEnvPtr->execStackPtr;
1825
1821
#ifdef TCL_COMPILE_DEBUG
1826
1822
    if (tclTraceExec >= 2) {
1827
1823
        PrintByteCodeInfo(codePtr);
1828
 
        fprintf(stdout, "  Starting stack top=%d\n", CURR_DEPTH);
 
1824
        fprintf(stdout, "  Starting stack top=%d\n", (int) CURR_DEPTH);
1829
1825
        fflush(stdout);
1830
1826
    }
1831
1827
#endif
2412
2408
 
2413
2409
            bcFramePtr->data.tebc.pc = (char *) pc;
2414
2410
            iPtr->cmdFramePtr = bcFramePtr;
2415
 
            TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
2416
 
                               codePtr, bcFramePtr,
2417
 
                               pc - codePtr->codeStart);
 
2411
            if (iPtr->flags & INTERP_DEBUG_FRAME) {
 
2412
                TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
 
2413
                        codePtr, bcFramePtr, pc - codePtr->codeStart);
 
2414
            }
2418
2415
            DECACHE_STACK_INFO();
2419
2416
            result = TclEvalObjvInternal(interp, objc, objv,
2420
2417
                    /* call from TEBC */(char *) -1, -1, 0);
2421
2418
            CACHE_STACK_INFO();
2422
 
            TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc,
2423
 
                                 codePtr,
2424
 
                                 pc - codePtr->codeStart);
 
2419
            if (iPtr->flags & INTERP_DEBUG_FRAME) {
 
2420
                TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
 
2421
                        codePtr, pc - codePtr->codeStart);
 
2422
            }
2425
2423
            iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
2426
2424
 
2427
2425
            if (result == TCL_OK) {
3693
3691
        if (result != TCL_OK) {
3694
3692
            TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
3695
3693
                    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
 
3694
            DECACHE_STACK_INFO();
3696
3695
            IllegalExprOperandType(interp, pc, valuePtr);
 
3696
            CACHE_STACK_INFO();
3697
3697
            goto checkForCatch;
3698
3698
        }
3699
3699
 
3701
3701
        if (result != TCL_OK) {
3702
3702
            TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
3703
3703
                    (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
 
3704
            DECACHE_STACK_INFO();
3704
3705
            IllegalExprOperandType(interp, pc, value2Ptr);
 
3706
            CACHE_STACK_INFO();
3705
3707
            goto checkForCatch;
3706
3708
        }
3707
3709
 
4809
4811
            TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
4810
4812
                    O2S(value2Ptr), (valuePtr->typePtr?
4811
4813
                    valuePtr->typePtr->name : "null")));
 
4814
            DECACHE_STACK_INFO();
4812
4815
            IllegalExprOperandType(interp, pc, valuePtr);
 
4816
            CACHE_STACK_INFO();
4813
4817
            goto checkForCatch;
4814
4818
        }
4815
4819
 
4820
4824
            TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
4821
4825
                    O2S(value2Ptr), (value2Ptr->typePtr?
4822
4826
                    value2Ptr->typePtr->name : "null")));
 
4827
            DECACHE_STACK_INFO();
4823
4828
            IllegalExprOperandType(interp, pc, value2Ptr);
 
4829
            CACHE_STACK_INFO();
4824
4830
            goto checkForCatch;
4825
4831
        }
4826
4832
 
5268
5274
            TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
5269
5275
                    O2S(value2Ptr), (valuePtr->typePtr?
5270
5276
                    valuePtr->typePtr->name : "null")));
 
5277
            DECACHE_STACK_INFO();
5271
5278
            IllegalExprOperandType(interp, pc, valuePtr);
 
5279
            CACHE_STACK_INFO();
5272
5280
            goto checkForCatch;
5273
5281
        }
5274
5282
        result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
5278
5286
            TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
5279
5287
                    O2S(value2Ptr), (value2Ptr->typePtr?
5280
5288
                    value2Ptr->typePtr->name : "null")));
 
5289
            DECACHE_STACK_INFO();
5281
5290
            IllegalExprOperandType(interp, pc, value2Ptr);
 
5291
            CACHE_STACK_INFO();
5282
5292
            goto checkForCatch;
5283
5293
        }
5284
5294
 
5516
5526
            TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
5517
5527
                    O2S(value2Ptr), O2S(valuePtr),
5518
5528
                    (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
 
5529
            DECACHE_STACK_INFO();
5519
5530
            IllegalExprOperandType(interp, pc, valuePtr);
 
5531
            CACHE_STACK_INFO();
5520
5532
            goto checkForCatch;
5521
5533
        }
5522
5534
 
5540
5552
            TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
5541
5553
                    O2S(value2Ptr), O2S(valuePtr),
5542
5554
                    (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
 
5555
            DECACHE_STACK_INFO();
5543
5556
            IllegalExprOperandType(interp, pc, value2Ptr);
 
5557
            CACHE_STACK_INFO();
5544
5558
            goto checkForCatch;
5545
5559
        }
5546
5560
 
5611
5625
            if (TclIsNaN(dResult)) {
5612
5626
                TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
5613
5627
                        O2S(valuePtr), O2S(value2Ptr)));
 
5628
                DECACHE_STACK_INFO();
5614
5629
                TclExprFloatError(interp, dResult);
 
5630
                CACHE_STACK_INFO();
5615
5631
                result = TCL_ERROR;
5616
5632
                goto checkForCatch;
5617
5633
            }
6265
6281
        if (result != TCL_OK) {
6266
6282
            TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
6267
6283
                    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
 
6284
            DECACHE_STACK_INFO();
6268
6285
            IllegalExprOperandType(interp, pc, valuePtr);
 
6286
            CACHE_STACK_INFO();
6269
6287
            goto checkForCatch;
6270
6288
        }
6271
6289
        /* TODO: Consider peephole opt. */
6289
6307
            result = TCL_ERROR;
6290
6308
            TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6291
6309
                    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
 
6310
            DECACHE_STACK_INFO();
6292
6311
            IllegalExprOperandType(interp, pc, valuePtr);
 
6312
            CACHE_STACK_INFO();
6293
6313
            goto checkForCatch;
6294
6314
        }
6295
6315
        if (type == TCL_NUMBER_LONG) {
6340
6360
            result = TCL_ERROR;
6341
6361
            TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6342
6362
                    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
 
6363
            DECACHE_STACK_INFO();
6343
6364
            IllegalExprOperandType(interp, pc, valuePtr);
 
6365
            CACHE_STACK_INFO();
6344
6366
            goto checkForCatch;
6345
6367
        }
6346
6368
        switch (type) {
6439
6461
                result = TCL_ERROR;
6440
6462
                TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6441
6463
                        (valuePtr->typePtr? valuePtr->typePtr->name:"null")));
 
6464
                DECACHE_STACK_INFO();
6442
6465
                IllegalExprOperandType(interp, pc, valuePtr);
 
6466
                CACHE_STACK_INFO();
6443
6467
                goto checkForCatch;
6444
6468
            } else {
6445
6469
                /* ... TryConvertToNumeric($NonNumeric) is acceptable */
6457
6481
 
6458
6482
                TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6459
6483
                        (valuePtr->typePtr? valuePtr->typePtr->name:"null")));
 
6484
                DECACHE_STACK_INFO();
6460
6485
                IllegalExprOperandType(interp, pc, valuePtr);
 
6486
                CACHE_STACK_INFO();
6461
6487
            } else {
6462
6488
                /*
6463
6489
                 * Numeric conversion of NaN -> error.
6465
6491
 
6466
6492
                TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
6467
6493
                        O2S(objResultPtr)));
 
6494
                DECACHE_STACK_INFO();
6468
6495
                TclExprFloatError(interp, *((const double *)ptr));
 
6496
                CACHE_STACK_INFO();
6469
6497
            }
6470
6498
            goto checkForCatch;
6471
6499
        }
6703
6731
 
6704
6732
        *(++catchTop) = CURR_DEPTH;
6705
6733
        TRACE(("%u => catchTop=%d, stackTop=%d\n",
6706
 
                TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1),
 
6734
                TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
6707
6735
                (int) CURR_DEPTH));
6708
6736
        NEXT_INST_F(5, 0, 0);
6709
6737
 
6710
6738
    case INST_END_CATCH:
6711
6739
        catchTop--;
 
6740
        DECACHE_STACK_INFO();
6712
6741
        Tcl_ResetResult(interp);
 
6742
        CACHE_STACK_INFO();
6713
6743
        result = TCL_OK;
6714
 
        TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1)));
 
6744
        TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
6715
6745
        NEXT_INST_F(1, 0, 0);
6716
6746
 
6717
6747
    case INST_PUSH_RESULT:
6773
6803
                    "%u => ERROR reading leaf dictionary key \"%s\": ",
6774
6804
                    opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
6775
6805
        } else {
 
6806
            DECACHE_STACK_INFO();
6776
6807
            Tcl_ResetResult(interp);
6777
6808
            Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
6778
6809
                    "\" not known in dictionary", NULL);
 
6810
            CACHE_STACK_INFO();
6779
6811
            TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
6780
6812
            result = TCL_ERROR;
6781
6813
        }
7246
7278
     */
7247
7279
 
7248
7280
 divideByZero:
 
7281
    DECACHE_STACK_INFO();
7249
7282
    Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
7250
7283
    Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
 
7284
    CACHE_STACK_INFO();
7251
7285
 
7252
7286
    result = TCL_ERROR;
7253
7287
    goto checkForCatch;
7258
7292
     */
7259
7293
 
7260
7294
 exponOfZero:
 
7295
    DECACHE_STACK_INFO();
7261
7296
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
7262
7297
            "exponentiation of zero by negative power", -1));
7263
7298
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
7264
7299
            "exponentiation of zero by negative power", NULL);
 
7300
    CACHE_STACK_INFO();
7265
7301
    result = TCL_ERROR;
7266
7302
    goto checkForCatch;
7267
7303
 
7452
7488
        if (traceInstructions) {
7453
7489
            fprintf(stdout, "  ... found catch at %d, catchTop=%d, "
7454
7490
                    "unwound to %ld, new pc %u\n",
7455
 
                    rangePtr->codeOffset, catchTop - initCatchTop - 1,
 
7491
                    rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1),
7456
7492
                    (long) *catchTop, (unsigned) rangePtr->catchOffset);
7457
7493
        }
7458
7494
#endif
8117
8153
    int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
8118
8154
    char *litTableStats;
8119
8155
    LiteralEntry *entryPtr;
 
8156
    Tcl_Obj *objPtr;
8120
8157
 
8121
8158
#define Percent(a,b) ((a) * 100.0 / (b))
8122
8159
 
 
8160
    objPtr = Tcl_NewObj();
 
8161
    Tcl_IncrRefCount(objPtr);
 
8162
 
8123
8163
    numInstructions = 0.0;
8124
8164
    for (i = 0;  i < 256;  i++) {
8125
8165
        if (statsPtr->instructionCount[i] != 0) {
8150
8190
     * Summary statistics, total and current source and ByteCode sizes.
8151
8191
     */
8152
8192
 
8153
 
    fprintf(stdout, "\n----------------------------------------------------------------\n");
8154
 
    fprintf(stdout,
8155
 
            "Compilation and execution statistics for interpreter 0x%p\n",
 
8193
    Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
 
8194
    Tcl_AppendPrintfToObj(objPtr,
 
8195
            "Compilation and execution statistics for interpreter %#lx\n",
8156
8196
            iPtr);
8157
8197
 
8158
 
    fprintf(stdout, "\nNumber ByteCodes executed        %ld\n",
 
8198
    Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed  %ld\n",
8159
8199
            statsPtr->numExecutions);
8160
 
    fprintf(stdout, "Number ByteCodes compiled  %ld\n",
 
8200
    Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled    %ld\n",
8161
8201
            statsPtr->numCompilations);
8162
 
    fprintf(stdout, "  Mean executions/compile  %.1f\n",
 
8202
    Tcl_AppendPrintfToObj(objPtr, "  Mean executions/compile    %.1f\n",
8163
8203
            statsPtr->numExecutions / (float)statsPtr->numCompilations);
8164
8204
 
8165
 
    fprintf(stdout, "\nInstructions executed            %.0f\n",
 
8205
    Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed              %.0f\n",
8166
8206
            numInstructions);
8167
 
    fprintf(stdout, "  Mean inst/compile                %.0f\n",
 
8207
    Tcl_AppendPrintfToObj(objPtr, "  Mean inst/compile          %.0f\n",
8168
8208
            numInstructions / statsPtr->numCompilations);
8169
 
    fprintf(stdout, "  Mean inst/execution              %.0f\n",
 
8209
    Tcl_AppendPrintfToObj(objPtr, "  Mean inst/execution                %.0f\n",
8170
8210
            numInstructions / statsPtr->numExecutions);
8171
8211
 
8172
 
    fprintf(stdout, "\nTotal ByteCodes                  %ld\n",
 
8212
    Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes                    %ld\n",
8173
8213
            statsPtr->numCompilations);
8174
 
    fprintf(stdout, "  Source bytes                     %.6g\n",
 
8214
    Tcl_AppendPrintfToObj(objPtr, "  Source bytes                       %.6g\n",
8175
8215
            statsPtr->totalSrcBytes);
8176
 
    fprintf(stdout, "  Code bytes                       %.6g\n",
 
8216
    Tcl_AppendPrintfToObj(objPtr, "  Code bytes                 %.6g\n",
8177
8217
            totalCodeBytes);
8178
 
    fprintf(stdout, "    ByteCode bytes         %.6g\n",
 
8218
    Tcl_AppendPrintfToObj(objPtr, "    ByteCode bytes           %.6g\n",
8179
8219
            statsPtr->totalByteCodeBytes);
8180
 
    fprintf(stdout, "    Literal bytes          %.6g\n",
 
8220
    Tcl_AppendPrintfToObj(objPtr, "    Literal bytes            %.6g\n",
8181
8221
            totalLiteralBytes);
8182
 
    fprintf(stdout, "      table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
 
8222
    Tcl_AppendPrintfToObj(objPtr, "      table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
8183
8223
            (unsigned long) sizeof(LiteralTable),
8184
8224
            (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8185
8225
            (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
8186
8226
            (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
8187
8227
            statsPtr->totalLitStringBytes);
8188
 
    fprintf(stdout, "  Mean code/compile                %.1f\n",
 
8228
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/compile          %.1f\n",
8189
8229
            totalCodeBytes / statsPtr->numCompilations);
8190
 
    fprintf(stdout, "  Mean code/source         %.1f\n",
 
8230
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/source           %.1f\n",
8191
8231
            totalCodeBytes / statsPtr->totalSrcBytes);
8192
8232
 
8193
 
    fprintf(stdout, "\nCurrent (active) ByteCodes       %ld\n",
 
8233
    Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n",
8194
8234
            numCurrentByteCodes);
8195
 
    fprintf(stdout, "  Source bytes                     %.6g\n",
 
8235
    Tcl_AppendPrintfToObj(objPtr, "  Source bytes                       %.6g\n",
8196
8236
            statsPtr->currentSrcBytes);
8197
 
    fprintf(stdout, "  Code bytes                       %.6g\n",
 
8237
    Tcl_AppendPrintfToObj(objPtr, "  Code bytes                 %.6g\n",
8198
8238
            currentCodeBytes);
8199
 
    fprintf(stdout, "    ByteCode bytes         %.6g\n",
 
8239
    Tcl_AppendPrintfToObj(objPtr, "    ByteCode bytes           %.6g\n",
8200
8240
            statsPtr->currentByteCodeBytes);
8201
 
    fprintf(stdout, "    Literal bytes          %.6g\n",
 
8241
    Tcl_AppendPrintfToObj(objPtr, "    Literal bytes            %.6g\n",
8202
8242
            currentLiteralBytes);
8203
 
    fprintf(stdout, "      table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
 
8243
    Tcl_AppendPrintfToObj(objPtr, "      table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
8204
8244
            (unsigned long) sizeof(LiteralTable),
8205
8245
            (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8206
8246
            (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
8207
8247
            (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
8208
8248
            statsPtr->currentLitStringBytes);
8209
 
    fprintf(stdout, "  Mean code/source         %.1f\n",
 
8249
    Tcl_AppendPrintfToObj(objPtr, "  Mean code/source           %.1f\n",
8210
8250
            currentCodeBytes / statsPtr->currentSrcBytes);
8211
 
    fprintf(stdout, "  Code + source bytes              %.6g (%0.1f mean code/src)\n",
 
8251
    Tcl_AppendPrintfToObj(objPtr, "  Code + source bytes                %.6g (%0.1f mean code/src)\n",
8212
8252
            (currentCodeBytes + statsPtr->currentSrcBytes),
8213
8253
            (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
8214
8254
 
8220
8260
     */
8221
8261
 
8222
8262
    numSharedMultX = 0;
8223
 
    fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
8224
 
    fprintf(stdout, "  Object had refcount <=1 (not shared)     %ld\n",
 
8263
    Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
 
8264
    Tcl_AppendPrintfToObj(objPtr, "  Object had refcount <=1 (not shared)       %ld\n",
8225
8265
            tclObjsShared[1]);
8226
8266
    for (i = 2;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {
8227
 
        fprintf(stdout, "  refcount ==%d                %ld\n",
 
8267
        Tcl_AppendPrintfToObj(objPtr, "  refcount ==%d          %ld\n",
8228
8268
                i, tclObjsShared[i]);
8229
8269
        numSharedMultX += tclObjsShared[i];
8230
8270
    }
8231
 
    fprintf(stdout, "  refcount >=%d            %ld\n",
 
8271
    Tcl_AppendPrintfToObj(objPtr, "  refcount >=%d              %ld\n",
8232
8272
            i, tclObjsShared[0]);
8233
8273
    numSharedMultX += tclObjsShared[0];
8234
 
    fprintf(stdout, "  Total shared objects                     %d\n",
 
8274
    Tcl_AppendPrintfToObj(objPtr, "  Total shared objects                       %d\n",
8235
8275
            numSharedMultX);
8236
8276
 
8237
8277
    /*
8268
8308
    sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
8269
8309
            - currentLiteralBytes;
8270
8310
 
8271
 
    fprintf(stdout, "\nTotal objects (all interps)      %ld\n",
 
8311
    Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)        %ld\n",
8272
8312
            tclObjsAlloced);
8273
 
    fprintf(stdout, "Current objects                    %ld\n",
 
8313
    Tcl_AppendPrintfToObj(objPtr, "Current objects                      %ld\n",
8274
8314
            (tclObjsAlloced - tclObjsFreed));
8275
 
    fprintf(stdout, "Total literal objects              %ld\n",
 
8315
    Tcl_AppendPrintfToObj(objPtr, "Total literal objects                %ld\n",
8276
8316
            statsPtr->numLiteralsCreated);
8277
8317
 
8278
 
    fprintf(stdout, "\nCurrent literal objects          %d (%0.1f%% of current objects)\n",
 
8318
    Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects            %d (%0.1f%% of current objects)\n",
8279
8319
            globalTablePtr->numEntries,
8280
8320
            Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
8281
 
    fprintf(stdout, "  ByteCode literals                %ld (%0.1f%% of current literals)\n",
 
8321
    Tcl_AppendPrintfToObj(objPtr, "  ByteCode literals          %ld (%0.1f%% of current literals)\n",
8282
8322
            numByteCodeLits,
8283
8323
            Percent(numByteCodeLits, globalTablePtr->numEntries));
8284
 
    fprintf(stdout, "  Literals reused > 1x             %d\n",
 
8324
    Tcl_AppendPrintfToObj(objPtr, "  Literals reused > 1x               %d\n",
8285
8325
            numSharedMultX);
8286
 
    fprintf(stdout, "  Mean reference count             %.2f\n",
 
8326
    Tcl_AppendPrintfToObj(objPtr, "  Mean reference count               %.2f\n",
8287
8327
            ((double) refCountSum) / globalTablePtr->numEntries);
8288
 
    fprintf(stdout, "  Mean len, str reused >1x         %.2f\n",
 
8328
    Tcl_AppendPrintfToObj(objPtr, "  Mean len, str reused >1x   %.2f\n",
8289
8329
            (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
8290
 
    fprintf(stdout, "  Mean len, str used 1x            %.2f\n",
 
8330
    Tcl_AppendPrintfToObj(objPtr, "  Mean len, str used 1x              %.2f\n",
8291
8331
            (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
8292
 
    fprintf(stdout, "  Total sharing savings            %.6g (%0.1f%% of bytes if no sharing)\n",
 
8332
    Tcl_AppendPrintfToObj(objPtr, "  Total sharing savings              %.6g (%0.1f%% of bytes if no sharing)\n",
8293
8333
            sharingBytesSaved,
8294
8334
            Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));
8295
 
    fprintf(stdout, "    Bytes with sharing             %.6g\n",
 
8335
    Tcl_AppendPrintfToObj(objPtr, "    Bytes with sharing               %.6g\n",
8296
8336
            currentLiteralBytes);
8297
 
    fprintf(stdout, "      table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
 
8337
    Tcl_AppendPrintfToObj(objPtr, "      table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
8298
8338
            (unsigned long) sizeof(LiteralTable),
8299
8339
            (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8300
8340
            (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
8301
8341
            (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
8302
8342
            statsPtr->currentLitStringBytes);
8303
 
    fprintf(stdout, "    Bytes if no sharing            %.6g = objects %.6g + strings %.6g\n",
 
8343
    Tcl_AppendPrintfToObj(objPtr, "    Bytes if no sharing              %.6g = objects %.6g + strings %.6g\n",
8304
8344
            (objBytesIfUnshared + strBytesIfUnshared),
8305
8345
            objBytesIfUnshared, strBytesIfUnshared);
8306
 
    fprintf(stdout, "  String sharing savings   %.6g = unshared %.6g - shared %.6g\n",
 
8346
    Tcl_AppendPrintfToObj(objPtr, "  String sharing savings     %.6g = unshared %.6g - shared %.6g\n",
8307
8347
            (strBytesIfUnshared - statsPtr->currentLitStringBytes),
8308
8348
            strBytesIfUnshared, statsPtr->currentLitStringBytes);
8309
 
    fprintf(stdout, "  Literal mgmt overhead            %ld (%0.1f%% of bytes with sharing)\n",
 
8349
    Tcl_AppendPrintfToObj(objPtr, "  Literal mgmt overhead              %ld (%0.1f%% of bytes with sharing)\n",
8310
8350
            literalMgmtBytes,
8311
8351
            Percent(literalMgmtBytes, currentLiteralBytes));
8312
 
    fprintf(stdout, "    table %lu + buckets %lu + entries %lu\n",
 
8352
    Tcl_AppendPrintfToObj(objPtr, "    table %lu + buckets %lu + entries %lu\n",
8313
8353
            (unsigned long) sizeof(LiteralTable),
8314
8354
            (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8315
8355
            (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)));
8318
8358
     * Breakdown of current ByteCode space requirements.
8319
8359
     */
8320
8360
 
8321
 
    fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
8322
 
    fprintf(stdout, "                         Bytes      Pct of    Avg per\n");
8323
 
    fprintf(stdout, "                                     total    ByteCode\n");
8324
 
    fprintf(stdout, "Total             %12.6g     100.00%%   %8.1f\n",
 
8361
    Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n");
 
8362
    Tcl_AppendPrintfToObj(objPtr, "                         Bytes      Pct of    Avg per\n");
 
8363
    Tcl_AppendPrintfToObj(objPtr, "                                     total    ByteCode\n");
 
8364
    Tcl_AppendPrintfToObj(objPtr, "Total             %12.6g     100.00%%   %8.1f\n",
8325
8365
            statsPtr->currentByteCodeBytes,
8326
8366
            statsPtr->currentByteCodeBytes / numCurrentByteCodes);
8327
 
    fprintf(stdout, "Header            %12.6g   %8.1f%%   %8.1f\n",
 
8367
    Tcl_AppendPrintfToObj(objPtr, "Header            %12.6g   %8.1f%%   %8.1f\n",
8328
8368
            currentHeaderBytes,
8329
8369
            Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes),
8330
8370
            currentHeaderBytes / numCurrentByteCodes);
8331
 
    fprintf(stdout, "Instructions      %12.6g   %8.1f%%   %8.1f\n",
 
8371
    Tcl_AppendPrintfToObj(objPtr, "Instructions      %12.6g   %8.1f%%   %8.1f\n",
8332
8372
            statsPtr->currentInstBytes,
8333
8373
            Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes),
8334
8374
            statsPtr->currentInstBytes / numCurrentByteCodes);
8335
 
    fprintf(stdout, "Literal ptr array %12.6g   %8.1f%%   %8.1f\n",
 
8375
    Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g   %8.1f%%   %8.1f\n",
8336
8376
            statsPtr->currentLitBytes,
8337
8377
            Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes),
8338
8378
            statsPtr->currentLitBytes / numCurrentByteCodes);
8339
 
    fprintf(stdout, "Exception table   %12.6g   %8.1f%%   %8.1f\n",
 
8379
    Tcl_AppendPrintfToObj(objPtr, "Exception table   %12.6g   %8.1f%%   %8.1f\n",
8340
8380
            statsPtr->currentExceptBytes,
8341
8381
            Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes),
8342
8382
            statsPtr->currentExceptBytes / numCurrentByteCodes);
8343
 
    fprintf(stdout, "Auxiliary data    %12.6g   %8.1f%%   %8.1f\n",
 
8383
    Tcl_AppendPrintfToObj(objPtr, "Auxiliary data    %12.6g   %8.1f%%   %8.1f\n",
8344
8384
            statsPtr->currentAuxBytes,
8345
8385
            Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes),
8346
8386
            statsPtr->currentAuxBytes / numCurrentByteCodes);
8347
 
    fprintf(stdout, "Command map       %12.6g   %8.1f%%   %8.1f\n",
 
8387
    Tcl_AppendPrintfToObj(objPtr, "Command map       %12.6g   %8.1f%%   %8.1f\n",
8348
8388
            statsPtr->currentCmdMapBytes,
8349
8389
            Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes),
8350
8390
            statsPtr->currentCmdMapBytes / numCurrentByteCodes);
8353
8393
     * Detailed literal statistics.
8354
8394
     */
8355
8395
 
8356
 
    fprintf(stdout, "\nLiteral string sizes:\n");
8357
 
    fprintf(stdout, "    Up to length           Percentage\n");
 
8396
    Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
 
8397
    Tcl_AppendPrintfToObj(objPtr, "      Up to length           Percentage\n");
8358
8398
    maxSizeDecade = 0;
8359
8399
    for (i = 31;  i >= 0;  i--) {
8360
8400
        if (statsPtr->literalCount[i] > 0) {
8366
8406
    for (i = 0;  i <= maxSizeDecade;  i++) {
8367
8407
        decadeHigh = (1 << (i+1)) - 1;
8368
8408
        sum += statsPtr->literalCount[i];
8369
 
        fprintf(stdout, "       %10d            %8.0f%%\n",
 
8409
        Tcl_AppendPrintfToObj(objPtr, " %10d            %8.0f%%\n",
8370
8410
                decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
8371
8411
    }
8372
8412
 
8373
8413
    litTableStats = TclLiteralStats(globalTablePtr);
8374
 
    fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
 
8414
    Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
8375
8415
            litTableStats);
8376
8416
    ckfree((char *) litTableStats);
8377
8417
 
8379
8419
     * Source and ByteCode size distributions.
8380
8420
     */
8381
8421
 
8382
 
    fprintf(stdout, "\nSource sizes:\n");
8383
 
    fprintf(stdout, "    Up to size             Percentage\n");
 
8422
    Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
 
8423
    Tcl_AppendPrintfToObj(objPtr, "      Up to size             Percentage\n");
8384
8424
    minSizeDecade = maxSizeDecade = 0;
8385
8425
    for (i = 0;  i < 31;  i++) {
8386
8426
        if (statsPtr->srcCount[i] > 0) {
8398
8438
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
8399
8439
        decadeHigh = (1 << (i+1)) - 1;
8400
8440
        sum += statsPtr->srcCount[i];
8401
 
        fprintf(stdout, "       %10d            %8.0f%%\n",
 
8441
        Tcl_AppendPrintfToObj(objPtr, " %10d            %8.0f%%\n",
8402
8442
                decadeHigh, Percent(sum, statsPtr->numCompilations));
8403
8443
    }
8404
8444
 
8405
 
    fprintf(stdout, "\nByteCode sizes:\n");
8406
 
    fprintf(stdout, "    Up to size             Percentage\n");
 
8445
    Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
 
8446
    Tcl_AppendPrintfToObj(objPtr, "      Up to size             Percentage\n");
8407
8447
    minSizeDecade = maxSizeDecade = 0;
8408
8448
    for (i = 0;  i < 31;  i++) {
8409
8449
        if (statsPtr->byteCodeCount[i] > 0) {
8421
8461
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
8422
8462
        decadeHigh = (1 << (i+1)) - 1;
8423
8463
        sum += statsPtr->byteCodeCount[i];
8424
 
        fprintf(stdout, "       %10d            %8.0f%%\n",
 
8464
        Tcl_AppendPrintfToObj(objPtr, " %10d            %8.0f%%\n",
8425
8465
                decadeHigh, Percent(sum, statsPtr->numCompilations));
8426
8466
    }
8427
8467
 
8428
 
    fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
8429
 
    fprintf(stdout, "          Up to ms         Percentage\n");
 
8468
    Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
 
8469
    Tcl_AppendPrintfToObj(objPtr, "            Up to ms         Percentage\n");
8430
8470
    minSizeDecade = maxSizeDecade = 0;
8431
8471
    for (i = 0;  i < 31;  i++) {
8432
8472
        if (statsPtr->lifetimeCount[i] > 0) {
8444
8484
    for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
8445
8485
        decadeHigh = (1 << (i+1)) - 1;
8446
8486
        sum += statsPtr->lifetimeCount[i];
8447
 
        fprintf(stdout, "       %12.3f          %8.0f%%\n",
 
8487
        Tcl_AppendPrintfToObj(objPtr, " %12.3f          %8.0f%%\n",
8448
8488
                decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
8449
8489
    }
8450
8490
 
8452
8492
     * Instruction counts.
8453
8493
     */
8454
8494
 
8455
 
    fprintf(stdout, "\nInstruction counts:\n");
 
8495
    Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
8456
8496
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
8457
 
        if (statsPtr->instructionCount[i] == 0) {
8458
 
            fprintf(stdout, "%20s %8ld %6.1f%%\n",
8459
 
                    tclInstructionTable[i].name,
8460
 
                    statsPtr->instructionCount[i],
 
8497
        Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ",
 
8498
                tclInstructionTable[i].name, statsPtr->instructionCount[i]);
 
8499
        if (statsPtr->instructionCount[i]) {
 
8500
            Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
8461
8501
                    Percent(statsPtr->instructionCount[i], numInstructions));
8462
 
        }
8463
 
    }
8464
 
 
8465
 
    fprintf(stdout, "\nInstructions NEVER executed:\n");
8466
 
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
8467
 
        if (statsPtr->instructionCount[i] == 0) {
8468
 
            fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
 
8502
        } else {
 
8503
            Tcl_AppendPrintfToObj(objPtr, "0\n");
8469
8504
        }
8470
8505
    }
8471
8506
 
8472
8507
#ifdef TCL_MEM_DEBUG
8473
 
    fprintf(stdout, "\nHeap Statistics:\n");
8474
 
    TclDumpMemoryInfo(stdout);
 
8508
    Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
 
8509
    TclDumpMemoryInfo((ClientData) objPtr, 1);
8475
8510
#endif
8476
 
    fprintf(stdout, "\n----------------------------------------------------------------\n");
 
8511
    Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
 
8512
 
 
8513
    if (objc == 1) {
 
8514
        Tcl_SetObjResult(interp, objPtr);
 
8515
    } else {
 
8516
        Tcl_Channel outChan;
 
8517
        char *str = Tcl_GetStringFromObj(objv[1], &length);
 
8518
 
 
8519
        if (length) {
 
8520
            if (strcmp(str, "stdout") == 0) {
 
8521
                outChan = Tcl_GetStdChannel(TCL_STDOUT);
 
8522
            } else if (strcmp(str, "stderr") == 0) {
 
8523
                outChan = Tcl_GetStdChannel(TCL_STDERR);
 
8524
            } else {
 
8525
                outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664);
 
8526
            }
 
8527
        } else {
 
8528
            outChan = Tcl_GetStdChannel(TCL_STDOUT);
 
8529
        }
 
8530
        if (outChan != NULL) {
 
8531
            Tcl_WriteObj(outChan, objPtr);
 
8532
        }
 
8533
    }
 
8534
    Tcl_DecrRefCount(objPtr);
8477
8535
    return TCL_OK;
8478
8536
}
8479
8537
#endif /* TCL_COMPILE_STATS */