From 672cb039e55156194700decdd3ab48d444249b4a Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2007 20:27:17 +0000 Subject: Add a new command, ::tcl::unsupported::disassemble --- ChangeLog | 61 +++++---- generic/tclBasic.c | 17 ++- generic/tclCompCmds.c | 46 ++++--- generic/tclCompile.c | 354 ++++++++++++++++++++++++++++++++------------------ generic/tclCompile.h | 21 +-- generic/tclInt.h | 6 +- generic/tclProc.c | 128 +++++++++++++++++- 7 files changed, 440 insertions(+), 193 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6d223ca..96f7379 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2007-09-25 Donal K. Fellows + + * generic/tclProc.c (Tcl_DisassembleObjCmd): Define a command, + ::tcl::unsupported::disassemble, which can disassemble procedures, + lambdas and general scripts. + * generic/tclCompile.c (TclDisassembleByteCodeObj): Split apart the + code to print disassemblies of bytecode so that there is reusable code + that spits it out in a Tcl_Obj and then that code is used when doing + tracing. + 2007-09-20 Don Porter *** 8.5b1 TAGGED FOR RELEASE *** @@ -8,31 +18,31 @@ * README: Bump version number to 8.5b1 * generic/tcl.h: Merge from core-stabilizer-branch. - * library/init.tcl: Stabilizing toward 8.5b1 release now done - * tools/tcl.wse.in: on the HEAD. core-stabilizer-branch is - * unix/configure.in: now suspended. + * library/init.tcl: Stabilizing toward 8.5b1 release now done on + * tools/tcl.wse.in: the HEAD. core-stabilizer-branch is now + * unix/configure.in: suspended. * unix/tcl.spec: * win/configure.in: 2007-09-19 Pat Thoyts - + * generic/tclStubLib.: Replaced isdigit with internal implementation. 2007-09-18 Don Porter - * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs() - * win/makefile.vc: so that we don't need the C library linked - in to libtclStub. + * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs() so + * win/makefile.vc: that we don't need the C library linked in to + libtclStub. 2007-09-17 Pat Thoyts - * win/makefile.vc: Add crt flags for tclStubLib now it uses - C-library functions + * win/makefile.vc: Add crt flags for tclStubLib now it uses C-library + functions. 2007-09-17 Joe English - * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable' - to build shared libraries on current NetBSDs [#1749251]. + * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable' to build + shared libraries on current NetBSDs. [Bug 1749251] * unix/configure: regenerated (autoconf-2.59). 2007-09-17 Don Porter @@ -42,12 +52,12 @@ * generic/tcl.h: Revised Tcl_InitStubs() to restore Tcl 8.4 * generic/tclPkg.c: source compatibility with callers of - * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1). - [Bug 1578344]. + * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1). [Bug + 1578344] 2007-09-17 Donal K. Fellows - * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd) + * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd) (TraceCommandObjCmd, TraceVariableObjCmd): Generate literal values * generic/tclNamesp.c (NamespaceCodeCmd): more efficiently using * generic/tclFCmd.c (CopyRenameOneFile): TclNewLiteralStringObj @@ -120,7 +130,7 @@ * generic/tclCompCmds.c (TclCompileDictCmd-update): * generic/tclCompile.c (tclInstructionTable): * generic/tclExecute.c (INST_DICT_UPDATE_END): fix stack management in - [dict update]. [Bug 1786481] + compiled [dict update]. [Bug 1786481] ***POTENTIAL INCOMPATIBILITY*** Scripts that were precompiled on earlier versions of 8.5 and use [dict @@ -184,8 +194,8 @@ 2007-09-08 Miguel Sofer - * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710] - fixed correctly, reverted fix of 2007-05-01. + * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710] fixed + correctly, reverted fix of 2007-05-01. 2007-09-08 Donal K. Fellows @@ -365,8 +375,8 @@ 2007-08-24 Miguel Sofer - * generic/tclCompile.c: replaced copy loop that tripped some - compilers with memmove [Bug 1780870] + * generic/tclCompile.c: replaced copy loop that tripped some compilers + with memmove. [Bug 1780870] 2007-08-23 Don Porter @@ -490,7 +500,7 @@ 2007-08-10 Miguel Sofer - * generic/tclInt.h: remove redundant ops in TclNewStringObj macro + * generic/tclInt.h: remove redundant ops in TclNewStringObj macro. 2007-08-10 Miguel Sofer @@ -537,10 +547,8 @@ non-resolved case, as the function is never called in that case. Renamed the function to InitResolvedLocals to calrify the point. -2007-08-07 Miguel Sofer - - * generic/tclInt.decls: Exporting via stubs to help - * generic/tclInt.h: xotcl adapt to VarReform. + * generic/tclInt.decls: Exporting via stubs to help xotcl adapt to + * generic/tclInt.h: VarReform. * generic/tclIntDecls.h: * generic/tclStubInit.c: @@ -574,9 +582,8 @@ * generic/tclGetDate.y: Added a cast to the definition of YYFREE to silence compiler warnings. * generic/tclDate.c: Regenerated - * win/tclWinTest.c: Added a cast to the call to - GetSecurityDescriptorDacl to silence compiler - warnings. + * win/tclWinTest.c: Added a cast to GetSecurityDescriptorDacl call + to silence compiler warnings. 2007-08-04 Miguel Sofer diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f06c029..69f1e98 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.269 2007/09/14 14:58:07 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.270 2007/09/25 20:27:17 dkf Exp $ */ #include "tclInt.h" @@ -472,12 +472,12 @@ Tcl_CreateInterp(void) /* * Initialise the tables for variable traces and searches *before* * creating the global ns - so that the trace on errorInfo can be - * recorded. + * recorded. */ - + Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS); - + iPtr->globalNsPtr = NULL; /* Force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", (ClientData) NULL, NULL); @@ -656,6 +656,13 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::Bgerror", TclDefaultBgErrorHandlerObjCmd, NULL, NULL); + /* + * Create an unsupported command for debugging bytecode. + */ + + Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", + Tcl_DisassembleObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -3386,7 +3393,7 @@ TclInterpReady( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "attempt to call eval in deleted interpreter", NULL); - Tcl_SetErrorCode(interp, "CORE", "IDELETE", + Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 67f8961..5c5831b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.119 2007/09/11 14:47:41 msofer Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.120 2007/09/25 20:27:17 dkf Exp $ */ #include "tclInt.h" @@ -138,15 +138,18 @@ static ClientData DupDictUpdateInfo(ClientData clientData); static void FreeDictUpdateInfo(ClientData clientData); static void PrintDictUpdateInfo(ClientData clientData, - ByteCode *codePtr, unsigned int pcOffset); + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); static ClientData DupForeachInfo(ClientData clientData); static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, - ByteCode *codePtr, unsigned int pcOffset); + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); static ClientData DupJumptableInfo(ClientData clientData); static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, - ByteCode *codePtr, unsigned int pcOffset); + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, @@ -1140,6 +1143,7 @@ FreeDictUpdateInfo( static void PrintDictUpdateInfo( ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { @@ -1148,9 +1152,9 @@ PrintDictUpdateInfo( for (i=0 ; ilength ; i++) { if (i) { - fprintf(stdout, ", "); + Tcl_AppendToObj(appendObj, ", ", -1); } - fprintf(stdout, "%%v%u", duiPtr->varIndices[i]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } @@ -1787,6 +1791,7 @@ FreeForeachInfo( static void PrintForeachInfo( ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { @@ -1794,29 +1799,32 @@ PrintForeachInfo( register ForeachVarList *varsPtr; int i, j; - fprintf(stdout, "data=["); + Tcl_AppendToObj(appendObj, "data=[", -1); for (i=0 ; inumLists ; i++) { if (i) { - fprintf(stdout, ", "); + Tcl_AppendToObj(appendObj, ", ", -1); } - fprintf(stdout, "%%v%u", (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) (infoPtr->firstValueTemp + i)); } - fprintf(stdout, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", + (unsigned) infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { if (i) { - fprintf(stdout, ","); + Tcl_AppendToObj(appendObj, ",", -1); } - fprintf(stdout, "\n\t\t it%%v%u\t[", + Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", (unsigned) (infoPtr->firstValueTemp + i)); varsPtr = infoPtr->varLists[i]; for (j=0 ; jnumVars ; j++) { if (j) { - fprintf(stdout, ", "); + Tcl_AppendToObj(appendObj, ", ", -1); } - fprintf(stdout, "%%v%u", (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } - fprintf(stdout, "]"); + Tcl_AppendToObj(appendObj, "]", -1); } } @@ -4305,6 +4313,7 @@ FreeJumptableInfo( static void PrintJumptableInfo( ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { @@ -4320,12 +4329,13 @@ PrintJumptableInfo( offset = PTR2INT(Tcl_GetHashValue(hPtr)); if (i++) { - fprintf(stdout, ", "); + Tcl_AppendToObj(appendObj, ", ", -1); if (i%4==0) { - fprintf(stdout, "\n\t\t"); + Tcl_AppendToObj(appendObj, "\n\t\t", -1); } } - fprintf(stdout, "\"%s\"->pc %d", keyPtr, pcOffset + offset); + Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", + keyPtr, pcOffset + offset); } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6ae3aaf..d4c5d9e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -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: tclCompile.c,v 1.133 2007/09/11 14:47:42 msofer Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.134 2007/09/25 20:27:17 dkf Exp $ */ #include "tclInt.h" @@ -376,10 +376,10 @@ InstructionDesc tclInstructionTable[] = { /* finds level and otherName in stack, links to local variable at * index op1. Leaves the level on stack. */ {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at + /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"variable", 5, 0, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at + /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, /* Compiled bytecodes to signal syntax error. */ @@ -407,6 +407,10 @@ static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static int FormatInstruction(ByteCode *codePtr, + unsigned char *pc, Tcl_Obj *bufferObj); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. @@ -720,7 +724,7 @@ TclCleanupByteCode( * 1) decrement the ref counts of the LiteralEntry's in its literal array, * 2) call the free procs for the auxiliary data items, 3) free the * localCache if it is unused, and finally 4) free the ByteCode - * structure's heap object. + * structure's heap object. * * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like * those generated from tbcload) is special, as they doesn't make use of @@ -916,7 +920,7 @@ TclInitCompileEnv( ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *ctxPtr = *invoker; - + if (invoker->type == TCL_LOCATION_BC) { /* * Note: Type BC => ctx.data.eval.path is not used. @@ -1162,7 +1166,7 @@ TclCompileScript( if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { /* Compile bytecodes to report the parse error at runtime. */ - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, /* Drop the command terminator (";","]") if appropriate */ (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1)? @@ -1330,7 +1334,7 @@ TclCompileScript( * case. [Bug 1752146] * Note that the environment is initialised with * atCmdStart=1 to avoid emitting ISC for the first - * command. + * command. */ if (envPtr->atCmdStart) { @@ -1341,9 +1345,9 @@ TclCompileScript( * this depends on the exact layout of the * INST_START_CMD's operands, so be careful! */ - + unsigned char *fixPtr = envPtr->codeNext - 4; - + TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, fixPtr); } @@ -1828,7 +1832,7 @@ TclCompileExprWords( * Side effects: * Instructions are added to envPtr to execute a no-op at runtime. No * result is pushed onto the stack: the compiler has to take care of this - * itself if the last compiled command is a NoOp. + * itself if the last compiled command is a NoOp. * *---------------------------------------------------------------------- */ @@ -3207,15 +3211,135 @@ TclPrintByteCodeObj( Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject( + FILE *outFile, /* The file to print the source to. */ + Tcl_Obj *objPtr, /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars) /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource( + FILE *outFile, /* The file to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + PrintSourceToObj(bufferObj, stringPtr, maxChars); + fprintf(outFile, TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclDisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDisassembleByteCodeObj( + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = objPtr->internalRep.otherValuePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj; + char ptrBuf1[20], ptrBuf2[20]; + TclNewObj(bufferObj); if (codePtr->refCount <= 0) { - return; /* already freed */ + return bufferObj; /* Already freed. */ } codeStart = codePtr->codeStart; @@ -3226,14 +3350,17 @@ TclPrintByteCodeObj( * Print header lines describing the ByteCode. */ - fprintf(stdout, - "\nByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, iPtr->compileEpoch); - fprintf(stdout, " Source "); - TclPrintSource(stdout, codePtr->source, + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); - fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + Tcl_AppendPrintfToObj(bufferObj, + "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -3244,7 +3371,7 @@ TclPrintByteCodeObj( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, + Tcl_AppendPrintfToObj(bufferObj, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, (unsigned long) (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), @@ -3264,14 +3391,18 @@ TclPrintByteCodeObj( if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; - fprintf(stdout, - " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", - procPtr, procPtr->refCount, procPtr->numArgs, + + sprintf(ptrBuf1, "%p", procPtr); + Tcl_AppendPrintfToObj(bufferObj, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; + for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " slot %d%s%s%s%s%s%s", i, + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", (localPtr->flags & VAR_ARRAY) ? ", array" : "", (localPtr->flags & VAR_LINK) ? ", link" : "", @@ -3279,9 +3410,10 @@ TclPrintByteCodeObj( (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); } else { - fprintf(stdout, ", \"%s\"\n", localPtr->name); + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); } localPtr = localPtr->nextPtr; } @@ -3293,25 +3425,28 @@ TclPrintByteCodeObj( */ if (codePtr->numExceptRanges > 0) { - fprintf(stdout, " Exception ranges %d, depth %d:\n", + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); - fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: - fprintf(stdout, "continue %d, break %d\n", + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: - fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); break; default: - Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d", + Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", rangePtr->type); } } @@ -3325,10 +3460,10 @@ TclPrintByteCodeObj( if (numCmds == 0) { pc = codeStart; while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); } - return; + return bufferObj; } /* @@ -3336,7 +3471,7 @@ TclPrintByteCodeObj( * for each command. These are encoded as a sequence of bytes. */ - fprintf(stdout, " Commands %d:", numCmds); + Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; srcDeltaNext = codePtr->srcDeltaStart; @@ -3381,13 +3516,13 @@ TclPrintByteCodeObj( srcLengthNext++; } - fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); } /* @@ -3436,14 +3571,14 @@ TclPrintByteCodeObj( */ while ((pc-codeStart) < codeOffset) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); } - fprintf(stdout, " Command %d: ", (i+1)); - TclPrintSource(stdout, (codePtr->source + srcOffset), + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), TclMin(srcLen, 55)); - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); } if (pc < codeLimit) { /* @@ -3451,43 +3586,37 @@ TclPrintByteCodeObj( */ while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); } } + return bufferObj; } /* *---------------------------------------------------------------------- * - * TclPrintInstruction -- + * FormatInstruction -- * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. + * Appends a representation of a bytecode instruction to a Tcl_Obj. * *---------------------------------------------------------------------- */ -int -TclPrintInstruction( +static int +FormatInstruction( ByteCode *codePtr, /* Bytecode containing the instruction. */ - unsigned char *pc) /* Points to first byte of instruction. */ + unsigned char *pc, /* Points to first byte of instruction. */ + Tcl_Obj *bufferObj) /* Object to append instruction info to. */ { Proc *procPtr = codePtr->procPtr; unsigned char opCode = *pc; register InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned int pcOffset = (pc - codeStart); - int opnd, i, j, numBytes = 1; + int opnd = 0, i, j, numBytes = 1; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[64]; /* Additional info to print after main opcode * and immediates. */ char *suffixSrc = NULL; @@ -3495,7 +3624,7 @@ TclPrintInstruction( AuxData *auxPtr = NULL; suffixBuffer[0] = '\0'; - fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: @@ -3504,7 +3633,7 @@ TclPrintInstruction( || opCode == INST_JUMP_FALSE1) { sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } - fprintf(stdout, "%+d ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; @@ -3514,14 +3643,14 @@ TclPrintInstruction( } else if (opCode == INST_START_CMD) { sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); } - fprintf(stdout, "%+d ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; if (opCode == INST_PUSH1) { suffixObj = codePtr->objArrayPtr[opnd]; } - fprintf(stdout, "%u ", (unsigned int) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd); break; case OPERAND_AUX4: case OPERAND_UINT4: @@ -3531,7 +3660,7 @@ TclPrintInstruction( } else if (opCode == INST_START_CMD && opnd != 1) { sprintf(suffixBuffer, ", %u cmds start here", opnd); } - fprintf(stdout, "%u ", (unsigned int) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd); if (instDesc->opTypes[i] == OPERAND_AUX4) { auxPtr = &codePtr->auxDataArrayPtr[opnd]; } @@ -3539,11 +3668,11 @@ TclPrintInstruction( case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { - fprintf(stdout, "%d ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); } else if (opnd == -2) { - fprintf(stdout, "end "); + Tcl_AppendPrintfToObj(bufferObj, "end "); } else { - fprintf(stdout, "end-%d ", -2-opnd); + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); } break; case OPERAND_LVT1: @@ -3556,7 +3685,7 @@ TclPrintInstruction( printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { - Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)", + Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", (unsigned int) opnd, localCt); } for (j = 0; j < opnd; j++) { @@ -3569,7 +3698,7 @@ TclPrintInstruction( suffixSrc = localPtr->name; } } - fprintf(stdout, "%%v%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); break; case OPERAND_NONE: default: @@ -3577,19 +3706,24 @@ TclPrintInstruction( } } if (suffixObj) { - fprintf(stdout, "\t# "); - TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { - fprintf(stdout, "\t# %s", suffixBuffer); + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); if (suffixSrc) { - TclPrintSource(stdout, suffixSrc, 40); + PrintSourceToObj(bufferObj, suffixSrc, 40); } } - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); if (auxPtr && auxPtr->type->printProc) { - fprintf(stdout, "\t\t["); - auxPtr->type->printProc(auxPtr->clientData, codePtr, pcOffset); - fprintf(stdout, "]\n"); + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); } return numBytes; } @@ -3597,55 +3731,16 @@ TclPrintInstruction( /* *---------------------------------------------------------------------- * - * TclPrintObject -- + * PrintSourceToObj -- * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. + * Appends a quoted representation of a string to a Tcl_Obj. * *---------------------------------------------------------------------- */ -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ +static void +PrintSourceToObj( + Tcl_Obj *appendObj, /* The object to print the source to. */ const char *stringPtr, /* The string to print. */ int maxChars) /* Maximum number of chars to print. */ { @@ -3653,40 +3748,39 @@ TclPrintSource( register int i = 0; if (stringPtr == NULL) { - fprintf(outFile, "\"\""); + Tcl_AppendToObj(appendObj, "\"\"", -1); return; } - fprintf(outFile, "\""); + Tcl_AppendToObj(appendObj, "\"", -1); p = stringPtr; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { case '"': - fprintf(outFile, "\\\""); + Tcl_AppendToObj(appendObj, "\\\"", -1); continue; case '\f': - fprintf(outFile, "\\f"); + Tcl_AppendToObj(appendObj, "\\f", -1); continue; case '\n': - fprintf(outFile, "\\n"); + Tcl_AppendToObj(appendObj, "\\n", -1); continue; case '\r': - fprintf(outFile, "\\r"); + Tcl_AppendToObj(appendObj, "\\r", -1); continue; case '\t': - fprintf(outFile, "\\t"); + Tcl_AppendToObj(appendObj, "\\t", -1); continue; case '\v': - fprintf(outFile, "\\v"); + Tcl_AppendToObj(appendObj, "\\v", -1); continue; default: - fprintf(outFile, "%c", *p); + Tcl_AppendPrintfToObj(appendObj, "%c", *p); continue; } } - fprintf(outFile, "\""); + Tcl_AppendToObj(appendObj, "\"", -1); } -#endif /* TCL_COMPILE_DEBUG */ #ifdef TCL_COMPILE_STATS /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3db6da9..0afc13b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.79 2007/09/13 15:27:07 das Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.80 2007/09/25 20:27:17 dkf Exp $ */ #ifndef _TCLCOMPILATION @@ -128,19 +128,19 @@ typedef struct CmdLocation { */ typedef struct ECL { - int srcOffset; /* Command location to find the entry. */ - int nline; - int *line; /* Line information for all words in the + int srcOffset; /* Command location to find the entry. */ + int nline; + int *line; /* Line information for all words in the * command. */ } ECL; typedef struct ExtCmdLoc { - int type; /* Context type. */ - Tcl_Obj *path; /* Path of the sourced file the command is + int type; /* Context type. */ + Tcl_Obj *path; /* Path of the sourced file the command is * in. */ - ECL *loc; /* Command word locations (lines). */ - int nloc; /* Number of allocated entries in 'loc'. */ - int nuloc; /* Number of used entries in 'loc'. */ + ECL *loc; /* Command word locations (lines). */ + int nloc; /* Number of allocated entries in 'loc'. */ + int nuloc; /* Number of used entries in 'loc'. */ } ExtCmdLoc; /* @@ -161,7 +161,8 @@ typedef struct ExtCmdLoc { typedef ClientData (AuxDataDupProc) (ClientData clientData); typedef void (AuxDataFreeProc) (ClientData clientData); typedef void (AuxDataPrintProc)(ClientData clientData, - struct ByteCode *codePtr, unsigned int pcOffset); + Tcl_Obj *appendObj, struct ByteCode *codePtr, + unsigned int pcOffset); /* * We define a separate AuxDataType struct to hold type-related information diff --git a/generic/tclInt.h b/generic/tclInt.h index 9ba2331..b589085 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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.h,v 1.335 2007/09/13 15:27:08 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.336 2007/09/25 20:27:17 dkf Exp $ */ #ifndef _TCLINT @@ -2565,6 +2565,7 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE Tcl_WideInt TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif +MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); /* *---------------------------------------------------------------- @@ -2627,6 +2628,9 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( MODULE_SCOPE int Tcl_DictObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); diff --git a/generic/tclProc.c b/generic/tclProc.c index 7008187..eac4033 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.134 2007/09/13 15:27:08 das Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.135 2007/09/25 20:27:18 dkf Exp $ */ #include "tclInt.h" @@ -1520,7 +1520,7 @@ PushProcCallFrame( CallFrame *framePtr, **framePtrPtr; int result; ByteCode *codePtr; - + /* * If necessary (i.e. if we haven't got a suitable compilation already * cached) compile the procedure's body. The compiler will allocate frame @@ -2729,6 +2729,130 @@ MakeLambdaError( (overflow ? "..." : ""), interp->errorLine)); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DisassembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + static const char *types[] = { + "lambda", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT + }; + int idx, result; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Proc *procPtr = NULL; + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + */ + + if (objv[2]->typePtr == &lambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = SetLambdaFromAny(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; + } + case DISAS_PROC: { + Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; + } + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objv[2]->typePtr != &tclByteCodeType) { + if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2])); + break; + } + return TCL_OK; +} + /* * Local Variables: * mode: c -- cgit v0.12